diff --git a/AUTHORS.md b/AUTHORS.md --- a/AUTHORS.md +++ b/AUTHORS.md @@ -2,16 +2,19 @@ - Aaron Wolen - Agustín Martín Barbero +- Akos Marton - Albert Krewinkel - Alex Ivkin - Alex Toldaiev - Alex Vong +- Alexander Batischev - Alexander Kondratskiy - Alexander Krotov - Alexander Sulfrian - Alexander V Vershilov - Alexandre Franke - Alfred Wechselberger +- Amar Al-Zubaidi - Amir Dekel - Amogh Rathore - Anabra @@ -26,8 +29,8 @@ - Arata Mizuki - Arata Mizuki - Arfon Smith -- Arfon Smith - Arlo O'Keeffe +- Artem Pelenitsyn - Artyom Kazak - B. Scott Michel - Bastien Dumont @@ -135,6 +138,7 @@ - Ian Max Andolina - Igor Khorlo - Igor Pashev +- Ilona Silverwood - Ilya V. Portnov - Ivan Panchenko - Ivan Trubach @@ -161,6 +165,7 @@ - Jens Getreu - Jens Petersen - Jesse Hathaway +- Jeremie Knuesel - Jérémy Bobbio - Jeroen de Haas - Jerry Sky @@ -184,6 +189,7 @@ - Juliette Fourcot - Juliusz Gonera - Justin Bogner +- Justin Wood - Karl Pettersson - Keiichiro Shikano - Kelsey Hightower @@ -196,6 +202,7 @@ - Leif Metcalf - Leonard Rosenthol - Lila +- Link Swanson - Loïc Grobol - Lorenzo - Lucas Escot @@ -203,6 +210,7 @@ - Lucas V. R - Luke Plant - Marc Schreiber +- Marcin Serwin - Mario Lang - Mark Szepieniec - Mark Wright @@ -249,6 +257,7 @@ - Ola Wolska - Ole Martin Ruud - Oliver Matthews +- Olivier Benz - Ophir Lifshitz - Or Neeman - OvidiusCicero @@ -264,9 +273,12 @@ - Philip Pesca - Philippe Ombredanne - Phillip Alday +- Pranesh Prakash +- Prat - Prayag Verma - Puneeth Chaganti - Quinn +- R. N. West - Ralf Stephan - Raniere Silva - Raymond Ehlers @@ -274,6 +286,7 @@ - Rowan Rodrik van der Molen - Roland Hieber - Roman Beránek +- Ruqi - RyanGlScott - S.P.H - Salim B @@ -292,13 +305,16 @@ - Sidharth Kapur - Simon Hengel - Simon Schuster +- Siphalor - Stefan Dresselhaus - Sukil Etxenike - Sukka - Sumit Sahrawat +- Sven Wick - TEC - Tarik Graba - Tatiana Porras +- Terence Eden - Thenaesh Elango - Thomas Hodgson - Thomas Weißschuh @@ -308,6 +324,7 @@ - Timothy Humphries - Tiziano Müller - Todd Sifleet +- TomBen - Tom Leese - Tristan Stenner - Tristan de Cacqueray @@ -323,12 +340,15 @@ - Viktor Kronvall - Vincent - Vlad Hanciuta +- Vladimir Alexiev - Waldir Pimenta - Wandmalfarbe - Wentao Han - Wikiwide - William Lupton +- William Rusnack - Winnie Hellmann +- Wout Gevaert - Xavier Olive - Yan Pashkovsky - YI @@ -337,8 +357,6 @@ - Zihang Chen - a-vrma - andrebauer -- argent0 -- badumont - black-desk - blmage - bucklereed @@ -355,12 +373,14 @@ - infinity0x - jeongminkim-islab - kaizshang91 +- lifeunleaded - lux-lth - luz paz - lwolfsonkin - mbrackeantidot - mjfs - mt_caret +- nbehrnd - niszet - nkalvi - nuew @@ -383,6 +403,7 @@ - thsutton - timo-a - vijayphoenix +- vkraven - wiefling - willj-dev - wuffi diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -355,23 +355,6 @@ pandoc +RTS -p -RTS [file]... less pandoc.prof -Templates ---------- - -The default templates live in `data/templates`, which is a git -subtree linked to . -The purpose of maintaining a separate repository is to allow -people to maintain variant templates as a fork. - -You can modify the templates and submit patches without worrying -much about this: when these patches are merged, we will -push them to the main templates repository by doing - - git subtree push --prefix=data/templates templates master - -where `templates` is a remote pointing to the templates -repository. - The code -------- diff --git a/COPYRIGHT b/COPYRIGHT --- a/COPYRIGHT +++ b/COPYRIGHT @@ -1,5 +1,5 @@ Pandoc -Copyright (C) 2006-2022 John MacFarlane +Copyright (C) 2006-2023 John MacFarlane With the exceptions noted below, this code is released under the [GPL], version 2 or later: @@ -37,7 +37,7 @@ Text.Pandoc.Builder, Text.Pandoc.Generics, Text.Pandoc.JSON, Text.Pandoc.Walk) are licensed under the BSD 3-clause license: -Copyright (c) 2006-2021, John MacFarlane +Copyright (c) 2006-2023, John MacFarlane All rights reserved. @@ -73,7 +73,7 @@ GPL (v2 or higher, same as pandoc) or (at your option) the BSD 3-clause license. -Copyright (c) 2014--2021, John MacFarlane +Copyright (c) 2014--2023, John MacFarlane ---------------------------------------------------------------------- src/Text/Pandoc/Writers/Muse.hs @@ -83,19 +83,19 @@ ---------------------------------------------------------------------- src/Text/Pandoc/Writers/Texinfo.hs -Copyright (C) 2008-2022 John MacFarlane and Peter Wang +Copyright (C) 2008-2023 John MacFarlane and Peter Wang Released under the GNU General Public License version 2 or later. ---------------------------------------------------------------------- src/Text/Pandoc/Writers/OpenDocument.hs -Copyright (C) 2008-2022 Andrea Rossato and John MacFarlane +Copyright (C) 2008-2023 Andrea Rossato and John MacFarlane Released under the GNU General Public License version 2 or later. ---------------------------------------------------------------------- src/Text/Pandoc/Writers/Org.hs -Copyright (C) 2010-2022 Puneeth Chaganti, John MacFarlane, and +Copyright (C) 2010-2023 Puneeth Chaganti, John MacFarlane, and Albert Krewinkel Released under the GNU General Public License version 2 or later. @@ -115,7 +115,7 @@ ---------------------------------------------------------------------- src/Text/Pandoc/Readers/Textile.hs -Copyright (C) 2010-2022 Paul Rivier and John MacFarlane +Copyright (C) 2010-2023 Paul Rivier and John MacFarlane Released under the GNU General Public License version 2 or later. @@ -133,7 +133,7 @@ ---------------------------------------------------------------------- src/Text/Pandoc/Readers/EPUB.hs -Copyright (C) 2014-2022 Matthew Pickering and John MacFarlane +Copyright (C) 2014-2023 Matthew Pickering and John MacFarlane Released under the GNU General Public License version 2 or later. @@ -141,15 +141,15 @@ src/Text/Pandoc/Readers/Org.hs src/Text/Pandoc/Readers/Org/* test/Tests/Readers/Org/* -Copyright (C) 2014-2022 Albert Krewinkel +Copyright (C) 2014-2023 Albert Krewinkel Released under the GNU General Public License version 2 or later. ---------------------------------------------------------------------- -src/Text/Pandoc/Lua.hs -src/Text/Pandoc/Lua/* -test/lua/* -Copyright (C) 2017--2022 Albert Krewinkel and John MacFarlane +pandoc-lua-engine/src/Text/Pandoc/Lua.hs +pandoc-lua-engine/src/Text/Pandoc/Lua/* +pandoc-lua-engine/test/lua/* +Copyright (C) 2017--2023 Albert Krewinkel and John MacFarlane Released under the GNU General Public License version 2 or later. @@ -157,7 +157,7 @@ src/Text/Pandoc/Readers/Jira.hs src/Text/Pandoc/Writers/Jira.hs test/Tests/Readers/Jira.hs -Copyright (C) 2019--2022 Albert Krewinkel +Copyright (C) 2019--2023 Albert Krewinkel Released under the GNU General Public License version 2 or later. @@ -177,7 +177,7 @@ ------------------------------------------------------------------------ Pandoc embeds a Lua interpreter (via hslua). -Copyright © 1994–2020 Lua.org, PUC-Rio. +Copyright © 1994–2022 Lua.org, PUC-Rio. Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the diff --git a/INSTALL.md b/INSTALL.md --- a/INSTALL.md +++ b/INSTALL.md @@ -215,8 +215,6 @@ `pandoc` executable into `~/.local/bin`, which you should add to your `PATH`. This process will take a while, and will consume a considerable amount of disk space. - If you also want the `pandoc-server` executable, add - `--flag pandoc:server` to the above command. ### Quick cabal method @@ -238,9 +236,6 @@ on linux/unix/macOS and in `%APPDATA%\cabal\bin` on Windows. Make sure this directory is in your path. - If you also want the `pandoc-server` executable, add - `-fserver` to the above command. - If you want to install a modified or development version of pandoc instead, switch to the source directory and do as above, but without the 'pandoc': @@ -285,15 +280,20 @@ `FLAGSPEC` is a list of Cabal configuration flags, optionally preceded by a `-` (to force the flag to `false`), and separated - by spaces. Pandoc's flags include: + by spaces. `pandoc`'s flags include: - `embed_data_files`: embed all data files into the binary (default no). This is helpful if you want to create a relocatable binary. - - `lua53`: embed support for Lua 5.3 instead of 5.4. + `pandoc-cli`'s flags include: - - `server`: build the `pandoc-server` executable. + - `lua`: compile in support for Lua filters and custom + writers. + - `server`: compile in support for running in HTTP server + mode when the executable is renamed (or symlinked as) + `pandoc-server`. + 3. Build: cabal build @@ -367,7 +367,7 @@ [Arch]: https://www.archlinux.org/packages/community/x86_64/pandoc/ [Cabal User's Guide]: https://cabal.readthedocs.io/ [Debian]: https://packages.debian.org/pandoc -[Fedora]: https://apps.fedoraproject.org/packages/pandoc +[Fedora]: https://packages.fedoraproject.org/pkgs/pandoc/pandoc/ [FreeBSD ports]: https://www.freshports.org/textproc/hs-pandoc/ [GHC]: https://www.haskell.org/ghc/ [GitLab CI/CD]: https://about.gitlab.com/stages-devops-lifecycle/continuous-integration/ @@ -391,4 +391,4 @@ [stack]: https://docs.haskellstack.org/en/stable/install_and_upgrade.html [cabal-install]: https://hackage.haskell.org/package/cabal-install [Void]: https://voidlinux.org/ -[uninstaller]: https://raw.githubusercontent.com/jgm/pandoc/master/macos/uninstall-pandoc.pl +[uninstaller]: https://raw.githubusercontent.com/jgm/pandoc/main/macos/uninstall-pandoc.pl diff --git a/MANUAL.txt b/MANUAL.txt --- a/MANUAL.txt +++ b/MANUAL.txt @@ -1,7 +1,7 @@ --- title: Pandoc User's Guide author: John MacFarlane -date: August 22, 2022 +date: January 17, 2023 --- # Synopsis @@ -140,7 +140,7 @@ `--listings` option is used), [`fancyvrb`], [`longtable`], [`booktabs`], [`graphicx`] (if the document contains images), [`hyperref`], [`xcolor`], -[`ulem`], [`geometry`] (with the `geometry` variable set), +[`soul`], [`geometry`] (with the `geometry` variable set), [`setspace`] (with `linestretch`), and [`babel`] (with `lang`). If `CJKmainfont` is set, [`xeCJK`] is needed. The use of `xelatex` or `lualatex` as @@ -191,7 +191,7 @@ [`polyglossia`]: https://ctan.org/pkg/polyglossia [`prince`]: https://www.princexml.com/ [`setspace`]: https://ctan.org/pkg/setspace -[`ulem`]: https://ctan.org/pkg/ulem +[`soul`]: https://ctan.org/pkg/soul [`unicode-math`]: https://ctan.org/pkg/unicode-math [`upquote`]: https://ctan.org/pkg/upquote [`weasyprint`]: https://weasyprint.org @@ -287,6 +287,7 @@ - `beamer` ([LaTeX beamer][`beamer`] slide show) - `bibtex` ([BibTeX] bibliography) - `biblatex` ([BibLaTeX] bibliography) + - `chunkedhtml` (zip archive of multiple linked HTML files) - `commonmark` ([CommonMark] Markdown) - `commonmark_x` ([CommonMark] Markdown with extensions) - `context` ([ConTeXt]) @@ -358,7 +359,12 @@ : Write output to *FILE* instead of *stdout*. If *FILE* is `-`, output will go to *stdout*, even if a non-textual format - (`docx`, `odt`, `epub2`, `epub3`) is specified. + (`docx`, `odt`, `epub2`, `epub3`) is specified. If the + output format is `chunkedhtml` and *FILE* has no extension, + then instead of producing a `.zip` file pandoc will create + a directory *FILE* and unpack the zip archive there + (unless *FILE* already exists, in which case an error + will be raised). `--data-dir=`*DIRECTORY* @@ -536,13 +542,6 @@ where X = NUMBER - 1.* Specify the base level for headings (defaults to 1). -`--strip-empty-paragraphs` - -: *Deprecated. Use the `+empty_paragraphs` extension instead.* - Ignore paragraphs with no content. This option is useful - for converting word processing documents where users have - used empty paragraphs to create inter-paragraph space. - `--indented-code-classes=`*CLASSES* : Specify classes to use for indented code blocks--for example, @@ -564,6 +563,17 @@ footnotes and links will not work across files. Reading binary files (docx, odt, epub) implies `--file-scope`. + If two or more files are processed using `--file-scope`, + prefixes based on the filenames will be added to identifiers + in order to disambiguate them, and internal links will + be adjusted accordingly. For example, a header with + identifier `foo` in `subdir/file1.txt` will have its + identifier changed to `subdir__file1.txt__foo`. + + In addition, a Div with an identifier based on the filename + will be added around the file's content, so that internal + links to the filename will point to this Div's identifier. + `-F` *PROGRAM*, `--filter=`*PROGRAM* : Specify an executable to be used as a filter transforming the @@ -643,7 +653,7 @@ : Read metadata from the supplied YAML (or JSON) file. This option can be used with every input format, but string scalars - in the YAML file will always be parsed as Markdown. (If the + in the metadata file will always be parsed as Markdown. (If the input format is Markdown or a Markdown variant, then the same variant will be used to parse the metadata file; if it is a non-Markdown format, pandoc's default Markdown @@ -970,7 +980,8 @@ `data-external="1"` will be left alone; the documents they link to will not be incorporated in the document. Limitation: resources that are loaded dynamically through - JavaScript cannot be incorporated; as a result, some + JavaScript cannot be incorporated; as a result, fonts may + be missing when `--mathjax` is used, and some advanced features (e.g. zoom or speaker notes) may not work in an offline "self-contained" `reveal.js` slide show. @@ -985,9 +996,9 @@ : Use only ASCII characters in output. Currently supported for XML and HTML formats (which use entities instead of UTF-8 when this option is selected), CommonMark, gfm, and Markdown (which use - entities), roff ms (which use hexadecimal escapes), and to a + entities), roff man and ms (which use hexadecimal escapes), and to a limited degree LaTeX (which uses standard commands for accented - characters when possible). roff man output uses ASCII by default. + characters when possible). `--reference-links` @@ -1013,9 +1024,9 @@ ATX-style headings are always used for levels 3+. This option also affects Markdown cells in `ipynb` output. -`--atx-headers` +`--list-tables` -: *Deprecated synonym for `--markdown-headings=atx`.* +: Render tables as list tables in RST output. `--top-level-division=default`|`section`|`chapter`|`part` @@ -1107,6 +1118,10 @@ : Link to a CSS style sheet. This option can be used repeatedly to include multiple files. They will be included in the order specified. + This option only affects HTML (including HTML slide shows) + and EPUB output. It should be used together with + `-s/--standalone`, because the link to the stylesheet goes + in the document header. A stylesheet is required for generating EPUB. If none is provided using this option (or the `css` or `stylesheet` @@ -1114,7 +1129,7 @@ user data directory (see `--data-dir`). If it is not found there, sensible defaults will be used. -`--reference-doc=`*FILE* +`--reference-doc=`*FILE*|*URL* : Use the specified file as a style reference in producing a docx or ODT file. @@ -1234,6 +1249,22 @@ in MS PowerPoint (pandoc will use the layouts with the names listed above). +`--split-level=`*NUMBER* + +: Specify the heading level at which to split an EPUB or + chunked HTML document into separate files. The default is to split + into chapters at level-1 headings. In the case of EPUB, this + option only affects the internal composition of the EPUB, not the way + chapters and sections are displayed to users. Some + readers may be slow if the chapter files are too large, so for large + documents with few level-1 headings, one might want to use a chapter + level of 2 or 3. For chunked HTML, this option determines + how much content goes in each "chunk." + +`--epub-chapter-level=`*NUMBER* + +: *Deprecated synonym for `--split-level`.* + `--epub-cover-image=`*FILE* : Use the specified image as the EPUB cover. It is recommended @@ -1241,6 +1272,11 @@ in a Markdown source document you can also specify `cover-image` in a YAML metadata block (see [EPUB Metadata], below). +`--epub-title-page=true`|`false` + +: Determines whether a the title page is included in the EPUB + (default is `true`). + `--epub-metadata=`*FILE* : Look in the specified XML file for metadata for the EPUB. @@ -1273,41 +1309,31 @@ to your CSS (see `--css`): @font-face { - font-family: DejaVuSans; - font-style: normal; - font-weight: normal; - src:url("DejaVuSans-Regular.ttf"); + font-family: DejaVuSans; + font-style: normal; + font-weight: normal; + src:url("../fonts/DejaVuSans-Regular.ttf"); } @font-face { - font-family: DejaVuSans; - font-style: normal; - font-weight: bold; - src:url("DejaVuSans-Bold.ttf"); + font-family: DejaVuSans; + font-style: normal; + font-weight: bold; + src:url("../fonts/DejaVuSans-Bold.ttf"); } @font-face { - font-family: DejaVuSans; - font-style: italic; - font-weight: normal; - src:url("DejaVuSans-Oblique.ttf"); + font-family: DejaVuSans; + font-style: italic; + font-weight: normal; + src:url("../fonts/DejaVuSans-Oblique.ttf"); } @font-face { - font-family: DejaVuSans; - font-style: italic; - font-weight: bold; - src:url("DejaVuSans-BoldOblique.ttf"); + font-family: DejaVuSans; + font-style: italic; + font-weight: bold; + src:url("../fonts/DejaVuSans-BoldOblique.ttf"); } body { font-family: "DejaVuSans"; } -`--epub-chapter-level=`*NUMBER* - -: Specify the heading level at which to split the EPUB into separate - "chapter" files. The default is to split into chapters at level-1 - headings. This option only affects the internal composition of the - EPUB, not the way chapters and sections are displayed to users. Some - readers may be slow if the chapter files are too large, so for large - documents with few level-1 headings, one might want to use a chapter - level of 2 or 3. - `--epub-subdirectory=`*DIRNAME* : Specify the subdirectory in the OCF container that is to hold @@ -1530,11 +1556,11 @@ 62 PandocShouldNeverHappenError 63 PandocSomeError 64 PandocParseError - 65 PandocParsecError 66 PandocMakePDFError 67 PandocSyntaxMapError 83 PandocFilterError 84 PandocLuaError + 89 PandocNoScriptingEngine 91 PandocMacroLoop 92 PandocUTF8DecodingError 93 PandocIpynbDecodingError @@ -1889,6 +1915,10 @@ | ``` | ``` | +----------------------------------+-----------------------------------+ | ``` | ``` yaml | +| --list-tables | list-tables: true | +| ``` | ``` | ++----------------------------------+-----------------------------------+ +| ``` | ``` yaml | | --top-level-division chapter | top-level-division: chapter | | ``` | ``` | +----------------------------------+-----------------------------------+ @@ -1943,6 +1973,10 @@ | ``` | ``` | +----------------------------------+-----------------------------------+ | ``` | ``` yaml | +| --epub-title-page=false | epub-title-page: false | +| ``` | ``` | ++----------------------------------+-----------------------------------+ +| ``` | ``` yaml | | --epub-metadata meta.xml | epub-metadata: meta.xml | | ``` | ``` | +----------------------------------+-----------------------------------+ @@ -1953,7 +1987,7 @@ | ``` | ``` | +----------------------------------+-----------------------------------+ | ``` | ``` yaml | -| --epub-chapter-level 2 | epub-chapter-level: 2 | +| --split-level 2 | split-level: 2 | | ``` | ``` | +----------------------------------+-----------------------------------+ | ``` | ``` yaml | @@ -2628,6 +2662,9 @@ : sets the CSS `line-height` property on the `html` element, which is preferred to be unitless. +`maxwidth` +: sets the CSS `max-width` property (default is 32em). + `backgroundcolor` : sets the CSS `background-color` property on the `html` element. @@ -2897,6 +2934,9 @@ `links-as-notes` : causes links to be printed as footnotes +`urlstyle` +: style for URLs (e.g., tt, same) + #### Front matter `lof`, `lot` @@ -3075,17 +3115,27 @@ ### Variables for ms `fontfamily` -: font family (e.g. `T` or `P`) +: `A` (Avant Garde), `B` (Bookman), `C` (Helvetica), `HN` + (Helvetica Narrow), `P` (Palatino), or `T` (Times New Roman). + This setting does not affect source code, which is always + displayed using monospace Courier. These built-in fonts are + limited in their coverage of characters. Additional fonts may + be installed using the script [`install-font.sh`] provided + by Peter Schaffter and documented in detail on [his web + site][ms-font-steps]. `indent` -: paragraph indent (e.g. `2m`) +: paragraph indent (e.g. `2m`) `lineheight` -: line height (e.g. `12p`) +: line height (e.g. `12p`) `pointsize` -: point size (e.g. `10p`) +: point size (e.g. `10p`) +[`install-font.sh`]: https://www.schaffter.ca/mom/bin/install-font.sh +[ms-font-steps]: https://www.schaffter.ca/mom/momdoc/appendices.html#steps + ### Variables set automatically Pandoc sets these variables automatically in response to [options] or @@ -3145,6 +3195,9 @@ `curdir` : working directory from which pandoc is run. +`pandoc-version` +: pandoc version. + `toc` : non-null value if `--toc/--table-of-contents` was specified @@ -3173,7 +3226,7 @@ Note that markdown extensions added to the `ipynb` format affect Markdown cells in Jupyter notebooks (as do command-line -options like `--atx-headers`). +options like `--markdown-headings`). ## Typography @@ -3526,7 +3579,15 @@ Natural tables allow more fine-grained global customization but come at a performance penalty compared to extreme tables. +#### Extension: `tagging` #### +Enabling this extension with `context` output will produce markup +suitable for the production of tagged PDFs. This includes +additional markers for paragraphs and alternative markup for +emphasized text. The `emphasis-command` template variable is set +if the extension is enabled. + + # Pandoc's Markdown Pandoc understands an extended and slightly revised version of @@ -3756,7 +3817,7 @@ not produce a nested block quote in pandoc: > This is a block quote. - >> Nested. + >> Not nested, since `blank_before_blockquote` is enabled by default ## Verbatim (code) blocks @@ -3857,6 +3918,18 @@ qsort [] = [] ``` +This shortcut form may be combined with attributes: + + ```haskell {.numberLines} + qsort [] = [] + ``` + +Which is equivalent to: + + ``` {.haskell .numberLines} + qsort [] = [] + ``` + If the `fenced_code_attributes` extension is disabled, but input contains class attribute(s) for the code block, the first class attribute will be printed after the opening fence as a bare @@ -4231,8 +4304,8 @@ A caption may optionally be provided with all 4 kinds of tables (as illustrated in the examples below). A caption is a paragraph beginning -with the string `Table:` (or just `:`), which will be stripped off. -It may appear either before or after the table. +with the string `Table:` (or `table:` or just `:`), which will be stripped +off. It may appear either before or after the table. #### Extension: `simple_tables` #### @@ -4344,13 +4417,36 @@ | | | - tasty | +---------------+---------------+--------------------+ -The row of `=`s separates the header from the table body, and can be -omitted for a headerless table. The cells of grid tables may contain -arbitrary block elements (multiple paragraphs, code blocks, lists, -etc.). Cells that span multiple columns or rows are not -supported. Grid tables can be created easily using Emacs' table-mode -(`M-x table-insert`). +The row of `=`s separates the header from the table body, +and can be omitted for a headerless table. The cells of grid +tables may contain arbitrary block elements (multiple +paragraphs, code blocks, lists, etc.). +Cells can span multiple columns or rows: + + +---------------------+----------+ + | Property | Earth | + +=============+=======+==========+ + | | min | -89.2 °C | + | Temperature +-------+----------+ + | 1961-1990 | mean | 14 °C | + | +-------+----------+ + | | min | 56.7 °C | + +-------------+-------+----------+ + +A table header may contain more than one row: + + +---------------------+-----------------------+ + | Location | Temperature 1961-1990 | + | | in degree Celsius | + | +-------+-------+-------+ + | | min | mean | max | + +=====================+=======+=======+=======+ + | Antarctica | -89.2 | N/A | 19.8 | + +---------------------+-------+-------+-------+ + | Earth | -89.2 | 14 | 56.7 | + +---------------------+-------+-------+-------+ + Alignments can be specified as with pipe tables, by putting colons at the boundaries of the separator line after the header: @@ -4367,18 +4463,23 @@ | Right | Left | Centered | +---------------+---------------+--------------------+ -##### Grid Table Limitations ##### +A table foot can be defined by enclosing it with separator lines +that use `=` instead of `-`: -Pandoc does not support grid tables with row spans or column spans. -This means that neither variable numbers of columns across rows nor -variable numbers of rows across columns are supported by Pandoc. -All grid tables must have the same number of columns in each row, -and the same number of rows in each column. For example, the -Docutils [sample grid tables] will not render as expected with -Pandoc. + +---------------+---------------+ + | Fruit | Price | + +===============+===============+ + | Bananas | $1.34 | + +---------------+---------------+ + | Oranges | $2.10 | + +===============+===============+ + | Sum | $3.44 | + +===============+===============+ -[sample grid tables]: https://docutils.sourceforge.io/docs/ref/rst/restructuredtext.html#grid-tables +The foot must always be placed at the very bottom of the table. +Grid tables can be created easily using Emacs' table-mode +(`M-x table-insert`). #### Extension: `pipe_tables` #### @@ -5508,6 +5609,13 @@ reference definition, not the file containing the reference link or image itself, if these differ. +#### Extension: `mark` #### + +To highlight out a section of text, begin and end it with +with `==`. Thus, for example, + + This ==is deleted text.== + #### Extension: `attributes` #### Allows attributes to be attached to any inline or block-level @@ -6466,9 +6574,11 @@ ### On all slides (beamer, reveal.js, pptx) With beamer and reveal.js, the configuration option `background-image` can be -used either in the YAML metadata block or as a command-line variable to get the -same image on every slide. +used either in the YAML metadata block or as a command-line variable to get the same image on every slide. +Note that for reveal.js, the `background-image` will be used as +a `parallaxBackgroundImage` (see below). + For pptx, you can use a [reference doc](#option--reference-doc) in which background images have been set on the [relevant layouts](#powerpoint-layout-choice). @@ -6476,11 +6586,12 @@ #### `parallaxBackgroundImage` (reveal.js) For reveal.js, there is also the reveal.js-native option -`parallaxBackgroundImage`, which can be used instead of `background-image` to -produce a parallax scrolling background. You must also set -`parallaxBackgroundSize`, and can optionally set `parallaxBackgroundHorizontal` -and `parallaxBackgroundVertical` to configure the scrolling behaviour. See the -[reveal.js documentation](https://revealjs.com/backgrounds/#parallax-background) +`parallaxBackgroundImage`, which produces a parallax scrolling background. +You must also set `parallaxBackgroundSize`, and can optionally set +`parallaxBackgroundHorizontal` +and `parallaxBackgroundVertical` to configure the scrolling behaviour. +See the [reveal.js +documentation](https://revealjs.com/backgrounds/#parallax-background) for more details about the meaning of these options. In reveal.js's overview mode, the parallaxBackgroundImage will show up @@ -6731,6 +6842,27 @@ in that case the variables defined in [Variables for HTML] may be used to fine-tune the style). +# Chunked HTML + +`pandoc -t chunkedhtml` will produce a zip archive of linked +HTML files, one for each section of the original document. +Internal links will automatically be adjusted to point to +the right place, images linked to under the working directory +will be incorporated, and navigation links will be added. +In addition, a JSON file `sitemap.json` will be included +describing the hierarchical structure of the files. + +If an output file without an extension is specified, then +it will be interpreted as a directory and the zip archive +will be automatically unpacked into it (unless it already +exists, in which case an error will be raised). Otherwise +a `.zip` file will be produced. + +The navigation links can be customized by adjusting the +template. By default, a table of contents is included only +on the top page. To include it on every page, set the +`toc` variable manually. + # Jupyter notebooks When creating a [Jupyter notebook], pandoc will try to infer the @@ -6852,8 +6984,8 @@ Note that options and extensions that affect reading and writing of Markdown will also affect Markdown cells in ipynb notebooks. For example, `--wrap=preserve` will preserve -soft line breaks in Markdown cells; `--atx-headers` will -cause ATX-style headings to be used; and `--preserve-tabs` will +soft line breaks in Markdown cells; `--markdown-headings=setext` will +cause Setext-style headings to be used; and `--preserve-tabs` will prevent tabs from being turned to spaces. # Syntax highlighting @@ -7003,8 +7135,8 @@ pandoc -f my_custom_markup_language.lua -t latex -s If the script is not found relative to the working directory, -it will be sought in the `readers` or `writers` subdirectory -of the user data directory (see `--data-dir`). +it will be sought in the `custom` subdirectory of the user data +directory (see `--data-dir`). A custom reader is a Lua script that defines one function, Reader, which takes a string as input and returns a Pandoc @@ -7021,10 +7153,7 @@ A custom writer is a Lua script that defines a function that specifies how to render each element in a Pandoc AST. -To see a documented example which you can modify according -to your needs: - - pandoc --print-default-data-file sample.lua +See the [djot-writer.lua] for a full-featured example. Note that custom writers have no default template. If you want to use `--standalone` with a custom writer, you will need to @@ -7035,6 +7164,7 @@ [Lua]: https://www.lua.org [lpeg]: http://www.inf.puc-rio.br/~roberto/lpeg/ +[djot-writer.lua]: https://github.com/jgm/djot/blob/main/djot-writer.lua # Reproducible builds @@ -7051,13 +7181,86 @@ EPUB, this can be set explicitly by setting the `identifier` metadata field (see [EPUB Metadata], above). +# Accessible PDFs and PDF archiving standards + +PDF is a flexible format, and using PDF in certain contexts +requires additional conventions. For example, PDFs are not +accessible by default; they define how characters are placed on a +page but do not contain semantic information on the content. +However, it is possible to generate accessible PDFs, which use +tagging to add semantic information to the document. + +Pandoc defaults to LaTeX to generate PDF. Tagging support in LaTeX +is in development and not readily available, so PDFs generated in +this way will always be untagged and not accessible. This means +that alternative engines must be used to generate accessible PDFs. + +The PDF standards PDF/A and PDF/UA define further restrictions +intended to optimize PDFs for archiving and accessibility. Tagging +is commonly used in combination with these standards to ensure +best results. + +Note, however, that standard compliance depends on many things, +including the colorspace of embedded images. Pandoc cannot check +this, and external programs must be used to ensure that generated +PDFs are in compliance. + +## ConTeXt + +ConTeXt always produces tagged PDFs, but the quality depends on +the input. The default ConTeXt markup generated by pandoc is +optimized for readability and reuse, not tagging. Enable the +[`tagging`](#extension--tagging) format extension to force markup +that is optimized for tagging. This can be combined with the +`pdfa` variable to generate standard-compliant PDFs. E.g.: + + pandoc --to=context+tagging -V pdfa=3a + +A recent `context` version should be used, as older versions +contained a bug that lead to invalid PDF metadata. + +## WeasyPrint + +The HTML-based engine WeasyPrint includes experimental support for +PDF/A and PDF/UA since version 57. Tagged PDFs can created with + + pandoc --pdf-engine=weasyprint \ + --pdf-engine-opt=--pdf-variant=pdf/ua-1 ... + +The feature is experimental and standard compliance should not be +assumed. + +## Prince XML + +The non-free HTML-to-PDf converter `prince` has extensive support +for various PDF standards as well as tagging. E.g.: + + pandoc --pdf-engine=prince \ + --pdf-engine-opt=--tagged-pdf ... + +See the prince documentation for more info. + +## Word Processors + +Word processors like LibreOffice and MS Word can also be used to +generate standardized and tagged PDF output. Pandoc does not +support direct conversions via these tools. However, pandoc can +convert a document to a `docx` or `odt` file, which can then be +opened and converted to PDF with the respective word processor. +See the documentation for [Word][word-accessible-pdfs] and +[LibreOffice][lo-pdf-export]. + +[word-accessible-pdfs]: https://support.microsoft.com/en-us/office/create-accessible-pdfs-064625e0-56ea-4e16-ad71-3aa33bb4b7ed +[lo-pdf-export]: https://help.libreoffice.org/7.1/en-US/text/shared/01/ref_pdf_export_general.html + + # Running pandoc as a web server If you rename (or symlink) the pandoc executable to -`pandoc-server`, it will start up a web server with a JSON -API. This server exposes most of the conversion functionality -of pandoc. For full documentation, see the [pandoc-server] -man page. +`pandoc-server`, or if you call pandoc with `server` as the first +argument, it will start up a web server with a JSON API. This +server exposes most of the conversion functionality of pandoc. For +full documentation, see the [pandoc-server] man page. If you rename (or symlink) the pandoc executable to `pandoc-server.cgi`, it will function as a CGI program @@ -7069,6 +7272,17 @@ [pandoc-server]: https://github.com/jgm/pandoc/blob/master/doc/pandoc-server.md +# Running pandoc as a Lua interpreter + +Calling the pandoc executable under the name `pandoc-lua` or with +`lua` as the first argument will make it function as a standalone +Lua interpreter. The behavior is mostly identical to that of the +[standalone `lua` executable][lua standalone], version 5.4. +However, there is no REPL yet, and the `-i` option has no effect. +For full documentation, see the [pandoc-lua] man page. + +[lua standalone]: https://www.lua.org/manual/5.4/manual.html#7 +[pandoc-lua]: https://github.com/jgm/pandoc/blob/master/doc/pandoc-lua.md # A note on security diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -11,7 +11,7 @@ release](https://img.shields.io/hackage/v/pandoc.svg?label=hackage)](https://hackage.haskell.org/package/pandoc) [![homebrew](https://img.shields.io/homebrew/v/pandoc.svg)](https://formulae.brew.sh/formula/pandoc) [![stackage LTS -package](https://stackage.org/package/pandoc/badge/lts)](https://www.stackage.org/lts/package/pandoc-types) +package](https://stackage.org/package/pandoc/badge/lts)](https://www.stackage.org/lts/package/pandoc) [![CI tests](https://github.com/jgm/pandoc/workflows/CI%20tests/badge.svg)](https://github.com/jgm/pandoc/actions) [![license](https://img.shields.io/badge/license-GPLv2+-lightgray.svg)](https://www.gnu.org/licenses/gpl.html) @@ -22,8 +22,10 @@ Pandoc is a [Haskell](https://haskell.org) library for converting from one markup format to another, and a command-line tool that uses this -library. It can convert *from* +library. +It can convert *from* +
- `bibtex` ([BibTeX](https://ctan.org/pkg/bibtex) bibliography) @@ -109,6 +111,7 @@ - `beamer` ([LaTeX beamer](https://ctan.org/pkg/beamer) slide show) - `bibtex` ([BibTeX](https://ctan.org/pkg/bibtex) bibliography) - `biblatex` ([BibLaTeX](https://ctan.org/pkg/biblatex) bibliography) +- `chunkedhtml` (zip archive of multiple linked HTML files) - `commonmark` ([CommonMark](https://commonmark.org) Markdown) - `commonmark_x` ([CommonMark](https://commonmark.org) Markdown with extensions) diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/app/pandoc.hs b/app/pandoc.hs deleted file mode 100644 --- a/app/pandoc.hs +++ /dev/null @@ -1,33 +0,0 @@ -{- | - Module : Main - Copyright : Copyright (C) 2006-2022 John MacFarlane - License : GNU GPL, version 2 or above - - Maintainer : John MacFarlane - Stability : alpha - Portability : portable - -Parses command-line options and calls the appropriate readers and -writers. --} -module Main where -import qualified Control.Exception as E -import Text.Pandoc.App (convertWithOpts, defaultOpts, options, parseOptions) -import Text.Pandoc.Error (handleError) -import Text.Pandoc.Server (ServerOpts(..), parseServerOpts, app) -import Safe (readDef) -import System.Environment (getProgName, lookupEnv) -import qualified Network.Wai.Handler.CGI as CGI -import qualified Network.Wai.Handler.Warp as Warp -import Network.Wai.Middleware.Timeout (timeout) - -main :: IO () -main = E.handle (handleError . Left) $ do - prg <- getProgName - cgiTimeout <- maybe 2 (readDef 2) <$> lookupEnv "PANDOC_SERVER_TIMEOUT" - case prg of - "pandoc-server.cgi" -> CGI.run (timeout cgiTimeout app) - "pandoc-server" -> do - sopts <- parseServerOpts - Warp.run (serverPort sopts) (timeout (serverTimeout sopts) app) - _ -> parseOptions options defaultOpts >>= convertWithOpts diff --git a/benchmark/benchmark-pandoc.hs b/benchmark/benchmark-pandoc.hs --- a/benchmark/benchmark-pandoc.hs +++ b/benchmark/benchmark-pandoc.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {- -Copyright (C) 2012-2022 John MacFarlane +Copyright (C) 2012-2023 John MacFarlane This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -28,6 +28,7 @@ import qualified Data.ByteString.Lazy as BL import Data.Maybe (mapMaybe) import Data.List (sortOn) +import Text.Pandoc.Format (FlavoredFormat(..)) readerBench :: Pandoc -> T.Text @@ -36,8 +37,8 @@ | name `elem` ["bibtex", "biblatex", "csljson"] = Nothing readerBench doc name = either (const Nothing) Just $ runPure $ do - (rdr, rexts) <- getReader name - (wtr, wexts) <- getWriter name + (rdr, rexts) <- getReader $ FlavoredFormat name mempty + (wtr, wexts) <- getWriter $ FlavoredFormat name mempty case (rdr, wtr) of (TextReader r, TextWriter w) -> do inp <- w def{ writerWrapText = WrapAuto @@ -70,7 +71,7 @@ | name `elem` ["bibtex", "biblatex", "csljson"] = Nothing writerBench imgs doc name = either (const Nothing) Just $ runPure $ do - (wtr, wexts) <- getWriter name + (wtr, wexts) <- getWriter $ FlavoredFormat name mempty case wtr of TextWriter writerFun -> return $ bench (T.unpack name) diff --git a/cabal.project b/cabal.project --- a/cabal.project +++ b/cabal.project @@ -1,4 +1,8 @@ -packages: pandoc.cabal +packages: . + pandoc-lua-engine + pandoc-server + pandoc-cli tests: True flags: +embed_data_files -constraints: aeson >= 2.0.1.0 +constraints: skylighting-format-blaze-html >= 0.1.1, + skylighting-format-context >= 0.1.0.1 diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,894 +1,1984 @@ # Revision history for pandoc -## pandoc 2.19.2 (2022-08-22) - - * Fix regression with data uris in 2.19.1 (#8239). - In 2.19.1 we used the base64URL encoding rather than base64. - - * pandoc-server: handle `citeproc` parameter as documented (#8235). - - * Org reader: treat *emacs-jupyter* src blocks as code cells (#8236, - Albert Krewinkel). This improves support for notebook-like org files - that are intended to be used with emacs-jupyter package. - - * HTML writer and templates: revert to using `width` property for column - widths (Albert Krewinkel). The default `flex` and `overflow-x` properties - of a column are set to `auto`. In combination, these changes allow to - get good results when using columns with or without explicit widths. - - * Org writer (Albert Krewinkel): - - + Add support for jupyter nodebook cells (#6367). - + Prefix code language of ipynb code blocks with `jupyter-`. - This is the convention used by the *emacs-jupyter* package. - + Keep code block attributes as header args. This allows to keep more - information in the resulting `src` blocks, making it easier to - roundtrip from or through Org. Org babel ignores unknown header - arguments. - + Add code block identifier as `#+name` to src blocks. - - * Fix some typos in the codebase (luz paz). - - * Require hslua-module-path 1.0.3 (#8228, Albert Krewinkel). - -## pandoc 2.19.1 (2022-08-18) - - * Add server capabilities. - - + New exported module Text.Pandoc.Server [API change]. - + The pandoc executable now starts up a web server when renamed or - symlinked as `pandoc-server`, and functions as a CGI program when - renamed or symlinked as `pandoc-server.cgi`. See the man page for - `pandoc-server` for full documentation. - - * Text.Pandoc.App.Opts: Redo `FromJSON` for `Opt` so that optional - values can be omitted (in which case the values from - `defaultOptions` are used). - - * Org reader: treat "abstract" block as metadata (Albert Krewinkel, #8204). - A block of type "abstract" is assumed to define the document's abstract. - It is transferred from the main text to the metadata. - - * Org template: add abstract from metadata as block of type "abstract" - (#8204). - - * HTML writer: use `flex` property for column widths - (Albert Krewinkel, #8232). - - * LaTeX writer: - - + Add label to tables that have an identifier (Albert Krewinkel, #8219). - Tables with an identifier are marked with a `\label`. A caption is - always included in this case, even if the caption is empty. - + Use `\textquotesingle` for straight quotes in text. - + Fix widths of multicolumn cells (#8218). - - * LaTeX template: fix behavior of `colorlinks` variable (Albert - Krewinkel, #8226). Fixes a regression in 2.19 that required the - `boxlinks` variable to be set in addition to the usual link coloring - variables. Otherwise links were never colored in LaTeX PDF output. - - * Text.Pandoc.Highlighting: Export `lookupHighlightingStyle` - [API change]. Previously this lived in an unexported module - Text.Pandoc.App.CommandLineOptions, under the name - `lookupHighlightStyle`. - - * Text.Pandoc.App: - - + Remove unneeded MonadIO constraints in readSources. - + Factor out `convertWithOpts'` from `convertWithOpts`. - This runs in any PandocMonad, MonadIO, MonadMask instance. - So far it is not exported, but it might find a use later. - - * Support `--strip-comments` in commonmark/gfm (#8222). - This change makes the commonmark reader sensitive to - `readerStripComments`. - - * Lua: add function `pandoc.utils.citeproc` (Albert Krewinkel). - The function runs the *citeproc* processor on a Pandoc document. - Exposing this functionality to Lua allows to make citation processing - part of a filter or writer, simplifies the creation of multiple - bibliographies, and enables the use of varying citation styles in - different parts of a document. - - * Refactor `linux/make_artifacts.sh`. - - * Update INSTALL.md installation from source instructions. - - * Use base64 package instead of base64-bytestring. It is supposed to be - faster and more standards-compliant. - - * trypandoc improvements: - - + Add dropdown with canned examples. - + Add citeproc support. - + Support csv, bibliographic and binary formats. - + Add load from file. - + Add permalink. Don't always reload page. - + Use vanilla JS and CSS + the new `pandoc-server.cgi`. - - * Allow haddock-library-1.11.0. - - * Convert `tool/extract-changes.hs` to a Lua filter. - - -## pandoc 2.19 (2022-08-03) - - * Add `--embed-resources` flag (Elliot Bobrow, #7331). This can be - used to embed resources without implying `--standalone`. - Deprecate `--self-contained` in favor of `--embed-resources --standalone`. - - * Allow environment variable interpolation in `highlight-style` - and `pdf-engine` fields in defaults files - (#8061; Jaehwang Jung, #8073). - - * Allow placing custom readers and writers in user data directory - (Albert Krewinkel, #8112) (`readers` and `writers` subdirectories). - - * Add `tsv` (tab separated values) as an input format (#7974). - [API change]: Text.Pandoc.Readers.CSV now exports `readTSV`. - Internal change: In Text.Pandoc.CSV, `CSVOptions` has changed - so that `csvQuote` takes a Maybe value. - - * Add `tex_math_dollars` to `gfm` default extensions (reflecting - gfm's new support for math). - - * RST, Org, Markdown readers: support rowspans and colspans in grid tables - (#8202, Albert Krewinkel). Note: the writers does not yet support these - more complex grid table features, so these complex grid tables will - not round-trip. - - * HTML, LaTeX, and MediaWiki readers: use `formatCode` - (#8162, #8129, Elliot Bobrow). This moves formatting from inside inline - code elements to the outside, since pandoc's Code element only takes string - content. - - * Markdown reader: - - + Don't parse inline notes with blank lines inside (#8028). - + Allow attributes in special spans (e.g. `smallcaps`, `underline`) - (Albert krewinkel, #4102). These spans are parsed as - SmallCaps or Underline elements, but any attributes are included - in a wrapping Span. - - * HTML reader: - - + Allow sublists that are not marked as items (Albert - Krewinkel, #8150). This is technically invalid HTML, but it can - be found in the wild and browsers handle it. - - * Org reader (Albert Krewinkel): - - + Recognize absolute paths on Windows (Albert Krewinkel, #8201). - + Recognize {webp,jxl} files as images (YI). - + Allow attrs for Org tables (Albert Krewinkel, #8049). Tables with - attributes are no longer wrapped in Div elements; attributes are added - directly to the table element. - + Support line selection in INCLUDE directives (Brian Leung, #8060). - + Fix Post / Pre mixup when setting emphasis chars (Amir Dekel, #8134). - - * LaTeX reader: - - + Support `\includesvg` (#8027). - + Unescape characters in `\lstinline` inside `\passthrough` (#8179). - + Improve `mathEnvWith` (#8122). When converting e.g. an align - environment to an aligned environment inside a Math element, we need - to include a newline before the `\end{aligned}`, since the previous - line might end in a comment. - + Fix treatment of extensions for `\input` in LaTeX reader (#8092). - Previously we required a `.tex` extension, but TeX - allows any extension for `\input` (as opposed to `\include`). - - * RTF reader: - - + support `\nosupersub` (#8170). - - * TikiWiki reader: - - + Support underlined text - - * DocBook reader: - - + Improved reading `` elements (Frerich Raabe, #8065). - - * JATS reader: - - + Strip `ref-` prefix from ref id in xref (#8007). - + Support edition in references (#8087). - - * RIS reader: - - + Make parser more forgiving (#8034). Allow blank lines after entries. - Allow entries with no space after the `-`, provided they - just have a newline, e.g. `DB -\n`. - + Get right order of names (#8055). - - * MediaWiki reader: - - + Allow HTML comment after row start (#8110). - - * DokuWiki reader: - - + The `tex_math_dollars` extension is now supported for `dokuwiki` - (but off by default) (#8178). - + Content inside `...` is parsed as raw LaTeX inline, - and inside `..` as raw LaTeX block (#8178). - + The behavior of `...` is changed, so that instead of - producing a code block, it produces raw HTML with ``. - - * LaTeX writer: - - + Improve grouping with autocites (#8088). - + Extend list of book documentclasses (Wentau Han, #8053). - + Fix width of multicolumn cells (Albert Krewinkel, #8090). - Cells spanning multiple columns must be given an explicit width, - calculated from the table properties. - + Beamer: allow containsverbatim as alternative to fragile (#8080). - - * HTML writer: - - + Add 'footnotes' identifier to footnotes section (#8043). - + Fix bug with `--number-offset`. This formerly caused section divs - to be produced, even when `--section-divs` was not specified (#8097). - + Use CSS flexboxes for columns (Albert Krewinkel). This allows - an arbitrary number of columns, while the previous approach assumed - exactly two columns. - + Allow "spanlike" classes to be combined (see #8194). Previously - classes like "underline" and "marked" had to be the first class - in a span in order for the span to be interpreted as a "ul" or - "mark" element. This commit allows these special classes to be - "stacked," e.g. `[test]{.mark .underline}`; in addition, the - special classes are no longer required to come first in the list - of classes. - + Avoid doubled style attribute when height and width are added to - style because of an image, but the image already has a style attribute - (#8047). - + Do not include the deprecated doc-endnote role (#8030). - doc-endnote was deprecated in DPUB-ARIA 1.1. - + Remove extra soft break for tasklist (black-desk, #8142). - Browser will display the extra newline character between checkbox and - text as a space, which make tasklist items cannot be aligned. - - * EPUB writer: - - + Allow choice of math method for v3 (#8164). Previously we always - used MathML for math in EPUB3, because the spec includes MathML. - But this is not widely supported by readers, so it seems better - to allow users to choose their math method as they can with - EPUB2 or HTML. **NOTE:** Existing workflows that produce EPUBv3 - documents including math will be affected by this change. You - must add `--mathml` to your command line if you want to continue - producing MathML. - - * RST writer: - - + Fix missing spaces with nested inlines (#8182). - + Always escape literal backslash (#8178). - - * Ms writer: - - + Add comment in preamble stating generator. - + Fix roff ms syntax highlighting definitions (#8175, thanks to - Branden Robinson). - - * ConTeXt writer: - - + Support complex table structures (Albert Krewinkel, #8116). - The following table feature are now supported in ConTeXt: - - - colspans, - - rowspans, - - multiple bodies, - - row headers, and - - multi-row table head and foot. - - The wrapping `placetable` environment is also given a `reference` option - with the table identifier, enabling referencing of the table from within - the document. - + Unify link handling (Albert Krewinkel, #8096). - Autolinks, i.e. links with content that's the same as the linked URL, - are now marked with the `\url` command. All other links, both internal - and external, are created with the `\goto` command, leading to shorter, - slightly more idiomatic code. As before, autolinks can still be styled - via `\setupurl`, other links via `\setupinteraction`. - + Use "sectionlevel" environment for headings (Albert Krewinkel, #5539). - The document hierarchy is now conveyed using the - `\startsectionlevel`/`\stopsectionlevel` by default. This makes it easy - to include pandoc-generated snippets in documents at arbitrary levels. - The more semantic environments "chapter", "section", "subsection", etc. - are used if the `--top-level-division` command line parameter is set to - a non-default value. - - * Docx writer: - - + Add `w:lang` to `rPr` for Span and Div with lang attribute, so - that Word can know that "Apfel" is not a spelling error (#8026). - + Prevent crashing when handling invalid tables (Albert Krewinkel, #8102). - Tables with different numbers of cells per row would sometimes crash - pandoc. This fix prevents this by cutting off overlong rows. - - * ICML writer: - - + Support custom-style attribute on Table (#8079). - - * AsciiDoc writer: - - + Fix commas in link text (#8070). Commas in link text trigger - interpretation of attributes. To block this, we replace them with - numeric entities. - + Fix underline. We were rendering it as `+++text+++`; this is now - changed to `[.underline]#text#`. See comment at - . - - * FB2 writer: - - + Fix handling of non-section Divs (#8123). - - * Markdown writer: - - + Disable soft wrapping when `hard_line_breaks` enabled (#8035). - We were already doing this for `markdown`; this commit does - the same thing for `markua` and `commonmark` and `gfm`. - + Avoid excessive indentation on bullet lists for `commonmark`, - `markua`, `gfm`. They are now nested by 2 spaces instead of 4 (#8011). - - * Text.Pandoc.Class: - - + Add new function `findFileWithDataFallback` [API Change] - (Albert Krewinkel). - + `fillMediaBag`: Keep attributes of original image on Span (Albert - Krewinkel, #8099). Images that cannot be fetched are replaced with a - Span that contains the image's description. The span now also retains - all original image attributes and inherits all attributes of the image. - Furthermore, the classes `image` and `placeholder` are added, and path - and title are store in attributes `original-image-src` and - `original-image-title`, respectively. - - * Text.Pandoc.Shared: - - + `makeSections`: don't make a section for a div with class "fragments" - (#8098). - + Ensure that Nulls are ignored by `makeSection` and in segmenting - slides (#8155). - + Add `formatCode` function to Text.Pandoc.Shared [API change] - (Elliot Bobrow, #8129). - + `taskListItemToAscii`: handle asciidoctor's characters (#8011). - Asciidoctor uses different unicode characters for task - lists; we should recognize them too and be able to convert - them to ascii task lists in formats like gfm. - + Deprecate `deLink` and mark for later removal. - - * Text.Pandoc.Writers.Shared: - - + `toTableOfContents`: Don't replace links with empty spans in TOC (#8020). - - * Text.Pandoc.Readers.Metadata: - - + Ensure that metadata values w/o trailing newlines are - parsed as inlines, as the manual states. - Previously, they were parsed as inlines if they would - otherwise have been a single Plain or Para, but otherwise - left unchanged. This led to some quirky results (e.g. #8143). - We now use the general function `blocksToInlines` from T.P.Shared. - - * Text.Pandoc.Parsing: - - + Simplify `gridTableWith'`, `gridTableWith` [API Change] (Albert - Krewinkel). The functions `gridTableWith` and `gridTableWith'` no - longer takes a boolean argument that toggles whether a table head - should be parsed: both, tables with heads and without heads, are - always accepted now. - - * Lua subsystem (Albert Krewinkel): - - + Extend `pandoc.system` module (Albert Krewinkel, #8184). - The module now has the additional functions `list_directory`, - `make_directory`, and `remove_directory`. This makes it easier to write - cross-platform scripts that need to inspect or modify the file system. - + Require pandoc-lua-marshal 0.1.7. Adds a `clone` methods to - Pandoc objects and allows to pass Blocks in instead of full - Caption elements. - + Add fields `pandoc.readers` and `pandoc.writers` (#8177). - The set of supported input and output formats is made available to Lua - users. - + Ensure that tables marshaled via JSON arrays behave like Lists. - This allows to invoke methods like `map` and `includes` on lists like - `PANDOC_WRITER_OPTIONS.extensions`. - + Require hslua-2.2.1, unless lua53 flag is set, and do not reset - foreign encoding before running Lua. This fixes a problem where - the encoding used for Lua filenames would sometimes mismatch the - encoding used by the OS. - + Simplify module loading code. Modules are now loaded directly; - the special pandoc Lua package searcher is no longer necessary and - has been removed. - + Add function pandoc.mediabag.fill (#8104). The function allows to - fill the mediabag with all images in a given document. Images that - cannot be fetched are replaced with a Span containing the - image description. - - * Populate mediabag after filters have run (Albert Krewinkel, #8099). - The mediabag is filled with document resources after the filters have - run. This allows, for example, filter authors to modify image paths - before pandoc tries to fetch the images. - Lua filters that rely on a filled mediabag can use the new - `pandoc.mediabag.fill` function to perform that action in the filter. - - * Ms template: redefine rather than removing .CH macro (#8175). - - * JATS template (Albert Krewinkel, except as noted): - - + Include particles, prefix, suffix in names. - + Mark authors with cor-id as corresponding authors. - Corresponding authors are marked by setting the attribute - `corresp="yes"` in their respective `` element. - + Unconditionally include permissions element (#8040). - Fixes a bug that caused license information to be omitted when no - copyright information was provided. - + Follow JATS4R recommendation and PudMed Central for license URI - (Castedo Ellerman, #8041). - - * LaTeX template: - - + Rename `\textormath` to `\TextOrMath` (Hos Es, #8036). - + Fix links-as-notes (Albert Krewinkel, #8077). - - * HTML template styles: - - + Remove `span.underline` rule. This is superfluous now that we - render Underline as ``. - + Improve CSS for task lists (#8151). - - * LaTeX template: Add `boxlinks` variable for LaTeX/PDF output (#8198). - If `boxlinks` is set but `colorlinks` is not, then boxes will - be printed around links (`hidelinks` will not be set in `hypersetup`). - - * `--self-contained`: Handle `url()` in ` +$for(css)$ + +$endfor$ +$for(header-includes)$ + $header-includes$ +$endfor$ +$if(math)$ + $math$ +$endif$ + + +$for(include-before)$ +$include-before$ +$endfor$ + +$if(title)$ +
+

$title$

+$if(subtitle)$ +

$subtitle$

+$endif$ +$for(author)$ +

$author$

+$endfor$ +$if(date)$ +

$date$

+$endif$ +$if(abstract)$ +
+
$abstract-title$
+$abstract$ +
+$endif$ +
+$endif$ +$if(toc)$ + +$endif$ +$body$ +$for(include-after)$ +$include-after$ +$endfor$ + + diff --git a/data/templates/default.context b/data/templates/default.context --- a/data/templates/default.context +++ b/data/templates/default.context @@ -114,6 +114,12 @@ \setupxtable[foot][] \setupxtable[lastrow][bottomframe=on] +$if(emphasis-commands)$ +$emphasis-commands$ +$endif$ +$if(highlighting-commands)$ +$highlighting-commands$ +$endif$ $if(csl-refs)$ \definemeasure[cslhangindent][1.5em] \definenarrower[hangingreferences][left=\measure{cslhangindent}] diff --git a/data/templates/default.epub2 b/data/templates/default.epub2 --- a/data/templates/default.epub2 +++ b/data/templates/default.epub2 @@ -7,8 +7,11 @@ $pagetitle$ diff --git a/data/templates/default.epub3 b/data/templates/default.epub3 --- a/data/templates/default.epub3 +++ b/data/templates/default.epub3 @@ -6,8 +6,11 @@ $pagetitle$ diff --git a/data/templates/default.latex b/data/templates/default.latex --- a/data/templates/default.latex +++ b/data/templates/default.latex @@ -82,11 +82,6 @@ \usepackage{beamerarticle} % needs to be loaded first $endif$ \usepackage{amsmath,amssymb} -$if(fontfamily)$ -\usepackage[$for(fontfamilyoptions)$$fontfamilyoptions$$sep$,$endfor$]{$fontfamily$} -$else$ -\usepackage{lmodern} -$endif$ $if(linestretch)$ \usepackage{setspace} $endif$ @@ -98,16 +93,49 @@ \else % if luatex or xetex $if(mathspec)$ \ifXeTeX - \usepackage{mathspec} + \usepackage{mathspec} % this also loads fontspec \else - \usepackage{unicode-math} + \usepackage{unicode-math} % this also loads fontspec \fi $else$ - \usepackage{unicode-math} + \usepackage{unicode-math} % this also loads fontspec $endif$ - \defaultfontfeatures{Scale=MatchLowercase} + \defaultfontfeatures{Scale=MatchLowercase}$-- must come before Beamer theme \defaultfontfeatures[\rmfamily]{Ligatures=TeX,Scale=1} +\fi +$if(fontfamily)$ +$else$ +$-- Set default font before Beamer theme so the theme can override it +\usepackage{lmodern} +$endif$ +$-- Set Beamer theme before user font settings so they can override theme +$if(beamer)$ +$if(theme)$ +\usetheme[$for(themeoptions)$$themeoptions$$sep$,$endfor$]{$theme$} +$endif$ +$if(colortheme)$ +\usecolortheme{$colortheme$} +$endif$ +$if(fonttheme)$ +\usefonttheme{$fonttheme$} +$endif$ $if(mainfont)$ +\usefonttheme{serif} % use mainfont rather than sansfont for slide text +$endif$ +$if(innertheme)$ +\useinnertheme{$innertheme$} +$endif$ +$if(outertheme)$ +\useoutertheme{$outertheme$} +$endif$ +$endif$ +$-- User font settings (must come after default font and Beamer theme) +$if(fontfamily)$ +\usepackage[$for(fontfamilyoptions)$$fontfamilyoptions$$sep$,$endfor$]{$fontfamily$} +$endif$ +\ifPDFTeX\else + % xetex/luatex font selection +$if(mainfont)$ \setmainfont[$for(mainfontoptions)$$mainfontoptions$$sep$,$endfor$]{$mainfont$} $endif$ $if(sansfont)$ @@ -167,26 +195,6 @@ \fi %% End of ZWNJ support $endif$ -$if(beamer)$ -$if(theme)$ -\usetheme[$for(themeoptions)$$themeoptions$$sep$,$endfor$]{$theme$} -$endif$ -$if(colortheme)$ -\usecolortheme{$colortheme$} -$endif$ -$if(fonttheme)$ -\usefonttheme{$fonttheme$} -$endif$ -$if(mainfont)$ -\usefonttheme{serif} % use mainfont rather than sansfont for slide text -$endif$ -$if(innertheme)$ -\useinnertheme{$innertheme$} -$endif$ -$if(outertheme)$ -\useoutertheme{$outertheme$} -$endif$ -$endif$ % Use upquote if available, for straight quotes in verbatim environments \IfFileExists{upquote.sty}{\usepackage{upquote}}{} \IfFileExists{microtype.sty}{% use microtype if available @@ -270,9 +278,12 @@ \def\fps@figure{htbp} \makeatother $endif$ +$if(svg)$ +\usepackage{svg} +$endif$ $if(strikeout)$ $-- also used for underline -\usepackage[normalem]{ulem} +\usepackage{soul} $endif$ \setlength{\emergencystretch}{3em} % prevent overfull lines \providecommand{\tightlist}{% @@ -282,6 +293,9 @@ $else$ \setcounter{secnumdepth}{-\maxdimen} % remove section numbering $endif$ +$if(subfigure)$ +\usepackage{subcaption} +$endif$ $if(beamer)$ $else$ $if(block-headings)$ @@ -332,7 +346,13 @@ \fi $if(babel-lang)$ \babelprovide[main,import]{$babel-lang$} +$if(mainfont)$ +\ifPDFTeX +\else +\babelfont[$babel-lang$]{rm}{$mainfont$} +\fi $endif$ +$endif$ $for(babel-otherlangs)$ \babelprovide[import]{$babel-otherlangs$} $endfor$ @@ -373,7 +393,7 @@ $endif$ \IfFileExists{bookmark.sty}{\usepackage{bookmark}}{\usepackage{hyperref}} \IfFileExists{xurl.sty}{\usepackage{xurl}}{} % add URL line breaks if available -\urlstyle{same} % disable monospaced font for URLs +\urlstyle{$if(urlstyle)$$urlstyle$$else$same$endif$} $if(links-as-notes)$ % Make links footnotes instead of hotlinks: \DeclareRobustCommand{\href}[2]{#2\footnote{\url{#1}}} diff --git a/data/templates/default.revealjs b/data/templates/default.revealjs --- a/data/templates/default.revealjs +++ b/data/templates/default.revealjs @@ -235,28 +235,28 @@ $if(parallaxBackgroundImage)$ // Parallax background image - parallaxBackgroundImage: '$parallaxBackgroundImage$', // e.g. "'https://s3.amazonaws.com/hakim-static/reveal-js/reveal-parallax-1.jpg'" + parallaxBackgroundImage: '$parallaxBackgroundImage/nowrap$', // e.g. "'https://s3.amazonaws.com/hakim-static/reveal-js/reveal-parallax-1.jpg'" $else$ $if(background-image)$ // Parallax background image - parallaxBackgroundImage: '$background-image$', // e.g. "'https://s3.amazonaws.com/hakim-static/reveal-js/reveal-parallax-1.jpg'" + parallaxBackgroundImage: '$background-image/nowrap$', // e.g. "'https://s3.amazonaws.com/hakim-static/reveal-js/reveal-parallax-1.jpg'" $endif$ $endif$ $if(parallaxBackgroundSize)$ // Parallax background size - parallaxBackgroundSize: '$parallaxBackgroundSize$', // CSS syntax, e.g. "2100px 900px" + parallaxBackgroundSize: '$parallaxBackgroundSize/nowrap$', // CSS syntax, e.g. "2100px 900px" $endif$ $if(parallaxBackgroundHorizontal)$ // Amount to move parallax background (horizontal and vertical) on slide change // Number, e.g. 100 - parallaxBackgroundHorizontal: $parallaxBackgroundHorizontal$, + parallaxBackgroundHorizontal: $parallaxBackgroundHorizontal/nowrap$, $endif$ $if(parallaxBackgroundVertical)$ - parallaxBackgroundVertical: $parallaxBackgroundVertical$, + parallaxBackgroundVertical: $parallaxBackgroundVertical/nowrap$, $endif$ $if(width)$ diff --git a/data/templates/styles.citations.html b/data/templates/styles.citations.html new file mode 100644 --- /dev/null +++ b/data/templates/styles.citations.html @@ -0,0 +1,23 @@ +/* CSS for citations */ +div.csl-bib-body { } +div.csl-entry { + clear: both; +$if(csl-entry-spacing)$ + margin-bottom: $csl-entry-spacing$; +$endif$ +} +.hanging-indent div.csl-entry { + margin-left:2em; + text-indent:-2em; +} +div.csl-left-margin { + min-width:2em; + float:left; +} +div.csl-right-inline { + margin-left:2em; + padding-left:1em; +} +div.csl-indent { + margin-left: 2em; +} diff --git a/data/templates/styles.html b/data/templates/styles.html --- a/data/templates/styles.html +++ b/data/templates/styles.html @@ -1,14 +1,20 @@ $if(document-css)$ html { - line-height: $if(linestretch)$$linestretch$$else$1.5$endif$; - font-family: $if(mainfont)$$mainfont$$else$Georgia, serif$endif$; - font-size: $if(fontsize)$$fontsize$$else$20px$endif$; +$if(mainfont)$ + font-family: $mainfont$; +$endif$ +$if(fontsize)$ + font-size: $fontsize$; +$endif$ +$if(linestretch)$ + line-height: $linestretch$; +$endif$ color: $if(fontcolor)$$fontcolor$$else$#1a1a1a$endif$; background-color: $if(backgroundcolor)$$backgroundcolor$$else$#fdfdfd$endif$; } body { margin: 0 auto; - max-width: 36em; + max-width: $if(maxwidth)$$maxwidth$$else$36em$endif$; padding-left: $if(margin-left)$$margin-left$$else$50px$endif$; padding-right: $if(margin-right)$$margin-right$$else$50px$endif$; padding-top: $if(margin-top)$$margin-top$$else$50px$endif$; @@ -21,13 +27,16 @@ @media (max-width: 600px) { body { font-size: 0.9em; - padding: 1em; + padding: 12px; } h1 { font-size: 1.8em; } } @media print { + html { + background-color: $if(backgroundcolor)$$backgroundcolor$$else$white$endif$; + } body { background-color: transparent; color: black; @@ -90,13 +99,14 @@ } $endif$ code { - font-family: $if(monofont)$$monofont$$else$Menlo, Monaco, 'Lucida Console', Consolas, monospace$endif$; + font-family: $if(monofont)$$monofont$$else$Menlo, Monaco, Consolas, 'Lucida Console', monospace$endif$; $if(monobackgroundcolor)$ background-color: $monobackgroundcolor$; padding: .2em .4em; $endif$ font-size: 85%; margin: 0; + hyphens: manual; } pre { margin: 1em 0; @@ -175,33 +185,13 @@ $if(quotes)$ q { quotes: "“" "”" "‘" "’"; } $endif$ -$if(highlighting-css)$ -$highlighting-css$ -$endif$ $if(displaymath-css)$ .display.math{display: block; text-align: center; margin: 0.5rem auto;} $endif$ -$if(csl-css)$ -div.csl-bib-body { } -div.csl-entry { - clear: both; -$if(csl-entry-spacing)$ - margin-bottom: $csl-entry-spacing$; +$if(highlighting-css)$ +/* CSS for syntax highlighting */ +$highlighting-css$ $endif$ -} -.hanging div.csl-entry { - margin-left:2em; - text-indent:-2em; -} -div.csl-left-margin { - min-width:2em; - float:left; -} -div.csl-right-inline { - margin-left:2em; - padding-left:1em; -} -div.csl-indent { - margin-left: 2em; -} +$if(csl-css)$ +$styles.citations.html()$ $endif$ diff --git a/man/pandoc.1 b/man/pandoc.1 --- a/man/pandoc.1 +++ b/man/pandoc.1 @@ -1,4 +1,4 @@ -.\" Automatically generated by Pandoc 2.19 +.\" Automatically generated by Pandoc 2.19.2 .\" .\" Define V font for inline verbatim, using C font in formats .\" that render this, and otherwise B font. @@ -14,7 +14,7 @@ . ftr VB CB . ftr VBI CBI .\} -.TH "Pandoc User\[cq]s Guide" "" "August 22, 2022" "pandoc 2.19.2" "" +.TH "Pandoc User\[cq]s Guide" "" "January 17, 2023" "pandoc 3.0" "" .hy .SH NAME pandoc - general markup converter @@ -187,7 +187,7 @@ \f[V]iftex\f[R], \f[V]listings\f[R] (if the \f[V]--listings\f[R] option is used), \f[V]fancyvrb\f[R], \f[V]longtable\f[R], \f[V]booktabs\f[R], \f[V]graphicx\f[R] (if the document contains images), -\f[V]hyperref\f[R], \f[V]xcolor\f[R], \f[V]ulem\f[R], \f[V]geometry\f[R] +\f[V]hyperref\f[R], \f[V]xcolor\f[R], \f[V]soul\f[R], \f[V]geometry\f[R] (with the \f[V]geometry\f[R] variable set), \f[V]setspace\f[R] (with \f[V]linestretch\f[R]), and \f[V]babel\f[R] (with \f[V]lang\f[R]). If \f[V]CJKmainfont\f[R] is set, \f[V]xeCJK\f[R] is needed. @@ -345,6 +345,8 @@ .IP \[bu] 2 \f[V]biblatex\f[R] (BibLaTeX bibliography) .IP \[bu] 2 +\f[V]chunkedhtml\f[R] (zip archive of multiple linked HTML files) +.IP \[bu] 2 \f[V]commonmark\f[R] (CommonMark Markdown) .IP \[bu] 2 \f[V]commonmark_x\f[R] (CommonMark Markdown with extensions) @@ -472,6 +474,11 @@ If \f[I]FILE\f[R] is \f[V]-\f[R], output will go to \f[I]stdout\f[R], even if a non-textual format (\f[V]docx\f[R], \f[V]odt\f[R], \f[V]epub2\f[R], \f[V]epub3\f[R]) is specified. +If the output format is \f[V]chunkedhtml\f[R] and \f[I]FILE\f[R] has no +extension, then instead of producing a \f[V].zip\f[R] file pandoc will +create a directory \f[I]FILE\f[R] and unpack the zip archive there +(unless \f[I]FILE\f[R] already exists, in which case an error will be +raised). .TP \f[V]--data-dir=\f[R]\f[I]DIRECTORY\f[R] Specify the user data directory to search for pandoc data files. @@ -580,13 +587,6 @@ Use \f[VI]--shift-heading-level-by\f[I]=X instead, where X = NUMBER - 1.\f[R] Specify the base level for headings (defaults to 1). .TP -\f[V]--strip-empty-paragraphs\f[R] -\f[I]Deprecated. -Use the \f[VI]+empty_paragraphs\f[I] extension instead.\f[R] Ignore -paragraphs with no content. -This option is useful for converting word processing documents where -users have used empty paragraphs to create inter-paragraph space. -.TP \f[V]--indented-code-classes=\f[R]\f[I]CLASSES\f[R] Specify classes to use for indented code blocks\[en]for example, \f[V]perl,numberLines\f[R] or \f[V]haskell\f[R]. @@ -605,6 +605,19 @@ to work as expected. If this option is set, footnotes and links will not work across files. Reading binary files (docx, odt, epub) implies \f[V]--file-scope\f[R]. +.RS +.PP +If two or more files are processed using \f[V]--file-scope\f[R], +prefixes based on the filenames will be added to identifiers in order to +disambiguate them, and internal links will be adjusted accordingly. +For example, a header with identifier \f[V]foo\f[R] in +\f[V]subdir/file1.txt\f[R] will have its identifier changed to +\f[V]subdir__file1.txt__foo\f[R]. +.PP +In addition, a Div with an identifier based on the filename will be +added around the file\[cq]s content, so that internal links to the +filename will point to this Div\[cq]s identifier. +.RE .TP \f[V]-F\f[R] \f[I]PROGRAM\f[R], \f[V]--filter=\f[R]\f[I]PROGRAM\f[R] Specify an executable to be used as a filter transforming the pandoc AST @@ -697,7 +710,7 @@ \f[V]--metadata-file=\f[R]\f[I]FILE\f[R] Read metadata from the supplied YAML (or JSON) file. This option can be used with every input format, but string scalars in -the YAML file will always be parsed as Markdown. +the metadata file will always be parsed as Markdown. (If the input format is Markdown or a Markdown variant, then the same variant will be used to parse the metadata file; if it is a non-Markdown format, pandoc\[cq]s default Markdown extensions will be used.) @@ -1017,8 +1030,9 @@ left alone; the documents they link to will not be incorporated in the document. Limitation: resources that are loaded dynamically through JavaScript -cannot be incorporated; as a result, some advanced features (e.g.\ zoom -or speaker notes) may not work in an offline \[lq]self-contained\[rq] +cannot be incorporated; as a result, fonts may be missing when +\f[V]--mathjax\f[R] is used, and some advanced features (e.g.\ zoom or +speaker notes) may not work in an offline \[lq]self-contained\[rq] \f[V]reveal.js\f[R] slide show. .TP \f[V]--html-q-tags\f[R] @@ -1030,10 +1044,9 @@ Use only ASCII characters in output. Currently supported for XML and HTML formats (which use entities instead of UTF-8 when this option is selected), CommonMark, gfm, and Markdown -(which use entities), roff ms (which use hexadecimal escapes), and to a -limited degree LaTeX (which uses standard commands for accented +(which use entities), roff man and ms (which use hexadecimal escapes), +and to a limited degree LaTeX (which uses standard commands for accented characters when possible). -roff man output uses ASCII by default. .TP \f[V]--reference-links\f[R] Use reference-style links, rather than inline links, in writing Markdown @@ -1059,8 +1072,8 @@ ATX-style headings are always used for levels 3+. This option also affects Markdown cells in \f[V]ipynb\f[R] output. .TP -\f[V]--atx-headers\f[R] -\f[I]Deprecated synonym for \f[VI]--markdown-headings=atx\f[I].\f[R] +\f[V]--list-tables\f[R] +Render tables as list tables in RST output. .TP \f[V]--top-level-division=default\f[R]|\f[V]section\f[R]|\f[V]chapter\f[R]|\f[V]part\f[R] Treat top-level headings as the given division type in LaTeX, ConTeXt, @@ -1156,6 +1169,10 @@ Link to a CSS style sheet. This option can be used repeatedly to include multiple files. They will be included in the order specified. +This option only affects HTML (including HTML slide shows) and EPUB +output. +It should be used together with \f[V]-s/--standalone\f[R], because the +link to the stylesheet goes in the document header. .RS .PP A stylesheet is required for generating EPUB. @@ -1166,7 +1183,7 @@ If it is not found there, sensible defaults will be used. .RE .TP -\f[V]--reference-doc=\f[R]\f[I]FILE\f[R] +\f[V]--reference-doc=\f[R]\f[I]FILE\f[R]|\f[I]URL\f[R] Use the specified file as a style reference in producing a docx or ODT file. .RS @@ -1331,6 +1348,21 @@ .RE .RE .TP +\f[V]--split-level=\f[R]\f[I]NUMBER\f[R] +Specify the heading level at which to split an EPUB or chunked HTML +document into separate files. +The default is to split into chapters at level-1 headings. +In the case of EPUB, this option only affects the internal composition +of the EPUB, not the way chapters and sections are displayed to users. +Some readers may be slow if the chapter files are too large, so for +large documents with few level-1 headings, one might want to use a +chapter level of 2 or 3. +For chunked HTML, this option determines how much content goes in each +\[lq]chunk.\[rq] +.TP +\f[V]--epub-chapter-level=\f[R]\f[I]NUMBER\f[R] +\f[I]Deprecated synonym for \f[VI]--split-level\f[I].\f[R] +.TP \f[V]--epub-cover-image=\f[R]\f[I]FILE\f[R] Use the specified image as the EPUB cover. It is recommended that the image be less than 1000px in width and @@ -1339,6 +1371,10 @@ \f[V]cover-image\f[R] in a YAML metadata block (see EPUB Metadata, below). .TP +\f[V]--epub-title-page=true\f[R]|\f[V]false\f[R] +Determines whether a the title page is included in the EPUB (default is +\f[V]true\f[R]). +.TP \f[V]--epub-metadata=\f[R]\f[I]FILE\f[R] Look in the specified XML file for metadata for the EPUB. The file should contain a series of Dublin Core elements. @@ -1380,44 +1416,34 @@ .nf \f[C] \[at]font-face { -font-family: DejaVuSans; -font-style: normal; -font-weight: normal; -src:url(\[dq]DejaVuSans-Regular.ttf\[dq]); + font-family: DejaVuSans; + font-style: normal; + font-weight: normal; + src:url(\[dq]../fonts/DejaVuSans-Regular.ttf\[dq]); } \[at]font-face { -font-family: DejaVuSans; -font-style: normal; -font-weight: bold; -src:url(\[dq]DejaVuSans-Bold.ttf\[dq]); + font-family: DejaVuSans; + font-style: normal; + font-weight: bold; + src:url(\[dq]../fonts/DejaVuSans-Bold.ttf\[dq]); } \[at]font-face { -font-family: DejaVuSans; -font-style: italic; -font-weight: normal; -src:url(\[dq]DejaVuSans-Oblique.ttf\[dq]); + font-family: DejaVuSans; + font-style: italic; + font-weight: normal; + src:url(\[dq]../fonts/DejaVuSans-Oblique.ttf\[dq]); } \[at]font-face { -font-family: DejaVuSans; -font-style: italic; -font-weight: bold; -src:url(\[dq]DejaVuSans-BoldOblique.ttf\[dq]); + font-family: DejaVuSans; + font-style: italic; + font-weight: bold; + src:url(\[dq]../fonts/DejaVuSans-BoldOblique.ttf\[dq]); } body { font-family: \[dq]DejaVuSans\[dq]; } \f[R] .fi .RE .TP -\f[V]--epub-chapter-level=\f[R]\f[I]NUMBER\f[R] -Specify the heading level at which to split the EPUB into separate -\[lq]chapter\[rq] files. -The default is to split into chapters at level-1 headings. -This option only affects the internal composition of the EPUB, not the -way chapters and sections are displayed to users. -Some readers may be slow if the chapter files are too large, so for -large documents with few level-1 headings, one might want to use a -chapter level of 2 or 3. -.TP \f[V]--epub-subdirectory=\f[R]\f[I]DIRNAME\f[R] Specify the subdirectory in the OCF container that is to hold the EPUB-specific contents. @@ -1655,11 +1681,11 @@ 62 PandocShouldNeverHappenError 63 PandocSomeError 64 PandocParseError - 65 PandocParsecError 66 PandocMakePDFError 67 PandocSyntaxMapError 83 PandocFilterError 84 PandocLuaError + 89 PandocNoScriptingEngine 91 PandocMacroLoop 92 PandocUTF8DecodingError 93 PandocIpynbDecodingError @@ -1939,6 +1965,8 @@ --markdown-headings atx markdown-headings: atx + --list-tables list-tables: true + --top-level-division chapter top-level-division: chapter --number-sections number-sections: true @@ -1968,6 +1996,8 @@ --epub-cover-image cover.jpg epub-cover-image: cover.jpg + --epub-title-page=false epub-title-page: false + --epub-metadata meta.xml epub-metadata: meta.xml epub-fonts: @@ -1975,7 +2005,7 @@ - headline.otf --epub-embed-font headline.otf - --epub-chapter-level 2 epub-chapter-level: 2 + --split-level 2 split-level: 2 --epub-subdirectory=\[dq]\[dq] epub-subdirectory: \[aq]\[aq] @@ -2693,6 +2723,9 @@ sets the CSS \f[V]line-height\f[R] property on the \f[V]html\f[R] element, which is preferred to be unitless. .TP +\f[V]maxwidth\f[R] +sets the CSS \f[V]max-width\f[R] property (default is 32em). +.TP \f[V]backgroundcolor\f[R] sets the CSS \f[V]background-color\f[R] property on the \f[V]html\f[R] element. @@ -3002,6 +3035,9 @@ .TP \f[V]links-as-notes\f[R] causes links to be printed as footnotes +.TP +\f[V]urlstyle\f[R] +style for URLs (e.g., tt, same) .SS Front matter .TP \f[V]lof\f[R], \f[V]lot\f[R] @@ -3161,7 +3197,15 @@ .SS Variables for ms .TP \f[V]fontfamily\f[R] -font family (e.g.\ \f[V]T\f[R] or \f[V]P\f[R]) +\f[V]A\f[R] (Avant Garde), \f[V]B\f[R] (Bookman), \f[V]C\f[R] +(Helvetica), \f[V]HN\f[R] (Helvetica Narrow), \f[V]P\f[R] (Palatino), or +\f[V]T\f[R] (Times New Roman). +This setting does not affect source code, which is always displayed +using monospace Courier. +These built-in fonts are limited in their coverage of characters. +Additional fonts may be installed using the script +\f[V]install-font.sh\f[R] provided by Peter Schaffter and documented in +detail on his web site. .TP \f[V]indent\f[R] paragraph indent (e.g.\ \f[V]2m\f[R]) @@ -3239,6 +3283,9 @@ \f[V]curdir\f[R] working directory from which pandoc is run. .TP +\f[V]pandoc-version\f[R] +pandoc version. +.TP \f[V]toc\f[R] non-null value if \f[V]--toc/--table-of-contents\f[R] was specified .TP @@ -3266,7 +3313,7 @@ .PP Note that markdown extensions added to the \f[V]ipynb\f[R] format affect Markdown cells in Jupyter notebooks (as do command-line options like -\f[V]--atx-headers\f[R]). +\f[V]--markdown-headings\f[R]). .SS Typography .SS Extension: \f[V]smart\f[R] .PP @@ -3642,6 +3689,14 @@ 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. +.SS Extension: \f[V]tagging\f[R] +.PP +Enabling this extension with \f[V]context\f[R] output will produce +markup suitable for the production of tagged PDFs. +This includes additional markers for paragraphs and alternative markup +for emphasized text. +The \f[V]emphasis-command\f[R] template variable is set if the extension +is enabled. .SH PANDOC\[cq]S MARKDOWN .PP Pandoc understands an extended and slightly revised version of John @@ -3952,7 +4007,7 @@ .nf \f[C] > This is a block quote. ->> Nested. +>> Not nested, since \[ga]blank_before_blockquote\[ga] is enabled by default \f[R] .fi .SS Verbatim (code) blocks @@ -4078,6 +4133,26 @@ \f[R] .fi .PP +This shortcut form may be combined with attributes: +.IP +.nf +\f[C] +\[ga]\[ga]\[ga]haskell {.numberLines} +qsort [] = [] +\[ga]\[ga]\[ga] +\f[R] +.fi +.PP +Which is equivalent to: +.IP +.nf +\f[C] +\[ga]\[ga]\[ga] {.haskell .numberLines} +qsort [] = [] +\[ga]\[ga]\[ga] +\f[R] +.fi +.PP If the \f[V]fenced_code_attributes\f[R] extension is disabled, but input contains class attribute(s) for the code block, the first class attribute will be printed after the opening fence as a bare word. @@ -4537,7 +4612,7 @@ A caption may optionally be provided with all 4 kinds of tables (as illustrated in the examples below). A caption is a paragraph beginning with the string \f[V]Table:\f[R] (or -just \f[V]:\f[R]), which will be stripped off. +\f[V]table:\f[R] or just \f[V]:\f[R]), which will be stripped off. It may appear either before or after the table. .SS Extension: \f[V]simple_tables\f[R] .PP @@ -4677,10 +4752,40 @@ can be omitted for a headerless table. The cells of grid tables may contain arbitrary block elements (multiple paragraphs, code blocks, lists, etc.). -Cells that span multiple columns or rows are not supported. -Grid tables can be created easily using Emacs\[cq] table-mode -(\f[V]M-x table-insert\f[R]). .PP +Cells can span multiple columns or rows: +.IP +.nf +\f[C] ++---------------------+----------+ +| Property | Earth | ++=============+=======+==========+ +| | min | -89.2 \[de]C | +| Temperature +-------+----------+ +| 1961-1990 | mean | 14 \[de]C | +| +-------+----------+ +| | min | 56.7 \[de]C | ++-------------+-------+----------+ +\f[R] +.fi +.PP +A table header may contain more than one row: +.IP +.nf +\f[C] ++---------------------+-----------------------+ +| Location | Temperature 1961-1990 | +| | in degree Celsius | +| +-------+-------+-------+ +| | min | mean | max | ++=====================+=======+=======+=======+ +| Antarctica | -89.2 | N/A | 19.8 | ++---------------------+-------+-------+-------+ +| Earth | -89.2 | 14 | 56.7 | ++---------------------+-------+-------+-------+ +\f[R] +.fi +.PP Alignments can be specified as with pipe tables, by putting colons at the boundaries of the separator line after the header: .IP @@ -4703,15 +4808,28 @@ +---------------+---------------+--------------------+ \f[R] .fi -.SS Grid Table Limitations .PP -Pandoc does not support grid tables with row spans or column spans. -This means that neither variable numbers of columns across rows nor -variable numbers of rows across columns are supported by Pandoc. -All grid tables must have the same number of columns in each row, and -the same number of rows in each column. -For example, the Docutils sample grid tables will not render as expected -with Pandoc. +A table foot can be defined by enclosing it with separator lines that +use \f[V]=\f[R] instead of \f[V]-\f[R]: +.IP +.nf +\f[C] + +---------------+---------------+ + | Fruit | Price | + +===============+===============+ + | Bananas | $1.34 | + +---------------+---------------+ + | Oranges | $2.10 | + +===============+===============+ + | Sum | $3.44 | + +===============+===============+ +\f[R] +.fi +.PP +The foot must always be placed at the very bottom of the table. +.PP +Grid tables can be created easily using Emacs\[cq] table-mode +(\f[V]M-x table-insert\f[R]). .SS Extension: \f[V]pipe_tables\f[R] .PP Pipe tables look like this: @@ -6159,6 +6277,17 @@ Note that relative paths in reference links and images will be rewritten relative to the file containing the link reference definition, not the file containing the reference link or image itself, if these differ. +.SS Extension: \f[V]mark\f[R] +.PP +To highlight out a section of text, begin and end it with with +\f[V]==\f[R]. +Thus, for example, +.IP +.nf +\f[C] +This ==is deleted text.== +\f[R] +.fi .SS Extension: \f[V]attributes\f[R] .PP Allows attributes to be attached to any inline or block-level element @@ -7299,13 +7428,16 @@ \f[V]background-image\f[R] can be used either in the YAML metadata block or as a command-line variable to get the same image on every slide. .PP +Note that for reveal.js, the \f[V]background-image\f[R] will be used as +a \f[V]parallaxBackgroundImage\f[R] (see below). +.PP For pptx, you can use a reference doc in which background images have been set on the relevant layouts. .SS \f[V]parallaxBackgroundImage\f[R] (reveal.js) .PP For reveal.js, there is also the reveal.js-native option -\f[V]parallaxBackgroundImage\f[R], which can be used instead of -\f[V]background-image\f[R] to produce a parallax scrolling background. +\f[V]parallaxBackgroundImage\f[R], which produces a parallax scrolling +background. You must also set \f[V]parallaxBackgroundSize\f[R], and can optionally set \f[V]parallaxBackgroundHorizontal\f[R] and \f[V]parallaxBackgroundVertical\f[R] to configure the scrolling @@ -7603,6 +7735,25 @@ styling of pandoc\[cq]s default HTML templates is desired (and in that case the variables defined in Variables for HTML may be used to fine-tune the style). +.SH CHUNKED HTML +.PP +\f[V]pandoc -t chunkedhtml\f[R] will produce a zip archive of linked +HTML files, one for each section of the original document. +Internal links will automatically be adjusted to point to the right +place, images linked to under the working directory will be +incorporated, and navigation links will be added. +In addition, a JSON file \f[V]sitemap.json\f[R] will be included +describing the hierarchical structure of the files. +.PP +If an output file without an extension is specified, then it will be +interpreted as a directory and the zip archive will be automatically +unpacked into it (unless it already exists, in which case an error will +be raised). +Otherwise a \f[V].zip\f[R] file will be produced. +.PP +The navigation links can be customized by adjusting the template. +By default, a table of contents is included only on the top page. +To include it on every page, set the \f[V]toc\f[R] variable manually. .SH JUPYTER NOTEBOOKS .PP When creating a Jupyter notebook, pandoc will try to infer the notebook @@ -7729,9 +7880,9 @@ Note that options and extensions that affect reading and writing of Markdown will also affect Markdown cells in ipynb notebooks. For example, \f[V]--wrap=preserve\f[R] will preserve soft line breaks in -Markdown cells; \f[V]--atx-headers\f[R] will cause ATX-style headings to -be used; and \f[V]--preserve-tabs\f[R] will prevent tabs from being -turned to spaces. +Markdown cells; \f[V]--markdown-headings=setext\f[R] will cause +Setext-style headings to be used; and \f[V]--preserve-tabs\f[R] will +prevent tabs from being turned to spaces. .SH SYNTAX HIGHLIGHTING .PP Pandoc will automatically highlight syntax in fenced code blocks that @@ -7909,8 +8060,8 @@ .fi .PP If the script is not found relative to the working directory, it will be -sought in the \f[V]readers\f[R] or \f[V]writers\f[R] subdirectory of the -user data directory (see \f[V]--data-dir\f[R]). +sought in the \f[V]custom\f[R] subdirectory of the user data directory +(see \f[V]--data-dir\f[R]). .PP A custom reader is a Lua script that defines one function, Reader, which takes a string as input and returns a Pandoc AST. @@ -7931,14 +8082,7 @@ .PP A custom writer is a Lua script that defines a function that specifies how to render each element in a Pandoc AST. -To see a documented example which you can modify according to your -needs: -.IP -.nf -\f[C] -pandoc --print-default-data-file sample.lua -\f[R] -.fi +See the djot-writer.lua for a full-featured example. .PP Note that custom writers have no default template. If you want to use \f[V]--standalone\f[R] with a custom writer, you will @@ -7960,10 +8104,94 @@ Some document formats also include a unique identifier. For EPUB, this can be set explicitly by setting the \f[V]identifier\f[R] metadata field (see EPUB Metadata, above). +.SH ACCESSIBLE PDFS AND PDF ARCHIVING STANDARDS +.PP +PDF is a flexible format, and using PDF in certain contexts requires +additional conventions. +For example, PDFs are not accessible by default; they define how +characters are placed on a page but do not contain semantic information +on the content. +However, it is possible to generate accessible PDFs, which use tagging +to add semantic information to the document. +.PP +Pandoc defaults to LaTeX to generate PDF. +Tagging support in LaTeX is in development and not readily available, so +PDFs generated in this way will always be untagged and not accessible. +This means that alternative engines must be used to generate accessible +PDFs. +.PP +The PDF standards PDF/A and PDF/UA define further restrictions intended +to optimize PDFs for archiving and accessibility. +Tagging is commonly used in combination with these standards to ensure +best results. +.PP +Note, however, that standard compliance depends on many things, +including the colorspace of embedded images. +Pandoc cannot check this, and external programs must be used to ensure +that generated PDFs are in compliance. +.SS ConTeXt +.PP +ConTeXt always produces tagged PDFs, but the quality depends on the +input. +The default ConTeXt markup generated by pandoc is optimized for +readability and reuse, not tagging. +Enable the \f[V]tagging\f[R] format extension to force markup that is +optimized for tagging. +This can be combined with the \f[V]pdfa\f[R] variable to generate +standard-compliant PDFs. +E.g.: +.IP +.nf +\f[C] +pandoc --to=context+tagging -V pdfa=3a +\f[R] +.fi +.PP +A recent \f[V]context\f[R] version should be used, as older versions +contained a bug that lead to invalid PDF metadata. +.SS WeasyPrint +.PP +The HTML-based engine WeasyPrint includes experimental support for PDF/A +and PDF/UA since version 57. +Tagged PDFs can created with +.IP +.nf +\f[C] +pandoc --pdf-engine=weasyprint \[rs] + --pdf-engine-opt=--pdf-variant=pdf/ua-1 ... +\f[R] +.fi +.PP +The feature is experimental and standard compliance should not be +assumed. +.SS Prince XML +.PP +The non-free HTML-to-PDf converter \f[V]prince\f[R] has extensive +support for various PDF standards as well as tagging. +E.g.: +.IP +.nf +\f[C] +pandoc --pdf-engine=prince \[rs] + --pdf-engine-opt=--tagged-pdf ... +\f[R] +.fi +.PP +See the prince documentation for more info. +.SS Word Processors +.PP +Word processors like LibreOffice and MS Word can also be used to +generate standardized and tagged PDF output. +Pandoc does not support direct conversions via these tools. +However, pandoc can convert a document to a \f[V]docx\f[R] or +\f[V]odt\f[R] file, which can then be opened and converted to PDF with +the respective word processor. +See the documentation for Word and LibreOffice. .SH RUNNING PANDOC AS A WEB SERVER .PP If you rename (or symlink) the pandoc executable to -\f[V]pandoc-server\f[R], it will start up a web server with a JSON API. +\f[V]pandoc-server\f[R], or if you call pandoc with \f[V]server\f[R] as +the first argument, it will start up a web server with a JSON API. This server exposes most of the conversion functionality of pandoc. For full documentation, see the pandoc-server man page. .PP @@ -7974,6 +8202,16 @@ \f[V]pandoc-server\f[R] is designed to be maximally secure; it uses Haskell\[cq]s type system to provide strong guarantees that no I/O will be performed on the server during pandoc conversions. +.SH RUNNING PANDOC AS A LUA INTERPRETER +.PP +Calling the pandoc executable under the name \f[V]pandoc-lua\f[R] or +with \f[V]lua\f[R] as the first argument will make it function as a +standalone Lua interpreter. +The behavior is mostly identical to that of the standalone \f[V]lua\f[R] +executable, version 5.4. +However, there is no REPL yet, and the \f[V]-i\f[R] option has no +effect. +For full documentation, see the pandoc-lua man page. .SH A NOTE ON SECURITY .IP "1." 3 Although pandoc itself will not create or modify any files other than diff --git a/pandoc.cabal b/pandoc.cabal --- a/pandoc.cabal +++ b/pandoc.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: pandoc -version: 2.19.2 +version: 3.0 build-type: Simple license: GPL-2.0-or-later license-file: COPYING.md @@ -12,11 +12,10 @@ homepage: https://pandoc.org category: Text tested-with: GHC == 8.6.5, GHC == 8.8.4, GHC == 8.10.7, GHC == 9.0.2, - GHC == 9.2.3 + GHC == 9.2.5, GHC == 9.4.4 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 - this library. The formats it can handle include + format to another. The formats it can handle include . - light markup formats (many variants of Markdown, reStructuredText, AsciiDoc, Org-mode, Muse, Textile, @@ -49,8 +48,10 @@ data-files: -- templates data/templates/styles.html + data/templates/styles.citations.html data/templates/default.html4 data/templates/default.html5 + data/templates/default.chunkedhtml data/templates/default.docbook4 data/templates/default.docbook5 data/templates/default.jats_archiving @@ -180,8 +181,6 @@ data/dzslides/template.html -- default abbreviations file data/abbreviations - -- sample lua custom writer - data/sample.lua -- sample lua custom reader data/creole.lua -- lua init script @@ -205,9 +204,6 @@ man/manfilter.lua man/pandoc.1.before man/pandoc.1.after - -- trypandoc - trypandoc/index.html - trypandoc/trypandoc.js -- tests test/bodybg.gif test/*.native @@ -219,6 +215,8 @@ test/command/B.txt test/command/C.txt test/command/D.txt + test/command/file1.txt + test/command/file2.txt test/command/three.txt test/command/01.csv test/command/chap1/spider.png @@ -244,7 +242,6 @@ test/command/SVG_logo.svg test/command/corrupt.svg test/command/inkscape-cube.svg - test/command/lua-pandoc-state.lua test/command/sub-file-chapter-1.tex test/command/sub-file-chapter-2.tex test/command/bar.tex @@ -326,12 +323,12 @@ test/tables.txt test/tables.fb2 test/tables.muse - test/tables.custom test/tables.xwiki test/tables/*.html4 test/tables/*.html5 test/tables/*.latex test/tables/*.native + test/tables/*.mediawiki test/tables/*.jats_archiving test/testsuite.txt test/writer.latex @@ -367,7 +364,6 @@ test/writer.zimwiki test/writer.xwiki test/writer.muse - test/writer.custom test/writers-lang-and-dir.latex test/writers-lang-and-dir.context test/dokuwiki_inline_formatting.dokuwiki @@ -413,10 +409,6 @@ test/odt/odt/*.odt test/odt/markdown/*.md test/odt/native/*.native - test/lua/*.lua - test/lua/module/*.lua - test/lua/module/partial.test - test/lua/module/tiny.epub source-repository head type: git location: git://github.com/jgm/pandoc.git @@ -425,14 +417,6 @@ Description: Embed data files in binary for relocatable executable. Default: False -flag lua53 - Description: Embed Lua 5.3 instead of 5.4. - Default: False - -flag nightly - Description: Add '-nightly-COMPILEDATE' to the output of '--version'. - Default: False - common common-options default-language: Haskell2010 build-depends: base >= 4.12 && < 5 @@ -461,13 +445,27 @@ build-depends: pandoc ghc-options: -rtsopts -with-rtsopts=-A8m -threaded +library xml-light + import: common-options + build-depends: xml >= 1.3.12 && < 1.4, + xml-conduit >= 1.9.1.1 && < 1.10, + xml-types >= 0.3 && < 0.4, + containers >= 0.6.0.1 && < 0.7, + text >= 1.1.1.0 && < 2.1 + hs-source-dirs: xml-light + exposed-modules: Text.Pandoc.XML.Light, + Text.Pandoc.XML.Light.Types, + Text.Pandoc.XML.Light.Proc, + Text.Pandoc.XML.Light.Output + library import: common-options - build-depends: Glob >= 0.7 && < 0.11, + build-depends: xml-light, + Glob >= 0.7 && < 0.11, JuicyPixels >= 3.1.6.1 && < 3.4, SHA >= 1.6 && < 1.7, - aeson >= 0.7 && < 2.2, + aeson >= 2.0.1.0 && < 2.2, aeson-pretty >= 0.8.9 && < 0.9, array >= 0.5 && < 0.6, attoparsec >= 0.12 && < 0.15, @@ -476,40 +474,34 @@ blaze-markup >= 0.8 && < 0.9, bytestring >= 0.9 && < 0.12, case-insensitive >= 1.2 && < 1.3, - citeproc >= 0.8.0.1 && < 0.9, + citeproc >= 0.8.1 && < 0.9, commonmark >= 0.2.2 && < 0.3, - commonmark-extensions >= 0.2.3.1 && < 0.3, - commonmark-pandoc >= 0.2.1.2 && < 0.3, + commonmark-extensions >= 0.2.3.3 && < 0.3, + commonmark-pandoc >= 0.2.1.3 && < 0.3, connection >= 0.3.1, containers >= 0.6.0.1 && < 0.7, data-default >= 0.4 && < 0.8, deepseq >= 1.3 && < 1.5, directory >= 1.2.3 && < 1.4, doclayout >= 0.4 && < 0.5, - doctemplates >= 0.10 && < 0.11, + doctemplates >= 0.11 && < 0.12, base64 >= 0.4 && < 0.5, emojis >= 0.1 && < 0.2, exceptions >= 0.8 && < 0.11, file-embed >= 0.0 && < 0.1, filepath >= 1.1 && < 1.5, - gridtables >= 0.0.3 && < 0.1, + gridtables >= 0.1 && < 0.2, haddock-library >= 1.10 && < 1.12, - hslua-module-doclayout>= 1.0.4 && < 1.1, - hslua-module-path >= 1.0.3 && < 1.1, - hslua-module-system >= 1.0 && < 1.1, - hslua-module-text >= 1.0 && < 1.1, - hslua-module-version >= 1.0 && < 1.1, http-client >= 0.4.30 && < 0.8, http-client-tls >= 0.2.4 && < 0.4, http-types >= 0.8 && < 0.13, ipynb >= 0.2 && < 0.3, - jira-wiki-markup >= 1.4 && < 1.5, - lpeg >= 1.0.1 && < 1.1, - mtl >= 2.2 && < 2.3, + jira-wiki-markup >= 1.5 && < 1.6, + mime-types >= 0.1.1 && < 0.2, + mtl >= 2.2 && < 2.4, network >= 2.6, network-uri >= 2.6 && < 2.8, - pandoc-lua-marshal >= 0.1.7 && < 0.2, - pandoc-types >= 1.22.2 && < 1.23, + pandoc-types >= 1.23 && < 1.24, parsec >= 3.1 && < 3.2, pretty >= 1.1 && < 1.2, pretty-show >= 1.10 && < 1.11, @@ -517,53 +509,43 @@ random >= 1 && < 1.3, safe >= 0.3.18 && < 0.4, scientific >= 0.3 && < 0.4, - skylighting >= 0.13 && < 0.14, - skylighting-core >= 0.13 && < 0.14, + skylighting >= 0.13.2 && < 0.14, + skylighting-core >= 0.13.2 && < 0.14, split >= 0.2 && < 0.3, syb >= 0.1 && < 0.8, tagsoup >= 0.14.6 && < 0.15, temporary >= 1.1 && < 1.4, - texmath >= 0.12.5.1 && < 0.12.6, + texmath >= 0.12.5.5 && < 0.12.6, text >= 1.1.1.0 && < 2.1, text-conversions >= 0.3 && < 0.4, time >= 1.5 && < 1.14, unicode-collation >= 0.1.1 && < 0.2, unicode-transforms >= 0.3 && < 0.5, - xml >= 1.3.12 && < 1.4, - xml-conduit >= 1.9.1.1 && < 1.10, - xml-types >= 0.3 && < 0.4, yaml >= 0.11 && < 0.12, zip-archive >= 0.2.3.4 && < 0.5, zlib >= 0.5 && < 0.7, - servant-server, - wai >= 0.3 + xml >= 1.3.12 && < 1.4 if !os(windows) build-depends: unix >= 2.4 && < 2.9 - if flag(nightly) - cpp-options: -DNIGHTLY - build-depends: template-haskell - if flag(lua53) - build-depends: hslua >= 2.1 && < 2.2, - hslua-aeson >= 2.2.1 && < 2.3 - else - build-depends: hslua >= 2.2.1 && < 2.3 - , hslua-aeson >= 2.2.1 && < 2.3 if flag(embed_data_files) cpp-options: -DEMBED_DATA_FILES - other-modules: Text.Pandoc.Data + other-modules: Text.Pandoc.Data.BakedIn hs-source-dirs: src exposed-modules: Text.Pandoc, Text.Pandoc.App, + Text.Pandoc.Data, Text.Pandoc.Options, Text.Pandoc.Extensions, + Text.Pandoc.Format, Text.Pandoc.Shared, Text.Pandoc.Sources, Text.Pandoc.MediaBag, Text.Pandoc.Error, Text.Pandoc.Filter, - Text.Pandoc.Server, + Text.Pandoc.Translations, + Text.Pandoc.Translations.Types, Text.Pandoc.Readers, Text.Pandoc.Readers.HTML, Text.Pandoc.Readers.LaTeX, @@ -589,7 +571,7 @@ Text.Pandoc.Readers.TikiWiki, Text.Pandoc.Readers.Txt2Tags, Text.Pandoc.Readers.Docx, - Text.Pandoc.Readers.Odt, + Text.Pandoc.Readers.ODT, Text.Pandoc.Readers.EPUB, Text.Pandoc.Readers.Muse, Text.Pandoc.Readers.Man, @@ -598,13 +580,13 @@ Text.Pandoc.Readers.Ipynb, Text.Pandoc.Readers.CSV, Text.Pandoc.Readers.RTF, - Text.Pandoc.Readers.Custom, Text.Pandoc.Writers, Text.Pandoc.Writers.Native, - Text.Pandoc.Writers.Docbook, + Text.Pandoc.Writers.DocBook, Text.Pandoc.Writers.JATS, Text.Pandoc.Writers.OPML, Text.Pandoc.Writers.HTML, + Text.Pandoc.Writers.ChunkedHTML, Text.Pandoc.Writers.Ipynb, Text.Pandoc.Writers.ICML, Text.Pandoc.Writers.Jira, @@ -620,7 +602,6 @@ Text.Pandoc.Writers.RST, Text.Pandoc.Writers.Org, Text.Pandoc.Writers.AsciiDoc, - Text.Pandoc.Writers.Custom, Text.Pandoc.Writers.Textile, Text.Pandoc.Writers.MediaWiki, Text.Pandoc.Writers.DokuWiki, @@ -640,9 +621,10 @@ Text.Pandoc.Writers.OOXML, Text.Pandoc.Writers.AnnotatedTable, Text.Pandoc.Writers.BibTeX, - Text.Pandoc.Lua, Text.Pandoc.PDF, Text.Pandoc.UTF8, + Text.Pandoc.Scripting, + Text.Pandoc.Slides, Text.Pandoc.Templates, Text.Pandoc.XML, Text.Pandoc.SelfContained, @@ -655,20 +637,22 @@ Text.Pandoc.Emoji, Text.Pandoc.ImageSize, Text.Pandoc.Class, - Text.Pandoc.Citeproc + Text.Pandoc.Class.IO, + Text.Pandoc.Citeproc, + Text.Pandoc.Chunks, + Text.Pandoc.Version other-modules: Text.Pandoc.App.CommandLineOptions, Text.Pandoc.App.FormatHeuristics, + Text.Pandoc.App.Input, Text.Pandoc.App.Opt, Text.Pandoc.App.OutputSettings, Text.Pandoc.Class.CommonState, - Text.Pandoc.Class.IO, Text.Pandoc.Class.PandocMonad, Text.Pandoc.Class.PandocIO, Text.Pandoc.Class.PandocPure, Text.Pandoc.Class.Sandbox, Text.Pandoc.Filter.Environment, Text.Pandoc.Filter.JSON, - Text.Pandoc.Filter.Lua, Text.Pandoc.Parsing.Capabilities, Text.Pandoc.Parsing.Citations, Text.Pandoc.Parsing.General, @@ -677,7 +661,7 @@ Text.Pandoc.Parsing.Math, Text.Pandoc.Parsing.Smart, Text.Pandoc.Parsing.State, - Text.Pandoc.Parsing.Types, + Text.Pandoc.Parsing.Future, Text.Pandoc.Readers.Docx.Lists, Text.Pandoc.Readers.Docx.Combine, Text.Pandoc.Readers.Docx.Parse, @@ -696,18 +680,17 @@ Text.Pandoc.Readers.LaTeX.Parsing, Text.Pandoc.Readers.LaTeX.SIunitx, Text.Pandoc.Readers.LaTeX.Table, - Text.Pandoc.Readers.LaTeX.Types, - Text.Pandoc.Readers.Odt.Base, - Text.Pandoc.Readers.Odt.Namespaces, - Text.Pandoc.Readers.Odt.StyleReader, - Text.Pandoc.Readers.Odt.ContentReader, - Text.Pandoc.Readers.Odt.Generic.Fallible, - Text.Pandoc.Readers.Odt.Generic.SetMap, - Text.Pandoc.Readers.Odt.Generic.Utils, - Text.Pandoc.Readers.Odt.Generic.Namespaces, - Text.Pandoc.Readers.Odt.Generic.XMLConverter, - Text.Pandoc.Readers.Odt.Arrows.State, - Text.Pandoc.Readers.Odt.Arrows.Utils, + Text.Pandoc.Readers.ODT.Base, + Text.Pandoc.Readers.ODT.Namespaces, + Text.Pandoc.Readers.ODT.StyleReader, + Text.Pandoc.Readers.ODT.ContentReader, + Text.Pandoc.Readers.ODT.Generic.Fallible, + Text.Pandoc.Readers.ODT.Generic.SetMap, + Text.Pandoc.Readers.ODT.Generic.Utils, + Text.Pandoc.Readers.ODT.Generic.Namespaces, + Text.Pandoc.Readers.ODT.Generic.XMLConverter, + Text.Pandoc.Readers.ODT.Arrows.State, + Text.Pandoc.Readers.ODT.Arrows.Utils, Text.Pandoc.Readers.Org.BlockStarts, Text.Pandoc.Readers.Org.Blocks, Text.Pandoc.Readers.Org.DocumentTree, @@ -740,40 +723,15 @@ Text.Pandoc.Writers.Blaze, Text.Pandoc.Writers.Powerpoint.Presentation, Text.Pandoc.Writers.Powerpoint.Output, - Text.Pandoc.Lua.ErrorConversion, - Text.Pandoc.Lua.Filter, - Text.Pandoc.Lua.Global, - Text.Pandoc.Lua.Init, - Text.Pandoc.Lua.Marshal.CommonState, - Text.Pandoc.Lua.Marshal.Context, - Text.Pandoc.Lua.Marshal.PandocError, - Text.Pandoc.Lua.Marshal.ReaderOptions, - Text.Pandoc.Lua.Marshal.Reference, - Text.Pandoc.Lua.Marshal.Sources, - Text.Pandoc.Lua.Marshal.Template, - Text.Pandoc.Lua.Marshal.WriterOptions, - Text.Pandoc.Lua.Module.MediaBag, - Text.Pandoc.Lua.Module.Pandoc, - Text.Pandoc.Lua.Module.System, - Text.Pandoc.Lua.Module.Template, - Text.Pandoc.Lua.Module.Types, - Text.Pandoc.Lua.Module.Utils, - Text.Pandoc.Lua.Orphans, - Text.Pandoc.Lua.PandocLua, - Text.Pandoc.Lua.Writer.Classic, - Text.Pandoc.XML.Light, - Text.Pandoc.XML.Light.Types, - Text.Pandoc.XML.Light.Proc, - Text.Pandoc.XML.Light.Output, - Text.Pandoc.Network.HTTP, + Text.Pandoc.TeX, + Text.Pandoc.URI, Text.Pandoc.CSS, Text.Pandoc.CSV, Text.Pandoc.RoffChar, Text.Pandoc.UUID, - Text.Pandoc.Translations, - Text.Pandoc.Slides, Text.Pandoc.Image, Text.Pandoc.Citeproc.BibTeX, + Text.Pandoc.Citeproc.Name, Text.Pandoc.Citeproc.CslJson, Text.Pandoc.Citeproc.Data, Text.Pandoc.Citeproc.Locator, @@ -783,16 +741,6 @@ autogen-modules: Paths_pandoc buildable: True -executable pandoc - import: common-executable - hs-source-dirs: app - main-is: pandoc.hs - buildable: True - other-modules: Paths_pandoc - build-depends: wai-extra >= 3.0.24, - warp, - safe - test-suite test-pandoc import: common-executable type: exitcode-stdio-1.0 @@ -804,17 +752,14 @@ bytestring >= 0.9 && < 0.12, containers >= 0.4.2.1 && < 0.7, directory >= 1.2.3 && < 1.4, - doctemplates >= 0.10 && < 0.11, - exceptions >= 0.8 && < 0.11, + doctemplates >= 0.11 && < 0.12, filepath >= 1.1 && < 1.5, - hslua >= 2.1 && < 2.3, - mtl >= 2.2 && < 2.3, - pandoc-types >= 1.22.2 && < 1.23, + mtl >= 2.2 && < 2.4, + pandoc-types >= 1.23 && < 1.24, process >= 1.2.3 && < 1.7, tasty >= 0.11 && < 1.5, tasty-golden >= 2.3 && < 2.4, tasty-hunit >= 0.9 && < 0.11, - tasty-lua >= 1.0 && < 1.1, tasty-quickcheck >= 0.8 && < 0.11, text >= 1.1.1.0 && < 2.1, time >= 1.5 && < 1.14, @@ -823,8 +768,6 @@ other-modules: Tests.Old Tests.Command Tests.Helpers - Tests.Lua - Tests.Lua.Module Tests.Shared Tests.Readers.LaTeX Tests.Readers.HTML @@ -848,7 +791,7 @@ Tests.Readers.RST Tests.Readers.RTF Tests.Readers.Docx - Tests.Readers.Odt + Tests.Readers.ODT Tests.Readers.Txt2Tags Tests.Readers.EPUB Tests.Readers.Muse @@ -858,7 +801,7 @@ Tests.Readers.DokuWiki Tests.Writers.Native Tests.Writers.ConTeXt - Tests.Writers.Docbook + Tests.Writers.DocBook Tests.Writers.HTML Tests.Writers.JATS Tests.Writers.Jira @@ -885,7 +828,7 @@ hs-source-dirs: benchmark build-depends: bytestring, tasty-bench >= 0.2 && <= 0.4, - mtl >= 2.2 && < 2.3, + mtl >= 2.2 && < 2.4, text >= 1.1.1.0 && < 2.1, deepseq -- we increase heap size to avoid benchmarking garbage collection: diff --git a/src/Text/Pandoc.hs b/src/Text/Pandoc.hs --- a/src/Text/Pandoc.hs +++ b/src/Text/Pandoc.hs @@ -3,7 +3,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {- | Module : Text.Pandoc - Copyright : Copyright (C) 2006-2022 John MacFarlane + Copyright : Copyright (C) 2006-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane @@ -47,6 +47,8 @@ , module Text.Pandoc.Logging -- * Typeclass , module Text.Pandoc.Class + -- * Internal data files + , module Text.Pandoc.Data -- * Error handling , module Text.Pandoc.Error -- * Readers: converting /to/ Pandoc format @@ -55,17 +57,23 @@ , module Text.Pandoc.Writers -- * Rendering templates and default templates , module Text.Pandoc.Templates - -- * Miscellaneous + -- * Localization + , setTranslations + , translateTerm + -- * Version information , pandocVersion + , pandocVersionText ) where import Text.Pandoc.Class import Text.Pandoc.Definition +import Text.Pandoc.Data import Text.Pandoc.Error import Text.Pandoc.Generic import Text.Pandoc.Logging import Text.Pandoc.Options import Text.Pandoc.Readers -import Text.Pandoc.Shared (pandocVersion) +import Text.Pandoc.Version (pandocVersion, pandocVersionText) import Text.Pandoc.Templates +import Text.Pandoc.Translations (setTranslations, translateTerm) import Text.Pandoc.Writers diff --git a/src/Text/Pandoc/App.hs b/src/Text/Pandoc/App.hs --- a/src/Text/Pandoc/App.hs +++ b/src/Text/Pandoc/App.hs @@ -1,11 +1,10 @@ -{-# LANGUAGE TupleSections #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {- | Module : Text.Pandoc.App - Copyright : Copyright (C) 2006-2022 John MacFarlane + Copyright : Copyright (C) 2006-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane @@ -16,8 +15,11 @@ -} module Text.Pandoc.App ( convertWithOpts + , handleOptInfo , Opt(..) + , OptInfo(..) , LineEnding(..) + , IpynbOutput (..) , Filter(..) , defaultOpts , parseOptions @@ -26,12 +28,10 @@ , applyFilters ) where import qualified Control.Exception as E -import Control.Monad ( (>=>), when, forM_ ) +import Control.Monad ( (>=>), when, forM, forM_ ) import Control.Monad.Trans ( MonadIO(..) ) import Control.Monad.Catch ( MonadMask ) -import Control.Monad.Except (throwError, catchError) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as B8 +import Control.Monad.Except (throwError) import qualified Data.ByteString.Lazy as BL import Data.Maybe (fromMaybe, isJust, isNothing) import qualified Data.Set as Set @@ -39,11 +39,10 @@ import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TE -import qualified Data.Text.Encoding as TSE import qualified Data.Text.Encoding.Error as TE -import qualified Data.Text.Encoding.Error as TSE -import Network.URI (URI (..), parseURI) -import System.Directory (doesDirectoryExist) +import System.Directory (doesDirectoryExist, createDirectory) +import Codec.Archive.Zip (toArchiveOrFail, + extractFilesFromArchive, ZipOption(..)) import System.Exit (exitSuccess) import System.FilePath ( takeBaseName, takeExtension) import System.IO (nativeNewline, stdout) @@ -51,33 +50,34 @@ import Text.Pandoc import Text.Pandoc.Builder (setMeta) import Text.Pandoc.MediaBag (mediaItems) -import Text.Pandoc.MIME (getCharset, MimeType) import Text.Pandoc.Image (svgToPng) import Text.Pandoc.App.FormatHeuristics (formatFromFilePaths) import Text.Pandoc.App.Opt (Opt (..), LineEnding (..), defaultOpts, - IpynbOutput (..)) + IpynbOutput (..), OptInfo(..)) import Text.Pandoc.App.CommandLineOptions (parseOptions, parseOptionsFromArgs, - options) + options, handleOptInfo) +import Text.Pandoc.App.Input (InputParameters (..), readInput) import Text.Pandoc.App.OutputSettings (OutputSettings (..), optToOutputSettings) import Text.Collate.Lang (Lang (..), parseLang) import Text.Pandoc.Filter (Filter (JSONFilter, LuaFilter), Environment (..), applyFilters) +import qualified Text.Pandoc.Format as Format import Text.Pandoc.PDF (makePDF) +import Text.Pandoc.Scripting (ScriptingEngine (..), CustomComponents(..)) import Text.Pandoc.SelfContained (makeSelfContained) -import Text.Pandoc.Shared (eastAsianLineBreakFilter, stripEmptyParagraphs, - headerShift, isURI, tabFilter, uriPathToPath, filterIpynbOutput, - defaultUserDataDir, tshow) +import Text.Pandoc.Shared (eastAsianLineBreakFilter, + headerShift, filterIpynbOutput, tshow) +import Text.Pandoc.URI (isURI) import Text.Pandoc.Writers.Shared (lookupMetaString) import Text.Pandoc.Readers.Markdown (yamlToMeta) -import Text.Pandoc.Readers.Custom (readCustom) import qualified Text.Pandoc.UTF8 as UTF8 #ifndef _WINDOWS import System.Posix.IO (stdOutput) import System.Posix.Terminal (queryTerminal) #endif -convertWithOpts :: Opt -> IO () -convertWithOpts opts = do +convertWithOpts :: ScriptingEngine -> Opt -> IO () +convertWithOpts scriptingEngine opts = do let outputFile = fromMaybe "-" (optOutputFile opts) datadir <- case optDataDir opts of Nothing -> do @@ -86,7 +86,7 @@ return $ if exists then Just d else Nothing - Just _ -> return $ optDataDir opts + mdatadir -> return mdatadir when (optDumpArgs opts) $ do UTF8.hPutStrLn stdout (T.pack outputFile) @@ -100,7 +100,7 @@ istty <- liftIO $ queryTerminal stdOutput #endif - res <- runIO $ convertWithOpts' istty datadir opts + res <- runIO $ convertWithOpts' scriptingEngine istty datadir opts case res of Left e -> E.throwIO e Right (output, reports) -> do @@ -117,28 +117,31 @@ case output of TextOutput t -> writerFn eol outputFile t BinaryOutput bs -> writeFnBinary outputFile bs + ZipOutput bs + | null (takeExtension outputFile) -> do + -- create directory and unzip + createDirectory outputFile -- will fail if directory exists + let zipopts = [OptRecursive, OptDestination outputFile] ++ + [OptVerbose | optVerbosity opts == INFO] + case toArchiveOrFail bs of + Right archive -> extractFilesFromArchive zipopts archive + Left e -> E.throwIO $ PandocShouldNeverHappenError $ T.pack e + | otherwise -> writeFnBinary outputFile bs convertWithOpts' :: (PandocMonad m, MonadIO m, MonadMask m) - => Bool + => ScriptingEngine + -> Bool -> Maybe FilePath -> Opt -> m (PandocOutput, [LogMessage]) -convertWithOpts' istty datadir opts = do +convertWithOpts' scriptingEngine istty datadir opts = do + configureCommonState datadir opts let outputFile = fromMaybe "-" (optOutputFile opts) let filters = optFilters opts - let verbosity = optVerbosity opts - let sources = case optInputFiles opts of Just xs | not (optIgnoreArgs opts) -> xs _ -> ["-"] - setTrace (optTrace opts) - setVerbosity verbosity - setUserDataDir datadir - setResourcePath (optResourcePath opts) - setInputFiles (fromMaybe ["-"] (optInputFiles opts)) - setOutputFile (optOutputFile opts) - -- assign reader and writer based on options and filenames readerName <- case optFrom opts of Just f -> return f @@ -151,8 +154,8 @@ (map (T.pack . takeExtension) sources) "markdown" return "markdown" - let readerNameBase = T.takeWhile (\c -> c /= '+' && c /= '-') readerName - + flvrd@(Format.FlavoredFormat readerNameBase _extsDiff) <- + Format.parseFlavoredFormat readerName let makeSandboxed pureReader = let files = maybe id (:) (optReferenceDoc opts) . maybe id (:) (optEpubMetadata opts) . @@ -168,31 +171,36 @@ (reader, readerExts) <- if ".lua" `T.isSuffixOf` readerName - then return (TextReader (readCustom (T.unpack readerName)), mempty) + then do + let scriptPath = T.unpack readerNameBase + components <- engineLoadCustom scriptingEngine scriptPath + r <- case customReader components of + Nothing -> throwError $ PandocAppError $ + readerName <> " does not contain a custom reader" + Just r -> return r + let extsConf = fromMaybe mempty (customExtensions components) + rexts <- Format.applyExtensionsDiff extsConf flvrd + return (r, rexts) else if optSandbox opts - then case runPure (getReader readerName) of + then case runPure (getReader flvrd) of Left e -> throwError e Right (r, rexts) -> return (makeSandboxed r, rexts) - else getReader readerName + else getReader flvrd - outputSettings <- optToOutputSettings opts + outputSettings <- optToOutputSettings scriptingEngine opts let format = outputFormat outputSettings let writer = outputWriter outputSettings - let writerName = outputWriterName outputSettings - let writerNameBase = T.takeWhile (\c -> c /= '+' && c /= '-') writerName let writerOptions = outputWriterOptions outputSettings + -- whether we are targeting PDF. let pdfOutput = isJust $ outputPdfProgram outputSettings - - let bibOutput = writerNameBase == "bibtex" || - writerNameBase == "biblatex" || - writerNameBase == "csljson" - - let standalone = optStandalone opts || - not (isTextFormat format) || - pdfOutput || - bibOutput + -- whether standalone output should be produced. + let bibOutput = format `elem` ["bibtex", "biblatex", "csljson"] + let standalone = isJust (writerTemplate writerOptions) || bibOutput + -- + -- Sanity checks + -- when (pdfOutput && readerNameBase == "latex") $ case optInputFiles opts of Just (inputFile:_) -> report $ UnusualConversion $ T.pack $ @@ -214,51 +222,29 @@ "Specify an output file using the -o option, or " <> "use '-o -' to force output to stdout." - - abbrevs <- Set.fromList . filter (not . T.null) . T.lines . UTF8.toText <$> - case optAbbreviations opts of - Nothing -> readDataFile "abbreviations" - Just f -> readFileStrict f - - case lookupMetaString "lang" (optMetadata opts) of - "" -> setTranslations $ Lang "en" Nothing (Just "US") [] [] [] - l -> case parseLang l of - Left _ -> report $ InvalidLang l - Right l' -> setTranslations l' + when (readerNameBase == "markdown_github" || + format == "markdown_github") $ + report $ Deprecated "markdown_github" "Use gfm instead." + abbrevs <- readAbbreviations (optAbbreviations opts) let readerOpts = def{ readerStandalone = standalone , readerColumns = optColumns opts , readerTabStop = optTabStop opts , readerIndentedCodeClasses = optIndentedCodeClasses opts - , readerDefaultImageExtension = - optDefaultImageExtension opts + , readerDefaultImageExtension = optDefaultImageExtension opts , readerTrackChanges = optTrackChanges opts , readerAbbreviations = abbrevs , readerExtensions = readerExts , readerStripComments = optStripComments opts } - metadataFromFile <- - case optMetadataFiles opts of - [] -> return mempty - paths -> do - -- If format is markdown or commonmark, use the enabled extensions, - -- otherwise treat metadata as pandoc markdown (see #7926, #6832) - let readerOptsMeta = - if readerNameBase == "markdown" || readerNameBase == "commonmark" - then readerOpts - else readerOpts{ readerExtensions = pandocExtensions } - mconcat <$> mapM - (\path -> do raw <- readMetadataFile path - yamlToMeta readerOptsMeta (Just path) raw) paths + metadataFromFile <- getMetadataFromFiles readerNameBase readerOpts + (optMetadataFiles opts) let transforms = (case optShiftHeadingLevelBy opts of 0 -> id x -> (headerShift x :)) . - (if optStripEmptyParagraphs opts - then (stripEmptyParagraphs :) - else id) . (if extensionEnabled Ext_east_asian_line_breaks readerExts && not (extensionEnabled Ext_east_asian_line_breaks @@ -280,22 +266,6 @@ _ -> Format format) :)) $ [] - let convertTabs = tabFilter (if optPreserveTabs opts || - readerNameBase == "t2t" || - readerNameBase == "man" || - readerNameBase == "tsv" - then 0 - else optTabStop opts) - - - when (readerNameBase == "markdown_github" || - writerNameBase == "markdown_github") $ - report $ Deprecated "markdown_github" "Use gfm instead." - - mapM_ (uncurry setRequestHeader) (optRequestHeaders opts) - - setNoCheckCertificate (optNoCheckCertificate opts) - let isPandocCiteproc (JSONFilter f) = takeBaseName f == "pandoc-citeproc" isPandocCiteproc _ = False @@ -313,52 +283,38 @@ let filterEnv = Environment readerOpts writerOptions - inputs <- readSources sources + let inputParams = InputParameters + { inputReader = reader + , inputReaderName = readerNameBase + , inputReaderOptions = readerOpts + , inputSources = sources + , inputFileScope = optFileScope opts + , inputSpacesPerTab = if optPreserveTabs opts + then Nothing + else Just (optTabStop opts) + } - doc <- (case reader of - TextReader r - | readerNameBase == "json" -> - mconcat <$> - mapM (inputToText convertTabs - >=> r readerOpts . (:[])) inputs - | optFileScope opts -> - mconcat <$> mapM - (inputToText convertTabs - >=> r readerOpts . (:[])) - inputs - | otherwise -> mapM (inputToText convertTabs) inputs - >>= r readerOpts - ByteStringReader r -> - mconcat <$> mapM (r readerOpts . inputToLazyByteString) inputs) + doc <- readInput inputParams >>= ( return . adjustMetadata (metadataFromFile <>) >=> return . adjustMetadata (<> optMetadata opts) >=> return . adjustMetadata (<> cslMetadata) >=> applyTransforms transforms - >=> applyFilters filterEnv filters [T.unpack format] + >=> applyFilters scriptingEngine filterEnv filters [T.unpack format] >=> (if not (optSandbox opts) && (isJust (optExtractMedia opts) - || writerNameBase == "docx") -- for fallback pngs + || format == "docx") -- for fallback pngs then fillMediaBag else return) >=> maybe return extractMedia (optExtractMedia opts) ) - when (writerNameBase == "docx" && not (optSandbox opts)) $ do - -- create fallback pngs for svgs - items <- mediaItems <$> getMediaBag - forM_ items $ \(fp, mt, bs) -> - case T.takeWhile (/=';') mt of - "image/svg+xml" -> do - res <- svgToPng (writerDpi writerOptions) bs - case res of - Right bs' -> do - let fp' = fp <> ".png" - insertMedia fp' (Just "image/png") bs' - Left e -> report $ CouldNotConvertImage (T.pack fp) (tshow e) - _ -> return () + when (format == "docx" && not (optSandbox opts)) $ do + createPngFallbacks (writerDpi writerOptions) output <- case writer of - ByteStringWriter f -> BinaryOutput <$> f writerOptions doc + ByteStringWriter f + | format == "chunkedhtml" -> ZipOutput <$> f writerOptions doc + | otherwise -> BinaryOutput <$> f writerOptions doc TextWriter f -> case outputPdfProgram outputSettings of Just pdfProg -> do res <- makePDF pdfProg (optPdfEngineOpts opts) f @@ -380,11 +336,72 @@ reports <- getLog return (output, reports) -data PandocOutput = TextOutput Text | BinaryOutput BL.ByteString +data PandocOutput = + TextOutput Text + | BinaryOutput BL.ByteString + | ZipOutput BL.ByteString deriving (Show) type Transform = Pandoc -> Pandoc +-- | Configure the common state +configureCommonState :: PandocMonad m => Maybe FilePath -> Opt -> m () +configureCommonState datadir opts = do + setUserDataDir datadir + setTrace (optTrace opts) + setVerbosity (optVerbosity opts) + setResourcePath (optResourcePath opts) + setInputFiles (fromMaybe ["-"] (optInputFiles opts)) + setOutputFile (optOutputFile opts) + setNoCheckCertificate (optNoCheckCertificate opts) + + mapM_ (uncurry setRequestHeader) (optRequestHeaders opts) + + case lookupMetaString "lang" (optMetadata opts) of + "" -> setTranslations $ Lang "en" Nothing (Just "US") [] [] [] + l -> case parseLang l of + Left _ -> report $ InvalidLang l + Right l' -> setTranslations l' + +-- | Retrieves the set of abbreviations to be used by pandoc. These currently +-- only affect the Markdown reader. +readAbbreviations :: PandocMonad m => Maybe FilePath -> m (Set.Set Text) +readAbbreviations mbfilepath = + Set.fromList . filter (not . T.null) . T.lines . UTF8.toText <$> + case mbfilepath of + Nothing -> readDataFile "abbreviations" + Just f -> readFileStrict f + +createPngFallbacks :: (PandocMonad m, MonadIO m) => Int -> m () +createPngFallbacks dpi = do + -- create fallback pngs for svgs + items <- mediaItems <$> getMediaBag + forM_ items $ \(fp, mt, bs) -> + case T.takeWhile (/=';') mt of + "image/svg+xml" -> do + res <- svgToPng dpi bs + case res of + Right bs' -> do + let fp' = fp <> ".png" + insertMedia fp' (Just "image/png") bs' + Left e -> report $ CouldNotConvertImage (T.pack fp) (tshow e) + _ -> return () + +getMetadataFromFiles :: PandocMonad m + => Text -> ReaderOptions -> [FilePath] -> m Meta +getMetadataFromFiles readerFormat readerOpts = \case + [] -> return mempty + paths -> mconcat <$> do + -- If format is markdown or commonmark, use the enabled extensions, + -- otherwise treat metadata as pandoc markdown (see #7926, #6832) + let readerOptsMeta = + if readerFormat `elem` ["markdown", "commonmark"] + then readerOpts + else readerOpts{ readerExtensions = pandocExtensions } + forM paths $ \path -> do + raw <- readMetadataFile path + yamlToMeta readerOptsMeta (Just path) raw + htmlFormat :: Text -> Bool htmlFormat = (`elem` ["html","html4","html5","s5","slidy", "slideous","dzslides","revealjs"]) @@ -399,64 +416,6 @@ applyTransforms :: Monad m => [Transform] -> Pandoc -> m Pandoc applyTransforms transforms d = return $ foldr ($) d transforms - -readSources :: PandocMonad m - => [FilePath] -> m [(FilePath, (BS.ByteString, Maybe MimeType))] -readSources srcs = - mapM (\fp -> do t <- readSource fp - return (if fp == "-" then "" else fp, t)) srcs - -readSource :: PandocMonad m - => FilePath -> m (BS.ByteString, Maybe MimeType) -readSource "-" = (,Nothing) <$> readStdinStrict -readSource src = - case parseURI src of - Just u | uriScheme u `elem` ["http:","https:"] -> openURL (T.pack src) - | uriScheme u == "file:" -> - (,Nothing) <$> - readFileStrict (uriPathToPath $ T.pack $ uriPath u) - _ -> (,Nothing) <$> readFileStrict src - -utf8ToText :: PandocMonad m => FilePath -> BS.ByteString -> m Text -utf8ToText fp bs = - case TSE.decodeUtf8' . dropBOM $ bs of - Left (TSE.DecodeError _ (Just w)) -> - case BS.elemIndex w bs of - Just offset -> throwError $ PandocUTF8DecodingError (T.pack fp) offset w - Nothing -> throwError $ PandocUTF8DecodingError (T.pack fp) 0 w - Left e -> throwError $ PandocAppError (tshow e) - Right t -> return t - where - dropBOM bs' = - if "\xEF\xBB\xBF" `BS.isPrefixOf` bs' - then BS.drop 3 bs' - else bs' - - -inputToText :: PandocMonad m - => (Text -> Text) - -> (FilePath, (BS.ByteString, Maybe MimeType)) - -> m (FilePath, Text) -inputToText convTabs (fp, (bs,mt)) = - (fp,) . convTabs . T.filter (/='\r') <$> - case mt >>= getCharset of - Just "UTF-8" -> utf8ToText fp bs - Just "ISO-8859-1" -> return $ T.pack $ B8.unpack bs - Just charset -> throwError $ PandocUnsupportedCharsetError charset - Nothing -> catchError - (utf8ToText fp bs) - (\case - PandocUTF8DecodingError{} -> do - report $ NotUTF8Encoded - (if null fp - then "input" - else fp) - return $ T.pack $ B8.unpack bs - e -> throwError e) - -inputToLazyByteString :: (FilePath, (BS.ByteString, Maybe MimeType)) - -> BL.ByteString -inputToLazyByteString (_, (bs,_)) = BL.fromStrict bs writeFnBinary :: FilePath -> BL.ByteString -> IO () writeFnBinary "-" = BL.putStr diff --git a/src/Text/Pandoc/App/CommandLineOptions.hs b/src/Text/Pandoc/App/CommandLineOptions.hs --- a/src/Text/Pandoc/App/CommandLineOptions.hs +++ b/src/Text/Pandoc/App/CommandLineOptions.hs @@ -1,14 +1,12 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeApplications #-} {- | Module : Text.Pandoc.App.CommandLineOptions - Copyright : Copyright (C) 2006-2022 John MacFarlane + Copyright : Copyright (C) 2006-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane @@ -20,13 +18,14 @@ module Text.Pandoc.App.CommandLineOptions ( parseOptions , parseOptionsFromArgs + , handleOptInfo , options , engines , setVariable ) where -import Control.Monad import Control.Monad.Trans import Control.Monad.State.Strict +import Data.Containers.ListUtils (nubOrd) import Data.Aeson.Encode.Pretty (encodePretty', Config(..), keyOrder, defConfig, Indent(..), NumberFormat(..)) import Data.Bifunctor (second) @@ -37,7 +36,6 @@ #endif import Data.Maybe (fromMaybe, isJust) import Data.Text (Text) -import HsLua (Exception, getglobal, openlibs, peek, run, top) import Safe (tailDef) import Skylighting (Syntax (..), defaultSyntaxMap) import System.Console.GetOpt @@ -50,49 +48,30 @@ import Text.Pandoc.Builder (setMeta) import Text.Pandoc.App.Opt (Opt (..), LineEnding (..), IpynbOutput (..), DefaultsState (..), applyDefaults, - fullDefaultsPath) + fullDefaultsPath, OptInfo(..)) import Text.Pandoc.Filter (Filter (..)) import Text.Pandoc.Highlighting (highlightingStyles, lookupHighlightingStyle) -import Text.Pandoc.Shared (ordNub, elemText, safeStrRead, defaultUserDataDir) +import Text.Pandoc.Scripting (ScriptingEngine (..), customTemplate) +import Text.Pandoc.Shared (safeStrRead) import Text.Printf - -#ifdef EMBED_DATA_FILES -import Text.Pandoc.Data (dataFiles) -#else -import Paths_pandoc (getDataDir) -import System.Directory (getDirectoryContents) -#endif - import qualified Control.Exception as E +import Control.Monad.Except (ExceptT(..), runExceptT, throwError) 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 qualified Text.Pandoc.UTF8 as UTF8 -#ifdef NIGHTLY -import qualified Language.Haskell.TH as TH -import Data.Time -#endif - -#ifdef NIGHTLY -versionSuffix :: String -versionSuffix = "-nightly-" ++ - $(TH.stringE =<< - TH.runIO (formatTime defaultTimeLocale "%F" <$> Data.Time.getCurrentTime)) -#else -versionSuffix :: String -versionSuffix = "" -#endif - -parseOptions :: [OptDescr (Opt -> IO Opt)] -> Opt -> IO Opt +parseOptions :: [OptDescr (Opt -> ExceptT OptInfo IO Opt)] + -> Opt -> IO (Either OptInfo Opt) parseOptions options' defaults = do - rawArgs <- map UTF8.decodeArg <$> getArgs - prg <- getProgName + rawArgs <- map UTF8.decodeArg <$> liftIO getArgs + prg <- liftIO getProgName parseOptionsFromArgs options' defaults prg rawArgs parseOptionsFromArgs - :: [OptDescr (Opt -> IO Opt)] -> Opt -> String -> [String] -> IO Opt + :: [OptDescr (Opt -> ExceptT OptInfo IO Opt)] + -> Opt -> String -> [String] -> IO (Either OptInfo Opt) parseOptionsFromArgs options' defaults prg rawArgs = do let (actions, args, unrecognizedOpts, errors) = getOpt' Permute options' (map UTF8.decodeArg rawArgs) @@ -101,17 +80,12 @@ foldr (handleUnrecognizedOption . takeWhile (/= '=')) [] unrecognizedOpts - unless (null errors && null unknownOptionErrors) $ - E.throwIO $ PandocOptionError $ T.pack $ - concat errors ++ unlines unknownOptionErrors ++ - ("Try " ++ prg ++ " --help for more information.") - - -- thread option data structure through all supplied option actions - opts <- foldl' (>>=) (return defaults) actions let mbArgs = case args of [] -> Nothing xs -> Just xs - return $ opts{ optInputFiles = + + let adjustOpts opts = + opts{ optInputFiles = map normalizePath <$> (optInputFiles opts <> mbArgs) , optStandalone = -- certain other options imply standalone optStandalone opts || @@ -121,6 +95,118 @@ not (null (optIncludeBeforeBody opts)) || not (null (optIncludeAfterBody opts)) } + if (null errors && null unknownOptionErrors) + then -- thread option data structure through all supplied option actions + runExceptT $ adjustOpts <$> (foldl' (>>=) (return defaults) actions) + else return $ Left $ OptError $ PandocOptionError $ T.pack $ + concat errors ++ unlines unknownOptionErrors ++ + ("Try " ++ prg ++ " --help for more information.") + +-- | React to an 'OptInfo' by printing the requested information +-- and exiting or (if there was a parsing error) raising an error. +handleOptInfo :: ScriptingEngine -> OptInfo -> IO () +handleOptInfo engine info = E.handle (handleError . Left) $ do + case info of + BashCompletion -> do + datafiles <- getDataFileNames + tpl <- runIOorExplode $ + UTF8.toString <$> + readDefaultDataFile "bash_completion.tpl" + let optnames (Option shorts longs _ _) = + map (\c -> ['-',c]) shorts ++ + map ("--" ++) longs + let allopts = unwords (concatMap optnames options) + UTF8.hPutStrLn stdout $ T.pack $ printf tpl allopts + (T.unpack $ T.unwords readersNames) + (T.unpack $ T.unwords writersNames) + (T.unpack $ T.unwords $ map fst highlightingStyles) + (unwords datafiles) + ListInputFormats -> mapM_ (UTF8.hPutStrLn stdout) readersNames + ListOutputFormats -> mapM_ (UTF8.hPutStrLn stdout) writersNames + ListExtensions mbfmt -> do + let formatName = fromMaybe "markdown" mbfmt + let allExts = getAllExtensions formatName + if formatName `notElem` + (map fst (readers :: [(Text, Reader PandocPure)]) ++ + map fst (writers :: [(Text, Writer PandocPure)])) + then E.throwIO $ PandocOptionError $ formatName <> + " is not a recognized reader or writer format" + else do + let defExts = getDefaultExtensions formatName + let showExt x = + (if extensionEnabled x defExts + then '+' + else if extensionEnabled x allExts + then '-' + else ' ') : drop 4 (show x) + mapM_ (UTF8.hPutStrLn stdout . T.pack . showExt) + (extensionsToList allExts) + ListHighlightLanguages -> do + let langs = [ T.unpack (T.toLower (sShortname s)) + | s <- M.elems defaultSyntaxMap + , sShortname s `notElem` + [T.pack "Alert", T.pack "Alert_indent"] + ] + mapM_ (UTF8.hPutStrLn stdout . T.pack) (sort langs) + ListHighlightStyles -> do + mapM_ (UTF8.hPutStrLn stdout . fst) highlightingStyles + PrintDefaultTemplate mbout fmt -> do + let write = maybe (UTF8.hPutStr stdout) (UTF8.writeFile) mbout + + templ <- runIO $ + case splitExtension (T.unpack fmt) of + (_, "") -> do + -- built-in format + setUserDataDir Nothing + getDefaultTemplate fmt + _ -> do + -- format looks like a filepath => custom writer + components <- engineLoadCustom engine (T.unpack fmt) + case customTemplate components of + Just t -> pure t + Nothing -> E.throw $ PandocNoTemplateError fmt + case templ of + Right t + | T.null t -> -- e.g. for docx, odt, json: + E.throwIO $ PandocCouldNotFindDataFileError $ T.pack + ("templates/default." ++ T.unpack fmt) + | otherwise -> write t + Left e -> E.throwIO e + PrintDefaultDataFile mbout f -> do + let write = maybe BS.putStr BS.writeFile mbout + runIOorExplode $ readDefaultDataFile (T.unpack f) >>= liftIO . write + PrintHighlightStyle mbout styleName -> do + let write = maybe B.putStr B.writeFile mbout + sty <- runIOorExplode $ lookupHighlightingStyle (T.unpack styleName) + write $ encodePretty' + defConfig{confIndent = Spaces 4 + ,confCompare = keyOrder + (map T.pack + ["text-color" + ,"background-color" + ,"line-number-color" + ,"line-number-background-color" + ,"bold" + ,"italic" + ,"underline" + ,"text-styles"]) + ,confNumFormat = Generic + ,confTrailingNewline = True} sty + VersionInfo -> do + prg <- getProgName + defaultDatadir <- defaultUserDataDir + UTF8.hPutStrLn stdout + $ T.pack + $ prg ++ " " ++ T.unpack pandocVersionText ++ + compileInfo ++ + "\nUser data directory: " ++ defaultDatadir ++ + ('\n':copyrightMessage) + Help -> do + prg <- getProgName + UTF8.hPutStr stdout (T.pack $ usageMessage prg options) + OptError e -> E.throwIO e + exitSuccess + -- | Supported LaTeX engines; the first item is used as default engine -- when going through LaTeX. latexEngines :: [String] @@ -141,11 +227,11 @@ ] pdfEngines :: [String] -pdfEngines = ordNub $ map snd engines +pdfEngines = nubOrd $ map snd engines -- | A list of functions, each transforming the options data structure -- in response to a command-line option. -options :: [OptDescr (Opt -> IO Opt)] +options :: [OptDescr (Opt -> ExceptT OptInfo IO Opt)] options = [ Option "fr" ["from","read"] (ReqArg @@ -192,11 +278,16 @@ , Option "d" ["defaults"] (ReqArg - (\arg opt -> runIOorExplode $ do - let defsState = DefaultsState { curDefaults = Nothing, - inheritanceGraph = [] } - fp <- fullDefaultsPath (optDataDir opt) arg - evalStateT (applyDefaults opt fp) defsState + (\arg opt -> do + res <- liftIO $ runIO $ do + let defsState = + DefaultsState { curDefaults = Nothing, + inheritanceGraph = [] } + fp <- fullDefaultsPath (optDataDir opt) arg + evalStateT (applyDefaults opt fp) defsState + case res of + Left e -> optError e + Right x -> return x ) "FILE") "" @@ -240,7 +331,7 @@ "auto" -> return opt{ optWrap = WrapAuto } "none" -> return opt{ optWrap = WrapNone } "preserve" -> return opt{ optWrap = WrapPreserve } - _ -> E.throwIO $ PandocOptionError + _ -> optError $ PandocOptionError "--wrap must be auto, none, or preserve") "auto|none|preserve") "" -- "Option for wrapping text in output" @@ -261,7 +352,7 @@ case safeStrRead arg of Just t | t >= 1 && t <= 6 -> return opt { optTOCDepth = t } - _ -> E.throwIO $ PandocOptionError + _ -> optError $ PandocOptionError "TOC level must be a number 1-6") "NUMBER") "" -- "Number of levels to include in TOC" @@ -277,7 +368,7 @@ case safeStrRead ("[" <> arg <> "]") of Just ns -> return opt { optNumberOffset = ns, optNumberSections = True } - _ -> E.throwIO $ PandocOptionError + _ -> optError $ PandocOptionError "could not parse number-offset") "NUMBERS") "" -- "Starting number for sections, subsections, etc." @@ -294,7 +385,7 @@ TopLevelPart } "default" -> return opt{ optTopLevelDivision = TopLevelDefault } - _ -> E.throwIO $ PandocOptionError $ + _ -> optError $ PandocOptionError $ "Top-level division must be " <> "section, chapter, part, or default" ) "section|chapter|part") @@ -366,7 +457,7 @@ (\arg opt -> case safeStrRead arg of Just t | t > 0 -> return opt { optDpi = t } - _ -> E.throwIO $ PandocOptionError + _ -> optError $ PandocOptionError "dpi must be a number greater than 0") "NUMBER") "" -- "Dpi (default 96)" @@ -379,7 +470,7 @@ "lf" -> return opt { optEol = LF } "native" -> return opt { optEol = Native } -- mac-syntax (cr) is not supported in ghc-base. - _ -> E.throwIO $ PandocOptionError + _ -> optError $ PandocOptionError "--eol must be crlf, lf, or native") "crlf|lf|native") "" -- "EOL (default OS-dependent)" @@ -389,7 +480,7 @@ (\arg opt -> case safeStrRead arg of Just t | t > 0 -> return opt { optColumns = t } - _ -> E.throwIO $ PandocOptionError + _ -> optError $ PandocOptionError "columns must be a number greater than 0") "NUMBER") "" -- "Length of line in characters" @@ -404,7 +495,7 @@ (\arg opt -> case safeStrRead arg of Just t | t > 0 -> return opt { optTabStop = t } - _ -> E.throwIO $ PandocOptionError + _ -> optError $ PandocOptionError "tab-stop must be a number greater than 0") "NUMBER") "" -- "Tab stop (default 4)" @@ -415,7 +506,9 @@ let b = takeBaseName arg if b `elem` pdfEngines then return opt { optPdfEngine = Just arg } - else E.throwIO $ PandocOptionError $ T.pack $ "pdf-engine must be one of " + else optError $ + PandocOptionError $ T.pack $ + "pdf-engine must be one of " ++ intercalate ", " pdfEngines) "PROGRAM") "" -- "Name of program to use in generating PDF" @@ -502,7 +595,7 @@ case safeStrRead arg of Just t -> return opt{ optShiftHeadingLevelBy = t } - _ -> E.throwIO $ PandocOptionError + _ -> optError $ PandocOptionError "shift-heading-level-by takes an integer argument") "NUMBER") "" -- "Shift heading level" @@ -515,19 +608,11 @@ case safeStrRead arg of Just t | t > 0 && t < 6 -> return opt{ optShiftHeadingLevelBy = t - 1 } - _ -> E.throwIO $ PandocOptionError + _ -> optError $ PandocOptionError "base-header-level must be 1-5") "NUMBER") "" -- "Headers base level" - , Option "" ["strip-empty-paragraphs"] - (NoArg - (\opt -> do - deprecatedOption "--strip-empty-paragraphs" - "Use +empty_paragraphs extension." - return opt{ optStripEmptyParagraphs = True })) - "" -- "Strip empty paragraphs" - , Option "" ["track-changes"] (ReqArg (\arg opt -> do @@ -535,7 +620,7 @@ "accept" -> return AcceptChanges "reject" -> return RejectChanges "all" -> return AllChanges - _ -> E.throwIO $ PandocOptionError $ T.pack + _ -> optError $ PandocOptionError $ T.pack ("Unknown option for track-changes: " ++ arg) return opt { optTrackChanges = action }) "accept|reject|all") @@ -558,27 +643,19 @@ "block" -> return EndOfBlock "section" -> return EndOfSection "document" -> return EndOfDocument - _ -> E.throwIO $ PandocOptionError $ T.pack + _ -> optError $ PandocOptionError $ T.pack ("Unknown option for reference-location: " ++ arg) return opt { optReferenceLocation = action }) "block|section|document") "" -- "Accepting or reject MS Word track-changes."" - , Option "" ["atx-headers"] - (NoArg - (\opt -> do - deprecatedOption "--atx-headers" - "Use --markdown-headings=atx instead." - return opt { optSetextHeaders = False } )) - "" -- "Use atx-style headers for markdown" - , Option "" ["markdown-headings"] (ReqArg (\arg opt -> do headingFormat <- case arg of "setext" -> pure True "atx" -> pure False - _ -> E.throwIO $ PandocOptionError $ T.pack + _ -> optError $ PandocOptionError $ T.pack ("Unknown markdown heading format: " ++ arg ++ ". Expecting atx or setext") pure opt { optSetextHeaders = headingFormat } @@ -586,6 +663,12 @@ "setext|atx") "" + , Option "" ["list-tables"] + (NoArg + (\opt -> do + return opt { optListTables = True } )) + "" -- "Use list tables for RST" + , Option "" ["listings"] (NoArg (\opt -> return opt { optListings = True })) @@ -602,7 +685,7 @@ case safeStrRead arg of Just t | t >= 0 && t <= 6 -> return opt { optSlideLevel = Just t } - _ -> E.throwIO $ PandocOptionError + _ -> optError $ PandocOptionError "slide level must be a number between 0 and 6") "NUMBER") "" -- "Force header level for slides" @@ -625,7 +708,7 @@ "references" -> return ReferenceObfuscation "javascript" -> return JavascriptObfuscation "none" -> return NoObfuscation - _ -> E.throwIO $ PandocOptionError $ T.pack + _ -> optError $ PandocOptionError $ T.pack ("Unknown obfuscation method: " ++ arg) return opt { optEmailObfuscation = method }) "none|javascript|references") @@ -672,6 +755,18 @@ "FILE") "" -- "Path of epub cover image" + , Option "" ["epub-title-page"] + (ReqArg + (\arg opt -> + case arg of + "true" -> return opt{ optEpubTitlePage = True } + "false" -> return opt{ optEpubTitlePage = False } + _ -> optError $ PandocOptionError $ + "Argument to --epub-title-page must be " <> + "true or false" ) + "true|false") + "" + , Option "" ["epub-metadata"] (ReqArg (\arg opt -> return opt { optEpubMetadata = Just $ @@ -687,17 +782,30 @@ "FILE") "" -- "Directory of fonts to embed" - , Option "" ["epub-chapter-level"] + , Option "" ["split-level"] (ReqArg (\arg opt -> case safeStrRead arg of Just t | t >= 1 && t <= 6 -> - return opt { optEpubChapterLevel = t } - _ -> E.throwIO $ PandocOptionError - "chapter level must be a number between 1 and 6") + return opt { optSplitLevel = t } + _ -> optError $ PandocOptionError + "split level must be a number between 1 and 6") "NUMBER") - "" -- "Header level at which to split chapters in EPUB" + "" -- "Header level at which to split documents in chunked HTML or EPUB" + , Option "" ["epub-chapter-level"] + (ReqArg + (\arg opt -> do + deprecatedOption "--epub-chapter-level" + "use --split-level" + case safeStrRead arg of + Just t | t >= 1 && t <= 6 -> + return opt { optSplitLevel = t } + _ -> optError $ PandocOptionError + "split level must be a number between 1 and 6") + "NUMBER") + "" -- "Header level at which to split documents in chunked HTML or EPUB" + , Option "" ["ipynb-output"] (ReqArg (\arg opt -> @@ -705,7 +813,7 @@ "all" -> return opt{ optIpynbOutput = IpynbOutputAll } "best" -> return opt{ optIpynbOutput = IpynbOutputBest } "none" -> return opt{ optIpynbOutput = IpynbOutputNone } - _ -> E.throwIO $ PandocOptionError + _ -> optError $ PandocOptionError "ipynb-output must be all, none, or best") "all|none|best") "" -- "Starting number for sections, subsections, etc." @@ -727,10 +835,12 @@ , Option "" ["csl"] (ReqArg - (\arg opt -> - return opt{ optMetadata = - addMeta "csl" (normalizePath arg) $ - optMetadata opt }) + (\arg opt -> do + case lookupMeta (T.pack "csl") $ optMetadata opt of + Just _ -> optError $ PandocOptionError + "Only one CSL file can be specified." + Nothing -> return opt{ optMetadata = addMeta "csl" (normalizePath arg) $ + optMetadata opt }) "FILE") "" @@ -828,186 +938,74 @@ "" -- "Log messages in JSON format to this file." , Option "" ["bash-completion"] - (NoArg - (\_ -> do - datafiles <- getDataFileNames - tpl <- runIOorExplode $ - UTF8.toString <$> - readDefaultDataFile "bash_completion.tpl" - let optnames (Option shorts longs _ _) = - map (\c -> ['-',c]) shorts ++ - map ("--" ++) longs - let allopts = unwords (concatMap optnames options) - UTF8.hPutStrLn stdout $ T.pack $ printf tpl allopts - (T.unpack $ T.unwords readersNames) - (T.unpack $ T.unwords writersNames) - (T.unpack $ T.unwords $ map fst highlightingStyles) - (unwords datafiles) - exitSuccess )) + (NoArg (\_ -> optInfo BashCompletion)) "" -- "Print bash completion script" , Option "" ["list-input-formats"] - (NoArg - (\_ -> do - mapM_ (UTF8.hPutStrLn stdout) readersNames - exitSuccess )) + (NoArg (\_ -> optInfo ListInputFormats)) "" , Option "" ["list-output-formats"] - (NoArg - (\_ -> do - mapM_ (UTF8.hPutStrLn stdout) writersNames - exitSuccess )) + (NoArg (\_ -> optInfo ListOutputFormats)) "" , Option "" ["list-extensions"] - (OptArg - (\arg _ -> do - let extList :: [Extension] - extList = [minBound..maxBound] - let allExts = - case arg of - Nothing -> extensionsFromList extList - Just fmt -> getAllExtensions $ T.pack fmt - let formatName = maybe "markdown" T.pack arg - if formatName `notElem` - (map fst (readers :: [(Text, Reader PandocPure)]) ++ - map fst (writers :: [(Text, Writer PandocPure)])) - then E.throwIO $ PandocOptionError $ formatName <> - " is not a recognized reader or writer format" - else do - let defExts = getDefaultExtensions formatName - let showExt x = - (if extensionEnabled x defExts - then '+' - else if extensionEnabled x allExts - then '-' - else ' ') : drop 4 (show x) - mapM_ (UTF8.hPutStrLn stdout . T.pack . showExt) - [ex | ex <- extList, extensionEnabled ex allExts] - exitSuccess ) - "FORMAT") + (OptArg (\arg _ -> optInfo $ ListExtensions $ T.pack <$> arg) + "FORMAT") "" , Option "" ["list-highlight-languages"] - (NoArg - (\_ -> do - let langs = [ T.unpack (T.toLower (sShortname s)) - | s <- M.elems defaultSyntaxMap - , sShortname s `notElem` - [T.pack "Alert", T.pack "Alert_indent"] - ] - mapM_ (UTF8.hPutStrLn stdout . T.pack) (sort langs) - exitSuccess )) + (NoArg (\_ -> optInfo ListHighlightLanguages)) "" , Option "" ["list-highlight-styles"] - (NoArg - (\_ -> do - mapM_ (UTF8.hPutStrLn stdout . fst) highlightingStyles - exitSuccess )) + (NoArg (\_ -> optInfo ListHighlightStyles)) "" , Option "D" ["print-default-template"] (ReqArg - (\arg opt -> do - let write = case optOutputFile opt of - Just f -> UTF8.writeFile f - Nothing -> UTF8.hPutStr stdout - templ <- runIO $ do - setUserDataDir Nothing - getDefaultTemplate (T.pack arg) - case templ of - Right t - | T.null t -> -- e.g. for docx, odt, json: - E.throwIO $ PandocCouldNotFindDataFileError $ T.pack - ("templates/default." ++ arg) - | otherwise -> write t - Left e -> E.throwIO e - exitSuccess) - "FORMAT") + (\arg opts -> optInfo $ + PrintDefaultTemplate (optOutputFile opts) (T.pack arg)) + "FORMAT") "" -- "Print default template for FORMAT" , Option "" ["print-default-data-file"] (ReqArg - (\arg opt -> do - let write = case optOutputFile opt of - Just f -> BS.writeFile f - Nothing -> BS.hPutStr stdout - runIOorExplode $ - readDefaultDataFile arg >>= liftIO . write - exitSuccess) - "FILE") + (\arg opts -> optInfo $ + PrintDefaultDataFile (optOutputFile opts) (T.pack arg)) + "FILE") "" -- "Print default data file" , Option "" ["print-highlight-style"] (ReqArg - (\arg opt -> do - let write = maybe B.putStr B.writeFile $ optOutputFile opt - sty <- runIOorExplode $ lookupHighlightingStyle arg - write $ encodePretty' - defConfig{confIndent = Spaces 4 - ,confCompare = keyOrder - (map T.pack - ["text-color" - ,"background-color" - ,"line-number-color" - ,"line-number-background-color" - ,"bold" - ,"italic" - ,"underline" - ,"text-styles"]) - ,confNumFormat = Generic - ,confTrailingNewline = True} sty - exitSuccess) + (\arg opts -> + optInfo $ PrintDefaultDataFile (optOutputFile opts) + (T.pack arg)) "STYLE|FILE") "" -- "Print default template for FORMAT" - , Option "v" ["version"] - (NoArg - (\_ -> do - prg <- getProgName - defaultDatadir <- defaultUserDataDir - luaVersion <- HsLua.run @HsLua.Exception $ do - openlibs - getglobal "_VERSION" - peek top - UTF8.hPutStrLn stdout - $ T.pack - $ prg ++ " " ++ T.unpack pandocVersion ++ versionSuffix ++ - compileInfo ++ "\nScripting engine: " ++ luaVersion ++ - "\nUser data directory: " ++ defaultDatadir ++ - ('\n':copyrightMessage) - exitSuccess )) + (NoArg (\_ -> optInfo VersionInfo)) "" -- "Print version" , Option "h" ["help"] - (NoArg - (\_ -> do - prg <- getProgName - UTF8.hPutStr stdout (T.pack $ usageMessage prg options) - exitSuccess )) + (NoArg (\_ -> optInfo Help)) "" -- "Show help" ] -getDataFileNames :: IO [FilePath] -getDataFileNames = do -#ifdef EMBED_DATA_FILES - let allDataFiles = map fst dataFiles -#else - allDataFiles <- filter (\x -> x /= "." && x /= "..") <$> - (getDataDir >>= getDirectoryContents) -#endif - return $ "reference.docx" : "reference.odt" : "reference.pptx" : allDataFiles +optError :: PandocError -> ExceptT OptInfo IO a +optError = throwError . OptError +optInfo :: OptInfo -> ExceptT OptInfo IO a +optInfo = throwError + -- Returns usage message -usageMessage :: String -> [OptDescr (Opt -> IO Opt)] -> String +usageMessage :: String -> [OptDescr (Opt -> ExceptT OptInfo IO Opt)] -> String usageMessage programName = usageInfo (programName ++ " [OPTIONS] [FILES]") copyrightMessage :: String copyrightMessage = intercalate "\n" [ - "Copyright (C) 2006-2022 John MacFarlane. Web: https://pandoc.org", + "Copyright (C) 2006-2023 John MacFarlane. Web: https://pandoc.org", "This is free software; see the source for copying conditions. There is no", "warranty, not even for merchantability or fitness for a particular purpose." ] @@ -1016,7 +1014,7 @@ "\nCompiled with pandoc-types " ++ VERSION_pandoc_types ++ ", texmath " ++ VERSION_texmath ++ ", skylighting " ++ VERSION_skylighting ++ ",\nciteproc " ++ VERSION_citeproc ++ - ", ipynb " ++ VERSION_ipynb ++ ", hslua " ++ VERSION_hslua + ", ipynb " ++ VERSION_ipynb handleUnrecognizedOption :: String -> [String] -> [String] handleUnrecognizedOption "--smart" = @@ -1055,14 +1053,14 @@ ("pdf" : map fst (writers :: [(Text, Writer PandocIO)])) splitField :: String -> (String, String) -splitField = second (tailDef "true") . break (`elemText` ":=") +splitField = second (tailDef "true") . break (\c -> c == ':' || c == '=') -deprecatedOption :: String -> String -> IO () -deprecatedOption o msg = - runIO (report $ Deprecated (T.pack o) (T.pack msg)) >>= - \case +deprecatedOption :: String -> String -> ExceptT OptInfo IO () +deprecatedOption o msg = do + res <- liftIO $ runIO (report $ Deprecated (T.pack o) (T.pack msg)) + case res of Right () -> return () - Left e -> E.throwIO e + Left e -> optError e -- | Set text value in text context. setVariable :: Text -> Text -> Context Text -> Context Text diff --git a/src/Text/Pandoc/App/FormatHeuristics.hs b/src/Text/Pandoc/App/FormatHeuristics.hs --- a/src/Text/Pandoc/App/FormatHeuristics.hs +++ b/src/Text/Pandoc/App/FormatHeuristics.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.App.FormatHeuristics - Copyright : Copyright (C) 2006-2022 John MacFarlane + Copyright : Copyright (C) 2006-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane diff --git a/src/Text/Pandoc/App/Input.hs b/src/Text/Pandoc/App/Input.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/App/Input.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +{- | + Module : Text.Pandoc.App.Input + Copyright : © 2006-2023 John MacFarlane + License : GPL-2.0-or-later + Maintainer : John MacFarlane + +Read from the file system into a pandoc document. +-} +module Text.Pandoc.App.Input + ( InputParameters (..) + , readInput + ) where + +import Control.Monad ((>=>)) +import Control.Monad.Except (throwError, catchError) +import Data.Text (Text) +import Network.URI (URI (..), parseURI, unEscapeString) +import Text.Pandoc.Class ( PandocMonad, openURL + , readFileStrict, readStdinStrict, report) +import Text.Pandoc.Definition (Pandoc (..), Attr, Block (..), Inline (..)) +import Text.Pandoc.Error (PandocError (..)) +import Text.Pandoc.Logging (LogMessage (..)) +import Text.Pandoc.MIME (getCharset, MimeType) +import Text.Pandoc.Options (Extensions, ReaderOptions (..)) +import Text.Pandoc.Readers (Reader (..)) +import Text.Pandoc.Shared (tabFilter, textToIdentifier, tshow) +import Text.Pandoc.URI (uriPathToPath) +import Text.Pandoc.Walk (walk) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as B8 +import qualified Data.ByteString.Lazy as BL +import qualified Data.Text as T +import qualified Data.Text.Encoding as TSE +import qualified Data.Text.Encoding.Error as TSE + +-- | Settings specifying how and which input should be processed. +data InputParameters m = InputParameters + { inputReader :: Reader m + , inputReaderName :: Text + , inputReaderOptions :: ReaderOptions + , inputSources :: [FilePath] + , inputSpacesPerTab :: Maybe Int + , inputFileScope :: Bool + } + +-- | Read all input into a pandoc document. +readInput :: PandocMonad m => InputParameters m -> m Pandoc +readInput params = do + let sources = inputSources params + let readerName = inputReaderName params + let readerOpts = inputReaderOptions params + let convertTabs :: Text -> Text + convertTabs = tabFilter $ case inputSpacesPerTab params of + Nothing -> 0 + Just ts -> if readerName `elem` ["t2t", "man", "tsv"] + then 0 + else ts + + inputs <- readSources sources + + case inputReader params of + TextReader r + | readerName == "json" -> + mconcat <$> mapM (inputToText convertTabs >=> r readerOpts . (:[])) + inputs + | inputFileScope params -> + mconcat <$> mapM + (\source -> do + (fp, txt) <- inputToText convertTabs source + adjustLinksAndIds (readerExtensions readerOpts) + (T.pack fp) (map (T.pack . fst) inputs) + <$> r readerOpts [(fp, txt)]) + inputs + | otherwise -> mapM (inputToText convertTabs) inputs >>= r readerOpts + ByteStringReader r -> + mconcat <$> mapM (r readerOpts . inputToLazyByteString) inputs + +readSources :: PandocMonad m + => [FilePath] -> m [(FilePath, (BS.ByteString, Maybe MimeType))] +readSources srcs = + mapM (\fp -> do t <- readSource fp + return (if fp == "-" then "" else fp, t)) srcs + +-- | Read input from a resource, i.e., either a file, a URL, or stdin +-- (@-@). +readSource :: PandocMonad m + => FilePath -> m (BS.ByteString, Maybe MimeType) +readSource "-" = (,Nothing) <$> readStdinStrict +readSource src = + case parseURI src of + Just u | uriScheme u `elem` ["http:","https:"] -> openURL (T.pack src) + | uriScheme u == "file:" -> + (,Nothing) <$> + readFileStrict (uriPathToPath $ T.pack $ uriPath u) + _ -> (,Nothing) <$> readFileStrict src + +utf8ToText :: PandocMonad m => FilePath -> BS.ByteString -> m Text +utf8ToText fp bs = + case TSE.decodeUtf8' . dropBOM $ bs of + Left (TSE.DecodeError _ (Just w)) -> + case BS.elemIndex w bs of + Just offset -> throwError $ PandocUTF8DecodingError (T.pack fp) offset w + Nothing -> throwError $ PandocUTF8DecodingError (T.pack fp) 0 w + Left e -> throwError $ PandocAppError (tshow e) + Right t -> return t + where + dropBOM bs' = + if "\xEF\xBB\xBF" `BS.isPrefixOf` bs' + then BS.drop 3 bs' + else bs' + +inputToText :: PandocMonad m + => (Text -> Text) + -> (FilePath, (BS.ByteString, Maybe MimeType)) + -> m (FilePath, Text) +inputToText convTabs (fp, (bs,mt)) = + (fp,) . convTabs . T.filter (/='\r') <$> + case mt >>= getCharset of + Just "UTF-8" -> utf8ToText fp bs + Just "ISO-8859-1" -> return $ T.pack $ B8.unpack bs + Just charset -> throwError $ PandocUnsupportedCharsetError charset + Nothing -> catchError + (utf8ToText fp bs) + (\case + PandocUTF8DecodingError{} -> do + report $ NotUTF8Encoded + (if null fp + then "input" + else fp) + return $ T.pack $ B8.unpack bs + e -> throwError e) + +inputToLazyByteString :: (FilePath, (BS.ByteString, Maybe MimeType)) + -> BL.ByteString +inputToLazyByteString (_, (bs,_)) = BL.fromStrict bs + +adjustLinksAndIds :: Extensions -> Text -> [Text] -> Pandoc -> Pandoc +adjustLinksAndIds exts thisfile allfiles + | length allfiles > 1 = addDiv . walk fixInline . walk fixBlock + | otherwise = id + where + toIdent :: Text -> Text + toIdent = textToIdentifier exts . T.intercalate "__" . + T.split (\c -> c == '/' || c == '\\') + + addDiv :: Pandoc -> Pandoc + addDiv (Pandoc m bs) + | T.null thisfile = Pandoc m bs + | otherwise = Pandoc m [Div (toIdent thisfile,[],[]) bs] + + fixBlock :: Block -> Block + fixBlock (CodeBlock attr t) = CodeBlock (fixAttrs attr) t + fixBlock (Header lev attr ils) = Header lev (fixAttrs attr) ils + fixBlock (Table attr cap cols th tbs tf) = + Table (fixAttrs attr) cap cols th tbs tf + fixBlock (Div attr bs) = Div (fixAttrs attr) bs + fixBlock x = x + + -- add thisfile as prefix of identifier + fixAttrs :: Attr -> Attr + fixAttrs (i,cs,kvs) + | T.null i = (i,cs,kvs) + | otherwise = + (T.intercalate "__" + (filter (not . T.null) [toIdent thisfile, i]), + cs, kvs) + + -- if URL begins with file from allfiles, convert to + -- an internal link with the appropriate identifier + fixURL :: Text -> Text + fixURL u = + let (a,b) = T.break (== '#') $ T.pack . unEscapeString . T.unpack $ u + filepart = if T.null a + then toIdent thisfile + else toIdent a + fragpart = T.dropWhile (== '#') b + in if T.null a || a `elem` allfiles + then "#" <> T.intercalate "__" + (filter (not . T.null) [filepart, fragpart]) + else u + + fixInline :: Inline -> Inline + fixInline (Code attr t) = Code (fixAttrs attr) t + fixInline (Link attr ils (url,tit)) = + Link (fixAttrs attr) ils (fixURL url,tit) + fixInline (Image attr ils (url,tit)) = + Image (fixAttrs attr) ils (fixURL url,tit) + fixInline (Span attr ils) = Span (fixAttrs attr) ils + fixInline x = x diff --git a/src/Text/Pandoc/App/Opt.hs b/src/Text/Pandoc/App/Opt.hs --- a/src/Text/Pandoc/App/Opt.hs +++ b/src/Text/Pandoc/App/Opt.hs @@ -7,7 +7,7 @@ {-# LANGUAGE FlexibleContexts #-} {- | Module : Text.Pandoc.App.Opt - Copyright : Copyright (C) 2006-2022 John MacFarlane + Copyright : Copyright (C) 2006-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane @@ -18,6 +18,7 @@ -} module Text.Pandoc.App.Opt ( Opt(..) + , OptInfo(..) , LineEnding (..) , IpynbOutput (..) , DefaultsState (..) @@ -25,7 +26,9 @@ , applyDefaults , fullDefaultsPath ) where -import Control.Monad.Except (MonadIO, liftIO, throwError, (>=>), foldM) +import Control.Monad.Except (throwError) +import Control.Monad.Trans (MonadIO, liftIO) +import Control.Monad ((>=>), foldM) import Control.Monad.State.Strict (StateT, modify, gets) import System.FilePath ( addExtension, (), takeExtension, takeDirectory ) import System.Directory ( canonicalizePath ) @@ -43,7 +46,8 @@ import Text.Pandoc.Class (readFileStrict, fileExists, setVerbosity, report, PandocMonad(lookupEnv), getUserDataDir) import Text.Pandoc.Error (PandocError (PandocParseError, PandocSomeError)) -import Text.Pandoc.Shared (defaultUserDataDir, findM, ordNub) +import Data.Containers.ListUtils (nubOrd) +import Text.Pandoc.Data (defaultUserDataDir) import qualified Text.Pandoc.Parsing as P import Text.Pandoc.Readers.Metadata (yamlMap) import Text.Pandoc.Class.PandocPure @@ -54,8 +58,8 @@ import qualified Data.Map as M import qualified Data.ByteString.Char8 as B8 import Text.Pandoc.Definition (Meta(..), MetaValue(..)) -import Data.Aeson (defaultOptions, Options(..), Result(..), camelTo2, - genericToJSON, fromJSON) +import Data.Aeson (defaultOptions, Options(..), Result(..), + genericToJSON, fromJSON, camelTo2) import Data.Aeson.TH (deriveJSON) import Control.Applicative ((<|>)) import Data.Yaml @@ -78,6 +82,22 @@ $(deriveJSON defaultOptions{ fieldLabelModifier = map toLower . drop 11 } ''IpynbOutput) +-- | Option parser results requesting informational output. +data OptInfo = + BashCompletion + | ListInputFormats + | ListOutputFormats + | ListExtensions (Maybe Text) + | ListHighlightLanguages + | ListHighlightStyles + | PrintDefaultTemplate (Maybe FilePath) Text + | PrintDefaultDataFile (Maybe FilePath) Text + | PrintHighlightStyle (Maybe FilePath) Text + | VersionInfo + | Help + | OptError PandocError + deriving (Show, Generic) + -- | Data structure for command line options. data Opt = Opt { optTabStop :: Int -- ^ Number of spaces per tab @@ -106,11 +126,12 @@ , optHTMLMathMethod :: HTMLMathMethod -- ^ Method to print HTML math , optAbbreviations :: Maybe FilePath -- ^ Path to abbrevs file , optReferenceDoc :: Maybe FilePath -- ^ Path of reference doc + , optSplitLevel :: Int -- ^ Header level at which to split documents in epub and chunkedhtml , optEpubSubdirectory :: String -- ^ EPUB subdir in OCF container , optEpubMetadata :: Maybe FilePath -- ^ EPUB metadata , optEpubFonts :: [FilePath] -- ^ EPUB fonts to embed - , optEpubChapterLevel :: Int -- ^ Header level at which to split chapters , optEpubCoverImage :: Maybe FilePath -- ^ Cover image for epub + , optEpubTitlePage :: Bool -- ^ INclude title page in EPUB , optTOCDepth :: Int -- ^ Number of levels to include in TOC , optDumpArgs :: Bool -- ^ Output command-line arguments , optIgnoreArgs :: Bool -- ^ Ignore command-line arguments @@ -126,7 +147,6 @@ , optFilters :: [Filter] -- ^ Filters to apply , optEmailObfuscation :: ObfuscationMethod , optIdentifierPrefix :: Text - , optStripEmptyParagraphs :: Bool -- ^ Strip empty paragraphs , optIndentedCodeClasses :: [Text] -- ^ Default classes for indented code blocks , optDataDir :: Maybe FilePath , optCiteMethod :: CiteMethod -- ^ Method to output cites @@ -135,6 +155,7 @@ , optPdfEngineOpts :: [String] -- ^ Flags to pass to the engine , optSlideLevel :: Maybe Int -- ^ Header level that creates slides , optSetextHeaders :: Bool -- ^ Use atx headers for markdown level 1-2 + , optListTables :: Bool -- ^ Use list tables for RST , optAscii :: Bool -- ^ Prefer ascii output , optDefaultImageExtension :: Text -- ^ Default image extension , optExtractMedia :: Maybe FilePath -- ^ Path to extract embedded media @@ -186,11 +207,13 @@ <*> o .:? "html-math-method" .!= optHTMLMathMethod defaultOpts <*> o .:? "abbreviations" <*> o .:? "reference-doc" + <*> ((o .:? "split-level") <|> (o .:? "epub-chapter-level")) + .!= optSplitLevel defaultOpts <*> o .:? "epub-subdirectory" .!= optEpubSubdirectory defaultOpts <*> o .:? "epub-metadata" <*> o .:? "epub-fonts" .!= optEpubFonts defaultOpts - <*> o .:? "epub-chapter-level" .!= optEpubChapterLevel defaultOpts <*> o .:? "epub-cover-image" + <*> o .:? "epub-title-page" .!= optEpubTitlePage defaultOpts <*> o .:? "toc-depth" .!= optTOCDepth defaultOpts <*> o .:? "dump-args" .!= optDumpArgs defaultOpts <*> o .:? "ignore-args" .!= optIgnoreArgs defaultOpts @@ -206,7 +229,6 @@ <*> o .:? "filters" .!= optFilters defaultOpts <*> o .:? "email-obfuscation" .!= optEmailObfuscation defaultOpts <*> o .:? "identifier-prefix" .!= optIdentifierPrefix defaultOpts - <*> o .:? "strip-empty-paragraphs" .!= optStripEmptyParagraphs defaultOpts <*> o .:? "indented-code-classes" .!= optIndentedCodeClasses defaultOpts <*> o .:? "data-dir" <*> o .:? "cite-method" .!= optCiteMethod defaultOpts @@ -215,6 +237,7 @@ <*> o .:? "pdf-engine-opts" .!= optPdfEngineOpts defaultOpts <*> o .:? "slide-level" <*> o .:? "setext-headers" .!= optSetextHeaders defaultOpts + <*> o .:? "list-tables" .!= optListTables defaultOpts <*> o .:? "ascii" .!= optAscii defaultOpts <*> o .:? "default-image-extension" .!= optDefaultImageExtension defaultOpts <*> o .:? "extract-media" @@ -537,7 +560,9 @@ parseJSON v >>= \x -> return (\o -> o{ optEpubFonts = optEpubFonts o <> map unpack x }) "epub-chapter-level" -> - parseJSON v >>= \x -> return (\o -> o{ optEpubChapterLevel = x }) + parseJSON v >>= \x -> return (\o -> o{ optSplitLevel = x }) + "split-level" -> + parseJSON v >>= \x -> return (\o -> o{ optSplitLevel = x }) "epub-cover-image" -> parseJSON v >>= \x -> return (\o -> o{ optEpubCoverImage = unpack <$> x }) @@ -577,8 +602,6 @@ "identifier-prefix" -> parseJSON v >>= \x -> return (\o -> o{ optIdentifierPrefix = x }) - "strip-empty-paragraphs" -> - parseJSON v >>= \x -> return (\o -> o{ optStripEmptyParagraphs = x }) "indented-code-classes" -> parseJSON v >>= \x -> return (\o -> o{ optIndentedCodeClasses = x }) @@ -601,14 +624,14 @@ return (\o -> o{ optPdfEngineOpts = [unpack x] })) "slide-level" -> parseJSON v >>= \x -> return (\o -> o{ optSlideLevel = x }) - "atx-headers" -> - parseJSON v >>= \x -> return (\o -> o{ optSetextHeaders = not x }) "markdown-headings" -> parseJSON v >>= \x -> return (\o -> case T.toLower x of "atx" -> o{ optSetextHeaders = False } "setext" -> o{ optSetextHeaders = True } _ -> o) + "list-tables" -> + parseJSON v >>= \x -> return (\o -> o{ optListTables = x }) "ascii" -> parseJSON v >>= \x -> return (\o -> o{ optAscii = x }) "default-image-extension" -> @@ -716,11 +739,12 @@ , optHTMLMathMethod = PlainMath , optAbbreviations = Nothing , optReferenceDoc = Nothing + , optSplitLevel = 1 , optEpubSubdirectory = "EPUB" , optEpubMetadata = Nothing , optEpubFonts = [] - , optEpubChapterLevel = 1 , optEpubCoverImage = Nothing + , optEpubTitlePage = True , optTOCDepth = 3 , optDumpArgs = False , optIgnoreArgs = False @@ -736,7 +760,6 @@ , optFilters = [] , optEmailObfuscation = NoObfuscation , optIdentifierPrefix = "" - , optStripEmptyParagraphs = False , optIndentedCodeClasses = [] , optDataDir = Nothing , optCiteMethod = Citeproc @@ -745,6 +768,7 @@ , optPdfEngineOpts = [] , optSlideLevel = Nothing , optSetextHeaders = False + , optListTables = False , optAscii = False , optDefaultImageExtension = "" , optExtractMedia = Nothing @@ -802,7 +826,14 @@ else file defaultDataDir <- liftIO defaultUserDataDir let defaultFp = fromMaybe defaultDataDir dataDir "defaults" fp - fromMaybe fp <$> findM fileExists [fp, defaultFp] + fpExists <- fileExists fp + if fpExists + then return fp + else do + defaultFpExists <- fileExists defaultFp + if defaultFpExists + then return defaultFp + else return fp -- | In a list of lists, append another list in front of every list which -- starts with specific element. @@ -817,4 +848,4 @@ cyclic :: Ord a => [[a]] -> Bool cyclic = any hasDuplicate where - hasDuplicate xs = length (ordNub xs) /= length xs + hasDuplicate xs = length (nubOrd xs) /= length xs diff --git a/src/Text/Pandoc/App/OutputSettings.hs b/src/Text/Pandoc/App/OutputSettings.hs --- a/src/Text/Pandoc/App/OutputSettings.hs +++ b/src/Text/Pandoc/App/OutputSettings.hs @@ -1,11 +1,12 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {- | Module : Text.Pandoc.App - Copyright : Copyright (C) 2006-2022 John MacFarlane + Copyright : Copyright (C) 2006-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane @@ -38,8 +39,10 @@ import Text.Pandoc.App.FormatHeuristics (formatFromFilePaths) import Text.Pandoc.App.Opt (Opt (..)) import Text.Pandoc.App.CommandLineOptions (engines, setVariable) +import qualified Text.Pandoc.Format as Format import Text.Pandoc.Highlighting (lookupHighlightingStyle) -import Text.Pandoc.Writers.Custom (writeCustom) +import Text.Pandoc.Scripting (ScriptingEngine (engineLoadCustom), + CustomComponents(..)) import qualified Text.Pandoc.UTF8 as UTF8 readUtf8File :: PandocMonad m => FilePath -> m T.Text @@ -49,14 +52,14 @@ data OutputSettings m = OutputSettings { outputFormat :: T.Text , outputWriter :: Writer m - , outputWriterName :: T.Text , outputWriterOptions :: WriterOptions , outputPdfProgram :: Maybe String } -- | Get output settings from command line options. -optToOutputSettings :: (PandocMonad m, MonadIO m) => Opt -> m (OutputSettings m) -optToOutputSettings opts = do +optToOutputSettings :: (PandocMonad m, MonadIO m) + => ScriptingEngine -> Opt -> m (OutputSettings m) +optToOutputSettings scriptingEngine opts = do let outputFile = fromMaybe "-" (optOutputFile opts) when (optDumpArgs opts) . liftIO $ do @@ -87,10 +90,6 @@ return ("html", Nothing) Just f -> return (f, Nothing) - let format = if ".lua" `T.isSuffixOf` writerName - then writerName - else T.toLower $ baseWriterName writerName - let makeSandboxed pureWriter = let files = maybe id (:) (optReferenceDoc opts) . maybe id (:) (optEpubMetadata opts) . @@ -101,24 +100,57 @@ optBibliography opts in case pureWriter of TextWriter w -> TextWriter $ \o d -> sandbox files (w o d) - ByteStringWriter w - -> ByteStringWriter $ \o d -> sandbox files (w o d) + ByteStringWriter w -> + ByteStringWriter $ \o d -> sandbox files (w o d) + flvrd@(Format.FlavoredFormat format _extsDiff) <- + Format.parseFlavoredFormat writerName - (writer, writerExts) <- - if ".lua" `T.isSuffixOf` format - then return (TextWriter - (\o d -> writeCustom (T.unpack writerName) o d), mempty) - else if optSandbox opts - then - case runPure (getWriter writerName) of - Left e -> throwError e - Right (w, wexts) -> - return (makeSandboxed w, wexts) - else getWriter (T.toLower writerName) + let standalone = optStandalone opts || isBinaryFormat format || pdfOutput + let templateOrThrow = \case + Left e -> throwError $ PandocTemplateError (T.pack e) + Right t -> pure t + let processCustomTemplate getDefault = + case optTemplate opts of + _ | not standalone -> return Nothing + Nothing -> Just <$> getDefault + Just tp -> do + -- strip off extensions + let tp' = case takeExtension tp of + "" -> tp <.> T.unpack format + _ -> tp + getTemplate tp' + >>= runWithPartials . compileTemplate tp' + >>= fmap Just . templateOrThrow - let standalone = optStandalone opts || not (isTextFormat format) || pdfOutput + (writer, writerExts, mtemplate) <- + if "lua" `T.isSuffixOf` format + then do + let path = T.unpack format + components <- engineLoadCustom scriptingEngine path + w <- case customWriter components of + Nothing -> throwError $ PandocAppError $ + format <> " does not contain a custom writer" + Just w -> return w + let extsConf = fromMaybe mempty $ customExtensions components + wexts <- Format.applyExtensionsDiff extsConf flvrd + templ <- processCustomTemplate $ + case customTemplate components of + Nothing -> throwError $ PandocNoTemplateError format + Just t -> (runWithDefaultPartials $ compileTemplate path t) >>= + templateOrThrow + return (w, wexts, templ) + else do + tmpl <- processCustomTemplate (compileDefaultTemplate format) + if optSandbox opts + then case runPure (getWriter flvrd) of + Right (w, wexts) -> return (makeSandboxed w, wexts, tmpl) + Left e -> throwError e + else do + (w, wexts) <- getWriter flvrd + return (w, wexts, tmpl) + let addSyntaxMap existingmap f = do res <- liftIO (parseSyntaxDefinition f) case res of @@ -160,6 +192,8 @@ >>= setVariableM "outputfile" (T.pack outputFile) >>= + setVariableM "pandoc-version" pandocVersionText + >>= setFilesVariableM "include-before" (optIncludeBeforeBody opts) >>= setFilesVariableM "include-after" (optIncludeAfterBody opts) @@ -170,8 +204,8 @@ >>= maybe return (setVariableM "title-prefix") (optTitlePrefix opts) >>= - maybe return (setVariableM "epub-cover-image") - (T.pack <$> optEpubCoverImage opts) + maybe return (setVariableM "epub-cover-image" . T.pack) + (optEpubCoverImage opts) >>= setVariableM "curdir" (T.pack curdir) >>= @@ -186,21 +220,8 @@ setVariableM "dzslides-core" dzcore vars else return vars) - templ <- case optTemplate opts of - _ | not standalone -> return Nothing - Nothing -> Just <$> compileDefaultTemplate format - Just tp -> do - -- strip off extensions - let tp' = case takeExtension tp of - "" -> tp <.> T.unpack format - _ -> tp - res <- getTemplate tp' >>= runWithPartials . compileTemplate tp' - case res of - Left e -> throwError $ PandocTemplateError $ T.pack e - Right t -> return $ Just t - let writerOpts = def { - writerTemplate = templ + writerTemplate = mtemplate , writerVariables = variables , writerTabStop = optTabStop opts , writerTableOfContents = optTableOfContents opts @@ -224,10 +245,12 @@ , writerSlideLevel = optSlideLevel opts , writerHighlightStyle = hlStyle , writerSetextHeaders = optSetextHeaders opts + , writerListTables = optListTables opts , writerEpubSubdirectory = T.pack $ optEpubSubdirectory opts , writerEpubMetadata = epubMetadata , writerEpubFonts = optEpubFonts opts - , writerEpubChapterLevel = optEpubChapterLevel opts + , writerEpubTitlePage = optEpubTitlePage opts + , writerSplitLevel = optSplitLevel opts , writerTOCDepth = optTOCDepth opts , writerReferenceDoc = optReferenceDoc opts , writerSyntaxMap = syntaxMap @@ -236,7 +259,6 @@ return $ OutputSettings { outputFormat = format , outputWriter = writer - , outputWriterName = writerName , outputWriterOptions = writerOpts , outputPdfProgram = maybePdfProg } @@ -278,6 +300,6 @@ isCustomWriter w = ".lua" `T.isSuffixOf` w -isTextFormat :: T.Text -> Bool -isTextFormat s = - s `notElem` ["odt","docx","epub2","epub3","epub","pptx","pdf"] +isBinaryFormat :: T.Text -> Bool +isBinaryFormat s = + s `elem` ["odt","docx","epub2","epub3","epub","pptx","pdf","chunkedhtml"] diff --git a/src/Text/Pandoc/Asciify.hs b/src/Text/Pandoc/Asciify.hs --- a/src/Text/Pandoc/Asciify.hs +++ b/src/Text/Pandoc/Asciify.hs @@ -1,6 +1,6 @@ {- | Module : Text.Pandoc.Asciify - Copyright : Copyright (C) 2013-2022 John MacFarlane + Copyright : Copyright (C) 2013-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane diff --git a/src/Text/Pandoc/CSS.hs b/src/Text/Pandoc/CSS.hs --- a/src/Text/Pandoc/CSS.hs +++ b/src/Text/Pandoc/CSS.hs @@ -1,6 +1,6 @@ {- | Module : Text.Pandoc.CSS -Copyright : © 2006-2022 John MacFarlane , +Copyright : © 2006-2023 John MacFarlane , 2015-2016 Mauro Bieg, 2015 Ophir Lifshitz License : GNU GPL, version 2 or above @@ -22,8 +22,9 @@ import Data.Maybe (mapMaybe, listToMaybe) import Data.Text (Text, pack) import Text.Pandoc.Shared (trim) -import Text.Parsec -import Text.Parsec.Text +import Text.Pandoc.Parsing + +type Parser = Parsec Text () ruleParser :: Parser (Text, Text) ruleParser = do diff --git a/src/Text/Pandoc/CSV.hs b/src/Text/Pandoc/CSV.hs --- a/src/Text/Pandoc/CSV.hs +++ b/src/Text/Pandoc/CSV.hs @@ -1,6 +1,6 @@ {- | Module : Text.Pandoc.CSV - Copyright : Copyright (C) 2017-2022 John MacFarlane + Copyright : Copyright (C) 2017-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane Stability : alpha @@ -19,8 +19,9 @@ import Control.Monad (unless, void, mzero) import Data.Text (Text) import qualified Data.Text as T -import Text.Parsec -import Text.Parsec.Text (Parser) +import Text.Pandoc.Parsing hiding (escaped) + +type Parser = Parsec Text () data CSVOptions = CSVOptions{ csvDelim :: Char diff --git a/src/Text/Pandoc/Chunks.hs b/src/Text/Pandoc/Chunks.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/Chunks.hs @@ -0,0 +1,411 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveGeneric #-} +{- | + Module : Text.Pandoc.Chunks + Copyright : Copyright (C) 2022-2023 John MacFarlane + License : GNU GPL, version 2 or above + + Maintainer : John MacFarlane + Stability : alpha + Portability : portable + +Functions and types for splitting a Pandoc into subdocuments, +e.g. for conversion into a set of HTML pages. +-} +module Text.Pandoc.Chunks + ( Chunk(..) + , ChunkedDoc(..) + , PathTemplate(..) + , splitIntoChunks + , toTOCTree + , tocToList + , SecInfo(..) + ) where +import Text.Pandoc.Definition +import Text.Pandoc.Shared (makeSections, stringify, inlineListToIdentifier) +import Text.Pandoc.Walk (Walkable(..)) +import Data.Text (Text) +import Text.Printf (printf) +import Data.Maybe (fromMaybe, isNothing) +import qualified Data.Map as M +import qualified Data.Text as T +import Data.String (IsString) +import GHC.Generics (Generic) +import Text.HTML.TagSoup (Tag (TagOpen), fromAttrib, parseTags) +import Data.Tree (Tree(..)) + +-- | Split 'Pandoc' into 'Chunk's, e.g. for conversion into +-- a set of HTML pages or EPUB chapters. +splitIntoChunks :: PathTemplate -- ^ Template for filepath + -> Bool -- ^ Number sections + -> Maybe Int -- ^ Base heading level + -> Int -- ^ Chunk level -- level of section to split at + -> Pandoc + -> ChunkedDoc +splitIntoChunks pathTemplate numberSections mbBaseLevel + chunklev (Pandoc meta blocks) = + addNav . + fixInternalReferences . + walk rmNavAttrs $ + ChunkedDoc{ chunkedMeta = meta + , chunkedChunks = chunks + , chunkedTOC = tocTree } + where + tocTree = fixTOCTreePaths chunks $ toTOCTree sections + chunks = makeChunks chunklev pathTemplate meta $ sections + sections = makeSections numberSections mbBaseLevel $ blocks + +-- | Add chunkNext, chunkPrev, chunkUp +addNav :: ChunkedDoc -> ChunkedDoc +addNav chunkedDoc = + chunkedDoc{ chunkedChunks = + addNext . addPrev . addUp $ chunkedChunks chunkedDoc } + +addUp :: [Chunk] -> [Chunk] +addUp (c : d : ds) + | chunkLevel c < chunkLevel d + = c : addUp (d{ chunkUp = Just c } : ds) + | chunkLevel c == chunkLevel d + = c : addUp (d{ chunkUp = chunkUp c} : ds) +addUp (c:cs) = c : addUp cs +addUp [] = [] + +addNext :: [Chunk] -> [Chunk] +addNext cs = zipWith go cs (map Just (tail cs) ++ [Nothing]) + where + go c nxt = c{ chunkNext = nxt } + +addPrev :: [Chunk] -> [Chunk] +addPrev cs = zipWith go cs (Nothing : map Just cs) + where + go c prev = c{ chunkPrev = prev } + +-- | Fix internal references so they point to the path of the chunk. +fixInternalReferences :: ChunkedDoc -> ChunkedDoc +fixInternalReferences chunkedDoc = walk fixInternalRefs chunkedDoc + where + fixInternalRefs :: Inline -> Inline + fixInternalRefs il@(Link attr ils (src,tit)) + = case T.uncons src of + Just ('#', ident) -> Link attr ils (src', tit) + where src' = case M.lookup ident refMap of + Just chunk -> T.pack (chunkPath chunk) <> src + Nothing -> src + _ -> il + fixInternalRefs il = il + + refMap = foldr chunkToRefs mempty (chunkedChunks chunkedDoc) + + chunkToRefs chunk m = + let idents = chunkId chunk : getIdents (chunkContents chunk) + in foldr (\ident -> M.insert ident chunk) m idents + + getIdents bs = query getBlockIdent bs ++ query getInlineIdent bs + + getBlockIdent :: Block -> [Text] + getBlockIdent (Div (ident, _, _) _) + | not (T.null ident) = [ident] + getBlockIdent (Header _ (ident, _, _) _) + | not (T.null ident) = [ident] + getBlockIdent (Table (ident,_,_) _ _ _ _ _) + | not (T.null ident) = [ident] + getBlockIdent (RawBlock fmt raw) + | isHtmlFormat fmt + = foldr (\tag -> + case tag of + TagOpen{} -> + case fromAttrib "id" tag of + "" -> id + x -> (x:) + _ -> id) + [] (parseTags raw) + getBlockIdent _ = [] + + getInlineIdent :: Inline -> [Text] + getInlineIdent (Span (ident, _, _) _) + | not (T.null ident) = [ident] + getInlineIdent (Link (ident, _, _) _ _) + | not (T.null ident) = [ident] + getInlineIdent (Image (ident, _, _) _ _) + | not (T.null ident) = [ident] + getInlineIdent (RawInline fmt raw) + | isHtmlFormat fmt + = foldr (\tag -> + case tag of + TagOpen{} -> + case fromAttrib "id" tag of + "" -> id + x -> (x:) + _ -> id) + [] (parseTags raw) + getInlineIdent _ = [] + + isHtmlFormat :: Format -> Bool + isHtmlFormat (Format "html") = True + isHtmlFormat (Format "html4") = True + isHtmlFormat (Format "html5") = True + isHtmlFormat _ = False + + +makeChunks :: Int -> PathTemplate -> Meta -> [Block] -> [Chunk] +makeChunks chunklev pathTemplate meta = secsToChunks 1 + where + isChunkHeader :: Block -> Bool + isChunkHeader (Div (_,"section":_,_) (Header n _ _:_)) = n <= chunklev + isChunkHeader _ = False + + secsToChunks :: Int -> [Block] -> [Chunk] + secsToChunks chunknum bs = + case break isChunkHeader bs of + ([], []) -> [] + ([], (d@(Div attr@(_,"section":_,_) (h@(Header lvl _ _) : bs')) : rest)) + | chunklev == lvl -> + -- If the header is of the same level as chunks, create a chunk + toChunk chunknum d : + secsToChunks (chunknum + 1) rest + | chunklev > lvl -> + case break isChunkHeader bs' of + (xs, ys) -> toChunk chunknum (Div attr (h:xs)) : + secsToChunks (chunknum + 1) (ys ++ rest) + (xs, ys) -> toChunk chunknum + (Div ("",["preamble"],[]) xs) : + secsToChunks (chunknum + 1) ys + + toChunk :: Int -> Block -> Chunk + toChunk chunknum + (Div (divid,"section":classes,kvs) (h@(Header lvl _ ils) : bs)) = + Chunk + { chunkHeading = ils + , chunkId = divid + , chunkLevel = lvl + , chunkNumber = chunknum + , chunkSectionNumber = secnum + , chunkPath = chunkpath + , chunkUp = Nothing + , chunkNext = Nothing + , chunkPrev = Nothing + , chunkUnlisted = "unlisted" `elem` classes + , chunkContents = + [Div (divid,"section":classes,kvs') (h : bs)] + } + where kvs' = kvs ++ [("nav-path", T.pack chunkpath)] + secnum = lookup "number" kvs + chunkpath = resolvePathTemplate pathTemplate chunknum + (stringify ils) + divid + (fromMaybe "" secnum) + toChunk chunknum (Div ("",["preamble"],[]) bs) = + Chunk + { chunkHeading = docTitle meta + , chunkId = inlineListToIdentifier mempty $ docTitle meta + , chunkLevel = 0 + , chunkNumber = chunknum + , chunkSectionNumber = Nothing + , chunkPath = resolvePathTemplate pathTemplate chunknum + (stringify (docTitle meta)) + (inlineListToIdentifier mempty (docTitle meta)) + "0" + , chunkUp = Nothing + , chunkPrev = Nothing + , chunkNext = Nothing + , chunkUnlisted = False + , chunkContents = bs + } + toChunk _ b = error $ "toChunk called on inappropriate block " <> show b + -- should not happen + + +-- Remove some attributes we added just to construct chunkNext etc. +rmNavAttrs :: Block -> Block +rmNavAttrs (Div (ident,classes,kvs) bs) = + Div (ident,classes,filter (not . isNavAttr) kvs) bs + where + isNavAttr (k,_) = "nav-" `T.isPrefixOf` k +rmNavAttrs b = b + +resolvePathTemplate :: PathTemplate + -> Int -- ^ Chunk number + -> Text -- ^ Stringified heading text + -> Text -- ^ Section identifier + -> Text -- ^ Section number + -> FilePath +resolvePathTemplate (PathTemplate templ) chunknum headingText ident secnum = + T.unpack . + T.replace "%n" (T.pack $ printf "%03d" chunknum) . + T.replace "%s" secnum . + T.replace "%h" headingText . + T.replace "%i" ident $ + templ + +-- | A 'PathTemplate' is a FilePath in which certain codes +-- will be substituted with information from a 'Chunk'. +-- @%n@ will be replaced with the chunk number +-- (padded with leading 0s to 3 digits), +-- @%s@ with the section number of the heading, +-- @%h@ with the (stringified) heading text, +-- @%i@ with the section identifier. +-- For example, @"section-%s-%i.html"@ might be resolved to +-- @"section-1.2-introduction.html"@. +newtype PathTemplate = + PathTemplate { unPathTemplate :: Text } + deriving (Show, IsString) + +-- | A part of a document (typically a chapter or section, or +-- the part of a section before its subsections). +data Chunk = + Chunk + { chunkHeading :: [Inline] + , chunkId :: Text + , chunkLevel :: Int + , chunkNumber :: Int + , chunkSectionNumber :: Maybe Text + , chunkPath :: FilePath + , chunkUp :: Maybe Chunk + , chunkPrev :: Maybe Chunk + , chunkNext :: Maybe Chunk + , chunkUnlisted :: Bool + , chunkContents :: [Block] + } + deriving (Show, Eq, Generic) + +instance Walkable Inline Chunk where + query f chunk = query f (chunkContents chunk) + walk f chunk = chunk{ chunkContents = walk f (chunkContents chunk) } + walkM f chunk = do + contents <- walkM f (chunkContents chunk) + return chunk{ chunkContents = contents } + +instance Walkable Block Chunk where + query f chunk = query f (chunkContents chunk) + walk f chunk = chunk{ chunkContents = walk f (chunkContents chunk) } + walkM f chunk = do + contents <- walkM f (chunkContents chunk) + return chunk{ chunkContents = contents } + +-- | A 'Pandoc' broken into 'Chunk's for writing to separate files. +data ChunkedDoc = + ChunkedDoc + { chunkedMeta :: Meta + , chunkedTOC :: Tree SecInfo + , chunkedChunks :: [Chunk] + } deriving (Show, Eq, Generic) + +instance Walkable Inline ChunkedDoc where + query f doc = query f (chunkedChunks doc) <> query f (chunkedMeta doc) + walk f doc = doc{ chunkedMeta = walk f (chunkedMeta doc) + , chunkedChunks = walk f (chunkedChunks doc) + } + walkM f doc = do + meta' <- walkM f (chunkedMeta doc) + chunks' <- walkM f (chunkedChunks doc) + return $ doc{ chunkedMeta = meta' + , chunkedChunks = chunks' } + +instance Walkable Block ChunkedDoc where + query f doc = query f (chunkedChunks doc) <> query f (chunkedMeta doc) + walk f doc = doc{ chunkedMeta = walk f (chunkedMeta doc) + , chunkedChunks = walk f (chunkedChunks doc) + } + walkM f doc = do + meta' <- walkM f (chunkedMeta doc) + chunks' <- walkM f (chunkedChunks doc) + return $ doc{ chunkedMeta = meta' + , chunkedChunks = chunks' } + +-- | Data for a section in a hierarchical document. +data SecInfo = + SecInfo + { secTitle :: [Inline] + , secNumber :: Maybe Text + , secId :: Text + , secPath :: Text -- including fragment, e.g. chunk001.html#section-one + , secLevel :: Int + } deriving (Show, Eq, Generic) + +instance Walkable Inline SecInfo where + query f sec = query f (secTitle sec) + walk f sec = sec{ secTitle = walk f (secTitle sec) } + walkM f sec = do + st <- walkM f (secTitle sec) + return sec{ secTitle = st } + +-- | Create tree of sections with titles, links, and numbers, +-- in a form that can be turned into a table of contents. +-- Presupposes that the '[Block]' is the output of 'makeSections'. +toTOCTree :: [Block] -> Tree SecInfo +toTOCTree = + Node SecInfo{ secTitle = [] + , secNumber = Nothing + , secId = "" + , secPath = "" + , secLevel = 0 } . foldr go [] + where + go :: Block -> [Tree SecInfo] -> [Tree SecInfo] + go (Div (ident,_,_) (Header lev (_,classes,kvs) ils : subsecs)) + | not (isNothing (lookup "number" kvs) && "unlisted" `elem` classes) + = ((Node SecInfo{ secTitle = ils + , secNumber = lookup "number" kvs + , secId = ident + , secPath = "" + , secLevel = lev } (foldr go [] subsecs)) :) + go (Div _ [d@Div{}]) = go d -- #8402 + go _ = id + +-- | Adjusts paths in the TOC tree generated by 'toTOCTree' +-- to reflect division into Chunks. +fixTOCTreePaths :: [Chunk] -> Tree SecInfo -> Tree SecInfo +fixTOCTreePaths chunks = go "" + where + idMap = foldr (\chunk -> M.insert (chunkId chunk) (chunkPath chunk)) + mempty chunks + go :: FilePath -> Tree SecInfo -> Tree SecInfo + go fp (Node secinfo subtrees) = + let newpath = M.lookup (secId secinfo) idMap + fp' = fromMaybe fp newpath + fragment = case newpath of + Nothing -> "#" <> secId secinfo + Just _ -> "" -- link to top of file + in Node secinfo{ secPath = T.pack fp' <> fragment } + (map (go fp') subtrees) + +-- | Creates a TOC link to the respective document section. +tocEntryToLink :: Bool -> SecInfo -> [Inline] +tocEntryToLink includeNumbers secinfo = headerLink + where + addNumber = case secNumber secinfo of + Just num | includeNumbers + -> (Span ("",["toc-section-number"],[]) + [Str num] :) . (Space :) + _ -> id + clean (Link _ xs _) = xs + clean (Note _) = [] + clean x = [x] + anchor = if T.null (secPath secinfo) + then if T.null (secId secinfo) + then "" + else "#" <> secId secinfo + else secPath secinfo + headerText = addNumber $ walk (concatMap clean) (secTitle secinfo) + headerLink = if T.null anchor + then headerText + else [Link ((if T.null (secId secinfo) + then "" + else "toc-" <> secId secinfo), [], []) + headerText (anchor, "")] + +-- | Generate a table of contents of the given depth. +tocToList :: Bool -> Int -> Tree SecInfo -> Block +tocToList includeNumbers tocDepth (Node _ subtrees) = BulletList (toItems subtrees) + where + toItems = map go . filter isBelowTocDepth + isBelowTocDepth (Node sec _) = secLevel sec <= tocDepth + go (Node secinfo xs) = + Plain (tocEntryToLink includeNumbers secinfo) : + case toItems xs of + [] -> [] + ys -> [BulletList ys] diff --git a/src/Text/Pandoc/Citeproc.hs b/src/Text/Pandoc/Citeproc.hs --- a/src/Text/Pandoc/Citeproc.hs +++ b/src/Text/Pandoc/Citeproc.hs @@ -16,6 +16,7 @@ LocatorInfo(..)) import Text.Pandoc.Citeproc.CslJson (cslJsonToReferences) import Text.Pandoc.Citeproc.BibTeX (readBibtexString, Variant(..)) +import Text.Pandoc.MIME (MimeType) import Text.Pandoc.Readers.RIS (readRIS) import Text.Pandoc.Citeproc.MetaValue (metaValueToReference, metaValueToText) import Text.Pandoc.Readers.Markdown (yamlToRefs) @@ -23,12 +24,14 @@ import qualified Text.Pandoc.Builder as B import Text.Pandoc.Definition as Pandoc import Text.Pandoc.Class (PandocMonad(..), getResourcePath, getUserDataDir, - fetchItem, readDataFile, report, setResourcePath) + fetchItem, report, setResourcePath) +import Text.Pandoc.Data (readDataFile) import Text.Pandoc.Error (PandocError(..)) import Text.Pandoc.Extensions (pandocExtensions) import Text.Pandoc.Logging (LogMessage(..)) import Text.Pandoc.Options (ReaderOptions(..)) -import Text.Pandoc.Shared (stringify, ordNub, tshow) +import Text.Pandoc.Shared (stringify, tshow) +import Data.Containers.ListUtils (nubOrd) import qualified Text.Pandoc.UTF8 as UTF8 import Text.Pandoc.Walk (query, walk, walkM) import Control.Applicative ((<|>)) @@ -235,8 +238,8 @@ getRefsFromBib :: PandocMonad m => Locale -> (Text -> Bool) -> Text -> m [Reference Inlines] getRefsFromBib locale idpred fp = do - (raw, _) <- fetchItem fp - case formatFromExtension (T.unpack fp) of + (raw, mt) <- fetchItem fp + case getBibliographyFormat (T.unpack fp) mt of Just f -> getRefs locale f idpred (Just fp) raw Nothing -> throwError $ PandocAppError $ "Could not determine bibliography format for " <> fp @@ -352,17 +355,28 @@ | Format_ris deriving (Show, Eq, Ord) -formatFromExtension :: FilePath -> Maybe BibFormat -formatFromExtension fp = case dropWhile (== '.') $ takeExtension fp of - "biblatex" -> Just Format_biblatex - "bibtex" -> Just Format_bibtex - "bib" -> Just Format_biblatex - "json" -> Just Format_json - "yaml" -> Just Format_yaml - "yml" -> Just Format_yaml - "ris" -> Just Format_ris - _ -> Nothing - +getBibliographyFormat :: FilePath -> Maybe MimeType -> Maybe BibFormat +getBibliographyFormat fp mbmime = do + let ext = takeExtension fp + case ext of + ".biblatex" -> pure Format_biblatex + ".bibtex" -> pure Format_bibtex + ".bib" -> pure Format_biblatex + ".json" -> pure Format_json + ".yaml" -> pure Format_yaml + ".yml" -> pure Format_yaml + ".ris" -> pure Format_ris + _ -> do + mime <- mbmime + case T.takeWhile (/= ';') mime of + "application/x-bibtex" -> pure Format_biblatex + "application/x-reseach-info-systems" -> pure Format_ris + "application/vnd.citationstyles.csl+json" -> pure Format_json + "application/json" -> pure Format_json + "application/x-yaml" -> pure Format_yaml + "text/x-yaml" -> pure Format_yaml + "text/yaml" -> pure Format_yaml + _ -> Nothing isNote :: Inline -> Bool isNote (Cite _ [Note _]) = True @@ -488,8 +502,8 @@ go (Div ("refs",cs,kvs) xs) = do put True -- refHeader isn't used if you have an explicit references div - let cs' = ordNub $ cs ++ refclasses - let kvs' = ordNub $ kvs ++ refkvs + let cs' = nubOrd $ cs ++ refclasses + let kvs' = nubOrd $ kvs ++ refkvs return $ Div ("refs",cs',kvs') (xs ++ refs) go x = return x diff --git a/src/Text/Pandoc/Citeproc/BibTeX.hs b/src/Text/Pandoc/Citeproc/BibTeX.hs --- a/src/Text/Pandoc/Citeproc/BibTeX.hs +++ b/src/Text/Pandoc/Citeproc/BibTeX.hs @@ -11,7 +11,8 @@ -- License : BSD-style (see LICENSE) -- -- Maintainer : John MacFarlane --- Stability : unstable-- Portability : unportable +-- Stability : unstable +-- Portability : portable -- ----------------------------------------------------------------------------- @@ -19,7 +20,6 @@ ( Variant(..) , readBibtexString , writeBibtexString - , toName ) where @@ -35,8 +35,10 @@ import qualified Text.Pandoc.Walk as Walk import Citeproc.Types import Citeproc.Pandoc () +import Data.List.Split (splitOn) import Text.Pandoc.Citeproc.Util (toIETF, splitStrWhen) import Text.Pandoc.Citeproc.Data (biblatexStringMap) +import Text.Pandoc.Citeproc.Name (toName, NameOpts(..), emptyName) import Data.Default import Data.Text (Text) import qualified Data.Text as T @@ -44,8 +46,8 @@ import Data.Maybe import Text.Pandoc.Parsing hiding ((<|>), many) import Control.Applicative -import Data.List.Split (splitOn, splitWhen, wordsBy) -import Control.Monad.RWS hiding ((<>)) +import Control.Monad ( guard, MonadPlus(..), void ) +import Control.Monad.RWS ( asks, RWST, gets, modify, evalRWST ) import qualified Data.Sequence as Seq import Data.Char (isAlphaNum, isDigit, isLetter, isUpper, toLower, toUpper, @@ -119,7 +121,8 @@ "treaty" | variant == Biblatex -> "legal" "personal_communication" | variant == Biblatex -> "letter" "motion_picture" | variant == Biblatex -> "movie" - "review" | variant == Biblatex -> "review" + "review" | variant == Biblatex -> "review" + "software" | variant == Biblatex -> "software" _ -> "misc" mbSubtype = @@ -144,6 +147,7 @@ , "volumes" , "number" , "pages" + , "version" , "date" , "eventdate" , "urldate" @@ -179,6 +183,8 @@ , "type" , "note" , "annote" + , "url" -- not officially supported, but supported by + -- some styles (#8287) ] valToInlines (TextVal t) = B.text t @@ -345,7 +351,7 @@ -- a map of bibtex "string" macros type StringMap = Map.Map Text Text -type BibParser = Parser Sources (Lang, StringMap) +type BibParser = Parsec Sources (Lang, StringMap) data Item = Item{ identifier :: Text , sourcePos :: SourcePos @@ -404,9 +410,7 @@ -- names let getNameList' f = Just <$> - getNameList (("bibtex", case variant of - Bibtex -> "true" - Biblatex -> "false") : opts) f + getNameList opts f author' <- getNameList' "author" <|> return Nothing containerAuthor' <- getNameList' "bookauthor" <|> return Nothing @@ -793,14 +797,6 @@ latex :: Text -> Bib Inlines latex = fmap blocksToInlines . latex' . T.strip -type Options = [(Text, Text)] - -parseOptions :: Text -> Options -parseOptions = map breakOpt . T.splitOn "," - where breakOpt x = case T.break (=='=') x of - (w,v) -> (T.toLower $ T.strip w, - T.toLower $ T.strip $ T.drop 1 v) - bibEntries :: BibParser [Item] bibEntries = do skipMany nonEntry @@ -839,17 +835,26 @@ updateState (\(l,m) -> (l, Map.insert k v m)) return () -take1WhileP :: Monad m => (Char -> Bool) -> ParserT Sources u m Text +take1WhileP :: Monad m => (Char -> Bool) -> ParsecT Sources u m Text take1WhileP f = T.pack <$> many1 (satisfy f) inBraces :: BibParser Text inBraces = do char '{' res <- manyTill + ( take1WhileP (\c -> c /= '{' && c /= '}' && c /= '\\' && c /= '%') + <|> (char '\\' >> T.cons '\\' . T.singleton <$> anyChar) + <|> ("" <$ (char '%' >> anyLine)) + <|> (braced <$> inBraces) + ) (char '}') + return $ T.concat res + +inBracesURL :: BibParser Text +inBracesURL = do + char '{' + res <- manyTill ( take1WhileP (\c -> c /= '{' && c /= '}' && c /= '\\') - <|> (char '\\' >> (do c <- oneOf "{}" - return $ T.pack ['\\',c]) - <|> return "\\") + <|> (char '\\' >> T.cons '\\' . T.singleton <$> anyChar) <|> (braced <$> inBraces) ) (char '}') return $ T.concat res @@ -867,6 +872,14 @@ <|> braced <$> inBraces ) (char '"') +inQuotesURL :: BibParser Text +inQuotesURL = do + char '"' + T.concat <$> manyTill + ( take1WhileP (\c -> c /= '{' && c /= '"' && c /= '\\') + <|> (char '\\' >> T.cons '\\' . T.singleton <$> anyChar) + ) (char '"') + fieldName :: BibParser Text fieldName = resolveAlias . T.toLower <$> take1WhileP (\c -> @@ -902,7 +915,9 @@ spaces' char '=' spaces' - vs <- (expandString <|> inQuotes <|> inBraces <|> rawWord) `sepBy` + let inQ = if k == "url" then inQuotesURL else inQuotes + let inB = if k == "url" then inBracesURL else inBraces + vs <- (expandString <|> inQ <|> inB <|> rawWord) `sepBy` try (spaces' >> char '#' >> spaces') spaces' return (k, T.concat vs) @@ -1132,21 +1147,37 @@ B.space <> s -getNameList :: Options -> Text -> Bib [Name] +parseOptions :: Text -> [(Text, Text)] +parseOptions = map breakOpt . T.splitOn "," + where breakOpt x = case T.break (=='=') x of + (w,v) -> (T.toLower $ T.strip w, + T.toLower $ T.strip $ T.drop 1 v) + +optionSet :: Text -> [(Text, Text)] -> Bool +optionSet key opts = case lookup key opts of + Just "true" -> True + Just s -> s == mempty + _ -> False + +getNameList :: [(Text, Text)] -> Text -> Bib [Name] getNameList opts f = do fs <- asks fields case Map.lookup f fs of - Just x -> latexNames opts x + Just x -> latexNames nameopts x Nothing -> notFound f + where + nameopts = NameOpts{ + nameOptsPrefixIsNonDroppingParticle = optionSet "useprefix" opts, + nameOptsUseJuniorComma = optionSet "juniorcomma" opts} -toNameList :: Options -> [Block] -> Bib [Name] +toNameList :: NameOpts -> [Block] -> Bib [Name] toNameList opts [Para xs] = filter (/= emptyName) <$> mapM (toName opts . addSpaceAfterPeriod) (splitByAnd xs) toNameList opts [Plain xs] = toNameList opts [Para xs] toNameList _ _ = mzero -latexNames :: Options -> Text -> Bib [Name] +latexNames :: NameOpts -> Text -> Bib [Name] latexNames opts t = latex' (T.strip t) >>= toNameList opts -- see issue 392 for motivation. We want to treat @@ -1163,109 +1194,6 @@ = Str (T.singleton c):Str ".":Space:go (Str (T.singleton d):xs) go (x:xs) = x:go xs -emptyName :: Name -emptyName = - Name { nameFamily = Nothing - , nameGiven = Nothing - , nameDroppingParticle = Nothing - , nameNonDroppingParticle = Nothing - , nameSuffix = Nothing - , nameLiteral = Nothing - , nameCommaSuffix = False - , nameStaticOrdering = False - } - -toName :: MonadPlus m => Options -> [Inline] -> m Name -toName _ [Str "others"] = - return emptyName{ nameLiteral = Just "others" } -toName _ [Span ("",[],[]) ils] = -- corporate author - return emptyName{ nameLiteral = Just $ stringify ils } - -- extended BibLaTeX name format - see #266 -toName _ ils@(Str ys:_) | T.any (== '=') ys = do - let commaParts = splitWhen (== Str ",") - . splitStrWhen (\c -> c == ',' || c == '=' || c == '\160') - $ ils - let addPart ag (Str "given" : Str "=" : xs) = - ag{ nameGiven = case nameGiven ag of - Nothing -> Just $ stringify xs - Just t -> Just $ t <> " " <> stringify xs } - addPart ag (Str "family" : Str "=" : xs) = - ag{ nameFamily = Just $ stringify xs } - addPart ag (Str "prefix" : Str "=" : xs) = - ag{ nameDroppingParticle = Just $ stringify xs } - addPart ag (Str "useprefix" : Str "=" : Str "true" : _) = - ag{ nameNonDroppingParticle = nameDroppingParticle ag - , nameDroppingParticle = Nothing } - addPart ag (Str "suffix" : Str "=" : xs) = - ag{ nameSuffix = Just $ stringify xs } - addPart ag (Space : xs) = addPart ag xs - addPart ag _ = ag - return $ foldl' addPart emptyName commaParts --- First von Last --- von Last, First --- von Last, Jr ,First --- NOTE: biblatex and bibtex differ on: --- Drummond de Andrade, Carlos --- bibtex takes "Drummond de" as the von; --- biblatex takes the whole as a last name. --- See https://github.com/plk/biblatex/issues/236 --- Here we implement the more sensible biblatex behavior. -toName opts ils = do - let useprefix = optionSet "useprefix" opts - let usecomma = optionSet "juniorcomma" opts - let bibtex = optionSet "bibtex" opts - let words' = wordsBy (\x -> x == Space || x == Str "\160") - let commaParts = map words' $ splitWhen (== Str ",") - $ splitStrWhen - (\c -> c == ',' || c == '\160') ils - let (first, vonlast, jr) = - case commaParts of - --- First is the longest sequence of white-space separated - -- words starting with an uppercase and that is not the - -- whole string. von is the longest sequence of whitespace - -- separated words whose last word starts with lower case - -- and that is not the whole string. - [fvl] -> let (caps', rest') = span isCapitalized fvl - in if null rest' && not (null caps') - then (init caps', [last caps'], []) - else (caps', rest', []) - [vl,f] -> (f, vl, []) - (vl:j:f:_) -> (f, vl, j ) - [] -> ([], [], []) - - let (von, lastname) = - if bibtex - then case span isCapitalized $ reverse vonlast of - ([],w:ws) -> (reverse ws, [w]) - (vs, ws) -> (reverse ws, reverse vs) - else case break isCapitalized vonlast of - (vs@(_:_), []) -> (init vs, [last vs]) - (vs, ws) -> (vs, ws) - let prefix = T.unwords $ map stringify von - let family = T.unwords $ map stringify lastname - let suffix = T.unwords $ map stringify jr - let given = T.unwords $ map stringify first - return - Name { nameFamily = if T.null family - then Nothing - else Just family - , nameGiven = if T.null given - then Nothing - else Just given - , nameDroppingParticle = if useprefix || T.null prefix - then Nothing - else Just prefix - , nameNonDroppingParticle = if useprefix && not (T.null prefix) - then Just prefix - else Nothing - , nameSuffix = if T.null suffix - then Nothing - else Just suffix - , nameLiteral = Nothing - , nameCommaSuffix = usecomma - , nameStaticOrdering = False - } - ordinalize :: Locale -> Text -> Text ordinalize locale n = let terms = localeTerms locale @@ -1279,20 +1207,6 @@ Just [] -> n Just (t:_) -> n <> snd t -isCapitalized :: [Inline] -> Bool -isCapitalized (Str (T.uncons -> Just (c,cs)) : rest) - | isUpper c = True - | isDigit c = isCapitalized (Str cs : rest) - | otherwise = False -isCapitalized (_:rest) = isCapitalized rest -isCapitalized [] = True - -optionSet :: Text -> Options -> Bool -optionSet key opts = case lookup key opts of - Just "true" -> True - Just s -> s == mempty - _ -> False - getTypeAndGenre :: Bib (Text, Maybe Text) getTypeAndGenre = do lang <- gets localeLang @@ -1336,7 +1250,7 @@ "proceedings" -> "book" "reference" -> "book" "report" -> "report" - "software" -> "book" -- no "software" type in CSL + "software" -> "software" "suppbook" -> "chapter" "suppcollection" -> "chapter" "suppperiodical" diff --git a/src/Text/Pandoc/Citeproc/CslJson.hs b/src/Text/Pandoc/Citeproc/CslJson.hs --- a/src/Text/Pandoc/Citeproc/CslJson.hs +++ b/src/Text/Pandoc/Citeproc/CslJson.hs @@ -6,7 +6,8 @@ import Citeproc.CslJson import Citeproc.Types import Control.Monad.Identity (runIdentity) -import Data.Aeson (eitherDecodeStrict') +import Data.Aeson (eitherDecodeStrict', FromJSON(parseJSON), (.:), Value(..)) +import Data.Aeson.Types (parseEither) import Data.ByteString (ByteString) import Text.Pandoc.Builder as B import Data.Text (Text) @@ -31,8 +32,11 @@ fromCslJson (CslLink u x) = B.link u "" (fromCslJson x) cslJsonToReferences :: ByteString -> Either String [Reference Inlines] -cslJsonToReferences raw = - case eitherDecodeStrict' raw of - Left e -> Left e - Right cslrefs -> Right $ - map (runIdentity . traverse (return . fromCslJson)) cslrefs +cslJsonToReferences raw = do + items <- + case eitherDecodeStrict' raw of + Left e -> Left e + Right (Object o) -> parseEither (.: "items") o + Right val@(Array _) -> parseEither parseJSON val + Right _ -> Left "expecting Object or Array" + pure $ map (runIdentity . traverse (return . fromCslJson)) items diff --git a/src/Text/Pandoc/Citeproc/Locator.hs b/src/Text/Pandoc/Citeproc/Locator.hs --- a/src/Text/Pandoc/Citeproc/Locator.hs +++ b/src/Text/Pandoc/Citeproc/Locator.hs @@ -12,9 +12,8 @@ import Data.Text (Text) import qualified Data.Text as T import Data.List (foldl') -import Text.Parsec import Text.Pandoc.Definition -import Text.Pandoc.Parsing (romanNumeral) +import Text.Pandoc.Parsing import Text.Pandoc.Shared (stringify) import Control.Monad (mzero) import qualified Data.Map as M @@ -80,9 +79,9 @@ pLocatorLabelDelimited :: LocatorMap -> LocatorParser (Text, Text, Bool) pLocatorLabelDelimited locMap - = pLocatorLabel' locMap lim <|> return ("", "page", True) - where - lim = stringify <$> anyToken + = pLocatorLabel' locMap (stringify <$> anyToken) + <|> (("", "page", True) <$ lookAhead (pMatchChar "digit" isDigit)) + <|> (pure ("", "", True)) pLocatorIntegrated :: LocatorMap -> LocatorParser LocatorInfo pLocatorIntegrated locMap = try $ do @@ -170,7 +169,7 @@ isc c = stringify <$> pMatchChar [c] (== c) sur c c' m = try $ do - (d, mid) <- between (isc c) (isc c') (option (False, "") m) + (d, mid) <- isc c *> option (False, "") m <* isc c' return (d, T.cons c . flip T.snoc c' $ mid) flattened = concatMap (\(o, c) -> [o, c]) braces @@ -296,6 +295,6 @@ , "paragraph" , "part" , "section" - , "sub verbo" + , "sub-verbo" , "verse" , "volume" ] diff --git a/src/Text/Pandoc/Citeproc/MetaValue.hs b/src/Text/Pandoc/Citeproc/MetaValue.hs --- a/src/Text/Pandoc/Citeproc/MetaValue.hs +++ b/src/Text/Pandoc/Citeproc/MetaValue.hs @@ -3,7 +3,6 @@ ( referenceToMetaValue , metaValueToReference , metaValueToText - , metaValueToPath ) where @@ -27,9 +26,6 @@ metaValueToText (MetaBlocks bls) = Just $ stringify bls metaValueToText (MetaList xs) = T.unwords <$> mapM metaValueToText xs metaValueToText _ = Nothing - -metaValueToPath :: MetaValue -> Maybe FilePath -metaValueToPath = fmap T.unpack . metaValueToText metaValueToBool :: MetaValue -> Maybe Bool metaValueToBool (MetaBool b) = Just b diff --git a/src/Text/Pandoc/Citeproc/Name.hs b/src/Text/Pandoc/Citeproc/Name.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/Citeproc/Name.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} +----------------------------------------------------------------------------- +-- | +-- Module : Text.CSL.Input.Name +-- Copyright : (c) John MacFarlane +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : John MacFarlane +-- Stability : unstable +-- Portability : portable +-- +----------------------------------------------------------------------------- + +module Text.Pandoc.Citeproc.Name + ( toName + , NameOpts(..) + , emptyName + ) + where + +import Text.Pandoc.Definition +import Text.Pandoc.Shared (stringify) +import Citeproc.Types +import Citeproc.Pandoc () +import Text.Pandoc.Citeproc.Util (splitStrWhen) +import qualified Data.Text as T +import Data.List.Split (splitWhen, wordsBy) +import Data.Char (isUpper, isDigit) +import Data.List (foldl') + +emptyName :: Name +emptyName = + Name { nameFamily = Nothing + , nameGiven = Nothing + , nameDroppingParticle = Nothing + , nameNonDroppingParticle = Nothing + , nameSuffix = Nothing + , nameLiteral = Nothing + , nameCommaSuffix = False + , nameStaticOrdering = False + } + +-- | Options for 'toName'. +data NameOpts = + NameOpts + { nameOptsPrefixIsNonDroppingParticle :: Bool + -- ^ Treat a prefix on the last name as a non-dropping particle + -- (default is to treat it as a dropping particle). This corresponds + -- to the biblatex option @useprefix@. + , nameOptsUseJuniorComma :: Bool + -- ^ Put a comma before a suffix like "Jr." This corresponds to the + -- biblatex option @juniorcomma@. + } deriving (Show) + +-- | Parse a list of 'Inline's into a citeproc 'Name', identifying +-- first and last name, particles, suffixes. +toName :: Monad m => NameOpts -> [Inline] -> m Name +toName _ [Str "others"] = + return emptyName{ nameLiteral = Just "others" } +toName _ [Span ("",[],[]) ils] = -- corporate author + return emptyName{ nameLiteral = Just $ stringify ils } +-- extended BibLaTeX name format - see #266 +toName _ ils@(Str ys:_) | T.any (== '=') ys = do + let commaParts = splitWhen (== Str ",") + . splitStrWhen (\c -> c == ',' || c == '=' || c == '\160') + $ ils + let addPart ag (Str "given" : Str "=" : xs) = + ag{ nameGiven = case nameGiven ag of + Nothing -> Just $ stringify xs + Just t -> Just $ t <> " " <> stringify xs } + addPart ag (Str "family" : Str "=" : xs) = + ag{ nameFamily = Just $ stringify xs } + addPart ag (Str "prefix" : Str "=" : xs) = + ag{ nameDroppingParticle = Just $ stringify xs } + addPart ag (Str "useprefix" : Str "=" : Str "true" : _) = + ag{ nameNonDroppingParticle = nameDroppingParticle ag + , nameDroppingParticle = Nothing } + addPart ag (Str "suffix" : Str "=" : xs) = + ag{ nameSuffix = Just $ stringify xs } + addPart ag (Space : xs) = addPart ag xs + addPart ag _ = ag + return $ foldl' addPart emptyName commaParts +-- First von Last +-- von Last, First +-- von Last, Jr ,First +-- NOTE: biblatex and bibtex differ on: +-- Drummond de Andrade, Carlos +-- bibtex takes "Drummond de" as the von; +-- biblatex takes the whole as a last name. +-- See https://github.com/plk/biblatex/issues/236 +-- Here we implement the more sensible biblatex behavior. +toName opts ils = do + let words' = wordsBy (\x -> x == Space || x == Str "\160") + let commaParts = map words' $ splitWhen (== Str ",") + $ splitStrWhen + (\c -> c == ',' || c == '\160') ils + let (first, vonlast, jr) = + case commaParts of + --- First is the longest sequence of white-space separated + -- words starting with an uppercase and that is not the + -- whole string. von is the longest sequence of whitespace + -- separated words whose last word starts with lower case + -- and that is not the whole string. + [fvl] -> let (caps', rest') = span isCapitalized fvl + in if null rest' && not (null caps') + then (init caps', [last caps'], []) + else (caps', rest', []) + [vl,f] -> (f, vl, []) + (vl:j:f:_) -> (f, vl, j ) + [] -> ([], [], []) + + let (von, lastname) = + case break isCapitalized vonlast of + (vs@(_:_), []) -> (init vs, [last vs]) + (vs, ws) -> (vs, ws) + let prefix = T.unwords $ map stringify von + let family = T.unwords $ map stringify lastname + let suffix = T.unwords $ map stringify jr + let given = T.unwords $ map stringify first + return + Name { nameFamily = if T.null family + then Nothing + else Just family + , nameGiven = if T.null given + then Nothing + else Just given + , nameDroppingParticle = if nameOptsPrefixIsNonDroppingParticle opts || + T.null prefix + then Nothing + else Just prefix + , nameNonDroppingParticle = if nameOptsPrefixIsNonDroppingParticle opts && + not (T.null prefix) + then Just prefix + else Nothing + , nameSuffix = if T.null suffix + then Nothing + else Just suffix + , nameLiteral = Nothing + , nameCommaSuffix = nameOptsUseJuniorComma opts + , nameStaticOrdering = False + } + +isCapitalized :: [Inline] -> Bool +isCapitalized (Str (T.uncons -> Just (c,cs)) : rest) + | isUpper c = True + | isDigit c = isCapitalized (Str cs : rest) + | otherwise = False +isCapitalized (_:rest) = isCapitalized rest +isCapitalized [] = True diff --git a/src/Text/Pandoc/Citeproc/Util.hs b/src/Text/Pandoc/Citeproc/Util.hs --- a/src/Text/Pandoc/Citeproc/Util.hs +++ b/src/Text/Pandoc/Citeproc/Util.hs @@ -79,4 +79,3 @@ toIETF "vietnamese" = "vi-VN" toIETF "latin" = "la" toIETF x = x - diff --git a/src/Text/Pandoc/Class.hs b/src/Text/Pandoc/Class.hs --- a/src/Text/Pandoc/Class.hs +++ b/src/Text/Pandoc/Class.hs @@ -27,5 +27,5 @@ import Text.Pandoc.Class.PandocMonad import Text.Pandoc.Class.PandocIO import Text.Pandoc.Class.PandocPure -import Text.Pandoc.Translations (Translations) +import Text.Pandoc.Translations.Types (Translations) import Text.Pandoc.Class.Sandbox diff --git a/src/Text/Pandoc/Class/CommonState.hs b/src/Text/Pandoc/Class/CommonState.hs --- a/src/Text/Pandoc/Class/CommonState.hs +++ b/src/Text/Pandoc/Class/CommonState.hs @@ -22,7 +22,7 @@ import Text.Collate.Lang (Lang) import Text.Pandoc.MediaBag (MediaBag) import Text.Pandoc.Logging (LogMessage, Verbosity (WARNING)) -import Text.Pandoc.Translations (Translations) +import Text.Pandoc.Translations.Types (Translations) -- | 'CommonState' represents state that is used by all -- instances of 'PandocMonad'. Normally users should not diff --git a/src/Text/Pandoc/Class/IO.hs b/src/Text/Pandoc/Class/IO.hs --- a/src/Text/Pandoc/Class/IO.hs +++ b/src/Text/Pandoc/Class/IO.hs @@ -32,6 +32,7 @@ , readFileStrict , readStdinStrict , extractMedia + , writeMedia ) where import Control.Monad.Except (throwError) diff --git a/src/Text/Pandoc/Class/PandocMonad.hs b/src/Text/Pandoc/Class/PandocMonad.hs --- a/src/Text/Pandoc/Class/PandocMonad.hs +++ b/src/Text/Pandoc/Class/PandocMonad.hs @@ -23,6 +23,7 @@ module Text.Pandoc.Class.PandocMonad ( PandocMonad(..) + , getTimestamp , getPOSIXTime , getZonedTime , readFileFromDirs @@ -45,22 +46,17 @@ , setOutputFile , setResourcePath , getResourcePath - , readDefaultDataFile - , readDataFile , readMetadataFile , fillMediaBag , toLang - , setTranslations - , translateTerm , makeCanonical , findFileWithDataFallback - , getTimestamp + , checkUserDataDir ) where -import Codec.Archive.Zip -import Control.Monad.Except (MonadError (catchError, throwError), - MonadTrans, lift, when) -import Data.List (foldl') +import Control.Monad.Except (MonadError (catchError, throwError)) +import Control.Monad.Trans (MonadTrans, lift) +import Control.Monad (when) import Data.Time (UTCTime) import Data.Time.Clock.POSIX (POSIXTime, utcTimeToPOSIXSeconds, posixSecondsToUTCTime) @@ -69,30 +65,25 @@ unEscapeString, parseURIReference, isAllowedInURI, parseURI, URI(..) ) import System.FilePath ((), takeExtension, dropExtension, - isRelative, splitDirectories, makeRelative) + isRelative, makeRelative) import System.Random (StdGen) -import Text.Collate.Lang (Lang(..), parseLang, renderLang) +import Text.Collate.Lang (Lang(..), parseLang) import Text.Pandoc.Class.CommonState (CommonState (..)) import Text.Pandoc.Definition import Text.Pandoc.Error import Text.Pandoc.Logging import Text.Pandoc.MIME (MimeType, getMimeType) import Text.Pandoc.MediaBag (MediaBag, lookupMedia, MediaItem(..)) -import Text.Pandoc.Shared (uriPathToPath, safeRead) -import Text.Pandoc.Translations (Term(..), Translations, lookupTerm, - readTranslations) +import Text.Pandoc.Shared (safeRead, makeCanonical) +import Text.Pandoc.URI (uriPathToPath) import Text.Pandoc.Walk (walkM) import Text.Parsec (ParsecT, getPosition, sourceLine, sourceName) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import qualified Data.Text as T import qualified Debug.Trace -import qualified System.FilePath.Posix as Posix import qualified Text.Pandoc.MediaBag as MB import qualified Text.Pandoc.UTF8 as UTF8 -#ifdef EMBED_DATA_FILES -import Text.Pandoc.Data (dataFiles) -#endif -- | The PandocMonad typeclass contains all the potentially -- IO-related functions used in pandoc's readers and writers. @@ -182,21 +173,6 @@ when (level <= verbosity) $ logOutput msg modifyCommonState $ \st -> st{ stLog = msg : stLog st } --- | Get the time from the @SOURCE_DATE_EPOCH@ --- environment variable. The variable should contain a --- unix time stamp, the number of seconds since midnight Jan 01 --- 1970 UTC. If the variable is not set or cannot be --- parsed as a unix time stamp, the current time is returned. --- This function is designed to make possible reproducible --- builds in formats that include a creation timestamp. -getTimestamp :: PandocMonad m => m UTCTime -getTimestamp = do - mbSourceDateEpoch <- lookupEnv "SOURCE_DATE_EPOCH" - case mbSourceDateEpoch >>= safeRead of - Just (epoch :: Integer) -> - return $ posixSecondsToUTCTime $ fromIntegral epoch - Nothing -> getCurrentTime - -- | Determine whether tracing is enabled. This affects -- the behavior of 'trace'. If tracing is not enabled, -- 'trace' does nothing. @@ -266,14 +242,28 @@ setResourcePath :: PandocMonad m => [FilePath] -> m () setResourcePath ps = modifyCommonState $ \st -> st{stResourcePath = ps} --- | Get the POSIX time. +-- | Get the current UTC time. If the @SOURCE_DATE_EPOCH@ environment +-- variable is set to a unix time (number of seconds since midnight +-- Jan 01 1970 UTC), it is used instead of the current time, to support +-- reproducible builds. +getTimestamp :: PandocMonad m => m UTCTime +getTimestamp = do + mbSourceDateEpoch <- lookupEnv "SOURCE_DATE_EPOCH" + case mbSourceDateEpoch >>= safeRead of + Just (epoch :: Integer) -> + return $ posixSecondsToUTCTime $ fromIntegral epoch + Nothing -> getCurrentTime + +-- | Get the POSIX time. If @SOURCE_DATE_EPOCH@ is set to a unix time, +-- it is used instead of the current time. getPOSIXTime :: PandocMonad m => m POSIXTime -getPOSIXTime = utcTimeToPOSIXSeconds <$> getCurrentTime +getPOSIXTime = utcTimeToPOSIXSeconds <$> getTimestamp --- | Get the zoned time. +-- | Get the zoned time. If @SOURCE_DATE_EPOCH@ is set to a unix time, +-- value (POSIX time), it is used instead of the current time. getZonedTime :: PandocMonad m => m ZonedTime getZonedTime = do - t <- getCurrentTime + t <- getTimestamp tz <- getCurrentTimeZone return $ utcToZonedTime tz t @@ -295,62 +285,6 @@ return Nothing Right l -> return (Just l) --- | Select the language to use with 'translateTerm'. --- Note that this does not read a translation file; --- that is only done the first time 'translateTerm' is --- used. -setTranslations :: PandocMonad m => Lang -> m () -setTranslations lang = - modifyCommonState $ \st -> st{ stTranslations = Just (lang, Nothing) } - --- | Load term map. -getTranslations :: PandocMonad m => m Translations -getTranslations = do - mbtrans <- getsCommonState stTranslations - case mbtrans of - Nothing -> return mempty -- no language defined - Just (_, Just t) -> return t - Just (lang, Nothing) -> do -- read from file - let translationFile = "translations/" <> renderLang lang <> ".yaml" - let fallbackFile = "translations/" <> langLanguage lang <> ".yaml" - let getTrans fp = do - bs <- readDataFile fp - case readTranslations (UTF8.toText bs) of - Left e -> do - report $ CouldNotLoadTranslations (renderLang lang) - (T.pack fp <> ": " <> e) - -- make sure we don't try again... - modifyCommonState $ \st -> - st{ stTranslations = Nothing } - return mempty - Right t -> do - modifyCommonState $ \st -> - st{ stTranslations = Just (lang, Just t) } - return t - catchError (getTrans $ T.unpack translationFile) - (\_ -> - catchError (getTrans $ T.unpack fallbackFile) - (\e -> do - report $ CouldNotLoadTranslations (renderLang lang) - $ case e of - PandocCouldNotFindDataFileError _ -> - "data file " <> fallbackFile <> " not found" - _ -> "" - -- make sure we don't try again... - modifyCommonState $ \st -> st{ stTranslations = Nothing } - return mempty)) - --- | Get a translation from the current term map. --- Issue a warning if the term is not defined. -translateTerm :: PandocMonad m => Term -> m T.Text -translateTerm term = do - translations <- getTranslations - case lookupTerm term translations of - Just s -> return s - Nothing -> do - report $ NoTranslation $ T.pack $ show term - return "" - -- | Specialized version of parseURIReference that disallows -- single-letter schemes. Reason: these are usually windows absolute -- paths. @@ -436,146 +370,6 @@ convertSlash '\\' = '/' convertSlash x = x --- | Retrieve default reference.docx. -getDefaultReferenceDocx :: PandocMonad m => m Archive -getDefaultReferenceDocx = do - let paths = ["[Content_Types].xml", - "_rels/.rels", - "docProps/app.xml", - "docProps/core.xml", - "docProps/custom.xml", - "word/document.xml", - "word/fontTable.xml", - "word/footnotes.xml", - "word/comments.xml", - "word/numbering.xml", - "word/settings.xml", - "word/webSettings.xml", - "word/styles.xml", - "word/_rels/document.xml.rels", - "word/_rels/footnotes.xml.rels", - "word/theme/theme1.xml"] - let toLazy = BL.fromChunks . (:[]) - let pathToEntry path = do - epochtime <- floor . utcTimeToPOSIXSeconds <$> getTimestamp - contents <- toLazy <$> readDataFile ("docx/" ++ path) - return $ toEntry path epochtime contents - datadir <- getUserDataDir - mbArchive <- case datadir of - Nothing -> return Nothing - Just d -> do - exists <- fileExists (d "reference.docx") - if exists - then return (Just (d "reference.docx")) - else return Nothing - case mbArchive of - Just arch -> toArchive <$> readFileLazy arch - Nothing -> foldr addEntryToArchive emptyArchive <$> - mapM pathToEntry paths - --- | Retrieve default reference.odt. -getDefaultReferenceODT :: PandocMonad m => m Archive -getDefaultReferenceODT = do - let paths = ["mimetype", - "manifest.rdf", - "styles.xml", - "content.xml", - "meta.xml", - "settings.xml", - "Configurations2/accelerator/current.xml", - "Thumbnails/thumbnail.png", - "META-INF/manifest.xml"] - let pathToEntry path = do epochtime <- floor `fmap` getPOSIXTime - contents <- (BL.fromChunks . (:[])) `fmap` - readDataFile ("odt/" ++ path) - return $ toEntry path epochtime contents - datadir <- getUserDataDir - mbArchive <- case datadir of - Nothing -> return Nothing - Just d -> do - exists <- fileExists (d "reference.odt") - if exists - then return (Just (d "reference.odt")) - else return Nothing - case mbArchive of - Just arch -> toArchive <$> readFileLazy arch - Nothing -> foldr addEntryToArchive emptyArchive <$> - mapM pathToEntry paths - --- | Retrieve default reference.pptx. -getDefaultReferencePptx :: PandocMonad m => m Archive -getDefaultReferencePptx = do - -- We're going to narrow this down substantially once we get it - -- working. - let paths = [ "[Content_Types].xml" - , "_rels/.rels" - , "docProps/app.xml" - , "docProps/core.xml" - , "ppt/_rels/presentation.xml.rels" - , "ppt/presProps.xml" - , "ppt/presentation.xml" - , "ppt/slideLayouts/_rels/slideLayout1.xml.rels" - , "ppt/slideLayouts/_rels/slideLayout2.xml.rels" - , "ppt/slideLayouts/_rels/slideLayout3.xml.rels" - , "ppt/slideLayouts/_rels/slideLayout4.xml.rels" - , "ppt/slideLayouts/_rels/slideLayout5.xml.rels" - , "ppt/slideLayouts/_rels/slideLayout6.xml.rels" - , "ppt/slideLayouts/_rels/slideLayout7.xml.rels" - , "ppt/slideLayouts/_rels/slideLayout8.xml.rels" - , "ppt/slideLayouts/_rels/slideLayout9.xml.rels" - , "ppt/slideLayouts/_rels/slideLayout10.xml.rels" - , "ppt/slideLayouts/_rels/slideLayout11.xml.rels" - , "ppt/slideLayouts/slideLayout1.xml" - , "ppt/slideLayouts/slideLayout10.xml" - , "ppt/slideLayouts/slideLayout11.xml" - , "ppt/slideLayouts/slideLayout2.xml" - , "ppt/slideLayouts/slideLayout3.xml" - , "ppt/slideLayouts/slideLayout4.xml" - , "ppt/slideLayouts/slideLayout5.xml" - , "ppt/slideLayouts/slideLayout6.xml" - , "ppt/slideLayouts/slideLayout7.xml" - , "ppt/slideLayouts/slideLayout8.xml" - , "ppt/slideLayouts/slideLayout9.xml" - , "ppt/slideMasters/_rels/slideMaster1.xml.rels" - , "ppt/slideMasters/slideMaster1.xml" - , "ppt/slides/_rels/slide1.xml.rels" - , "ppt/slides/slide1.xml" - , "ppt/slides/_rels/slide2.xml.rels" - , "ppt/slides/slide2.xml" - , "ppt/slides/_rels/slide3.xml.rels" - , "ppt/slides/slide3.xml" - , "ppt/slides/_rels/slide4.xml.rels" - , "ppt/slides/slide4.xml" - , "ppt/tableStyles.xml" - , "ppt/theme/theme1.xml" - , "ppt/viewProps.xml" - -- These relate to notes slides. - , "ppt/notesMasters/notesMaster1.xml" - , "ppt/notesMasters/_rels/notesMaster1.xml.rels" - , "ppt/notesSlides/notesSlide1.xml" - , "ppt/notesSlides/_rels/notesSlide1.xml.rels" - , "ppt/notesSlides/notesSlide2.xml" - , "ppt/notesSlides/_rels/notesSlide2.xml.rels" - , "ppt/theme/theme2.xml" - ] - let toLazy = BL.fromChunks . (:[]) - let pathToEntry path = do - epochtime <- floor . utcTimeToPOSIXSeconds <$> getCurrentTime - contents <- toLazy <$> readDataFile ("pptx/" ++ path) - return $ toEntry path epochtime contents - datadir <- getUserDataDir - mbArchive <- case datadir of - Nothing -> return Nothing - Just d -> do - exists <- fileExists (d "reference.pptx") - if exists - then return (Just (d "reference.pptx")) - else return Nothing - case mbArchive of - Just arch -> toArchive <$> readFileLazy arch - Nothing -> foldr addEntryToArchive emptyArchive <$> - mapM pathToEntry paths - -- | Checks if the file path is relative to a parent directory. isRelativeToParentDir :: FilePath -> Bool isRelativeToParentDir fname = @@ -590,61 +384,12 @@ then getUserDataDir else return Nothing ---- | Read file from user data directory or, ---- if not found there, from the default data files. -readDataFile :: PandocMonad m => FilePath -> m B.ByteString -readDataFile fname = do - datadir <- checkUserDataDir fname - case datadir of - Nothing -> readDefaultDataFile fname - Just userDir -> do - exists <- fileExists (userDir fname) - if exists - then readFileStrict (userDir fname) - else readDefaultDataFile fname - -- | Read metadata file from the working directory or, if not found there, from -- the metadata subdirectory of the user data directory. readMetadataFile :: PandocMonad m => FilePath -> m B.ByteString readMetadataFile fname = findFileWithDataFallback "metadata" fname >>= \case Nothing -> throwError $ PandocCouldNotFindMetadataFileError (T.pack fname) Just metadataFile -> readFileStrict metadataFile - --- | Read file from from the default data files. -readDefaultDataFile :: PandocMonad m => FilePath -> m B.ByteString -readDefaultDataFile "reference.docx" = - B.concat . BL.toChunks . fromArchive <$> getDefaultReferenceDocx -readDefaultDataFile "reference.pptx" = - B.concat . BL.toChunks . fromArchive <$> getDefaultReferencePptx -readDefaultDataFile "reference.odt" = - B.concat . BL.toChunks . fromArchive <$> getDefaultReferenceODT -readDefaultDataFile fname = -#ifdef EMBED_DATA_FILES - case lookup (makeCanonical fname) dataFiles of - Nothing -> throwError $ PandocCouldNotFindDataFileError $ T.pack fname - Just contents -> return contents -#else - getDataFileName fname' >>= checkExistence >>= readFileStrict - where fname' = if fname == "MANUAL.txt" then fname else "data" fname - --- | Returns the input filename unchanged if the file exits, and throws --- a `PandocCouldNotFindDataFileError` if it doesn't. -checkExistence :: PandocMonad m => FilePath -> m FilePath -checkExistence fn = do - exists <- fileExists fn - if exists - then return fn - else throwError $ PandocCouldNotFindDataFileError $ T.pack fn -#endif - --- | Canonicalizes a file path by removing redundant @.@ and @..@. -makeCanonical :: FilePath -> FilePath -makeCanonical = Posix.joinPath . transformPathParts . splitDirectories - where transformPathParts = reverse . foldl' go [] - go as "." = as - go ("..":as) ".." = ["..", ".."] <> as - go (_:as) ".." = as - go as x = x : as -- | Tries to run an action on a file: for each directory given, a -- filepath is created from the given filename, and the action is run on diff --git a/src/Text/Pandoc/Class/PandocPure.hs b/src/Text/Pandoc/Class/PandocPure.hs --- a/src/Text/Pandoc/Class/PandocPure.hs +++ b/src/Text/Pandoc/Class/PandocPure.hs @@ -29,8 +29,17 @@ ) where import Codec.Archive.Zip +import Control.Monad.Trans ( MonadTrans(lift) ) import Control.Monad.Except + ( ExceptT(..), MonadError(throwError), runExceptT ) import Control.Monad.State.Strict + ( StateT(StateT), + State, + MonadState(put, get), + modify, + evalState, + evalStateT ) +import Control.Monad (foldM) import Data.Default import Data.Text (Text) import Data.Time (UTCTime) diff --git a/src/Text/Pandoc/Class/Sandbox.hs b/src/Text/Pandoc/Class/Sandbox.hs --- a/src/Text/Pandoc/Class/Sandbox.hs +++ b/src/Text/Pandoc/Class/Sandbox.hs @@ -1,6 +1,6 @@ {- | Module : Text.Pandoc.Class.Sandbox -Copyright : Copyright (C) 2021-2022 John MacFarlane +Copyright : Copyright (C) 2021-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane () @@ -47,4 +47,3 @@ mapM_ logOutput (filter ((<= verbosity) . messageVerbosity) newMessages) return result - diff --git a/src/Text/Pandoc/Data.hs b/src/Text/Pandoc/Data.hs --- a/src/Text/Pandoc/Data.hs +++ b/src/Text/Pandoc/Data.hs @@ -1,32 +1,247 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +#ifdef EMBED_DATA_FILES {-# LANGUAGE TemplateHaskell #-} +#endif {- | Module : Text.Pandoc.Data -Copyright : Copyright (C) 2013-2022 John MacFarlane +Copyright : Copyright (C) 2013-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane Stability : alpha Portability : portable -Provide contents data files as Haskell values. +Access to pandoc's data files. -} -module Text.Pandoc.Data (dataFiles) where - +module Text.Pandoc.Data ( readDefaultDataFile + , readDataFile + , getDataFileNames + , defaultUserDataDir + ) where +import Text.Pandoc.Class (PandocMonad(..), checkUserDataDir, getTimestamp, + getUserDataDir, getPOSIXTime) +import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) +import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString as B -import Data.FileEmbed -import System.FilePath (splitDirectories) -import qualified System.FilePath.Posix as Posix +import Codec.Archive.Zip +import qualified Data.Text as T +import Control.Monad.Except (throwError) +import Text.Pandoc.Error (PandocError(..)) +import System.FilePath +import System.Directory +import qualified Control.Exception as E +#ifdef EMBED_DATA_FILES +import Text.Pandoc.Data.BakedIn (dataFiles) +import Text.Pandoc.Shared (makeCanonical) +#else +import Paths_pandoc (getDataDir) +#endif --- We ensure that the data files are stored using Posix --- path separators (/), even on Windows. -dataFiles :: [(FilePath, B.ByteString)] -dataFiles = map (\(fp, contents) -> - (Posix.joinPath (splitDirectories fp), contents)) dataFiles' +-- | Read file from from the default data files. +readDefaultDataFile :: PandocMonad m => FilePath -> m B.ByteString +readDefaultDataFile "reference.docx" = + B.concat . BL.toChunks . fromArchive <$> getDefaultReferenceDocx +readDefaultDataFile "reference.pptx" = + B.concat . BL.toChunks . fromArchive <$> getDefaultReferencePptx +readDefaultDataFile "reference.odt" = + B.concat . BL.toChunks . fromArchive <$> getDefaultReferenceODT +readDefaultDataFile fname = +#ifdef EMBED_DATA_FILES + case lookup (makeCanonical fname) dataFiles of + Nothing -> throwError $ PandocCouldNotFindDataFileError $ T.pack fname + Just contents -> return contents +#else + getDataFileName fname' >>= checkExistence >>= readFileStrict + where fname' = if fname == "MANUAL.txt" then fname else "data" fname -dataFiles' :: [(FilePath, B.ByteString)] -dataFiles' = ("MANUAL.txt", $(embedFile "MANUAL.txt")) : - -- handle the hidden file separately, since embedDir doesn't - -- include it: - ("docx/_rels/.rels", $(embedFile "data/docx/_rels/.rels")) : - ("pptx/_rels/.rels", $(embedFile "data/pptx/_rels/.rels")) : - $(embedDir "data") +-- | Returns the input filename unchanged if the file exits, and throws +-- a `PandocCouldNotFindDataFileError` if it doesn't. +checkExistence :: PandocMonad m => FilePath -> m FilePath +checkExistence fn = do + exists <- fileExists fn + if exists + then return fn + else throwError $ PandocCouldNotFindDataFileError $ T.pack fn +#endif + +--- | Read file from user data directory or, +--- if not found there, from the default data files. +readDataFile :: PandocMonad m => FilePath -> m B.ByteString +readDataFile fname = do + datadir <- checkUserDataDir fname + case datadir of + Nothing -> readDefaultDataFile fname + Just userDir -> do + exists <- fileExists (userDir fname) + if exists + then readFileStrict (userDir fname) + else readDefaultDataFile fname + +-- | Retrieve default reference.docx. +getDefaultReferenceDocx :: PandocMonad m => m Archive +getDefaultReferenceDocx = do + let paths = ["[Content_Types].xml", + "_rels/.rels", + "docProps/app.xml", + "docProps/core.xml", + "docProps/custom.xml", + "word/document.xml", + "word/fontTable.xml", + "word/footnotes.xml", + "word/comments.xml", + "word/numbering.xml", + "word/settings.xml", + "word/webSettings.xml", + "word/styles.xml", + "word/_rels/document.xml.rels", + "word/_rels/footnotes.xml.rels", + "word/theme/theme1.xml"] + let toLazy = BL.fromChunks . (:[]) + let pathToEntry path = do + epochtime <- floor . utcTimeToPOSIXSeconds <$> getTimestamp + contents <- toLazy <$> readDataFile ("docx/" ++ path) + return $ toEntry path epochtime contents + datadir <- getUserDataDir + mbArchive <- case datadir of + Nothing -> return Nothing + Just d -> do + exists <- fileExists (d "reference.docx") + if exists + then return (Just (d "reference.docx")) + else return Nothing + case mbArchive of + Just arch -> toArchive <$> readFileLazy arch + Nothing -> foldr addEntryToArchive emptyArchive <$> + mapM pathToEntry paths + +-- | Retrieve default reference.odt. +getDefaultReferenceODT :: PandocMonad m => m Archive +getDefaultReferenceODT = do + let paths = ["mimetype", + "manifest.rdf", + "styles.xml", + "content.xml", + "meta.xml", + "settings.xml", + "Configurations2/accelerator/current.xml", + "Thumbnails/thumbnail.png", + "META-INF/manifest.xml"] + let pathToEntry path = do epochtime <- floor `fmap` getPOSIXTime + contents <- (BL.fromChunks . (:[])) `fmap` + readDataFile ("odt/" ++ path) + return $ toEntry path epochtime contents + datadir <- getUserDataDir + mbArchive <- case datadir of + Nothing -> return Nothing + Just d -> do + exists <- fileExists (d "reference.odt") + if exists + then return (Just (d "reference.odt")) + else return Nothing + case mbArchive of + Just arch -> toArchive <$> readFileLazy arch + Nothing -> foldr addEntryToArchive emptyArchive <$> + mapM pathToEntry paths + +-- | Retrieve default reference.pptx. +getDefaultReferencePptx :: PandocMonad m => m Archive +getDefaultReferencePptx = do + -- We're going to narrow this down substantially once we get it + -- working. + let paths = [ "[Content_Types].xml" + , "_rels/.rels" + , "docProps/app.xml" + , "docProps/core.xml" + , "ppt/_rels/presentation.xml.rels" + , "ppt/presProps.xml" + , "ppt/presentation.xml" + , "ppt/slideLayouts/_rels/slideLayout1.xml.rels" + , "ppt/slideLayouts/_rels/slideLayout2.xml.rels" + , "ppt/slideLayouts/_rels/slideLayout3.xml.rels" + , "ppt/slideLayouts/_rels/slideLayout4.xml.rels" + , "ppt/slideLayouts/_rels/slideLayout5.xml.rels" + , "ppt/slideLayouts/_rels/slideLayout6.xml.rels" + , "ppt/slideLayouts/_rels/slideLayout7.xml.rels" + , "ppt/slideLayouts/_rels/slideLayout8.xml.rels" + , "ppt/slideLayouts/_rels/slideLayout9.xml.rels" + , "ppt/slideLayouts/_rels/slideLayout10.xml.rels" + , "ppt/slideLayouts/_rels/slideLayout11.xml.rels" + , "ppt/slideLayouts/slideLayout1.xml" + , "ppt/slideLayouts/slideLayout10.xml" + , "ppt/slideLayouts/slideLayout11.xml" + , "ppt/slideLayouts/slideLayout2.xml" + , "ppt/slideLayouts/slideLayout3.xml" + , "ppt/slideLayouts/slideLayout4.xml" + , "ppt/slideLayouts/slideLayout5.xml" + , "ppt/slideLayouts/slideLayout6.xml" + , "ppt/slideLayouts/slideLayout7.xml" + , "ppt/slideLayouts/slideLayout8.xml" + , "ppt/slideLayouts/slideLayout9.xml" + , "ppt/slideMasters/_rels/slideMaster1.xml.rels" + , "ppt/slideMasters/slideMaster1.xml" + , "ppt/slides/_rels/slide1.xml.rels" + , "ppt/slides/slide1.xml" + , "ppt/slides/_rels/slide2.xml.rels" + , "ppt/slides/slide2.xml" + , "ppt/slides/_rels/slide3.xml.rels" + , "ppt/slides/slide3.xml" + , "ppt/slides/_rels/slide4.xml.rels" + , "ppt/slides/slide4.xml" + , "ppt/tableStyles.xml" + , "ppt/theme/theme1.xml" + , "ppt/viewProps.xml" + -- These relate to notes slides. + , "ppt/notesMasters/notesMaster1.xml" + , "ppt/notesMasters/_rels/notesMaster1.xml.rels" + , "ppt/notesSlides/notesSlide1.xml" + , "ppt/notesSlides/_rels/notesSlide1.xml.rels" + , "ppt/notesSlides/notesSlide2.xml" + , "ppt/notesSlides/_rels/notesSlide2.xml.rels" + , "ppt/theme/theme2.xml" + ] + let toLazy = BL.fromChunks . (:[]) + let pathToEntry path = do + epochtime <- floor <$> getPOSIXTime + contents <- toLazy <$> readDataFile ("pptx/" ++ path) + return $ toEntry path epochtime contents + datadir <- getUserDataDir + mbArchive <- case datadir of + Nothing -> return Nothing + Just d -> do + exists <- fileExists (d "reference.pptx") + if exists + then return (Just (d "reference.pptx")) + else return Nothing + case mbArchive of + Just arch -> toArchive <$> readFileLazy arch + Nothing -> foldr addEntryToArchive emptyArchive <$> + mapM pathToEntry paths + +getDataFileNames :: IO [FilePath] +getDataFileNames = do +#ifdef EMBED_DATA_FILES + let allDataFiles = map fst dataFiles +#else + allDataFiles <- filter (\x -> x /= "." && x /= "..") <$> + (getDataDir >>= getDirectoryContents) +#endif + return $ "reference.docx" : "reference.odt" : "reference.pptx" : allDataFiles + +-- | Return appropriate user data directory for platform. We use +-- XDG_DATA_HOME (or its default value), but for backwards compatibility, +-- we fall back to the legacy user data directory ($HOME/.pandoc on *nix) +-- if the XDG_DATA_HOME is missing and this exists. If neither directory +-- is present, we return the XDG data directory. If the XDG data directory +-- is not defined (e.g. because we are in an environment where $HOME is +-- not defined), we return the empty string. +defaultUserDataDir :: IO FilePath +defaultUserDataDir = do + xdgDir <- E.catch (getXdgDirectory XdgData "pandoc") + (\(_ :: E.SomeException) -> return mempty) + legacyDir <- getAppUserDataDirectory "pandoc" + xdgExists <- doesDirectoryExist xdgDir + legacyDirExists <- doesDirectoryExist legacyDir + if not xdgExists && legacyDirExists + then return legacyDir + else return xdgDir diff --git a/src/Text/Pandoc/Data/BakedIn.hs b/src/Text/Pandoc/Data/BakedIn.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/Data/BakedIn.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE TemplateHaskell #-} +{- | +Module : Text.Pandoc.Data.BakedIn +Copyright : Copyright (C) 2013-2023 John MacFarlane +License : GNU GPL, version 2 or above + +Maintainer : John MacFarlane +Stability : alpha +Portability : portable + +Provide contents data files as Haskell values. +-} +module Text.Pandoc.Data.BakedIn (dataFiles) where + +import qualified Data.ByteString as B +import Data.FileEmbed +import System.FilePath (splitDirectories) +import qualified System.FilePath.Posix as Posix + +-- We ensure that the data files are stored using Posix +-- path separators (/), even on Windows. +dataFiles :: [(FilePath, B.ByteString)] +dataFiles = map (\(fp, contents) -> + (Posix.joinPath (splitDirectories fp), contents)) dataFiles' + +dataFiles' :: [(FilePath, B.ByteString)] +dataFiles' = ("MANUAL.txt", $(embedFile "MANUAL.txt")) : + -- handle the hidden file separately, since embedDir doesn't + -- include it: + ("docx/_rels/.rels", $(embedFile "data/docx/_rels/.rels")) : + ("pptx/_rels/.rels", $(embedFile "data/pptx/_rels/.rels")) : + $(embedDir "data") diff --git a/src/Text/Pandoc/Error.hs b/src/Text/Pandoc/Error.hs --- a/src/Text/Pandoc/Error.hs +++ b/src/Text/Pandoc/Error.hs @@ -3,7 +3,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Error - Copyright : Copyright (C) 2006-2022 John MacFarlane + Copyright : Copyright (C) 2006-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane @@ -23,18 +23,13 @@ import Data.Typeable (Typeable) import Data.Word (Word8) import Data.Text (Text) -import Data.List (sortOn) import qualified Data.Text as T -import Data.Ord (Down(..)) import GHC.Generics (Generic) import Network.HTTP.Client (HttpException) import System.Exit (ExitCode (..), exitWith) import System.IO (stderr) import qualified Text.Pandoc.UTF8 as UTF8 -import Text.Pandoc.Sources (Sources(..)) import Text.Printf (printf) -import Text.Parsec.Error -import Text.Parsec.Pos hiding (Line) import Text.Pandoc.Shared (tshow) import Citeproc (CiteprocError, prettyCiteprocError) @@ -43,7 +38,6 @@ | PandocShouldNeverHappenError Text | PandocSomeError Text | PandocParseError Text - | PandocParsecError Sources ParseError | PandocMakePDFError Text | PandocOptionError Text | PandocSyntaxMapError Text @@ -53,16 +47,19 @@ | PandocXMLError Text Text | PandocFilterError Text Text | PandocLuaError Text + | PandocNoScriptingEngine | PandocCouldNotFindDataFileError Text | PandocCouldNotFindMetadataFileError Text | PandocResourceNotFound Text | PandocTemplateError Text + | PandocNoTemplateError Text | PandocAppError Text | PandocEpubSubdirectoryError Text | PandocMacroLoop Text | PandocUTF8DecodingError Text Int Word8 | PandocIpynbDecodingError Text | PandocUnsupportedCharsetError Text + | PandocFormatError Text Text | PandocUnknownReaderError Text | PandocUnknownWriterError Text | PandocUnsupportedExtensionError Text Text @@ -83,28 +80,6 @@ "Please report this to pandoc's developers: " <> s PandocSomeError s -> s PandocParseError s -> s - PandocParsecError (Sources inputs) err' -> - let errPos = errorPos err' - errLine = sourceLine errPos - errColumn = sourceColumn errPos - errFile = sourceName errPos - errorInFile = - case sortOn (Down . sourceLine . fst) - [ (pos,t) - | (pos,t) <- inputs - , sourceName pos == errFile - , sourceLine pos <= errLine - ] of - [] -> "" - ((pos,txt):_) -> - let ls = T.lines txt <> [""] - ln = (errLine - sourceLine pos) + 1 - in if length ls > ln && ln >= 1 - then T.concat ["\n", ls !! (ln - 1) - ,"\n", T.replicate (errColumn - 1) " " - ,"^"] - else "" - in "Error at " <> tshow err' <> errorInFile PandocMakePDFError s -> s PandocOptionError s -> s PandocSyntaxMapError s -> s @@ -117,6 +92,8 @@ PandocFilterError filtername msg -> "Error running filter " <> filtername <> ":\n" <> msg PandocLuaError msg -> "Error running Lua:\n" <> msg + PandocNoScriptingEngine -> "This version of pandoc has been compiled " <> + "without Lua support." PandocCouldNotFindDataFileError fn -> "Could not find data file " <> fn PandocCouldNotFindMetadataFileError fn -> @@ -124,6 +101,7 @@ PandocResourceNotFound fn -> "File " <> fn <> " not found in resource path" PandocTemplateError s -> "Error compiling template " <> s + PandocNoTemplateError fp -> "No template defined in " <> fp PandocAppError s -> s PandocEpubSubdirectoryError s -> "EPUB subdirectory name '" <> s <> "' contains illegal characters" @@ -137,6 +115,8 @@ "ipynb decoding error: " <> w PandocUnsupportedCharsetError charset -> "Unsupported charset " <> charset + PandocFormatError format s -> + "Error parsing format " <> tshow format <> ": " <> s PandocUnknownReaderError r -> "Unknown input format " <> r <> case r of @@ -178,6 +158,7 @@ PandocAppError{} -> 4 PandocTemplateError{} -> 5 PandocOptionError{} -> 6 + PandocFormatError{} -> 20 PandocUnknownReaderError{} -> 21 PandocUnknownWriterError{} -> 22 PandocUnsupportedExtensionError{} -> 23 @@ -191,11 +172,12 @@ PandocShouldNeverHappenError{} -> 62 PandocSomeError{} -> 63 PandocParseError{} -> 64 - PandocParsecError{} -> 65 PandocMakePDFError{} -> 66 PandocSyntaxMapError{} -> 67 PandocFilterError{} -> 83 PandocLuaError{} -> 84 + PandocNoTemplateError{} -> 87 + PandocNoScriptingEngine -> 89 PandocMacroLoop{} -> 91 PandocUTF8DecodingError{} -> 92 PandocIpynbDecodingError{} -> 93 diff --git a/src/Text/Pandoc/Extensions.hs b/src/Text/Pandoc/Extensions.hs --- a/src/Text/Pandoc/Extensions.hs +++ b/src/Text/Pandoc/Extensions.hs @@ -1,12 +1,10 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Extensions - Copyright : Copyright (C) 2012-2022 John MacFarlane + Copyright : Copyright (C) 2012-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane @@ -16,13 +14,16 @@ Data structures and functions for representing markup extensions. -} module Text.Pandoc.Extensions ( Extension(..) + , readExtension + , showExtension , Extensions , emptyExtensions , extensionsFromList - , parseFormatSpec + , extensionsToList , extensionEnabled , enableExtension , disableExtension + , disableExtensions , getDefaultExtensions , getAllExtensions , pandocExtensions @@ -32,16 +33,14 @@ , githubMarkdownExtensions , multimarkdownExtensions ) where -import Data.Bits (clearBit, setBit, testBit, (.|.)) import Data.Data (Data) -import Data.List (foldl') import qualified Data.Text as T import Data.Typeable (Typeable) import GHC.Generics (Generic) -import Safe (readMay) -import Text.Parsec -import Data.Aeson.TH (deriveJSON) +import Text.Read (readMaybe) import Data.Aeson +import Data.List (sort) +import qualified Data.Set as Set -- | Individually selectable syntax extensions. data Extension = @@ -97,6 +96,7 @@ | Ext_link_attributes -- ^ link and image attributes | Ext_lists_without_preceding_blankline -- ^ Allow lists without preceding blank | Ext_literate_haskell -- ^ Enable literate Haskell conventions + | Ext_mark -- ^ Enable ==mark== syntax to highlight text | Ext_markdown_attribute -- ^ Interpret text inside HTML as markdown iff -- container has attribute 'markdown' | Ext_markdown_in_html_blocks -- ^ Interpret as markdown inside HTML blocks @@ -129,50 +129,84 @@ | Ext_subscript -- ^ Subscript using ~this~ syntax | Ext_superscript -- ^ Superscript using ^this^ syntax | Ext_styles -- ^ Read styles that pandoc doesn't know + | Ext_tagging -- ^ Output optimized for PDF tagging | Ext_task_lists -- ^ Parse certain list items as task list items | Ext_table_captions -- ^ Pandoc-style table captions | Ext_tex_math_dollars -- ^ TeX math between $..$ or $$..$$ | Ext_tex_math_double_backslash -- ^ TeX math btw \\(..\\) \\[..\\] | Ext_tex_math_single_backslash -- ^ TeX math btw \(..\) \[..\] + | Ext_wikilinks_title_after_pipe -- ^ Support wikilinks of style + -- [[target|title]] + | Ext_wikilinks_title_before_pipe -- ^ Support wikilinks of style + -- [[title|target]] | Ext_xrefs_name -- ^ Use xrefs with names | Ext_xrefs_number -- ^ Use xrefs with numbers | Ext_yaml_metadata_block -- ^ YAML metadata block - deriving (Show, Read, Enum, Eq, Ord, Bounded, Data, Typeable, Generic) + | CustomExtension T.Text -- ^ Custom extension + deriving (Show, Read, Eq, Ord, Data, Typeable, Generic) -$(deriveJSON defaultOptions{ constructorTagModifier = drop 4 } ''Extension) +instance FromJSON Extension where + parseJSON = withText "Extension" (pure . readExtension . T.unpack) -newtype Extensions = Extensions Integer +instance ToJSON Extension where + toJSON = String . showExtension + +newtype Extensions = Extensions (Set.Set Extension) deriving (Show, Read, Eq, Ord, Data, Typeable, Generic) instance Semigroup Extensions where - (Extensions a) <> (Extensions b) = Extensions (a .|. b) + (Extensions a) <> (Extensions b) = Extensions (a <> b) instance Monoid Extensions where - mempty = Extensions 0 + mempty = Extensions mempty mappend = (<>) instance FromJSON Extensions where - parseJSON = - return . foldr enableExtension emptyExtensions . fromJSON + parseJSON = fmap extensionsFromList . parseJSON instance ToJSON Extensions where - toJSON exts = toJSON $ - [ext | ext <- [minBound..maxBound], extensionEnabled ext exts] + toJSON (Extensions exts) = toJSON exts +-- | Reads a single extension from a string. +readExtension :: String -> Extension +readExtension "lhs" = Ext_literate_haskell +readExtension name = + case readMaybe ("Ext_" ++ name) of + Just ext -> ext + Nothing -> CustomExtension (T.pack name) + +-- | Show an extension in human-readable form. +showExtension :: Extension -> T.Text +showExtension ext = + case ext of + CustomExtension t -> t + _ -> T.drop 4 $ T.pack $ show ext + extensionsFromList :: [Extension] -> Extensions -extensionsFromList = foldr enableExtension emptyExtensions +extensionsFromList = Extensions . Set.fromList +extensionsToList :: Extensions -> [Extension] +extensionsToList (Extensions extset) = sort $ Set.toList extset + emptyExtensions :: Extensions -emptyExtensions = Extensions 0 +emptyExtensions = Extensions mempty extensionEnabled :: Extension -> Extensions -> Bool -extensionEnabled x (Extensions exts) = testBit exts (fromEnum x) +extensionEnabled x (Extensions exts) = x `Set.member` exts enableExtension :: Extension -> Extensions -> Extensions -enableExtension x (Extensions exts) = Extensions (setBit exts (fromEnum x)) +enableExtension x (Extensions exts) = Extensions (Set.insert x exts) disableExtension :: Extension -> Extensions -> Extensions -disableExtension x (Extensions exts) = Extensions (clearBit exts (fromEnum x)) +disableExtension x (Extensions exts) = Extensions (Set.delete x exts) +-- | Removes the extensions in the second set from those in the first. +disableExtensions :: Extensions -- ^ base set + -> Extensions -- ^ extensions to remove + -> Extensions +disableExtensions (Extensions base) (Extensions remove) = Extensions $ + -- keep only those extensions that are in `base` but not in `remove`. + base `Set.difference` remove + -- | Extensions to be used with pandoc-flavored markdown. pandocExtensions :: Extensions pandocExtensions = extensionsFromList @@ -466,6 +500,7 @@ , Ext_mmd_title_block , Ext_abbreviations , Ext_autolink_bare_uris + , Ext_mark , Ext_mmd_link_attributes , Ext_mmd_header_identifiers , Ext_compact_definition_lists @@ -474,6 +509,8 @@ , Ext_literate_haskell , Ext_short_subsuperscripts , Ext_rebase_relative_paths + , Ext_wikilinks_title_after_pipe + , Ext_wikilinks_title_before_pipe ] getAll "markdown_strict" = allMarkdownExtensions getAll "markdown_phpextra" = allMarkdownExtensions @@ -526,6 +563,8 @@ , Ext_implicit_header_references , Ext_attributes , Ext_sourcepos + , Ext_wikilinks_title_after_pipe + , Ext_wikilinks_title_before_pipe , Ext_yaml_metadata_block , Ext_rebase_relative_paths ] @@ -572,6 +611,7 @@ [ Ext_smart , Ext_raw_tex , Ext_ntb + , Ext_tagging ] getAll "textile" = autoIdExtensions <> extensionsFromList @@ -605,30 +645,3 @@ extensionsFromList [ Ext_smart ] getAll _ = mempty - - --- | Parse a format-specifying string into a markup format, --- a set of extensions to enable, and a set of extensions to disable. -parseFormatSpec :: T.Text - -> Either ParseError (T.Text, [Extension], [Extension]) -parseFormatSpec = parse formatSpec "" - where formatSpec = do - name <- formatName - (extsToEnable, extsToDisable) <- foldl' (flip ($)) ([],[]) <$> - many extMod - return (T.pack name, reverse extsToEnable, reverse extsToDisable) - formatName = many1 $ noneOf "-+" - extMod = do - polarity <- oneOf "-+" - name <- many $ noneOf "-+" - ext <- case readMay ("Ext_" ++ name) of - Just n -> return n - Nothing - | name == "lhs" -> return Ext_literate_haskell - | otherwise -> unexpected $ - "unknown extension: " ++ name - return $ \(extsToEnable, extsToDisable) -> - case polarity of - '+' -> (ext : extsToEnable, extsToDisable) - _ -> (extsToEnable, ext : extsToDisable) - diff --git a/src/Text/Pandoc/Filter.hs b/src/Text/Pandoc/Filter.hs --- a/src/Text/Pandoc/Filter.hs +++ b/src/Text/Pandoc/Filter.hs @@ -3,7 +3,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Filter - Copyright : Copyright (C) 2006-2022 John MacFarlane + Copyright : Copyright (C) 2006-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane @@ -16,6 +16,7 @@ ( Filter (..) , Environment (..) , applyFilters + , applyJSONFilter ) where import System.CPUTime (getCPUTime) @@ -28,8 +29,8 @@ import Text.Pandoc.Filter.Environment (Environment (..)) import Text.Pandoc.Logging import Text.Pandoc.Citeproc (processCitations) +import Text.Pandoc.Scripting (ScriptingEngine (engineApplyFilter)) import qualified Text.Pandoc.Filter.JSON as JSONFilter -import qualified Text.Pandoc.Filter.Lua as LuaFilter import qualified Data.Text as T import System.FilePath (takeExtension) import Control.Applicative ((<|>)) @@ -73,21 +74,22 @@ -- | Modify the given document using a filter. applyFilters :: (PandocMonad m, MonadIO m) - => Environment + => ScriptingEngine + -> Environment -> [Filter] -> [String] -> Pandoc -> m Pandoc -applyFilters fenv filters args d = do +applyFilters scrngin fenv filters args d = do expandedFilters <- mapM expandFilterPath filters foldM applyFilter d expandedFilters where applyFilter doc (JSONFilter f) = withMessages f $ JSONFilter.apply fenv args f doc applyFilter doc (LuaFilter f) = - withMessages f $ LuaFilter.apply fenv args f doc + withMessages f $ engineApplyFilter scrngin fenv args f doc applyFilter doc CiteprocFilter = - processCitations doc + withMessages "citeproc" $ processCitations doc withMessages f action = do verbosity <- getVerbosity when (verbosity == INFO) $ report $ RunningFilter f @@ -106,3 +108,11 @@ filterPath :: PandocMonad m => FilePath -> m FilePath filterPath fp = fromMaybe fp <$> findFileWithDataFallback "filters" fp + +applyJSONFilter :: MonadIO m + => Environment + -> [String] + -> FilePath + -> Pandoc + -> m Pandoc +applyJSONFilter = JSONFilter.apply diff --git a/src/Text/Pandoc/Filter/JSON.hs b/src/Text/Pandoc/Filter/JSON.hs --- a/src/Text/Pandoc/Filter/JSON.hs +++ b/src/Text/Pandoc/Filter/JSON.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Filter - Copyright : Copyright (C) 2006-2022 John MacFarlane + Copyright : Copyright (C) 2006-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane @@ -27,7 +27,8 @@ import Text.Pandoc.Error (PandocError (PandocFilterError)) import Text.Pandoc.Filter.Environment (Environment (..)) import Text.Pandoc.Process (pipeProcess) -import Text.Pandoc.Shared (pandocVersion, tshow) +import Text.Pandoc.Version (pandocVersionText) +import Text.Pandoc.Shared (tshow) import qualified Control.Exception as E import qualified Text.Pandoc.UTF8 as UTF8 @@ -65,7 +66,7 @@ let ropts = envReaderOptions fenv env <- getEnvironment let env' = Just - ( ("PANDOC_VERSION", T.unpack pandocVersion) + ( ("PANDOC_VERSION", T.unpack pandocVersionText) : ("PANDOC_READER_OPTIONS", UTF8.toStringLazy (encode ropts)) : env ) (exitcode, outbs) <- E.handle filterException $ diff --git a/src/Text/Pandoc/Filter/Lua.hs b/src/Text/Pandoc/Filter/Lua.hs deleted file mode 100644 --- a/src/Text/Pandoc/Filter/Lua.hs +++ /dev/null @@ -1,51 +0,0 @@ -{- | - Module : Text.Pandoc.Filter.Lua - Copyright : Copyright (C) 2006-2022 John MacFarlane - License : GNU GPL, version 2 or above - - Maintainer : John MacFarlane - Stability : alpha - Portability : portable - -Apply Lua filters to modify a pandoc documents programmatically. --} -module Text.Pandoc.Filter.Lua (apply) where - -import Control.Exception (throw) -import Control.Monad ((>=>)) -import qualified Data.Text as T -import Text.Pandoc.Class (PandocMonad) -import Control.Monad.Trans (MonadIO) -import Text.Pandoc.Definition (Pandoc) -import Text.Pandoc.Error (PandocError (PandocFilterError, PandocLuaError)) -import Text.Pandoc.Filter.Environment (Environment (..)) -import Text.Pandoc.Lua (Global (..), runLua, runFilterFile, setGlobals) - --- | Run the Lua filter in @filterPath@ for a transformation to the --- target format (first element in args). Pandoc uses Lua init files to --- setup the Lua interpreter. -apply :: (PandocMonad m, MonadIO m) - => Environment - -> [String] - -> FilePath - -> Pandoc - -> m Pandoc -apply fenv args fp doc = do - let format = case args of - (x:_) -> x - _ -> error "Format not supplied for Lua filter" - runLua >=> forceResult fp $ do - setGlobals [ FORMAT $ T.pack format - , PANDOC_READER_OPTIONS (envReaderOptions fenv) - , PANDOC_WRITER_OPTIONS (envWriterOptions fenv) - , PANDOC_SCRIPT_FILE fp - ] - runFilterFile fp doc - -forceResult :: (PandocMonad m, MonadIO m) - => FilePath -> Either PandocError Pandoc -> m Pandoc -forceResult fp eitherResult = case eitherResult of - Right x -> return x - Left err -> throw . PandocFilterError (T.pack fp) $ case err of - PandocLuaError msg -> msg - _ -> T.pack $ show err diff --git a/src/Text/Pandoc/Format.hs b/src/Text/Pandoc/Format.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/Format.hs @@ -0,0 +1,150 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{- | + Module : Text.Pandoc.Format + Copyright : © 2022-2023 Albert Krewinkel + License : GPL-2.0-or-later + Maintainer : Albert Krewinkel + +Handling of format specifiers for input and output. +-} +module Text.Pandoc.Format + ( FlavoredFormat (..) + , ExtensionsConfig (..) + , ExtensionsDiff (..) + , diffExtensions + , parseFlavoredFormat + , applyExtensionsDiff + , getExtensionsConfig + ) where + +import Control.Monad.Except (throwError) +import Data.List (foldl') +import System.FilePath (splitExtension) +import Text.Pandoc.Class (PandocMonad) +import Text.Pandoc.Error (PandocError (..)) +import Text.Pandoc.Extensions + ( Extensions + , disableExtensions + , enableExtension + , extensionsToList + , getAllExtensions + , getDefaultExtensions + , showExtension + , readExtension + ) +import Text.Pandoc.Parsing +import qualified Data.Text as T + +-- | Format specifier with the format's name and the lists of extensions +-- to be enabled or disabled. +data FlavoredFormat = FlavoredFormat + { formatName :: T.Text + , formatExtsDiff :: ExtensionsDiff + } deriving (Show) + +-- | Changes to a set of extensions, i.e., list of extensions to be +-- enabled or disabled. +data ExtensionsDiff = ExtensionsDiff + { extsToEnable :: Extensions + , extsToDisable :: Extensions + } deriving (Show) + +instance Semigroup ExtensionsDiff where + ExtensionsDiff enA disA <> ExtensionsDiff enB disB = + ExtensionsDiff + ((enA `disableExtensions` disB) <> enB) + ((disA `disableExtensions` enB) <> disB) + +instance Monoid ExtensionsDiff where + mempty = ExtensionsDiff mempty mempty + mappend = (<>) + +-- | Calculate the change set to get from one set of extensions to +-- another. +diffExtensions :: Extensions -> Extensions -> ExtensionsDiff +diffExtensions def actual = ExtensionsDiff + { extsToEnable = actual `disableExtensions` def + , extsToDisable = def `disableExtensions` actual + } + +-- | Describes the properties of a format. +data ExtensionsConfig = ExtensionsConfig + { extsDefault :: Extensions -- ^ Extensions enabled by default + , extsSupported :: Extensions -- ^ Extensions that can be enabled or disabled. + } deriving (Show) + +-- | Returns the extensions configuration of a format. +getExtensionsConfig :: T.Text -> ExtensionsConfig +getExtensionsConfig fmt = ExtensionsConfig + { extsDefault = getDefaultExtensions fmt + , extsSupported = getAllExtensions fmt + } + +instance Semigroup ExtensionsConfig where + ExtensionsConfig x1 y1 <> ExtensionsConfig x2 y2 = + ExtensionsConfig (x1 <> x2) (y1 <> y2) + +instance Monoid ExtensionsConfig where + mappend = (<>) + mempty = ExtensionsConfig mempty mempty + +-- | Apply the extension changes in the format spec to the extensions +-- given in the format's extensions configuration. Throws an error in +-- case of an unknown or unsupported extension. +applyExtensionsDiff :: PandocMonad m + => ExtensionsConfig + -> FlavoredFormat + -> m Extensions +applyExtensionsDiff extConf (FlavoredFormat fname extsDiff) = do + let extsInDiff = extsToEnable extsDiff <> extsToDisable extsDiff + let unsupported = extsInDiff `disableExtensions` (extsSupported extConf) + case extensionsToList unsupported of + ext:_ -> throwError $ PandocUnsupportedExtensionError + (showExtension ext) fname + [] -> pure ((extsDefault extConf `disableExtensions` + extsToDisable extsDiff) <> extsToEnable extsDiff) + +-- | Parse a format-specifying string into a markup format and the +-- change set to the format's extensions. Throws an error if the spec +-- cannot be parsed or contains an unknown extension. +parseFlavoredFormat :: PandocMonad m + => T.Text + -> m FlavoredFormat +parseFlavoredFormat spec = + -- Paths like `latex-foo-bar.lua` or `latex-smart-citations.lua` + -- should be parsed as the format name. The `-` (or `+`) in the + -- filename would confuse the extensions parser, so, if `spec` looks + -- like a filename, the file's basename is split off into the prefix. + -- Only the remaining part is parsed, and the prefix is appended back + -- to the format after parsing. + case parse (fixSourcePos *> formatSpec) "" spec' of + Right (fname, extsDiff) -> pure (FlavoredFormat (prefix <> fname) extsDiff) + Left err -> throwError $ PandocFormatError spec (T.pack $ show err) + where + fixSourcePos = do + pos <- getPosition + setPosition (incSourceColumn pos (T.length prefix)) + formatSpec = do + name <- parseFormatName + extsDiff <- pExtensionsDiff + return ( T.pack name, extsDiff ) + parseFormatName = many1 $ noneOf "-+" + (prefix, spec') = case splitExtension (T.unpack spec) of + (_, "") -> ("", T.toLower spec) -- no extension + (p,s) -> (T.pack p, T.pack s) + +pExtensionsDiff :: (UpdateSourcePos s Char, Stream s m Char) + => ParsecT s u m ExtensionsDiff +pExtensionsDiff = foldl' (flip ($)) mempty <$> many extMod + where + extMod = do + polarity <- oneOf "-+" + name <- many $ noneOf "-+" + let ext = readExtension name + return $ \extsDiff -> + case polarity of + '+' -> extsDiff{extsToEnable = enableExtension ext $ + extsToEnable extsDiff} + _ -> extsDiff{extsToDisable = enableExtension ext $ + extsToDisable extsDiff} diff --git a/src/Text/Pandoc/Highlighting.hs b/src/Text/Pandoc/Highlighting.hs --- a/src/Text/Pandoc/Highlighting.hs +++ b/src/Text/Pandoc/Highlighting.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Highlighting - Copyright : Copyright (C) 2008-2022 John MacFarlane + Copyright : Copyright (C) 2008-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane @@ -15,12 +15,21 @@ , languages , languagesByExtension , highlight + -- * Formats + -- ** LaTeX , formatLaTeXInline , formatLaTeXBlock , styleToLaTeX + -- ** HTML , formatHtmlInline , formatHtmlBlock + , formatHtml4Block , styleToCss + -- ** ConTeXt + , formatConTeXtInline + , formatConTeXtBlock + , styleToConTeXt + -- * Styles , pygments , espresso , zenburn @@ -236,4 +245,3 @@ Just sty -> return sty Nothing -> throwError $ PandocOptionError $ T.pack $ "Unknown highlight-style " ++ s - diff --git a/src/Text/Pandoc/Image.hs b/src/Text/Pandoc/Image.hs --- a/src/Text/Pandoc/Image.hs +++ b/src/Text/Pandoc/Image.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings, ScopedTypeVariables, CPP #-} {- | Module : Text.Pandoc.Image -Copyright : Copyright (C) 2020-2022 John MacFarlane +Copyright : Copyright (C) 2020-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane diff --git a/src/Text/Pandoc/ImageSize.hs b/src/Text/Pandoc/ImageSize.hs --- a/src/Text/Pandoc/ImageSize.hs +++ b/src/Text/Pandoc/ImageSize.hs @@ -3,7 +3,7 @@ {-# OPTIONS_GHC -fno-warn-type-defaults #-} {- | Module : Text.Pandoc.ImageSize -Copyright : Copyright (C) 2011-2022 John MacFarlane +Copyright : Copyright (C) 2011-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane diff --git a/src/Text/Pandoc/Logging.hs b/src/Text/Pandoc/Logging.hs --- a/src/Text/Pandoc/Logging.hs +++ b/src/Text/Pandoc/Logging.hs @@ -3,7 +3,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Logging - Copyright : Copyright (C) 2006-2022 John MacFarlane + Copyright : Copyright (C) 2006-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane diff --git a/src/Text/Pandoc/Lua.hs b/src/Text/Pandoc/Lua.hs deleted file mode 100644 --- a/src/Text/Pandoc/Lua.hs +++ /dev/null @@ -1,23 +0,0 @@ -{- | - Module : Text.Pandoc.Lua - Copyright : Copyright © 2017-2022 Albert Krewinkel - License : GNU GPL, version 2 or above - - Maintainer : Albert Krewinkel - Stability : alpha - -Running pandoc Lua filters. --} -module Text.Pandoc.Lua - ( runLua - -- * Lua globals - , Global (..) - , setGlobals - -- * Filters - , runFilterFile - ) where - -import Text.Pandoc.Lua.Filter (runFilterFile) -import Text.Pandoc.Lua.Global (Global (..), setGlobals) -import Text.Pandoc.Lua.Init (runLua) -import Text.Pandoc.Lua.Orphans () diff --git a/src/Text/Pandoc/Lua/ErrorConversion.hs b/src/Text/Pandoc/Lua/ErrorConversion.hs deleted file mode 100644 --- a/src/Text/Pandoc/Lua/ErrorConversion.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -{- | - Module : Text.Pandoc.Lua.ErrorConversion - Copyright : © 2020-2022 Albert Krewinkel - License : GNU GPL, version 2 or above - - Maintainer : Albert Krewinkel - Stability : alpha - -Define how Lua errors are converted into @'PandocError'@ Haskell -exceptions, and /vice versa/. --} -module Text.Pandoc.Lua.ErrorConversion - ( addContextToException - ) where - -import HsLua (LuaError, LuaE, resultToEither, runPeek, top) -import Text.Pandoc.Error (PandocError (PandocLuaError)) -import Text.Pandoc.Lua.Marshal.PandocError (pushPandocError, peekPandocError) - -import qualified Data.Text as T -import qualified HsLua as Lua - -addContextToException :: () -addContextToException = undefined - --- | Retrieve a @'PandocError'@ from the Lua stack. -popPandocError :: LuaE PandocError PandocError -popPandocError = do - errResult <- runPeek $ peekPandocError top - case resultToEither errResult of - Right x -> return x - Left err -> return $ PandocLuaError (T.pack err) - --- Ensure conversions between Lua errors and 'PandocError' exceptions --- are possible. -instance LuaError PandocError where - popException = popPandocError - pushException = pushPandocError - luaException = PandocLuaError . T.pack diff --git a/src/Text/Pandoc/Lua/Filter.hs b/src/Text/Pandoc/Lua/Filter.hs deleted file mode 100644 --- a/src/Text/Pandoc/Lua/Filter.hs +++ /dev/null @@ -1,46 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE IncoherentInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{- | -Module : Text.Pandoc.Lua.Filter -Copyright : © 2012-2022 John MacFarlane, - © 2017-2022 Albert Krewinkel -License : GNU GPL, version 2 or above -Maintainer : Albert Krewinkel -Stability : alpha - -Types and functions for running Lua filters. --} -module Text.Pandoc.Lua.Filter - ( runFilterFile - ) where -import Control.Monad ((>=>), (<$!>)) -import HsLua as Lua -import Text.Pandoc.Definition -import Text.Pandoc.Error (PandocError) -import Text.Pandoc.Lua.ErrorConversion () -import Text.Pandoc.Lua.Marshal.AST -import Text.Pandoc.Lua.Marshal.Filter - - --- | Transform document using the filter defined in the given file. -runFilterFile :: FilePath -> Pandoc -> LuaE PandocError Pandoc -runFilterFile filterPath doc = do - oldtop <- gettop - stat <- dofileTrace filterPath - if stat /= Lua.OK - then throwErrorAsException - else do - newtop <- gettop - -- Use the returned filters, or the implicitly defined global - -- filter if nothing was returned. - luaFilters <- forcePeek $ - if newtop - oldtop >= 1 - then peekList peekFilter top - else (:[]) <$!> (liftLua pushglobaltable *> peekFilter top) - settop oldtop - runAll luaFilters doc - -runAll :: [Filter] -> Pandoc -> LuaE PandocError Pandoc -runAll = foldr ((>=>) . applyFully) return diff --git a/src/Text/Pandoc/Lua/Global.hs b/src/Text/Pandoc/Lua/Global.hs deleted file mode 100644 --- a/src/Text/Pandoc/Lua/Global.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{- | - Module : Text.Pandoc.Lua - Copyright : Copyright © 2017-2022 Albert Krewinkel - License : GNU GPL, version 2 or above - - Maintainer : Albert Krewinkel - Stability : alpha - -Pandoc's Lua globals. --} -module Text.Pandoc.Lua.Global - ( Global (..) - , setGlobals - ) where - -import HsLua as Lua -import HsLua.Module.Version (pushVersion) -import Paths_pandoc (version) -import Text.Pandoc.Class.CommonState (CommonState) -import Text.Pandoc.Definition (Pandoc, pandocTypesVersion) -import Text.Pandoc.Error (PandocError) -import Text.Pandoc.Lua.Marshal.CommonState (pushCommonState) -import Text.Pandoc.Lua.Marshal.Pandoc (pushPandoc) -import Text.Pandoc.Lua.Marshal.ReaderOptions (pushReaderOptionsReadonly) -import Text.Pandoc.Lua.Marshal.WriterOptions (pushWriterOptions) -import Text.Pandoc.Lua.Orphans () -import Text.Pandoc.Options (ReaderOptions, WriterOptions) - -import qualified Data.Text as Text - --- | Permissible global Lua variables. -data Global = - FORMAT Text.Text - | PANDOC_API_VERSION - | PANDOC_DOCUMENT Pandoc - | PANDOC_READER_OPTIONS ReaderOptions - | PANDOC_WRITER_OPTIONS WriterOptions - | PANDOC_SCRIPT_FILE FilePath - | PANDOC_STATE CommonState - | PANDOC_VERSION - -- Cannot derive instance of Data because of CommonState - --- | Set all given globals. -setGlobals :: [Global] -> LuaE PandocError () -setGlobals = mapM_ setGlobal - -setGlobal :: Global -> LuaE PandocError () -setGlobal global = case global of - -- This could be simplified if Global was an instance of Data. - FORMAT format -> do - Lua.pushText format - Lua.setglobal "FORMAT" - PANDOC_API_VERSION -> do - pushVersion pandocTypesVersion - Lua.setglobal "PANDOC_API_VERSION" - PANDOC_DOCUMENT doc -> do - pushPandoc doc - Lua.setglobal "PANDOC_DOCUMENT" - PANDOC_READER_OPTIONS ropts -> do - pushReaderOptionsReadonly ropts - Lua.setglobal "PANDOC_READER_OPTIONS" - PANDOC_WRITER_OPTIONS wopts -> do - pushWriterOptions wopts - Lua.setglobal "PANDOC_WRITER_OPTIONS" - PANDOC_SCRIPT_FILE filePath -> do - Lua.pushString filePath - Lua.setglobal "PANDOC_SCRIPT_FILE" - PANDOC_STATE commonState -> do - pushCommonState commonState - Lua.setglobal "PANDOC_STATE" - PANDOC_VERSION -> do - pushVersion version - Lua.setglobal "PANDOC_VERSION" diff --git a/src/Text/Pandoc/Lua/Init.hs b/src/Text/Pandoc/Lua/Init.hs deleted file mode 100644 --- a/src/Text/Pandoc/Lua/Init.hs +++ /dev/null @@ -1,153 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{- | - Module : Text.Pandoc.Lua - Copyright : Copyright © 2017-2022 Albert Krewinkel - License : GNU GPL, version 2 or above - - Maintainer : Albert Krewinkel - Stability : alpha - -Functions to initialize the Lua interpreter. --} -module Text.Pandoc.Lua.Init - ( runLua - ) where - -import Control.Monad (forM, forM_, when) -import Control.Monad.Catch (throwM, try) -import Control.Monad.Trans (MonadIO (..)) -import Data.Maybe (catMaybes) -import HsLua as Lua hiding (status, try) -import Text.Pandoc.Class.PandocMonad (PandocMonad, readDataFile) -import Text.Pandoc.Error (PandocError (PandocLuaError)) -import Text.Pandoc.Lua.Marshal.List (newListMetatable, pushListModule) -import Text.Pandoc.Lua.PandocLua (PandocLua, liftPandocLua, runPandocLua) -import qualified Data.ByteString.Char8 as Char8 -import qualified Data.Text as T -import qualified Lua.LPeg as LPeg -import qualified HsLua.Aeson -import qualified HsLua.Module.DocLayout as Module.Layout -import qualified HsLua.Module.Path as Module.Path -import qualified HsLua.Module.Text as Module.Text -import qualified Text.Pandoc.Lua.Module.Pandoc as Module.Pandoc -import qualified Text.Pandoc.Lua.Module.MediaBag as Pandoc.MediaBag -import qualified Text.Pandoc.Lua.Module.System as Pandoc.System -import qualified Text.Pandoc.Lua.Module.Template as Pandoc.Template -import qualified Text.Pandoc.Lua.Module.Types as Pandoc.Types -import qualified Text.Pandoc.Lua.Module.Utils as Pandoc.Utils - --- | Run the lua interpreter, using pandoc's default way of environment --- initialization. -runLua :: (PandocMonad m, MonadIO m) - => LuaE PandocError a -> m (Either PandocError a) -runLua action = - runPandocLua . try $ do - initLuaState - liftPandocLua action - --- | Modules that are loaded at startup and assigned to fields in the --- pandoc module. --- --- Note that @pandoc.List@ is not included here for technical reasons; --- it must be handled separately. -loadedModules :: [Module PandocError] -loadedModules = - [ Pandoc.MediaBag.documentedModule - , Pandoc.System.documentedModule - , Pandoc.Template.documentedModule - , Pandoc.Types.documentedModule - , Pandoc.Utils.documentedModule - , Module.Layout.documentedModule { moduleName = "pandoc.layout" } - , Module.Path.documentedModule { moduleName = "pandoc.path" } - , Module.Text.documentedModule - ] - --- | Initialize the lua state with all required values -initLuaState :: PandocLua () -initLuaState = do - liftPandocLua Lua.openlibs - initJsonMetatable - initPandocModule - installLpegSearcher - setGlobalModules - loadInitScript "init.lua" - where - initPandocModule :: PandocLua () - initPandocModule = liftPandocLua $ do - -- Push module table - registerModule Module.Pandoc.documentedModule - -- load modules and add them to the `pandoc` module table. - forM_ loadedModules $ \mdl -> do - registerModule mdl - let fieldname (Name mdlname) = Name . - maybe mdlname snd . Char8.uncons . snd $ - Char8.break (== '.') mdlname - Lua.setfield (nth 2) (fieldname $ moduleName mdl) - -- pandoc.List is low-level and must be opened differently. - requirehs "pandoc.List" (const pushListModule) - setfield (nth 2) "List" - -- assign module to global variable - Lua.setglobal "pandoc" - - loadInitScript :: FilePath -> PandocLua () - loadInitScript scriptFile = do - script <- readDataFile scriptFile - status <- liftPandocLua $ Lua.dostring script - when (status /= Lua.OK) . liftPandocLua $ do - err <- popException - let prefix = "Couldn't load '" <> T.pack scriptFile <> "':\n" - throwM . PandocLuaError . (prefix <>) $ case err of - PandocLuaError msg -> msg - _ -> T.pack $ show err - - setGlobalModules :: PandocLua () - setGlobalModules = liftPandocLua $ do - let globalModules = - [ ("lpeg", LPeg.luaopen_lpeg_ptr) -- must be loaded first - , ("re", LPeg.luaopen_re_ptr) -- re depends on lpeg - ] - loadedBuiltInModules <- fmap catMaybes . forM globalModules $ - \(pkgname, luaopen) -> do - Lua.pushcfunction luaopen - usedBuiltIn <- Lua.pcall 0 1 Nothing >>= \case - OK -> do -- all good, loading succeeded - -- register as loaded module so later modules can rely on this - Lua.getfield Lua.registryindex Lua.loaded - Lua.pushvalue (Lua.nth 2) - Lua.setfield (Lua.nth 2) pkgname - Lua.pop 1 -- pop _LOADED - return True - _ -> do -- built-in library failed, load system lib - Lua.pop 1 -- ignore error message - -- Try loading via the normal package loading mechanism. - Lua.getglobal "require" - Lua.pushName pkgname - Lua.call 1 1 -- Throws an exception if loading failed again! - return False - - -- Module on top of stack. Register as global - Lua.setglobal pkgname - return $ if usedBuiltIn then Just pkgname else Nothing - - -- Remove module entry from _LOADED table in registry if we used a - -- built-in library. This ensures that later calls to @require@ will - -- prefer the shared library, if any. - forM_ loadedBuiltInModules $ \pkgname -> do - Lua.getfield Lua.registryindex Lua.loaded - Lua.pushnil - Lua.setfield (Lua.nth 2) pkgname - Lua.pop 1 -- registry - - installLpegSearcher :: PandocLua () - installLpegSearcher = liftPandocLua $ do - Lua.getglobal' "package.searchers" - Lua.pushHaskellFunction $ Lua.state >>= liftIO . LPeg.lpeg_searcher - Lua.rawseti (Lua.nth 2) . (+1) . fromIntegral =<< Lua.rawlen (Lua.nth 2) - Lua.pop 1 -- remove 'package.searchers' from stack - --- | Setup the metatable that's assigned to Lua tables that were created --- from/via JSON arrays. -initJsonMetatable :: PandocLua () -initJsonMetatable = liftPandocLua $ do - newListMetatable HsLua.Aeson.jsonarray (pure ()) diff --git a/src/Text/Pandoc/Lua/Marshal/CommonState.hs b/src/Text/Pandoc/Lua/Marshal/CommonState.hs deleted file mode 100644 --- a/src/Text/Pandoc/Lua/Marshal/CommonState.hs +++ /dev/null @@ -1,68 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{- | - Module : Text.Pandoc.Lua.Marshal.CommonState - Copyright : © 2012-2022 John MacFarlane - © 2017-2022 Albert Krewinkel - License : GNU GPL, version 2 or above - Maintainer : Albert Krewinkel - Stability : alpha - -Instances to marshal (push) and unmarshal (peek) the common state. --} -module Text.Pandoc.Lua.Marshal.CommonState - ( typeCommonState - , peekCommonState - , pushCommonState - ) where - -import HsLua -import Text.Pandoc.Class (CommonState (..)) -import Text.Pandoc.Logging (LogMessage, showLogMessage) -import Text.Pandoc.Lua.Marshal.List (pushPandocList) - --- | Lua type used for the @CommonState@ object. -typeCommonState :: LuaError e => DocumentedType e CommonState -typeCommonState = deftype "pandoc CommonState" [] - [ readonly "input_files" "input files passed to pandoc" - (pushPandocList pushString, stInputFiles) - - , readonly "output_file" "the file to which pandoc will write" - (maybe pushnil pushString, stOutputFile) - - , readonly "log" "list of log messages" - (pushPandocList (pushUD typeLogMessage), stLog) - - , readonly "request_headers" "headers to add for HTTP requests" - (pushPandocList (pushPair pushText pushText), stRequestHeaders) - - , readonly "resource_path" - "path to search for resources like included images" - (pushPandocList pushString, stResourcePath) - - , readonly "source_url" "absolute URL + dir of 1st source file" - (maybe pushnil pushText, stSourceURL) - - , readonly "user_data_dir" "directory to search for data files" - (maybe pushnil pushString, stUserDataDir) - - , readonly "trace" "controls whether tracing messages are issued" - (pushBool, stTrace) - - , readonly "verbosity" "verbosity level" - (pushString . show, stVerbosity) - ] - -peekCommonState :: LuaError e => Peeker e CommonState -peekCommonState = peekUD typeCommonState - -pushCommonState :: LuaError e => Pusher e CommonState -pushCommonState = pushUD typeCommonState - -typeLogMessage :: LuaError e => DocumentedType e LogMessage -typeLogMessage = deftype "pandoc LogMessage" - [ operation Index $ defun "__tostring" - ### liftPure showLogMessage - <#> udparam typeLogMessage "msg" "object" - =#> functionResult pushText "string" "stringified log message" - ] - mempty -- no members diff --git a/src/Text/Pandoc/Lua/Marshal/Context.hs b/src/Text/Pandoc/Lua/Marshal/Context.hs deleted file mode 100644 --- a/src/Text/Pandoc/Lua/Marshal/Context.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -{- | - Module : Text.Pandoc.Lua.Marshaling.Context - Copyright : © 2012-2022 John MacFarlane - © 2017-2022 Albert Krewinkel - License : GNU GPL, version 2 or above - - Maintainer : Albert Krewinkel - Stability : alpha - -Marshaling instance for doctemplates Context and its components. --} -module Text.Pandoc.Lua.Marshal.Context () where - -import qualified HsLua as Lua -import HsLua (Pushable) -import Text.DocTemplates (Context(..), Val(..), TemplateTarget) -import Text.DocLayout (render) - -instance (TemplateTarget a, Pushable a) => Pushable (Context a) where - push (Context m) = Lua.push m - -instance (TemplateTarget a, Pushable a) => Pushable (Val a) where - push NullVal = Lua.push () - push (BoolVal b) = Lua.push b - push (MapVal ctx) = Lua.push ctx - push (ListVal xs) = Lua.push xs - push (SimpleVal d) = Lua.push $ render Nothing d diff --git a/src/Text/Pandoc/Lua/Marshal/PandocError.hs b/src/Text/Pandoc/Lua/Marshal/PandocError.hs deleted file mode 100644 --- a/src/Text/Pandoc/Lua/Marshal/PandocError.hs +++ /dev/null @@ -1,50 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{- | - Module : Text.Pandoc.Lua.Marshal.PandocError - Copyright : © 2020-2022 Albert Krewinkel - License : GNU GPL, version 2 or above - - Maintainer : Albert Krewinkel - Stability : alpha - -Marshal of @'PandocError'@ values. --} -module Text.Pandoc.Lua.Marshal.PandocError - ( peekPandocError - , pushPandocError - , typePandocError - ) - where - -import HsLua (LuaError, Peeker, Pusher, liftLua, pushString) -import HsLua.Packaging -import Text.Pandoc.Error (PandocError (PandocLuaError)) - -import qualified HsLua as Lua -import qualified Text.Pandoc.UTF8 as UTF8 - --- | Lua userdata type definition for PandocError. -typePandocError :: LuaError e => DocumentedType e PandocError -typePandocError = deftype "PandocError" - [ operation Tostring $ defun "__tostring" - ### liftPure (show @PandocError) - <#> udparam typePandocError "obj" "PandocError object" - =#> functionResult pushString "string" "string representation of error." - ] - mempty -- no members - --- | Peek a @'PandocError'@ element to the Lua stack. -pushPandocError :: LuaError e => Pusher e PandocError -pushPandocError = pushUD typePandocError - --- | Retrieve a @'PandocError'@ from the Lua stack. -peekPandocError :: LuaError e => Peeker e PandocError -peekPandocError idx = Lua.retrieving "PandocError" $ - liftLua (Lua.ltype idx) >>= \case - Lua.TypeUserdata -> peekUD typePandocError idx - _ -> do - msg <- liftLua $ Lua.state >>= \l -> Lua.liftIO (Lua.popErrorMessage l) - return $ PandocLuaError (UTF8.toText msg) diff --git a/src/Text/Pandoc/Lua/Marshal/ReaderOptions.hs b/src/Text/Pandoc/Lua/Marshal/ReaderOptions.hs deleted file mode 100644 --- a/src/Text/Pandoc/Lua/Marshal/ReaderOptions.hs +++ /dev/null @@ -1,137 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -{- | - Module : Text.Pandoc.Lua.Marshaling.ReaderOptions - Copyright : © 2012-2022 John MacFarlane - © 2017-2022 Albert Krewinkel - License : GNU GPL, version 2 or above - - Maintainer : Albert Krewinkel - Stability : alpha - -Marshaling instance for ReaderOptions and its components. --} -module Text.Pandoc.Lua.Marshal.ReaderOptions - ( peekReaderOptions - , pushReaderOptions - , pushReaderOptionsReadonly - ) where - -import Data.Default (def) -import HsLua as Lua -#if !MIN_VERSION_hslua(2,2,0) -import HsLua.Aeson (peekViaJSON, pushViaJSON) -#endif -import Text.Pandoc.Lua.Marshal.List (pushPandocList) -import Text.Pandoc.Options (ReaderOptions (..)) - --- --- Reader Options --- - --- | Retrieve a ReaderOptions value, either from a normal ReaderOptions --- value, from a read-only object, or from a table with the same --- keys as a ReaderOptions object. -peekReaderOptions :: LuaError e => Peeker e ReaderOptions -peekReaderOptions = retrieving "ReaderOptions" . \idx -> - liftLua (ltype idx) >>= \case - TypeUserdata -> choice [ peekUD typeReaderOptions - , peekUD typeReaderOptionsReadonly - ] - idx - TypeTable -> peekReaderOptionsTable idx - _ -> failPeek =<< - typeMismatchMessage "ReaderOptions userdata or table" idx - --- | Pushes a ReaderOptions value as userdata object. -pushReaderOptions :: LuaError e => Pusher e ReaderOptions -pushReaderOptions = pushUD typeReaderOptions - --- | Pushes a ReaderOptions object, but makes it read-only. -pushReaderOptionsReadonly :: LuaError e => Pusher e ReaderOptions -pushReaderOptionsReadonly = pushUD typeReaderOptionsReadonly - --- | ReaderOptions object type for read-only values. -typeReaderOptionsReadonly :: LuaError e => DocumentedType e ReaderOptions -typeReaderOptionsReadonly = deftype "ReaderOptions (read-only)" - [ operation Tostring $ lambda - ### liftPure show - <#> udparam typeReaderOptions "opts" "options to print in native format" - =#> functionResult pushString "string" "Haskell representation" - , operation Newindex $ lambda - ### (failLua "This ReaderOptions value is read-only.") - =?> "Throws an error when called, i.e., an assignment is made." - ] - readerOptionsMembers - --- | 'ReaderOptions' object type. -typeReaderOptions :: LuaError e => DocumentedType e ReaderOptions -typeReaderOptions = deftype "ReaderOptions" - [ operation Tostring $ lambda - ### liftPure show - <#> udparam typeReaderOptions "opts" "options to print in native format" - =#> functionResult pushString "string" "Haskell representation" - ] - readerOptionsMembers - --- | Member properties of 'ReaderOptions' Lua values. -readerOptionsMembers :: LuaError e - => [Member e (DocumentedFunction e) ReaderOptions] -readerOptionsMembers = - [ property "abbreviations" "" - (pushSet pushText, readerAbbreviations) - (peekSet peekText, \opts x -> opts{ readerAbbreviations = x }) - , property "columns" "" - (pushIntegral, readerColumns) - (peekIntegral, \opts x -> opts{ readerColumns = x }) - , property "default_image_extension" "" - (pushText, readerDefaultImageExtension) - (peekText, \opts x -> opts{ readerDefaultImageExtension = x }) - , property "extensions" "" - (pushViaJSON, readerExtensions) - (peekViaJSON, \opts x -> opts{ readerExtensions = x }) - , property "indented_code_classes" "" - (pushPandocList pushText, readerIndentedCodeClasses) - (peekList peekText, \opts x -> opts{ readerIndentedCodeClasses = x }) - , property "standalone" "" - (pushBool, readerStandalone) - (peekBool, \opts x -> opts{ readerStandalone = x }) - , property "strip_comments" "" - (pushBool, readerStripComments) - (peekBool, \opts x -> opts{ readerStripComments = x }) - , property "tab_stop" "" - (pushIntegral, readerTabStop) - (peekIntegral, \opts x -> opts{ readerTabStop = x }) - , property "track_changes" "" - (pushViaJSON, readerTrackChanges) - (choice [peekRead, peekViaJSON], \opts x -> opts{ readerTrackChanges = x }) - ] - --- | Retrieves a 'ReaderOptions' object from a table on the stack, using --- the default values for all missing fields. --- --- Internally, this pushes the default reader options, sets each --- key/value pair of the table in the userdata value, then retrieves the --- object again. This will update all fields and complain about unknown --- keys. -peekReaderOptionsTable :: LuaError e => Peeker e ReaderOptions -peekReaderOptionsTable idx = retrieving "ReaderOptions (table)" $ do - liftLua $ do - absidx <- absindex idx - pushUD typeReaderOptions def - let setFields = do - next absidx >>= \case - False -> return () -- all fields were copied - True -> do - pushvalue (nth 2) *> insert (nth 2) - settable (nth 4) -- set in userdata object - setFields - pushnil -- first key - setFields - peekUD typeReaderOptions top `lastly` pop 1 - -instance Pushable ReaderOptions where - push = pushReaderOptions diff --git a/src/Text/Pandoc/Lua/Marshal/Reference.hs b/src/Text/Pandoc/Lua/Marshal/Reference.hs deleted file mode 100644 --- a/src/Text/Pandoc/Lua/Marshal/Reference.hs +++ /dev/null @@ -1,96 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -{- | - Module : Text.Pandoc.Lua.Marshaling.ReaderOptions - Copyright : © 2012-2022 John MacFarlane - © 2017-2022 Albert Krewinkel - License : GNU GPL, version 2 or above - - Maintainer : Albert Krewinkel - Stability : alpha - -Marshal citeproc 'Reference' values. --} -module Text.Pandoc.Lua.Marshal.Reference - ( pushReference - ) where - -import Citeproc.Types - ( Date (..), DateParts (..), ItemId (..), Name (..), Reference (..) - , Val (..), Variable, fromVariable - ) -import Control.Monad (forM_) -import HsLua hiding (Name, Reference, pushName, peekName) -import Text.Pandoc.Builder (Inlines, toList) -import Text.Pandoc.Lua.Marshal.Inline (pushInlines) -import Text.Pandoc.Lua.Marshal.List (pushPandocList) - -import qualified Data.Map as Map - --- | Pushes a ReaderOptions value as userdata object. -pushReference :: LuaError e => Pusher e (Reference Inlines) -pushReference reference = do - pushAsTable [ ("id", pushItemId . referenceId) - , ("type", pushText . referenceType) - ] - reference - forM_ (Map.toList $ referenceVariables reference) $ \(var, val) -> do - pushVariable var - pushVal val - rawset (nth 3) - --- | Pushes an 'ItemId' as a string. -pushItemId :: Pusher e ItemId -pushItemId = pushText . unItemId - --- | Pushes a person's 'Name' as a table. -pushName :: LuaError e => Pusher e Name -pushName = pushAsTable - [ ("family" , pushTextOrNil . nameFamily) - , ("given" , pushTextOrNil . nameGiven) - , ("dropping-particle" , pushTextOrNil . nameDroppingParticle) - , ("non-dropping-particle" , pushTextOrNil . nameNonDroppingParticle) - , ("suffix" , pushTextOrNil . nameSuffix) - , ("literal" , pushTextOrNil . nameLiteral) - , ("comma-suffix" , pushBoolOrNil . nameCommaSuffix) - , ("static-ordering" , pushBoolOrNil . nameStaticOrdering) - ] - where - pushTextOrNil = \case - Nothing -> pushnil - Just xs -> pushText xs - --- | Pushes a boolean, but uses @nil@ instead of @false@; table fields --- are not set unless the value is true. -pushBoolOrNil :: Pusher e Bool -pushBoolOrNil = \case - False -> pushnil - True -> pushBool True - --- | Pushes a 'Variable' as string. -pushVariable :: Pusher e Variable -pushVariable = pushText . fromVariable - --- | Pushes a 'Val', i.e., a variable value. -pushVal :: LuaError e => Pusher e (Val Inlines) -pushVal = \case - TextVal t -> pushText t - FancyVal inlns -> pushInlines $ toList inlns - NumVal i -> pushIntegral i - NamesVal names -> pushPandocList pushName names - DateVal date -> pushDate date - _ -> pushText mempty - --- | Pushes a 'Date' as table. -pushDate :: LuaError e => Pusher e Date -pushDate = pushAsTable - [ ("date-parts", pushPandocList pushDateParts . dateParts) - , ("circa", pushBoolOrNil . dateCirca) - , ("season", maybe pushnil pushIntegral . dateSeason) - , ("literal", maybe pushnil pushText . dateLiteral) - ] - where - -- date parts are lists of Int values - pushDateParts (DateParts dp) = pushPandocList pushIntegral dp diff --git a/src/Text/Pandoc/Lua/Marshal/Sources.hs b/src/Text/Pandoc/Lua/Marshal/Sources.hs deleted file mode 100644 --- a/src/Text/Pandoc/Lua/Marshal/Sources.hs +++ /dev/null @@ -1,56 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -{- | -Module : Text.Pandoc.Lua.Marshaling.Sources -Copyright : © 2021-2022 Albert Krewinkel -License : GNU GPL, version 2 or above -Maintainer : Albert Krewinkel - -Marshal 'Sources'. --} -module Text.Pandoc.Lua.Marshal.Sources - ( peekSources - , pushSources - ) where - -import Control.Monad ((<$!>)) -import Data.Text (Text) -import HsLua as Lua -import Text.Pandoc.Lua.Marshal.List (newListMetatable) -import Text.Pandoc.Sources (Sources (..), toSources) -import Text.Parsec (SourcePos, sourceName) - --- | Pushes the 'Sources' as a list of lazy Lua objects. -pushSources :: LuaError e => Pusher e Sources -pushSources (Sources srcs) = do - pushList (pushUD typeSource) srcs - newListMetatable "pandoc Sources" $ do - pushName "__tostring" - pushHaskellFunction $ do - sources <- forcePeek $ peekList (peekUD typeSource) (nthBottom 1) - pushText . mconcat $ map snd sources - return 1 - rawset (nth 3) - setmetatable (nth 2) - --- | Retrieves sources from the stack. -peekSources :: LuaError e => Peeker e Sources -peekSources idx = liftLua (ltype idx) >>= \case - TypeString -> toSources <$!> peekText idx - TypeTable -> Sources <$!> peekList (peekUD typeSource) idx - _ -> Sources . (:[]) <$!> peekUD typeSource idx - --- | Source object type. -typeSource :: LuaError e => DocumentedType e (SourcePos, Text) -typeSource = deftype "pandoc input source" - [ operation Tostring $ lambda - ### liftPure snd - <#> udparam typeSource "srcs" "Source to print in native format" - =#> functionResult pushText "string" "Haskell representation" - ] - [ readonly "name" "source name" - (pushString, sourceName . fst) - , readonly "text" "source text" - (pushText, snd) - ] diff --git a/src/Text/Pandoc/Lua/Marshal/Template.hs b/src/Text/Pandoc/Lua/Marshal/Template.hs deleted file mode 100644 --- a/src/Text/Pandoc/Lua/Marshal/Template.hs +++ /dev/null @@ -1,31 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -{- | -Module : Text.Pandoc.Lua.Marshal.Template -Copyright : © 2021-2022 Albert Krewinkel -License : GNU GPL, version 2 or above -Maintainer : Albert Krewinkel - -Marshal 'Template' 'Text'. --} -module Text.Pandoc.Lua.Marshal.Template - ( pushTemplate - , peekTemplate - , typeTemplate - ) where - -import Data.Text (Text) -import HsLua as Lua -import Text.DocTemplates (Template) - --- | Pushes a 'Template' as a an opaque userdata value. -pushTemplate :: LuaError e => Pusher e (Template Text) -pushTemplate = pushUD typeTemplate - --- | Retrieves a 'Template' 'Text' value from the stack. -peekTemplate :: LuaError e => Peeker e (Template Text) -peekTemplate = peekUD typeTemplate - --- | Template object type. -typeTemplate :: LuaError e => DocumentedType e (Template Text) -typeTemplate = deftype "pandoc Template" [] [] diff --git a/src/Text/Pandoc/Lua/Marshal/WriterOptions.hs b/src/Text/Pandoc/Lua/Marshal/WriterOptions.hs deleted file mode 100644 --- a/src/Text/Pandoc/Lua/Marshal/WriterOptions.hs +++ /dev/null @@ -1,244 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -{- | - Module : Text.Pandoc.Lua.Marshaling.WriterOptions - Copyright : © 2021-2022 Albert Krewinkel, John MacFarlane - License : GNU GPL, version 2 or above - - Maintainer : Albert Krewinkel - Stability : alpha - -Marshaling instance for WriterOptions and its components. --} -module Text.Pandoc.Lua.Marshal.WriterOptions - ( peekWriterOptions - , pushWriterOptions - ) where - -import Control.Applicative (optional) -import Data.Default (def) -import HsLua as Lua -#if !MIN_VERSION_hslua(2,2,0) -import HsLua.Aeson (peekViaJSON, pushViaJSON) -#endif -import Text.Pandoc.Lua.Marshal.List (pushPandocList) -import Text.Pandoc.Lua.Marshal.Template (peekTemplate, pushTemplate) -import Text.Pandoc.Options (WriterOptions (..)) - --- --- Writer Options --- - --- | Retrieve a WriterOptions value, either from a normal WriterOptions --- value, from a read-only object, or from a table with the same --- keys as a WriterOptions object. -peekWriterOptions :: LuaError e => Peeker e WriterOptions -peekWriterOptions = retrieving "WriterOptions" . \idx -> - liftLua (ltype idx) >>= \case - TypeUserdata -> peekUD typeWriterOptions idx - TypeTable -> peekWriterOptionsTable idx - _ -> failPeek =<< - typeMismatchMessage "WriterOptions userdata or table" idx - --- | Pushes a WriterOptions value as userdata object. -pushWriterOptions :: LuaError e => Pusher e WriterOptions -pushWriterOptions = pushUD typeWriterOptions - --- | 'WriterOptions' object type. -typeWriterOptions :: LuaError e => DocumentedType e WriterOptions -typeWriterOptions = deftype "WriterOptions" - [ operation Tostring $ lambda - ### liftPure show - <#> udparam typeWriterOptions "opts" "options to print in native format" - =#> functionResult pushString "string" "Haskell representation" - ] - [ property "cite_method" - "How to print cites" - (pushViaJSON, writerCiteMethod) - (peekViaJSON, \opts x -> opts{ writerCiteMethod = x }) - - , property "columns" - "Characters in a line (for text wrapping)" - (pushIntegral, writerColumns) - (peekIntegral, \opts x -> opts{ writerColumns = x }) - - , property "dpi" - "DPI for pixel to/from inch/cm conversions" - (pushIntegral, writerDpi) - (peekIntegral, \opts x -> opts{ writerDpi = x }) - - , property "email_obfuscation" - "How to obfuscate emails" - (pushViaJSON, writerEmailObfuscation) - (peekViaJSON, \opts x -> opts{ writerEmailObfuscation = x }) - - , property "epub_chapter_level" - "Header level for chapters (separate files)" - (pushIntegral, writerEpubChapterLevel) - (peekIntegral, \opts x -> opts{ writerEpubChapterLevel = x }) - - , property "epub_fonts" - "Paths to fonts to embed" - (pushPandocList pushString, writerEpubFonts) - (peekList peekString, \opts x -> opts{ writerEpubFonts = x }) - - , property "epub_metadata" - "Metadata to include in EPUB" - (maybe pushnil pushText, writerEpubMetadata) - (optional . peekText, \opts x -> opts{ writerEpubMetadata = x }) - - , property "epub_subdirectory" - "Subdir for epub in OCF" - (pushText, writerEpubSubdirectory) - (peekText, \opts x -> opts{ writerEpubSubdirectory = x }) - - , property "extensions" - "Markdown extensions that can be used" - (pushViaJSON, writerExtensions) - (peekViaJSON, \opts x -> opts{ writerExtensions = x }) - - , property "highlight_style" - "Style to use for highlighting (nil = no highlighting)" - (maybe pushnil pushViaJSON, writerHighlightStyle) - (optional . peekViaJSON, \opts x -> opts{ writerHighlightStyle = x }) - - , property "html_math_method" - "How to print math in HTML" - (pushViaJSON, writerHTMLMathMethod) - (peekViaJSON, \opts x -> opts{ writerHTMLMathMethod = x }) - - , property "html_q_tags" - "Use @@ tags for quotes in HTML" - (pushBool, writerHtmlQTags) - (peekBool, \opts x -> opts{ writerHtmlQTags = x }) - - , property "identifier_prefix" - "Prefix for section & note ids in HTML and for footnote marks in markdown" - (pushText, writerIdentifierPrefix) - (peekText, \opts x -> opts{ writerIdentifierPrefix = x }) - - , property "incremental" - "True if lists should be incremental" - (pushBool, writerIncremental) - (peekBool, \opts x -> opts{ writerIncremental = x }) - - , property "listings" - "Use listings package for code" - (pushBool, writerListings) - (peekBool, \opts x -> opts{ writerListings = x }) - - , property "number_offset" - "Starting number for section, subsection, ..." - (pushPandocList pushIntegral, writerNumberOffset) - (peekList peekIntegral, \opts x -> opts{ writerNumberOffset = x }) - - , property "number_sections" - "Number sections in LaTeX" - (pushBool, writerNumberSections) - (peekBool, \opts x -> opts{ writerNumberSections = x }) - - , property "prefer_ascii" - "Prefer ASCII representations of characters when possible" - (pushBool, writerPreferAscii) - (peekBool, \opts x -> opts{ writerPreferAscii = x }) - - , property "reference_doc" - "Path to reference document if specified" - (maybe pushnil pushString, writerReferenceDoc) - (optional . peekString, \opts x -> opts{ writerReferenceDoc = x }) - - , property "reference_links" - "Use reference links in writing markdown, rst" - (pushBool, writerReferenceLinks) - (peekBool, \opts x -> opts{ writerReferenceLinks = x }) - - , property "reference_location" - "Location of footnotes and references for writing markdown" - (pushViaJSON, writerReferenceLocation) - (peekViaJSON, \opts x -> opts{ writerReferenceLocation = x }) - - , property "section_divs" - "Put sections in div tags in HTML" - (pushBool, writerSectionDivs) - (peekBool, \opts x -> opts{ writerSectionDivs = x }) - - , property "setext_headers" - "Use setext headers for levels 1-2 in markdown" - (pushBool, writerSetextHeaders) - (peekBool, \opts x -> opts{ writerSetextHeaders = x }) - - , property "slide_level" - "Force header level of slides" - (maybe pushnil pushIntegral, writerSlideLevel) - (optional . peekIntegral, \opts x -> opts{ writerSlideLevel = x }) - - -- , property "syntax_map" "Syntax highlighting definition" - -- (pushViaJSON, writerSyntaxMap) - -- (peekViaJSON, \opts x -> opts{ writerSyntaxMap = x }) - -- :: SyntaxMap - - , property "tab_stop" - "Tabstop for conversion btw spaces and tabs" - (pushIntegral, writerTabStop) - (peekIntegral, \opts x -> opts{ writerTabStop = x }) - - , property "table_of_contents" - "Include table of contents" - (pushBool, writerTableOfContents) - (peekBool, \opts x -> opts{ writerTableOfContents = x }) - - , property "template" - "Template to use" - (maybe pushnil pushTemplate, writerTemplate) - (optional . peekTemplate, \opts x -> opts{ writerTemplate = x }) - -- :: Maybe (Template Text) - - , property "toc_depth" - "Number of levels to include in TOC" - (pushIntegral, writerTOCDepth) - (peekIntegral, \opts x -> opts{ writerTOCDepth = x }) - - , property "top_level_division" - "Type of top-level divisions" - (pushViaJSON, writerTopLevelDivision) - (peekViaJSON, \opts x -> opts{ writerTopLevelDivision = x }) - - , property "variables" - "Variables to set in template" - (pushViaJSON, writerVariables) - (peekViaJSON, \opts x -> opts{ writerVariables = x }) - - , property "wrap_text" - "Option for wrapping text" - (pushViaJSON, writerWrapText) - (peekViaJSON, \opts x -> opts{ writerWrapText = x }) - ] - --- | Retrieves a 'WriterOptions' object from a table on the stack, using --- the default values for all missing fields. --- --- Internally, this pushes the default writer options, sets each --- key/value pair of the table in the userdata value, then retrieves the --- object again. This will update all fields and complain about unknown --- keys. -peekWriterOptionsTable :: LuaError e => Peeker e WriterOptions -peekWriterOptionsTable idx = retrieving "WriterOptions (table)" $ do - liftLua $ do - absidx <- absindex idx - pushUD typeWriterOptions def - let setFields = do - next absidx >>= \case - False -> return () -- all fields were copied - True -> do - pushvalue (nth 2) *> insert (nth 2) - settable (nth 4) -- set in userdata object - setFields - pushnil -- first key - setFields - peekUD typeWriterOptions top `lastly` pop 1 - -instance Pushable WriterOptions where - push = pushWriterOptions diff --git a/src/Text/Pandoc/Lua/Module/MediaBag.hs b/src/Text/Pandoc/Lua/Module/MediaBag.hs deleted file mode 100644 --- a/src/Text/Pandoc/Lua/Module/MediaBag.hs +++ /dev/null @@ -1,143 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{- | - Module : Text.Pandoc.Lua.Module.MediaBag - Copyright : Copyright © 2017-2022 Albert Krewinkel - License : GNU GPL, version 2 or above - Maintainer : Albert Krewinkel - -The Lua module @pandoc.mediabag@. --} -module Text.Pandoc.Lua.Module.MediaBag - ( documentedModule - ) where - -import Prelude hiding (lookup) -import Data.Maybe (fromMaybe) -import HsLua ( LuaE, DocumentedFunction, Module (..) - , (<#>), (###), (=#>), (=?>), (#?), defun, functionResult - , opt, parameter, stringParam, textParam) -import Text.Pandoc.Class.CommonState (CommonState (..)) -import Text.Pandoc.Class.PandocMonad (fetchItem, fillMediaBag, getMediaBag, - modifyCommonState, setMediaBag) -import Text.Pandoc.Error (PandocError) -import Text.Pandoc.Lua.Marshal.Pandoc (peekPandoc, pushPandoc) -import Text.Pandoc.Lua.Marshal.List (pushPandocList) -import Text.Pandoc.Lua.Orphans () -import Text.Pandoc.Lua.PandocLua (unPandocLua) -import Text.Pandoc.MIME (MimeType) - -import qualified Data.ByteString.Lazy as BL -import qualified HsLua as Lua -import qualified Text.Pandoc.MediaBag as MB - --- --- MediaBag submodule --- -documentedModule :: Module PandocError -documentedModule = Module - { moduleName = "pandoc.mediabag" - , moduleDescription = "mediabag access" - , moduleFields = [] - , moduleFunctions = - [ delete - , empty - , fetch - , fill - , insert - , items - , list - , lookup - ] - , moduleOperations = [] - } - --- | Delete a single item from the media bag. -delete :: DocumentedFunction PandocError -delete = defun "delete" - ### (\fp -> unPandocLua $ modifyCommonState - (\st -> st { stMediaBag = MB.deleteMedia fp (stMediaBag st) })) - <#> stringParam "filepath" "filename of item to delete" - =#> [] - - --- | Delete all items from the media bag. -empty :: DocumentedFunction PandocError -empty = defun "empty" - ### unPandocLua (modifyCommonState (\st -> st { stMediaBag = mempty })) - =#> [] - --- | Fill the mediabag with all images in the document that aren't --- present yet. -fill :: DocumentedFunction PandocError -fill = defun "fill" - ### unPandocLua . fillMediaBag - <#> parameter peekPandoc "Pandoc" "doc" - "document from which to fill the mediabag" - =#> functionResult pushPandoc "Pandoc" "modified document" - #? ("Fills the mediabag with the images in the given document.\n" <> - "An image that cannot be retrieved will be replaced with a Span\n" <> - "of class \"image\" that contains the image description.\n" <> - "" <> - "Images for which the mediabag already contains an item will\n" <> - "not be processed again.") - --- | Insert a new item into the media bag. -insert :: DocumentedFunction PandocError -insert = defun "insert" - ### (\fp mmime contents -> unPandocLua $ do - mb <- getMediaBag - setMediaBag $ MB.insertMedia fp mmime contents mb - return (Lua.NumResults 0)) - <#> stringParam "filepath" "item file path" - <#> opt (textParam "mimetype" "the item's MIME type") - <#> parameter Lua.peekLazyByteString "string" "contents" "binary contents" - =#> [] - --- | Returns iterator values to be used with a Lua @for@ loop. -items :: DocumentedFunction PandocError -items = defun "items" - ### (do - mb <-unPandocLua getMediaBag - let pushItem (fp, mimetype, contents) = do - Lua.pushString fp - Lua.pushText mimetype - Lua.pushByteString $ BL.toStrict contents - return (Lua.NumResults 3) - Lua.pushIterator pushItem (MB.mediaItems mb)) - =?> "Iterator triple" - --- | Function to lookup a value in the mediabag. -lookup :: DocumentedFunction PandocError -lookup = defun "lookup" - ### (\fp -> unPandocLua (MB.lookupMedia fp <$> getMediaBag) >>= \case - Nothing -> 1 <$ Lua.pushnil - Just item -> 2 <$ do - Lua.pushText $ MB.mediaMimeType item - Lua.pushLazyByteString $ MB.mediaContents item) - <#> stringParam "filepath" "path of item to lookup" - =?> "MIME type and contents" - --- | Function listing all mediabag items. -list :: DocumentedFunction PandocError -list = defun "list" - ### (unPandocLua (MB.mediaDirectory <$> getMediaBag)) - =#> functionResult (pushPandocList pushEntry) "table" "list of entry triples" - where - pushEntry :: (FilePath, MimeType, Int) -> LuaE PandocError () - pushEntry (fp, mimeType, contentLength) = do - Lua.newtable - Lua.pushName "path" *> Lua.pushString fp *> Lua.rawset (-3) - Lua.pushName "type" *> Lua.pushText mimeType *> Lua.rawset (-3) - Lua.pushName "length" *> Lua.pushIntegral contentLength *> Lua.rawset (-3) - --- | Lua function to retrieve a new item. -fetch :: DocumentedFunction PandocError -fetch = defun "fetch" - ### (\src -> do - (bs, mimeType) <- unPandocLua $ fetchItem src - Lua.pushText $ fromMaybe "" mimeType - Lua.pushByteString bs - return 2) - <#> textParam "src" "URI to fetch" - =?> "Returns two string values: the fetched contents and the mimetype." diff --git a/src/Text/Pandoc/Lua/Module/Pandoc.hs b/src/Text/Pandoc/Lua/Module/Pandoc.hs deleted file mode 100644 --- a/src/Text/Pandoc/Lua/Module/Pandoc.hs +++ /dev/null @@ -1,320 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{- | - Module : Text.Pandoc.Lua.Module.Pandoc - Copyright : Copyright © 2017-2022 Albert Krewinkel - License : GNU GPL, version 2 or above - - Maintainer : Albert Krewinkel - Stability : alpha - -Pandoc module for lua. --} -module Text.Pandoc.Lua.Module.Pandoc - ( pushModule - , documentedModule - ) where - -import Prelude hiding (read) -import Control.Applicative ((<|>)) -import Control.Monad (forM_, when) -import Control.Monad.Catch (catch, throwM) -import Data.Data (Data, dataTypeConstrs, dataTypeOf, showConstr) -import Data.Default (Default (..)) -import Data.Maybe (fromMaybe) -import Data.Proxy (Proxy (Proxy)) -import HsLua hiding (pushModule) -import System.Exit (ExitCode (..)) -import Text.Pandoc.Definition -import Text.Pandoc.Error (PandocError (..)) -import Text.Pandoc.Lua.Orphans () -import Text.Pandoc.Lua.Marshal.AST -import Text.Pandoc.Lua.Marshal.Filter (peekFilter) -import Text.Pandoc.Lua.Marshal.ReaderOptions ( peekReaderOptions - , pushReaderOptions) -import Text.Pandoc.Lua.Marshal.Sources (peekSources) -import Text.Pandoc.Lua.Marshal.WriterOptions ( peekWriterOptions - , pushWriterOptions) -import Text.Pandoc.Lua.Module.Utils (sha1) -import Text.Pandoc.Lua.PandocLua (PandocLua (unPandocLua), liftPandocLua) -import Text.Pandoc.Options ( ReaderOptions (readerExtensions) - , WriterOptions (writerExtensions) ) -import Text.Pandoc.Process (pipeProcess) -import Text.Pandoc.Readers (Reader (..), getReader, readers) -import Text.Pandoc.Sources (toSources) -import Text.Pandoc.Writers (Writer (..), getWriter, writers) - -import qualified HsLua as Lua -import qualified Data.ByteString.Lazy as BL -import qualified Data.ByteString.Lazy.Char8 as BSL -import qualified Data.Set as Set -import qualified Data.Text as T -import qualified Text.Pandoc.UTF8 as UTF8 - --- | Push the "pandoc" package to the Lua stack. Requires the `List` --- module to be loadable. -pushModule :: PandocLua NumResults -pushModule = do - liftPandocLua $ Lua.pushModule documentedModule - return 1 - -documentedModule :: Module PandocError -documentedModule = Module - { moduleName = "pandoc" - , moduleDescription = T.unlines - [ "Lua functions for pandoc scripts; includes constructors for" - , "document elements, functions to parse text in a given" - , "format, and functions to filter and modify a subtree." - ] - , moduleFields = readersField : writersField : - stringConstants ++ [inlineField, blockField] - , moduleOperations = [] - , moduleFunctions = mconcat - [ functions - , otherConstructors - , blockConstructors - , inlineConstructors - , metaValueConstructors - ] - } - --- | Set of input formats accepted by @read@. -readersField :: Field PandocError -readersField = Field - { fieldName = "readers" - , fieldDescription = T.unlines - [ "Set of formats that pandoc can parse. All keys in this table can" - , "be used as the `format` value in `pandoc.read`." - ] - , fieldPushValue = pushSet pushText $ - Set.fromList (map fst (readers @PandocLua)) - } - --- | Set of input formats accepted by @write@. -writersField :: Field PandocError -writersField = Field - { fieldName = "writers" - , fieldDescription = T.unlines - [ "Set of formats that pandoc can generate. All keys in this table" - , "can be used as the `format` value in `pandoc.write`." - ] - , fieldPushValue = pushSet pushText $ - Set.fromList (map fst (writers @PandocLua)) - } - --- | Inline table field -inlineField :: Field PandocError -inlineField = Field - { fieldName = "Inline" - , fieldDescription = "Inline constructors, nested under 'constructors'." - -- the nesting happens for historical reasons and should probably be - -- changed. - , fieldPushValue = pushWithConstructorsSubtable inlineConstructors - } - --- | @Block@ module field -blockField :: Field PandocError -blockField = Field - { fieldName = "Block" - , fieldDescription = "Inline constructors, nested under 'constructors'." - -- the nesting happens for historical reasons and should probably be - -- changed. - , fieldPushValue = pushWithConstructorsSubtable blockConstructors - } - -pushWithConstructorsSubtable :: [DocumentedFunction PandocError] - -> LuaE PandocError () -pushWithConstructorsSubtable constructors = do - newtable -- Field table - newtable -- constructor table - pushName "constructor" *> pushvalue (nth 2) *> rawset (nth 4) - forM_ constructors $ \fn -> do - pushName (functionName fn) - pushDocumentedFunction fn - rawset (nth 3) - pop 1 -- pop constructor table - -otherConstructors :: LuaError e => [DocumentedFunction e] -otherConstructors = - [ mkPandoc - , mkMeta - , mkAttr - , mkAttributeList - , mkBlocks - , mkCitation - , mkCell - , mkRow - , mkTableHead - , mkTableFoot - , mkInlines - , mkListAttributes - , mkSimpleTable - - , defun "ReaderOptions" - ### liftPure id - <#> parameter peekReaderOptions "ReaderOptions|table" "opts" "reader options" - =#> functionResult pushReaderOptions "ReaderOptions" "new object" - #? "Creates a new ReaderOptions value." - - , defun "WriterOptions" - ### liftPure id - <#> parameter peekWriterOptions "WriterOptions|table" "opts" - "writer options" - =#> functionResult pushWriterOptions "WriterOptions" "new object" - #? "Creates a new WriterOptions value." - ] - -stringConstants :: [Field e] -stringConstants = - let constrs :: forall a. Data a => Proxy a -> [String] - constrs _ = map showConstr . dataTypeConstrs . dataTypeOf @a $ undefined - nullaryConstructors = mconcat - [ constrs (Proxy @ListNumberStyle) - , constrs (Proxy @ListNumberDelim) - , constrs (Proxy @QuoteType) - , constrs (Proxy @MathType) - , constrs (Proxy @Alignment) - , constrs (Proxy @CitationMode) - ] - toField s = Field - { fieldName = T.pack s - , fieldDescription = T.pack s - , fieldPushValue = pushString s - } - in map toField nullaryConstructors - -functions :: [DocumentedFunction PandocError] -functions = - [ defun "pipe" - ### (\command args input -> do - (ec, output) <- Lua.liftIO $ pipeProcess Nothing command args input - `catch` (throwM . PandocIOError "pipe") - case ec of - ExitSuccess -> 1 <$ Lua.pushLazyByteString output - ExitFailure n -> do - pushPipeError (PipeError (T.pack command) n output) - Lua.error) - <#> parameter peekString "string" "command" "path to executable" - <#> parameter (peekList peekString) "{string,...}" "args" - "list of arguments" - <#> parameter peekLazyByteString "string" "input" - "input passed to process via stdin" - =?> "output string, or error triple" - - , defun "read" - ### (\content mformatspec mreaderOptions -> do - let formatSpec = fromMaybe "markdown" mformatspec - readerOpts = fromMaybe def mreaderOptions - readAction = getReader formatSpec >>= \case - (TextReader r, es) -> - r readerOpts{readerExtensions = es} - (case content of - Left bs -> toSources $ UTF8.toText bs - Right sources -> sources) - (ByteStringReader r, es) -> - case content of - Left bs -> r readerOpts{readerExtensions = es} - (BSL.fromStrict bs) - Right _ -> liftPandocLua $ Lua.failLua - "Cannot use bytestring reader with Sources" - try (unPandocLua readAction) >>= \case - Right pd -> - -- success, got a Pandoc document - return pd - Left (PandocUnknownReaderError f) -> - Lua.failLua . T.unpack $ "Unknown reader: " <> f - Left (PandocUnsupportedExtensionError e f) -> - Lua.failLua . T.unpack $ - "Extension " <> e <> " not supported for " <> f - Left e -> - throwM e) - <#> parameter (\idx -> (Left <$> peekByteString idx) - <|> (Right <$> peekSources idx)) - "string|Sources" "content" "text to parse" - <#> opt (textParam "formatspec" "format and extensions") - <#> opt (parameter peekReaderOptions "ReaderOptions" "reader_options" - "reader options") - =#> functionResult pushPandoc "Pandoc" "result document" - - , sha1 - - , defun "walk_block" - ### walkElement - <#> parameter peekBlockFuzzy "Block" "block" "element to traverse" - <#> parameter peekFilter "Filter" "lua_filter" "filter functions" - =#> functionResult pushBlock "Block" "modified Block" - - , defun "walk_inline" - ### walkElement - <#> parameter peekInlineFuzzy "Inline" "inline" "element to traverse" - <#> parameter peekFilter "Filter" "lua_filter" "filter functions" - =#> functionResult pushInline "Inline" "modified Inline" - - , defun "write" - ### (\doc mformatspec mwriterOpts -> do - let formatSpec = fromMaybe "html" mformatspec - writerOpts = fromMaybe def mwriterOpts - unPandocLua $ getWriter formatSpec >>= \case - (TextWriter w, es) -> Right <$> - w writerOpts{ writerExtensions = es } doc - (ByteStringWriter w, es) -> Left <$> - w writerOpts{ writerExtensions = es } doc) - <#> parameter peekPandoc "Pandoc" "doc" "document to convert" - <#> opt (textParam "formatspec" "format and extensions") - <#> opt (parameter peekWriterOptions "WriterOptions" "writer_options" - "writer options") - =#> functionResult (either pushLazyByteString pushText) "string" - "result document" - ] - where - walkElement x f = - walkInlineSplicing f x - >>= walkInlinesStraight f - >>= walkBlockSplicing f - >>= walkBlocksStraight f - -data PipeError = PipeError - { pipeErrorCommand :: T.Text - , pipeErrorCode :: Int - , pipeErrorOutput :: BL.ByteString - } - -peekPipeError :: LuaError e => StackIndex -> LuaE e PipeError -peekPipeError idx = - PipeError - <$> (Lua.getfield idx "command" *> Lua.peek (-1) <* Lua.pop 1) - <*> (Lua.getfield idx "error_code" *> Lua.peek (-1) <* Lua.pop 1) - <*> (Lua.getfield idx "output" *> Lua.peek (-1) <* Lua.pop 1) - -pushPipeError :: LuaError e => Pusher e PipeError -pushPipeError pipeErr = do - pushAsTable [ ("command" , pushText . pipeErrorCommand) - , ("error_code" , pushIntegral . pipeErrorCode) - , ("output" , pushLazyByteString . pipeErrorOutput) - ] pipeErr - pushPipeErrorMetaTable - Lua.setmetatable (nth 2) - where - pushPipeErrorMetaTable :: LuaError e => LuaE e () - pushPipeErrorMetaTable = do - v <- Lua.newmetatable "pandoc pipe error" - when v $ do - pushName "__tostring" - pushHaskellFunction pipeErrorMessage - rawset (nth 3) - - pipeErrorMessage :: LuaError e => LuaE e NumResults - pipeErrorMessage = do - (PipeError cmd errorCode output) <- peekPipeError (nthBottom 1) - pushByteString . BSL.toStrict . BSL.concat $ - [ BSL.pack "Error running " - , BSL.pack $ T.unpack cmd - , BSL.pack " (error code " - , BSL.pack $ show errorCode - , BSL.pack "): " - , if output == mempty then BSL.pack "" else output - ] - return (NumResults 1) diff --git a/src/Text/Pandoc/Lua/Module/System.hs b/src/Text/Pandoc/Lua/Module/System.hs deleted file mode 100644 --- a/src/Text/Pandoc/Lua/Module/System.hs +++ /dev/null @@ -1,41 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{- | - Module : Text.Pandoc.Lua.Module.System - Copyright : © 2019-2022 Albert Krewinkel - License : GNU GPL, version 2 or above - - Maintainer : Albert Krewinkel - Stability : alpha - -Pandoc's system Lua module. --} -module Text.Pandoc.Lua.Module.System - ( documentedModule - ) where - -import HsLua -import HsLua.Module.System - (arch, env, getwd, ls, mkdir, os, rmdir, with_env, with_tmpdir, with_wd) - --- | Push the pandoc.system module on the Lua stack. -documentedModule :: LuaError e => Module e -documentedModule = Module - { moduleName = "pandoc.system" - , moduleDescription = "system functions" - , moduleFields = - [ arch - , os - ] - , moduleFunctions = - [ setName "environment" env - , setName "get_working_directory" getwd - , setName "list_directory" ls - , setName "make_directory" mkdir - , setName "remove_directory" rmdir - , setName "with_environment" with_env - , setName "with_temporary_directory" with_tmpdir - , setName "with_working_directory" with_wd - ] - , moduleOperations = [] - } diff --git a/src/Text/Pandoc/Lua/Module/Template.hs b/src/Text/Pandoc/Lua/Module/Template.hs deleted file mode 100644 --- a/src/Text/Pandoc/Lua/Module/Template.hs +++ /dev/null @@ -1,61 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{- | - Module : Text.Pandoc.Lua.Module.Template - Copyright : Copyright © 2022 Albert Krewinkel, John MacFarlane - License : GNU GPL, version 2 or above - Maintainer : Albert Krewinkel - -Lua module to handle pandoc templates. --} -module Text.Pandoc.Lua.Module.Template - ( documentedModule - ) where - -import HsLua -import Text.Pandoc.Error (PandocError) -import Text.Pandoc.Lua.Marshal.Template (pushTemplate) -import Text.Pandoc.Lua.PandocLua (PandocLua (unPandocLua), liftPandocLua) -import Text.Pandoc.Templates - (compileTemplate, getDefaultTemplate, runWithPartials, runWithDefaultPartials) - -import qualified Data.Text as T - --- | The "pandoc.template" module. -documentedModule :: Module PandocError -documentedModule = Module - { moduleName = "pandoc.template" - , moduleDescription = T.unlines - [ "Lua functions for pandoc templates." - ] - , moduleFields = [] - , moduleOperations = [] - , moduleFunctions = functions - } - --- | Template module functions. -functions :: [DocumentedFunction PandocError] -functions = - [ defun "compile" - ### (\template mfilepath -> unPandocLua $ - case mfilepath of - Just fp -> runWithPartials (compileTemplate fp template) - Nothing -> runWithDefaultPartials - (compileTemplate "templates/default" template)) - <#> parameter peekText "string" "template" "template string" - <#> opt (stringParam "templ_path" "template path") - =#> functionResult (either failLua pushTemplate) "pandoc Template" - "compiled template" - - , defun "default" - ### (\mformat -> unPandocLua $ do - let getFORMAT = liftPandocLua $ do - getglobal "FORMAT" - forcePeek $ peekText top `lastly` pop 1 - format <- maybe getFORMAT pure mformat - getDefaultTemplate format) - <#> opt (textParam "writer" - "writer for which the template should be returned.") - =#> functionResult pushText "string" - "string representation of the writer's default template" - - ] diff --git a/src/Text/Pandoc/Lua/Module/Types.hs b/src/Text/Pandoc/Lua/Module/Types.hs deleted file mode 100644 --- a/src/Text/Pandoc/Lua/Module/Types.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{- | - Module : Text.Pandoc.Lua.Module.Types - Copyright : © 2019-2022 Albert Krewinkel - License : GNU GPL, version 2 or above - - Maintainer : Albert Krewinkel - Stability : alpha - -Pandoc data type constructors. --} -module Text.Pandoc.Lua.Module.Types - ( documentedModule - ) where - -import HsLua ( Module (..), (###), (<#>), (=#>) - , defun, functionResult, parameter) -import HsLua.Module.Version (peekVersionFuzzy, pushVersion) -import Text.Pandoc.Error (PandocError) -import Text.Pandoc.Lua.ErrorConversion () - --- | Push the pandoc.types module on the Lua stack. -documentedModule :: Module PandocError -documentedModule = Module - { moduleName = "pandoc.types" - , moduleDescription = - "Constructors for types that are not part of the pandoc AST." - , moduleFields = [] - , moduleFunctions = - [ defun "Version" - ### return - <#> parameter peekVersionFuzzy "string|integer|{integer,...}|Version" - "version_specifier" - (mconcat [ "either a version string like `'2.7.3'`, " - , "a single integer like `2`, " - , "list of integers like `{2,7,3}`, " - , "or a Version object" - ]) - =#> functionResult pushVersion "Version" "A new Version object." - ] - , moduleOperations = [] - } diff --git a/src/Text/Pandoc/Lua/Module/Utils.hs b/src/Text/Pandoc/Lua/Module/Utils.hs deleted file mode 100644 --- a/src/Text/Pandoc/Lua/Module/Utils.hs +++ /dev/null @@ -1,239 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{- | - Module : Text.Pandoc.Lua.Module.Utils - Copyright : Copyright © 2017-2022 Albert Krewinkel - License : GNU GPL, version 2 or above - - Maintainer : Albert Krewinkel - Stability : alpha - -Utility module for Lua, exposing internal helper functions. --} -module Text.Pandoc.Lua.Module.Utils - ( documentedModule - , sha1 - ) where - -import Control.Applicative ((<|>)) -import Control.Monad ((<$!>)) -import Data.Data (showConstr, toConstr) -import Data.Default (def) -import Data.Maybe (fromMaybe) -import Data.Version (Version) -import HsLua as Lua -import HsLua.Module.Version (peekVersionFuzzy, pushVersion) -import Text.Pandoc.Citeproc (getReferences, processCitations) -import Text.Pandoc.Definition -import Text.Pandoc.Error (PandocError) -import Text.Pandoc.Lua.Marshal.AST -import Text.Pandoc.Lua.Marshal.Reference -import Text.Pandoc.Lua.PandocLua (PandocLua (unPandocLua)) - -import qualified Data.Digest.Pure.SHA as SHA -import qualified Data.ByteString.Lazy as BSL -import qualified Data.Map as Map -import qualified Data.Text as T -import qualified Text.Pandoc.Builder as B -import qualified Text.Pandoc.Filter.JSON as JSONFilter -import qualified Text.Pandoc.Shared as Shared -import qualified Text.Pandoc.UTF8 as UTF8 -import qualified Text.Pandoc.Writers.Shared as Shared - --- | Push the "pandoc.utils" module to the Lua stack. -documentedModule :: Module PandocError -documentedModule = Module - { moduleName = "pandoc.utils" - , moduleDescription = "pandoc utility functions" - , moduleFields = [] - , moduleOperations = [] - , moduleFunctions = - [ defun "blocks_to_inlines" - ### (\blks mSep -> do - let sep = maybe Shared.defaultBlocksSeparator B.fromList mSep - return $ B.toList (Shared.blocksToInlinesWithSep sep blks)) - <#> parameter (peekList peekBlock) "list of blocks" - "blocks" "" - <#> opt (parameter (peekList peekInline) "list of inlines" "inline" "") - =#> functionResult pushInlines "list of inlines" "" - - , defun "citeproc" - ### unPandocLua . processCitations - <#> parameter peekPandoc "Pandoc" "doc" "document" - =#> functionResult pushPandoc "Pandoc" "processed document" - #? T.unwords - [ "Process the citations in the file, replacing them with " - , "rendered citations and adding a bibliography. " - , "See the manual section on citation rendering for details." - ] - - , defun "equals" - ### equal - <#> parameter pure "AST element" "elem1" "" - <#> parameter pure "AST element" "elem2" "" - =#> functionResult pushBool "boolean" "true iff elem1 == elem2" - - , defun "make_sections" - ### liftPure3 Shared.makeSections - <#> parameter peekBool "boolean" "numbering" "add header numbers" - <#> parameter (\i -> (Nothing <$ peekNil i) <|> (Just <$!> peekIntegral i)) - "integer or nil" "baselevel" "" - <#> parameter (peekList peekBlock) "list of blocks" - "blocks" "document blocks to process" - =#> functionResult pushBlocks "list of Blocks" - "processes blocks" - - , defun "normalize_date" - ### liftPure Shared.normalizeDate - <#> parameter peekText "string" "date" "the date string" - =#> functionResult (maybe pushnil pushText) "string or nil" - "normalized date, or nil if normalization failed." - #? T.unwords - [ "Parse a date and convert (if possible) to \"YYYY-MM-DD\" format. We" - , "limit years to the range 1601-9999 (ISO 8601 accepts greater than" - , "or equal to 1583, but MS Word only accepts dates starting 1601)." - , "Returns nil instead of a string if the conversion failed." - ] - - , sha1 - - , defun "Version" - ### liftPure (id @Version) - <#> parameter peekVersionFuzzy - "version string, list of integers, or integer" - "v" "version description" - =#> functionResult pushVersion "Version" "new Version object" - #? "Creates a Version object." - - , defun "references" - ### (unPandocLua . getReferences Nothing) - <#> parameter peekPandoc "Pandoc" "doc" "document" - =#> functionResult (pushPandocList pushReference) "table" - "lift of references" - #? mconcat - [ "Get references defined inline in the metadata and via an external " - , "bibliography. Only references that are actually cited in the " - , "document (either with a genuine citation or with `nocite`) are " - , "returned. URL variables are converted to links." - ] - - , defun "run_json_filter" - ### (\doc filterPath margs -> do - args <- case margs of - Just xs -> return xs - Nothing -> do - Lua.getglobal "FORMAT" - (forcePeek ((:[]) <$!> peekString top) <* pop 1) - JSONFilter.apply def args filterPath doc - ) - <#> parameter peekPandoc "Pandoc" "doc" "input document" - <#> parameter peekString "filepath" "filter_path" "path to filter" - <#> opt (parameter (peekList peekString) "list of strings" - "args" "arguments to pass to the filter") - =#> functionResult pushPandoc "Pandoc" "filtered document" - - , defun "stringify" - ### stringify - <#> parameter pure "AST element" "elem" "some pandoc AST element" - =#> functionResult pushText "string" "stringified element" - - , defun "from_simple_table" - ### from_simple_table - <#> parameter peekSimpleTable "SimpleTable" "simple_tbl" "" - =?> "Simple table" - - , defun "to_roman_numeral" - ### liftPure Shared.toRomanNumeral - <#> parameter (peekIntegral @Int) "integer" "n" "number smaller than 4000" - =#> functionResult pushText "string" "roman numeral" - #? "Converts a number < 4000 to uppercase roman numeral." - - , defun "to_simple_table" - ### to_simple_table - <#> parameter peekTable "Block" "tbl" "a table" - =#> functionResult pushSimpleTable "SimpleTable" "SimpleTable object" - #? "Converts a table into an old/simple table." - - , defun "type" - ### (\idx -> getmetafield idx "__name" >>= \case - TypeString -> fromMaybe mempty <$> tostring top - _ -> ltype idx >>= typename) - <#> parameter pure "any" "object" "" - =#> functionResult pushByteString "string" "type of the given value" - #? ("Pandoc-friendly version of Lua's default `type` function, " <> - "returning the type of a value. If the argument has a " <> - "string-valued metafield `__name`, then it gives that string. " <> - "Otherwise it behaves just like the normal `type` function.") - ] - } - --- | Documented Lua function to compute the hash of a string. -sha1 :: DocumentedFunction e -sha1 = defun "sha1" - ### liftPure (SHA.showDigest . SHA.sha1) - <#> parameter (fmap BSL.fromStrict . peekByteString) "string" "input" "" - =#> functionResult pushString "string" "hexadecimal hash value" - #? "Compute the hash of the given string value." - - --- | Convert pandoc structure to a string with formatting removed. --- Footnotes are skipped (since we don't want their contents in link --- labels). -stringify :: LuaError e => StackIndex -> LuaE e T.Text -stringify idx = forcePeek . retrieving "stringifyable element" $ - choice - [ (fmap Shared.stringify . peekPandoc) - , (fmap Shared.stringify . peekInline) - , (fmap Shared.stringify . peekBlock) - , (fmap Shared.stringify . peekCitation) - , (fmap stringifyMetaValue . peekMetaValue) - , (fmap (const "") . peekAttr) - , (fmap (const "") . peekListAttributes) - ] idx - where - stringifyMetaValue :: MetaValue -> T.Text - stringifyMetaValue mv = case mv of - MetaBool b -> T.toLower $ T.pack (show b) - MetaString s -> s - MetaList xs -> mconcat $ map stringifyMetaValue xs - MetaMap m -> mconcat $ map (stringifyMetaValue . snd) (Map.toList m) - _ -> Shared.stringify mv - --- | Converts an old/simple table into a normal table block element. -from_simple_table :: SimpleTable -> LuaE PandocError NumResults -from_simple_table (SimpleTable capt aligns widths head' body) = do - Lua.push $ Table - nullAttr - (Caption Nothing [Plain capt | not (null capt)]) - (zipWith (\a w -> (a, toColWidth w)) aligns widths) - (TableHead nullAttr [blockListToRow head' | not (null head') ]) - [TableBody nullAttr 0 [] $ map blockListToRow body | not (null body)] - (TableFoot nullAttr []) - return (NumResults 1) - where - blockListToRow :: [[Block]] -> Row - blockListToRow = Row nullAttr . map (B.simpleCell . B.fromList) - - toColWidth :: Double -> ColWidth - toColWidth 0 = ColWidthDefault - toColWidth w = ColWidth w - --- | Converts a table into an old/simple table. -to_simple_table :: Block -> LuaE PandocError SimpleTable -to_simple_table = \case - Table _attr caption specs thead tbodies tfoot -> do - let (capt, aligns, widths, headers, rows) = - Shared.toLegacyTable caption specs thead tbodies tfoot - return $ SimpleTable capt aligns widths headers rows - blk -> Lua.failLua $ mconcat - [ "Expected Table, got ", showConstr (toConstr blk), "." ] - -peekTable :: LuaError e => Peeker e Block -peekTable idx = peekBlock idx >>= \case - t@(Table {}) -> return t - b -> Lua.failPeek $ mconcat - [ "Expected Table, got " - , UTF8.fromString $ showConstr (toConstr b) - , "." ] diff --git a/src/Text/Pandoc/Lua/Orphans.hs b/src/Text/Pandoc/Lua/Orphans.hs deleted file mode 100644 --- a/src/Text/Pandoc/Lua/Orphans.hs +++ /dev/null @@ -1,116 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE FlexibleInstances #-} -{- | - Module : Text.Pandoc.Lua.Orphans - Copyright : © 2012-2022 John MacFarlane - © 2017-2022 Albert Krewinkel - License : GNU GPL, version 2 or above - - Maintainer : Albert Krewinkel - Stability : alpha - -Orphan instances for Lua's Pushable and Peekable type classes. --} -module Text.Pandoc.Lua.Orphans () where - -import Data.Version (Version) -import HsLua -import HsLua.Module.Version (peekVersionFuzzy) -import Text.Pandoc.Definition -import Text.Pandoc.Lua.Marshal.AST -import Text.Pandoc.Lua.Marshal.CommonState () -import Text.Pandoc.Lua.Marshal.Context () -import Text.Pandoc.Lua.Marshal.PandocError() -import Text.Pandoc.Lua.Marshal.ReaderOptions () -import Text.Pandoc.Lua.Marshal.Sources (pushSources) -import Text.Pandoc.Lua.ErrorConversion () -import Text.Pandoc.Sources (Sources) - -instance Pushable Pandoc where - push = pushPandoc - -instance Pushable Meta where - push = pushMeta - -instance Pushable MetaValue where - push = pushMetaValue - -instance Pushable Block where - push = pushBlock - -instance {-# OVERLAPPING #-} Pushable [Block] where - push = pushBlocks - -instance Pushable Alignment where - push = pushString . show - -instance Pushable CitationMode where - push = pushCitationMode - -instance Pushable Format where - push = pushFormat - -instance Pushable ListNumberDelim where - push = pushString . show - -instance Pushable ListNumberStyle where - push = pushString . show - -instance Pushable MathType where - push = pushMathType - -instance Pushable QuoteType where - push = pushQuoteType - -instance Pushable Cell where - push = pushCell - -instance Pushable Inline where - push = pushInline - -instance {-# OVERLAPPING #-} Pushable [Inline] where - push = pushInlines - -instance Pushable Citation where - push = pushCitation - -instance Pushable Row where - push = pushRow - -instance Pushable TableBody where - push = pushTableBody - -instance Pushable TableFoot where - push = pushTableFoot - -instance Pushable TableHead where - push = pushTableHead - --- These instances exist only for testing. It's a hack to avoid making --- the marshalling modules public. -instance Peekable Inline where - safepeek = peekInline - -instance Peekable Block where - safepeek = peekBlock - -instance Peekable Cell where - safepeek = peekCell - -instance Peekable Meta where - safepeek = peekMeta - -instance Peekable Pandoc where - safepeek = peekPandoc - -instance Peekable Row where - safepeek = peekRow - -instance Peekable Version where - safepeek = peekVersionFuzzy - -instance {-# OVERLAPPING #-} Peekable Attr where - safepeek = peekAttr - -instance Pushable Sources where - push = pushSources diff --git a/src/Text/Pandoc/Lua/PandocLua.hs b/src/Text/Pandoc/Lua/PandocLua.hs deleted file mode 100644 --- a/src/Text/Pandoc/Lua/PandocLua.hs +++ /dev/null @@ -1,113 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -{- | - Module : Text.Pandoc.Lua.PandocLua - Copyright : Copyright © 2020-2022 Albert Krewinkel - License : GNU GPL, version 2 or above - - Maintainer : Albert Krewinkel - Stability : alpha - -PandocMonad instance which allows execution of Lua operations and which -uses Lua to handle state. --} -module Text.Pandoc.Lua.PandocLua - ( PandocLua (..) - , runPandocLua - , liftPandocLua - ) where - -import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow) -import Control.Monad.Except (MonadError (catchError, throwError)) -import Control.Monad.IO.Class (MonadIO) -import HsLua as Lua -import Text.Pandoc.Class.PandocMonad (PandocMonad (..)) -import Text.Pandoc.Error (PandocError) -import Text.Pandoc.Lua.Global (Global (..), setGlobals) -import Text.Pandoc.Lua.Marshal.CommonState (peekCommonState) - -import qualified Control.Monad.Catch as Catch -import qualified Text.Pandoc.Class.IO as IO - --- | Type providing access to both, pandoc and Lua operations. -newtype PandocLua a = PandocLua { unPandocLua :: LuaE PandocError a } - deriving - ( Applicative - , Functor - , Monad - , MonadCatch - , MonadIO - , MonadMask - , MonadThrow - ) - --- | Lift a @'Lua'@ operation into the @'PandocLua'@ type. -liftPandocLua :: LuaE PandocError a -> PandocLua a -liftPandocLua = PandocLua - --- | Evaluate a @'PandocLua'@ computation, running all contained Lua --- operations.. -runPandocLua :: (PandocMonad m, MonadIO m) => PandocLua a -> m a -runPandocLua pLua = do - origState <- getCommonState - globals <- defaultGlobals - (result, newState) <- liftIO . Lua.run . unPandocLua $ do - putCommonState origState - liftPandocLua $ setGlobals globals - r <- pLua - c <- getCommonState - return (r, c) - putCommonState newState - return result - -instance {-# OVERLAPPING #-} Exposable PandocError (PandocLua NumResults) where - partialApply _narg = liftLua . unPandocLua - -instance Pushable a => Exposable PandocError (PandocLua a) where - partialApply _narg x = 1 <$ (liftLua (unPandocLua x >>= Lua.push)) - --- | Global variables which should always be set. -defaultGlobals :: PandocMonad m => m [Global] -defaultGlobals = do - commonState <- getCommonState - return - [ PANDOC_API_VERSION - , PANDOC_STATE commonState - , PANDOC_VERSION - ] - -instance MonadError PandocError PandocLua where - catchError = Catch.catch - throwError = Catch.throwM - -instance PandocMonad PandocLua where - lookupEnv = IO.lookupEnv - getCurrentTime = IO.getCurrentTime - getCurrentTimeZone = IO.getCurrentTimeZone - newStdGen = IO.newStdGen - newUniqueHash = IO.newUniqueHash - - openURL = IO.openURL - - readFileLazy = IO.readFileLazy - readFileStrict = IO.readFileStrict - readStdinStrict = IO.readStdinStrict - - glob = IO.glob - fileExists = IO.fileExists - getDataFileName = IO.getDataFileName - getModificationTime = IO.getModificationTime - - getCommonState = PandocLua $ do - Lua.getglobal "PANDOC_STATE" - forcePeek $ peekCommonState Lua.top - putCommonState = PandocLua . setGlobals . (:[]) . PANDOC_STATE - - logOutput = IO.logOutput diff --git a/src/Text/Pandoc/Lua/Writer/Classic.hs b/src/Text/Pandoc/Lua/Writer/Classic.hs deleted file mode 100644 --- a/src/Text/Pandoc/Lua/Writer/Classic.hs +++ /dev/null @@ -1,250 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{- | - Module : Text.Pandoc.Lua.Writer.Classic - Copyright : Copyright (C) 2012-2022 John MacFarlane - License : GNU GPL, version 2 or above - - Maintainer : John MacFarlane - Stability : alpha - Portability : portable - -Conversion of Pandoc documents using a \"classic\" custom Lua writer. --} -module Text.Pandoc.Lua.Writer.Classic - ( runCustom - ) where -import Control.Applicative (optional) -import Control.Arrow ((***)) -import Data.List (intersperse) -import Data.Maybe (fromMaybe) -import qualified Data.Text as T -import Data.Text (Text, pack) -import HsLua as Lua hiding (Operation (Div)) -#if !MIN_VERSION_hslua(2,2,0) -import HsLua.Aeson (peekViaJSON) -#endif -import Text.DocLayout (literal, render) -import Text.DocTemplates (Context) -import Text.Pandoc.Definition -import Text.Pandoc.Lua.Marshal.Attr (pushAttributeList) -import Text.Pandoc.Lua.Orphans () -import Text.Pandoc.Options -import Text.Pandoc.Templates (renderTemplate) -import Text.Pandoc.Writers.Shared - --- | List of key-value pairs that is pushed to Lua as AttributeList --- userdata. -newtype AttributeList = AttributeList [(Text, Text)] -instance Pushable AttributeList where - push (AttributeList kvs) = pushAttributeList kvs - -attrToMap :: Attr -> AttributeList -attrToMap (id',classes,keyvals) = AttributeList - $ ("id", id') - : ("class", T.unwords classes) - : keyvals - -newtype Stringify a = Stringify a - -instance Pushable (Stringify Format) where - push (Stringify (Format f)) = Lua.push (T.toLower f) - -instance Pushable (Stringify [Inline]) where - push (Stringify ils) = Lua.push =<< inlineListToCustom ils - -instance Pushable (Stringify [Block]) where - push (Stringify blks) = Lua.push =<< blockListToCustom blks - -instance Pushable (Stringify MetaValue) where - push (Stringify (MetaMap m)) = Lua.push (fmap Stringify m) - push (Stringify (MetaList xs)) = Lua.push (map Stringify xs) - push (Stringify (MetaBool x)) = Lua.push x - push (Stringify (MetaString s)) = Lua.push s - push (Stringify (MetaInlines ils)) = Lua.push (Stringify ils) - push (Stringify (MetaBlocks bs)) = Lua.push (Stringify bs) - -instance Pushable (Stringify Citation) where - push (Stringify cit) = flip pushAsTable cit - [ ("citationId", push . citationId) - , ("citationPrefix", push . Stringify . citationPrefix) - , ("citationSuffix", push . Stringify . citationSuffix) - , ("citationMode", push . citationMode) - , ("citationNoteNum", push . citationNoteNum) - , ("citationHash", push . citationHash) - ] - --- | Key-value pair, pushed as a table with @a@ as the only key and @v@ as the --- associated value. -newtype KeyValue a b = KeyValue (a, b) - -instance (Pushable a, Pushable b) => Pushable (KeyValue a b) where - push (KeyValue (k, v)) = do - Lua.newtable - Lua.push k - Lua.push v - Lua.rawset (Lua.nth 3) - --- | Convert Pandoc to custom markup using a classic Lua writer. -runCustom :: LuaError e - => WriterOptions - -> Pandoc - -> LuaE e Text -runCustom opts doc@(Pandoc meta _) = do - (body, context) <- docToCustom opts doc - -- convert metavalues to a template context (variables) - metaContext <- metaToContext opts - (fmap (literal . pack) . blockListToCustom) - (fmap (literal . pack) . inlineListToCustom) - meta - -- merge contexts from metadata and variables - let renderContext = context <> metaContext - return $ case writerTemplate opts of - Nothing -> body - Just tpl -> render Nothing $ - renderTemplate tpl $ setField "body" body renderContext - --- | Converts a Pandoc value to custom markup using a classic Lua writer. -docToCustom :: forall e. LuaError e - => WriterOptions -> Pandoc -> LuaE e (Text, Context Text) -docToCustom opts (Pandoc (Meta metamap) blocks) = do - body <- blockListToCustom blocks - -- invoke doesn't work with multiple return values, so we have to call - -- `Doc` manually. - Lua.getglobal "Doc" -- function - push body -- argument 1 - push (fmap Stringify metamap) -- argument 2 - push (writerVariables opts) -- argument 3 - call 3 2 - rendered <- peek (nth 2) -- first return value - context <- forcePeek . optional $ peekViaJSON top -- snd return value - return (rendered, fromMaybe mempty context) - - --- | Convert Pandoc block element to Custom. -blockToCustom :: forall e. LuaError e - => Block -- ^ Block element - -> LuaE e String - -blockToCustom Null = return "" - -blockToCustom (Plain inlines) = invoke "Plain" (Stringify inlines) - -blockToCustom (Para [Image attr txt (src,tit)]) = - invoke "CaptionedImage" src tit (Stringify txt) (attrToMap attr) - -blockToCustom (Para inlines) = invoke "Para" (Stringify inlines) - -blockToCustom (LineBlock linesList) = - invoke "LineBlock" (map (Stringify) linesList) - -blockToCustom (RawBlock format str) = - invoke "RawBlock" (Stringify format) str - -blockToCustom HorizontalRule = invoke "HorizontalRule" - -blockToCustom (Header level attr inlines) = - invoke "Header" level (Stringify inlines) (attrToMap attr) - -blockToCustom (CodeBlock attr str) = - invoke "CodeBlock" str (attrToMap attr) - -blockToCustom (BlockQuote blocks) = - invoke "BlockQuote" (Stringify blocks) - -blockToCustom (Table _ blkCapt specs thead tbody tfoot) = - let (capt, aligns, widths, headers, rows) = toLegacyTable blkCapt specs thead tbody tfoot - aligns' = map show aligns - capt' = Stringify capt - headers' = map (Stringify) headers - rows' = map (map (Stringify)) rows - in invoke "Table" capt' aligns' widths headers' rows' - -blockToCustom (BulletList items) = - invoke "BulletList" (map (Stringify) items) - -blockToCustom (OrderedList (num,sty,delim) items) = - invoke "OrderedList" (map (Stringify) items) num (show sty) (show delim) - -blockToCustom (DefinitionList items) = - invoke "DefinitionList" - (map (KeyValue . (Stringify *** map (Stringify))) items) - -blockToCustom (Div attr items) = - invoke "Div" (Stringify items) (attrToMap attr) - --- | Convert list of Pandoc block elements to Custom. -blockListToCustom :: forall e. LuaError e - => [Block] -- ^ List of block elements - -> LuaE e String -blockListToCustom xs = do - blocksep <- invoke "Blocksep" - bs <- mapM blockToCustom xs - return $ mconcat $ intersperse blocksep bs - --- | Convert list of Pandoc inline elements to Custom. -inlineListToCustom :: forall e. LuaError e => [Inline] -> LuaE e String -inlineListToCustom lst = do - xs <- mapM (inlineToCustom @e) lst - return $ mconcat xs - --- | Convert Pandoc inline element to Custom. -inlineToCustom :: forall e. LuaError e => Inline -> LuaE e String - -inlineToCustom (Str str) = invoke "Str" str - -inlineToCustom Space = invoke "Space" - -inlineToCustom SoftBreak = invoke "SoftBreak" - -inlineToCustom (Emph lst) = invoke "Emph" (Stringify lst) - -inlineToCustom (Underline lst) = invoke "Underline" (Stringify lst) - -inlineToCustom (Strong lst) = invoke "Strong" (Stringify lst) - -inlineToCustom (Strikeout lst) = invoke "Strikeout" (Stringify lst) - -inlineToCustom (Superscript lst) = invoke "Superscript" (Stringify lst) - -inlineToCustom (Subscript lst) = invoke "Subscript" (Stringify lst) - -inlineToCustom (SmallCaps lst) = invoke "SmallCaps" (Stringify lst) - -inlineToCustom (Quoted SingleQuote lst) = - invoke "SingleQuoted" (Stringify lst) - -inlineToCustom (Quoted DoubleQuote lst) = - invoke "DoubleQuoted" (Stringify lst) - -inlineToCustom (Cite cs lst) = - invoke "Cite" (Stringify lst) (map (Stringify) cs) - -inlineToCustom (Code attr str) = - invoke "Code" str (attrToMap attr) - -inlineToCustom (Math DisplayMath str) = - invoke "DisplayMath" str - -inlineToCustom (Math InlineMath str) = - invoke "InlineMath" str - -inlineToCustom (RawInline format str) = - invoke "RawInline" (Stringify format) str - -inlineToCustom LineBreak = invoke "LineBreak" - -inlineToCustom (Link attr txt (src,tit)) = - invoke "Link" (Stringify txt) src tit (attrToMap attr) - -inlineToCustom (Image attr alt (src,tit)) = - invoke "Image" (Stringify alt) src tit (attrToMap attr) - -inlineToCustom (Note contents) = invoke "Note" (Stringify contents) - -inlineToCustom (Span attr items) = - invoke "Span" (Stringify items) (attrToMap attr) diff --git a/src/Text/Pandoc/MIME.hs b/src/Text/Pandoc/MIME.hs --- a/src/Text/Pandoc/MIME.hs +++ b/src/Text/Pandoc/MIME.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.MIME - Copyright : Copyright (C) 2011-2022 John MacFarlane + Copyright : Copyright (C) 2011-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane @@ -20,8 +20,10 @@ import Data.List (isPrefixOf, isSuffixOf) import qualified Data.Map as M import qualified Data.Text as T +import qualified Data.Text.Encoding as T import Data.Maybe (fromMaybe, listToMaybe) import Data.Tuple (swap) +import qualified Network.Mime import System.FilePath type MimeType = T.Text @@ -81,37 +83,17 @@ -- Except for first entry, list borrowed from -- mimeTypesList :: [(T.Text, MimeType)] -mimeTypesList = - [("cpt","image/x-corelphotopaint") - ,("gz","application/x-gzip") - ,("cabal","application/x-cabal") - ,("%","application/x-trash") +mimeTypesList = M.toList (M.map T.decodeUtf8 Network.Mime.defaultMimeMap) ++ + [("%","application/x-trash") ,("323","text/h323") - ,("3gp","video/3gpp") - ,("7z","application/x-7z-compressed") - ,("abw","application/x-abiword") - ,("ai","application/postscript") - ,("aif","audio/x-aiff") - ,("aifc","audio/x-aiff") - ,("aiff","audio/x-aiff") ,("alc","chemical/x-alchemy") ,("art","image/x-jg") - ,("asc","text/plain") - ,("asf","video/x-ms-asf") ,("asn","chemical/x-ncbi-asn1") ,("aso","chemical/x-ncbi-asn1-binary") - ,("asx","video/x-ms-asf") - ,("atom","application/atom") - ,("atomcat","application/atomcat+xml") ,("atomsrv","application/atomserv+xml") - ,("au","audio/basic") - ,("avi","video/x-msvideo") ,("b","chemical/x-molconn-Z") ,("bak","application/x-trash") ,("bat","application/x-msdos-program") - ,("bcpio","application/x-bcpio") - ,("bib","text/x-bibtex") - ,("bin","application/octet-stream") ,("bmp","image/x-ms-bmp") ,("boo","text/x-boo") ,("book","application/x-maker") @@ -119,89 +101,55 @@ ,("c","text/x-csrc") ,("c++","text/x-c++src") ,("c3d","chemical/x-chem3d") - ,("cab","application/x-cab") + ,("cabal","application/x-cabal") ,("cac","chemical/x-cache") ,("cache","chemical/x-cache") - ,("cap","application/cap") ,("cascii","chemical/x-cactvs-binary") - ,("cat","application/vnd.ms-pki.seccat") ,("cbin","chemical/x-cactvs-binary") - ,("cbr","application/x-cbr") ,("cbz","application/x-cbz") ,("cc","text/x-c++src") ,("cdf","application/x-cdf") ,("cdr","image/x-coreldraw") ,("cdt","image/x-coreldrawtemplate") - ,("cdx","chemical/x-cdx") - ,("cdy","application/vnd.cinderella") ,("cef","chemical/x-cxf") ,("cer","chemical/x-cerius") ,("chm","chemical/x-chemdraw") ,("chrt","application/x-kchart") - ,("cif","chemical/x-cif") - ,("class","application/java-vm") - ,("cls","text/x-tex") - ,("cmdf","chemical/x-cmdf") - ,("cml","chemical/x-cml") - ,("cod","application/vnd.rim.cod") ,("com","application/x-msdos-program") ,("cpa","chemical/x-compass") - ,("cpio","application/x-cpio") ,("cpp","text/x-c++src") - ,("cpt","application/mac-compactpro") + ,("cpt","image/x-corelphotopaint") ,("crl","application/x-pkcs7-crl") - ,("crt","application/x-x509-ca-cert") ,("csf","chemical/x-cache-csf") - ,("csh","application/x-csh") ,("csm","chemical/x-csml") - ,("csml","chemical/x-csml") - ,("css","text/css") - ,("csv","text/csv") ,("ctab","chemical/x-cactvs-binary") ,("ctx","chemical/x-ctx") - ,("cu","application/cu-seeme") ,("cub","chemical/x-gaussian-cube") ,("cxf","chemical/x-cxf") ,("cxx","text/x-c++src") ,("d","text/x-dsrc") ,("dat","chemical/x-mopac-input") - ,("dcr","application/x-director") - ,("deb","application/x-debian-package") ,("dif","video/dv") ,("diff","text/x-diff") - ,("dir","application/x-director") - ,("djv","image/vnd.djvu") - ,("djvu","image/vnd.djvu") ,("dl","video/dl") ,("dll","application/x-msdos-program") - ,("dmg","application/x-apple-diskimage") ,("dms","application/x-dms") - ,("doc","application/msword") - ,("dot","application/msword") - ,("dv","video/dv") - ,("dvi","application/x-dvi") ,("dx","chemical/x-jcamp-dx") - ,("dxr","application/x-director") ,("emb","chemical/x-embl-dl-nucleotide") ,("embl","chemical/x-embl-dl-nucleotide") ,("emf","image/x-emf") - ,("emz","application/x-msmetafile") - ,("eml","message/rfc822") ,("ent","chemical/x-ncbi-asn1-ascii") - ,("eot","application/vnd.ms-fontobject") + + -- The type used in mime-types is `application/postscript`, + -- but code in Text.Pandoc.PDF relies on the type being + -- `application/eps`. Do not remove without updating that + -- module. ,("eps","application/eps") - ,("etx","text/x-setext") - ,("exe","application/x-msdos-program") - ,("ez","application/andrew-inset") + ,("fb","application/x-maker") ,("fbdoc","application/x-maker") ,("fch","chemical/x-gaussian-checkpoint") ,("fchk","chemical/x-gaussian-checkpoint") - ,("fig","application/x-xfig") - ,("flac","application/x-flac") - ,("fli","video/fli") - ,("fm","application/x-maker") - ,("frame","application/x-maker") ,("frm","application/x-maker") ,("fs","text/plain") ,("gal","chemical/x-gaussian-log") @@ -212,164 +160,66 @@ ,("gcf","application/x-graphing-calculator") ,("gcg","chemical/x-gcg8-sequence") ,("gen","chemical/x-genbank") - ,("gf","application/x-tex-gf") - ,("gif","image/gif") ,("gjc","chemical/x-gaussian-input") ,("gjf","chemical/x-gaussian-input") ,("gl","video/gl") ,("glsl","text/plain") - ,("gnumeric","application/x-gnumeric") ,("gpt","chemical/x-mopac-graph") - ,("gsf","application/x-font") ,("gsm","audio/x-gsm") - ,("gtar","application/x-gtar") ,("h","text/x-chdr") ,("h++","text/x-c++hdr") - ,("hdf","application/x-hdf") ,("hh","text/x-c++hdr") ,("hin","chemical/x-hin") ,("hpp","text/x-c++hdr") - ,("hqx","application/mac-binhex40") ,("hs","text/x-haskell") ,("hta","application/hta") - ,("htc","text/x-component") - ,("htm","text/html") - ,("html","text/html") ,("hxx","text/x-c++hdr") ,("ica","application/x-ica") - ,("ice","x-conference/x-cooltalk") - ,("ico","image/x-icon") - ,("ics","text/calendar") ,("icz","text/calendar") - ,("ief","image/ief") - ,("iges","model/iges") - ,("igs","model/iges") ,("iii","application/x-iphone") ,("inp","chemical/x-gamess-input") ,("ins","application/x-internet-signup") - ,("iso","application/x-iso9660-image") ,("isp","application/x-internet-signup") ,("ist","chemical/x-isostar") ,("istr","chemical/x-isostar") - ,("jad","text/vnd.sun.j2me.app-descriptor") - ,("jar","application/java-archive") - ,("java","text/x-java") ,("jdx","chemical/x-jcamp-dx") - ,("jmz","application/x-jmol") - ,("jng","image/x-jng") - ,("jnlp","application/x-java-jnlp-file") - ,("jpe","image/jpeg") - ,("jpeg","image/jpeg") ,("jfif","image/jpeg") - ,("jpg","image/jpeg") - ,("js","application/javascript") - ,("kar","audio/midi") + ,("jmz","application/x-jmol") ,("key","application/pgp-keys") ,("kil","application/x-killustrator") ,("kin","chemical/x-kinemage") - ,("kml","application/vnd.google-earth.kml+xml") - ,("kmz","application/vnd.google-earth.kmz") - ,("kpr","application/x-kpresenter") - ,("kpt","application/x-kpresenter") - ,("ksp","application/x-kspread") - ,("kwd","application/x-kword") - ,("kwt","application/x-kword") - ,("latex","application/x-latex") - ,("lha","application/x-lha") ,("lhs","text/x-literate-haskell") ,("lsf","video/x-la-asf") ,("lsx","video/x-la-asf") - ,("ltx","text/x-tex") ,("lyx","application/x-lyx") ,("lzh","application/x-lzh") ,("lzx","application/x-lzx") - ,("m3u","audio/mpegurl") - ,("m4a","audio/mpeg") - ,("m4v","video/x-m4v") - ,("maker","application/x-maker") ,("man","application/x-troff-man") ,("mcif","chemical/x-mmcif") ,("mcm","chemical/x-macmolecule") ,("mdb","application/msaccess") ,("me","application/x-troff-me") - ,("mesh","model/mesh") - ,("mid","audio/midi") - ,("midi","audio/midi") - ,("mif","application/x-mif") - ,("mkv","video/x-matroska") ,("mm","application/x-freemind") ,("mmd","chemical/x-macromodel-input") - ,("mmf","application/vnd.smaf") - ,("mml","text/mathml") ,("mmod","chemical/x-macromodel-input") - ,("mng","video/x-mng") ,("moc","text/x-moc") ,("mol","chemical/x-mdl-molfile") ,("mol2","chemical/x-mol2") ,("moo","chemical/x-mopac-out") ,("mop","chemical/x-mopac-input") ,("mopcrt","chemical/x-mopac-input") - ,("mov","video/quicktime") - ,("movie","video/x-sgi-movie") - ,("mp2","audio/mpeg") - ,("mp3","audio/mpeg") - ,("mp4","video/mp4") ,("mpc","chemical/x-mopac-input") - ,("mpe","video/mpeg") - ,("mpeg","video/mpeg") ,("mpega","audio/mpeg") - ,("mpg","video/mpeg") - ,("mpga","audio/mpeg") ,("ms","application/x-troff-ms") - ,("msh","model/mesh") ,("msi","application/x-msi") ,("mvb","chemical/x-mopac-vib") - ,("mxu","video/vnd.mpegurl") - ,("nb","application/mathematica") - ,("nc","application/x-netcdf") ,("nwc","application/x-nwc") ,("o","application/x-object") - ,("oda","application/oda") - ,("odb","application/vnd.oasis.opendocument.database") - ,("odc","application/vnd.oasis.opendocument.chart") - ,("odf","application/vnd.oasis.opendocument.formula") - ,("odg","application/vnd.oasis.opendocument.graphics") - ,("odi","application/vnd.oasis.opendocument.image") - ,("odm","application/vnd.oasis.opendocument.text-master") - ,("odp","application/vnd.oasis.opendocument.presentation") - ,("ods","application/vnd.oasis.opendocument.spreadsheet") - ,("odt","application/vnd.oasis.opendocument.text") - ,("oga","audio/ogg") - ,("ogg","application/ogg") - ,("ogv","video/ogg") - ,("ogx","application/ogg") ,("old","application/x-trash") - ,("opus","audio/ogg") - ,("otg","application/vnd.oasis.opendocument.graphics-template") - ,("oth","application/vnd.oasis.opendocument.text-web") - ,("otp","application/vnd.oasis.opendocument.presentation-template") - ,("ots","application/vnd.oasis.opendocument.spreadsheet-template") - ,("otf","font/otf") - ,("ott","application/vnd.oasis.opendocument.text-template") ,("oza","application/x-oz-application") - ,("p","text/x-pascal") - ,("p7r","application/x-pkcs7-certreqresp") - ,("pac","application/x-ns-proxy-autoconfig") - ,("pas","text/x-pascal") ,("pat","image/x-coreldrawpattern") ,("patch","text/x-diff") - ,("pbm","image/x-portable-bitmap") - ,("pcap","application/cap") - ,("pcf","application/x-font") - ,("pcf.Z","application/x-font") - ,("pcx","image/pcx") ,("pdb","chemical/x-pdb") - ,("pdf","application/pdf") - ,("pfa","application/x-font") - ,("pfb","application/x-font") - ,("pgm","image/x-portable-graymap") - ,("pgn","application/x-chess-pgn") - ,("pgp","application/pgp-signature") ,("php","application/x-httpd-php") ,("php3","application/x-httpd-php3") ,("php3p","application/x-httpd-php3-preprocessed") @@ -378,171 +228,46 @@ ,("pht","application/x-httpd-php") ,("phtml","application/x-httpd-php") ,("pk","application/x-tex-pk") - ,("pl","text/x-perl") ,("pls","audio/x-scpls") - ,("pm","text/x-perl") - ,("png","image/png") - ,("pnm","image/x-portable-anymap") ,("pot","text/plain") - ,("ppm","image/x-portable-pixmap") - ,("pps","application/vnd.ms-powerpoint") - ,("ppt","application/vnd.ms-powerpoint") - ,("prf","application/pics-rules") ,("prt","chemical/x-ncbi-asn1-ascii") - ,("ps","application/postscript") - ,("psd","image/x-photoshop") ,("py","text/x-python") ,("pyc","application/x-python-code") ,("pyo","application/x-python-code") - ,("qt","video/quicktime") ,("qtl","application/x-quicktimeplayer") - ,("ra","audio/x-pn-realaudio") - ,("ram","audio/x-pn-realaudio") - ,("rar","application/rar") - ,("ras","image/x-cmu-raster") ,("rd","chemical/x-mdl-rdfile") - ,("rdf","application/rdf+xml") - ,("rgb","image/x-rgb") ,("rhtml","application/x-httpd-eruby") ,("rm","audio/x-pn-realaudio") - ,("roff","application/x-troff") ,("ros","chemical/x-rosdal") - ,("rpm","application/x-redhat-package-manager") - ,("rss","application/rss+xml") - ,("rtf","application/rtf") - ,("rtx","text/richtext") ,("rxn","chemical/x-mdl-rxnfile") ,("sct","text/scriptlet") ,("sd","chemical/x-mdl-sdfile") ,("sd2","audio/x-sd2") - ,("sda","application/vnd.stardivision.draw") - ,("sdc","application/vnd.stardivision.calc") - ,("sdd","application/vnd.stardivision.impress") ,("sdf","application/vnd.stardivision.math") ,("sds","application/vnd.stardivision.chart") - ,("sdw","application/vnd.stardivision.writer") - ,("ser","application/java-serialized-object") ,("sgf","application/x-go-sgf") - ,("sgl","application/vnd.stardivision.writer-global") - ,("sh","application/x-sh") - ,("shar","application/x-shar") - ,("shtml","text/html") ,("sid","audio/prs.sid") ,("sik","application/x-trash") - ,("silo","model/mesh") - ,("sis","application/vnd.symbian.install") - ,("sisx","x-epoc/x-sisx-app") - ,("sit","application/x-stuffit") - ,("sitx","application/x-stuffit") - ,("skd","application/x-koan") - ,("skm","application/x-koan") - ,("skp","application/x-koan") - ,("skt","application/x-koan") - ,("smi","application/smil") - ,("smil","application/smil") - ,("snd","audio/basic") ,("spc","chemical/x-galactic-spc") - ,("spl","application/futuresplash") - ,("spx","audio/ogg") - ,("src","application/x-wais-source") - ,("stc","application/vnd.sun.xml.calc.template") - ,("std","application/vnd.sun.xml.draw.template") - ,("sti","application/vnd.sun.xml.impress.template") - ,("stl","application/vnd.ms-pki.stl") - ,("stw","application/vnd.sun.xml.writer.template") - ,("sty","text/x-tex") - ,("sv4cpio","application/x-sv4cpio") - ,("sv4crc","application/x-sv4crc") - ,("svg","image/svg+xml") - -- removed for now, since it causes problems with - -- extensionFromMimeType: see #2183. - -- ,("svgz","image/svg+xml") ,("sw","chemical/x-swissprot") - ,("swf","application/x-shockwave-flash") ,("swfl","application/x-shockwave-flash") - ,("sxc","application/vnd.sun.xml.calc") - ,("sxd","application/vnd.sun.xml.draw") - ,("sxg","application/vnd.sun.xml.writer.global") - ,("sxi","application/vnd.sun.xml.impress") - ,("sxm","application/vnd.sun.xml.math") - ,("sxw","application/vnd.sun.xml.writer") - ,("t","application/x-troff") - ,("tar","application/x-tar") ,("taz","application/x-gtar") - ,("tcl","application/x-tcl") - ,("tex","text/x-tex") - ,("texi","application/x-texinfo") - ,("texinfo","application/x-texinfo") - ,("text","text/plain") ,("tgf","chemical/x-mdl-tgf") - ,("tgz","application/x-gtar") - ,("tif","image/tiff") - ,("tiff","image/tiff") - ,("tk","text/x-tcl") ,("tm","text/texmacs") - ,("torrent","application/x-bittorrent") - ,("tr","application/x-troff") ,("ts","text/texmacs") ,("tsp","application/dsptype") - ,("tsv","text/tab-separated-values") - ,("ttf","font/ttf") - ,("txt","text/plain") - ,("udeb","application/x-debian-package") - ,("uls","text/iuls") - ,("ustar","application/x-ustar") ,("val","chemical/x-ncbi-asn1-binary") - ,("vcd","application/x-cdlink") - ,("vcf","text/x-vcard") - ,("vcs","text/x-vcalendar") ,("vmd","chemical/x-vmd") ,("vms","chemical/x-vamas-iso14976") ,("vrm","x-world/x-vrml") - ,("vrml","model/vrml") ,("vs","text/plain") - ,("vsd","application/vnd.visio") - ,("vtt","text/vtt") - ,("wad","application/x-doom") - ,("wav","audio/x-wav") - ,("wax","audio/x-ms-wax") - ,("wbmp","image/vnd.wap.wbmp") - ,("wbxml","application/vnd.wap.wbxml") - ,("webm","video/webm") - ,("webp","image/webp") ,("wk","application/x-123") - ,("wm","video/x-ms-wm") - ,("wma","audio/x-ms-wma") - ,("wmd","application/x-ms-wmd") ,("wmf","image/x-wmf") - ,("wml","text/vnd.wap.wml") - ,("wmlc","application/vnd.wap.wmlc") - ,("wmls","text/vnd.wap.wmlscript") - ,("wmlsc","application/vnd.wap.wmlscriptc") - ,("wmv","video/x-ms-wmv") - ,("wmx","video/x-ms-wmx") ,("wmz","application/x-ms-wmz") - ,("woff","font/woff") - ,("woff2","font/woff2") ,("wp5","application/wordperfect5.1") - ,("wpd","application/wordperfect") - ,("wrl","model/vrml") ,("wsc","text/scriptlet") - ,("wvx","video/x-ms-wvx") ,("wz","application/x-wingz") - ,("xbm","image/x-xbitmap") - ,("xcf","image/x-xcf") - ,("xht","application/xhtml+xml") - ,("xhtml","application/xhtml+xml") ,("xlb","application/vnd.ms-excel") - ,("xls","application/vnd.ms-excel") - ,("xlt","application/vnd.ms-excel") - ,("xml","application/xml") - ,("xpi","application/x-xpinstall") - ,("xpm","image/x-xpixmap") - ,("xsl","application/xml") ,("xtel","chemical/x-xtel") - ,("xul","application/vnd.mozilla.xul+xml") - ,("xwd","image/x-xwindowdump") - ,("xyz","chemical/x-xyz") - ,("zip","application/zip") ,("zmt","chemical/x-mopac-input") ] diff --git a/src/Text/Pandoc/MediaBag.hs b/src/Text/Pandoc/MediaBag.hs --- a/src/Text/Pandoc/MediaBag.hs +++ b/src/Text/Pandoc/MediaBag.hs @@ -4,7 +4,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {- | Module : Text.Pandoc.MediaBag - Copyright : Copyright (C) 2014-2015, 2017-2022 John MacFarlane + Copyright : Copyright (C) 2014-2015, 2017-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane diff --git a/src/Text/Pandoc/Network/HTTP.hs b/src/Text/Pandoc/Network/HTTP.hs deleted file mode 100644 --- a/src/Text/Pandoc/Network/HTTP.hs +++ /dev/null @@ -1,18 +0,0 @@ -{- | - Module : Text.Pandoc.Writers.Markdown.Inline - Copyright : Copyright (C) 2006-2022 John MacFarlane - License : GNU GPL, version 2 or above - - Maintainer : John MacFarlane - Stability : alpha - Portability : portable --} -module Text.Pandoc.Network.HTTP ( - urlEncode - ) where -import qualified Network.HTTP.Types as HTTP -import qualified Text.Pandoc.UTF8 as UTF8 -import qualified Data.Text as T - -urlEncode :: T.Text -> T.Text -urlEncode = UTF8.toText . HTTP.urlEncode True . UTF8.fromText diff --git a/src/Text/Pandoc/Options.hs b/src/Text/Pandoc/Options.hs --- a/src/Text/Pandoc/Options.hs +++ b/src/Text/Pandoc/Options.hs @@ -6,7 +6,7 @@ {-# LANGUAGE TemplateHaskell #-} {- | Module : Text.Pandoc.Options - Copyright : Copyright (C) 2012-2022 John MacFarlane + Copyright : Copyright (C) 2012-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane @@ -312,10 +312,12 @@ , writerHighlightStyle :: Maybe Style -- ^ Style to use for highlighting -- (Nothing = no highlighting) , writerSetextHeaders :: Bool -- ^ Use setext headers for levels 1-2 in markdown + , writerListTables :: Bool -- ^ Use list tables for RST tables , writerEpubSubdirectory :: Text -- ^ Subdir for epub in OCF , writerEpubMetadata :: Maybe Text -- ^ Metadata to include in EPUB , writerEpubFonts :: [FilePath] -- ^ Paths to fonts to embed - , writerEpubChapterLevel :: Int -- ^ Header level for chapters (separate files) + , writerEpubTitlePage :: Bool -- ^ Include title page in epub + , writerSplitLevel :: Int -- ^ Header level at which to split EPUB or chunked HTML into separate files , writerTOCDepth :: Int -- ^ Number of levels to include in TOC , writerReferenceDoc :: Maybe FilePath -- ^ Path to reference document if specified , writerReferenceLocation :: ReferenceLocation -- ^ Location of footnotes and references for writing markdown @@ -347,10 +349,12 @@ , writerListings = False , writerHighlightStyle = Just pygments , writerSetextHeaders = False + , writerListTables = False , writerEpubSubdirectory = "EPUB" , writerEpubMetadata = Nothing , writerEpubFonts = [] - , writerEpubChapterLevel = 1 + , writerEpubTitlePage = True + , writerSplitLevel = 1 , writerTOCDepth = 3 , writerReferenceDoc = Nothing , writerReferenceLocation = EndOfDocument diff --git a/src/Text/Pandoc/PDF.hs b/src/Text/Pandoc/PDF.hs --- a/src/Text/Pandoc/PDF.hs +++ b/src/Text/Pandoc/PDF.hs @@ -5,7 +5,7 @@ {-# LANGUAGE FlexibleContexts #-} {- | Module : Text.Pandoc.PDF - Copyright : Copyright (C) 2012-2022 John MacFarlane + Copyright : Copyright (C) 2012-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane @@ -61,6 +61,7 @@ readFileLazy, readFileStrict, fileExists, report, extractMedia, PandocMonad) import Text.Pandoc.Logging +import Text.DocTemplates ( FromContext(lookupContext) ) #ifdef _WINDOWS changePathSeparators :: FilePath -> FilePath @@ -89,8 +90,16 @@ liftIO $ html2pdf verbosity program pdfargs source "pdfroff" -> do source <- writer opts doc + let paperargs = + case lookupContext "papersize" (writerVariables opts) of + Just s + | T.takeEnd 1 s == "l" -> ["-P-p" <> + T.unpack (T.dropEnd 1 s), "-P-l"] + | otherwise -> ["-P-p" <> T.unpack s] + Nothing -> [] let args = ["-ms", "-mpdfmark", "-mspdf", - "-e", "-t", "-k", "-KUTF-8", "-i"] ++ pdfargs + "-e", "-t", "-k", "-KUTF-8", "-i"] ++ + paperargs ++ pdfargs generic2pdf program args source baseProg -> do withTempDir "tex2pdf." $ \tmpdir' -> do diff --git a/src/Text/Pandoc/Parsing.hs b/src/Text/Pandoc/Parsing.hs --- a/src/Text/Pandoc/Parsing.hs +++ b/src/Text/Pandoc/Parsing.hs @@ -1,6 +1,6 @@ {- | Module : Text.Pandoc.Parsing - Copyright : Copyright (C) 2006-2022 John MacFarlane + Copyright : Copyright (C) 2006-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane @@ -47,6 +47,7 @@ mathDisplay, withHorizDisplacement, withRaw, + fromParsecError, escaped, characterReference, upperRoman, @@ -104,10 +105,9 @@ doubleCloseQuote, ellipses, dash, - nested, citeKey, - Parser, - ParserT, + Parsec, + ParsecT, Future(..), runF, askF, @@ -119,7 +119,7 @@ extractIdClass, insertIncludedFile, -- * Re-exports from Text.Parsec - Stream, + Stream(..), runParser, runParserT, parse, @@ -154,6 +154,8 @@ setState, updateState, SourcePos, + SourceName, + updatePosString, getPosition, setPosition, sourceName, @@ -168,13 +170,19 @@ initialPos, Line, Column, - ParseError + ParseError, + errorMessages, + messageString ) where import Text.Pandoc.Sources import Text.Parsec - ( setSourceName, + ( Parsec, + ParsecT, + SourcePos, + SourceName, + setSourceName, Column, Line, incSourceLine, @@ -221,9 +229,11 @@ runParserT, runParser, ParseError, - SourcePos, Stream(..) ) -import Text.Parsec.Pos (initialPos, newPos) +import Text.Parsec.Error ( + errorMessages, + messageString ) +import Text.Parsec.Pos (initialPos, newPos, updatePosString) import Text.Pandoc.Parsing.Capabilities ( guardDisabled, guardEnabled, @@ -268,7 +278,6 @@ manyTillChar, manyUntil, manyUntilChar, - nested, nonspaceChar, notFollowedBy', oneOfStrings, @@ -287,7 +296,8 @@ trimInlinesF, uri, withHorizDisplacement, - withRaw ) + withRaw, + fromParsecError ) import Text.Pandoc.Parsing.GridTable ( gridTableWith, gridTableWith', @@ -329,5 +339,5 @@ ParserContext(..), ParserState(..), SubstTable ) -import Text.Pandoc.Parsing.Types - ( ParserT, askF, asksF, returnF, runF, Future(..), Parser ) +import Text.Pandoc.Parsing.Future + ( askF, asksF, returnF, runF, Future(..) ) diff --git a/src/Text/Pandoc/Parsing/Capabilities.hs b/src/Text/Pandoc/Parsing/Capabilities.hs --- a/src/Text/Pandoc/Parsing/Capabilities.hs +++ b/src/Text/Pandoc/Parsing/Capabilities.hs @@ -1,7 +1,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {- | Module : Text.Pandoc.Parsing - Copyright : © 2006-2022 John MacFarlane + Copyright : © 2006-2023 John MacFarlane License : GPL-2.0-or-later Maintainer : John MacFarlane @@ -43,7 +43,8 @@ import Control.Monad (guard, when) import Data.Text (Text) -import Text.Parsec (ParsecT, SourcePos, Stream, getPosition, getState, updateState) +import Text.Parsec (SourcePos, Stream, ParsecT, + getPosition, getState, updateState) import Text.Pandoc.Class.PandocMonad (PandocMonad, report) import Text.Pandoc.Logging (LogMessage) import Text.Pandoc.Options @@ -51,15 +52,14 @@ , ReaderOptions(readerExtensions) , extensionEnabled ) -import Text.Pandoc.Parsing.Types -import Text.Pandoc.Readers.LaTeX.Types (Macro) +import Text.Pandoc.TeX (Macro) import qualified Data.Map as M import qualified Data.Set as Set class HasReaderOptions st where extractReaderOptions :: st -> ReaderOptions - getOption :: (Stream s m t) => (ReaderOptions -> b) -> ParserT s st m b + getOption :: (Stream s m t) => (ReaderOptions -> b) -> ParsecT s st m b -- default getOption f = f . extractReaderOptions <$> getState @@ -69,7 +69,7 @@ failIfInQuoteContext :: (HasQuoteContext st m, Stream s m t) => QuoteContext - -> ParserT s st m () + -> ParsecT s st m () failIfInQuoteContext context = do context' <- getQuoteContext when (context' == context) $ Prelude.fail "already inside quotes" @@ -97,34 +97,34 @@ -- | Add a log message. logMessage :: (Stream s m a, HasLogMessages st) - => LogMessage -> ParserT s st m () + => LogMessage -> ParsecT s st m () logMessage msg = updateState (addLogMessage msg) -- | Report all the accumulated log messages, according to verbosity level. -reportLogMessages :: (PandocMonad m, HasLogMessages st) => ParserT s st m () +reportLogMessages :: (PandocMonad m, HasLogMessages st) => ParsecT s st m () reportLogMessages = do msgs <- getLogMessages <$> getState mapM_ report msgs -- | Succeed only if the extension is enabled. guardEnabled :: (Stream s m a, HasReaderOptions st) - => Extension -> ParserT s st m () + => Extension -> ParsecT s st m () guardEnabled ext = getOption readerExtensions >>= guard . extensionEnabled ext -- | Succeed only if the extension is disabled. guardDisabled :: (Stream s m a, HasReaderOptions st) - => Extension -> ParserT s st m () + => Extension -> ParsecT s st m () guardDisabled ext = getOption readerExtensions >>= guard . not . extensionEnabled ext -- | Update the position on which the last string ended. updateLastStrPos :: (Stream s m a, HasLastStrPosition st) - => ParserT s st m () + => ParsecT s st m () updateLastStrPos = getPosition >>= updateState . setLastStrPos . Just -- | Whether we are right after the end of a string. -notAfterString :: (Stream s m a, HasLastStrPosition st) => ParserT s st m Bool +notAfterString :: (Stream s m a, HasLastStrPosition st) => ParsecT s st m Bool notAfterString = do pos <- getPosition st <- getState diff --git a/src/Text/Pandoc/Parsing/Citations.hs b/src/Text/Pandoc/Parsing/Citations.hs --- a/src/Text/Pandoc/Parsing/Citations.hs +++ b/src/Text/Pandoc/Parsing/Citations.hs @@ -2,7 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Parsing.Citations -Copyright : © 2006-2022 John MacFarlane +Copyright : © 2006-2023 John MacFarlane License : GPL-2.0-or-later Maintainer : John MacFarlane @@ -21,6 +21,7 @@ import Text.Parsec ( (<|>) , Stream(..) + , ParsecT , lookAhead , many , option @@ -28,25 +29,25 @@ ) import Text.Pandoc.Parsing.Capabilities (HasLastStrPosition, notAfterString) import Text.Pandoc.Parsing.General -import Text.Pandoc.Parsing.Types (ParserT) import qualified Data.Text as T citeKey :: (Stream s m Char, UpdateSourcePos s Char, HasLastStrPosition st) => Bool -- ^ If True, allow expanded @{..} syntax. - -> ParserT s st m (Bool, Text) + -> ParsecT s st m (Bool, Text) citeKey allowBraced = try $ do guard =<< notAfterString suppress_author <- option False (True <$ char '-') char '@' key <- simpleCiteIdentifier <|> if allowBraced - then charsInBalanced '{' '}' (satisfy (not . isSpace)) + then charsInBalanced '{' '}' + (T.singleton <$> (satisfy (not . isSpace))) else mzero return (suppress_author, key) simpleCiteIdentifier :: (Stream s m Char, UpdateSourcePos s Char) - => ParserT s st m Text + => ParsecT s st m Text simpleCiteIdentifier = do firstChar <- alphaNum <|> char '_' <|> char '*' -- @* for wildcard in nocite let regchar = satisfy (\c -> isAlphaNum c || c == '_') @@ -54,4 +55,3 @@ rest <- many $ regchar <|> internal (oneOf ":.#$%&-+?<>~/") <|> try (oneOf ":/" <* lookAhead (char '/')) return $ T.pack $ firstChar:rest - diff --git a/src/Text/Pandoc/Parsing/Future.hs b/src/Text/Pandoc/Parsing/Future.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/Parsing/Future.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{- | + Module : Text.Pandoc.Parsing.Future + Copyright : Copyright (C) 2006-2023 John MacFarlane + License : GPL-2.0-or-later + Maintainer : John MacFarlane + +Future type for parsing. +-} + +module Text.Pandoc.Parsing.Future + ( Future (..) + , runF + , askF + , asksF + , returnF + ) +where + +import Prelude hiding (Applicative(..)) +import Control.Applicative (Applicative(..)) +import Control.Monad.Reader + ( asks, runReader, MonadReader(ask), Reader, ReaderT(ReaderT) ) + +-- | Reader monad wrapping the parser state. This is used to possibly +-- delay evaluation until all relevant information has been parsed and +-- made available in the parser state. +newtype Future s a = Future { runDelayed :: Reader s a } + deriving (Monad, Applicative, Functor) + +instance Semigroup a => Semigroup (Future s a) where + (<>) = liftA2 (<>) + +instance (Semigroup a, Monoid a) => Monoid (Future s a) where + mempty = return mempty + mappend = (<>) + +-- | Run a delayed action with the given state. +runF :: Future s a -> s -> a +runF = runReader . runDelayed + +askF :: Future s s +askF = Future ask + +asksF :: (s -> a) -> Future s a +asksF f = Future $ asks f + +returnF :: Monad m => a -> m (Future s a) +returnF = return . return diff --git a/src/Text/Pandoc/Parsing/General.hs b/src/Text/Pandoc/Parsing/General.hs --- a/src/Text/Pandoc/Parsing/General.hs +++ b/src/Text/Pandoc/Parsing/General.hs @@ -2,7 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Parsing.General -Copyright : © 2006-2022 John MacFarlane +Copyright : © 2006-2023 John MacFarlane License : GPL-2.0-or-later Maintainer : John MacFarlane @@ -37,7 +37,6 @@ , manyTillChar , manyUntil , manyUntilChar - , nested , nonspaceChar , notFollowedBy' , oneOfStrings @@ -58,19 +57,20 @@ , uri , withHorizDisplacement , withRaw + , fromParsecError ) where import Control.Monad - ( guard - , join + ( join , liftM , unless , void , when + , MonadPlus(mzero) ) import Control.Monad.Except ( MonadError(throwError) ) -import Control.Monad.Identity ( Identity(..), MonadPlus(mzero) ) +import Control.Monad.Identity ( Identity(..) ) import Data.Char ( chr , isAlphaNum @@ -82,10 +82,10 @@ , toUpper ) import Data.Functor (($>)) -import Data.List (intercalate) +import Data.List (intercalate, sortOn) +import Data.Ord (Down(..)) import Data.Maybe (fromMaybe) import Data.Text (Text) -import Text.HTML.TagSoup.Entity (lookupEntity) import Text.Pandoc.Asciify (toAsciiText) import Text.Pandoc.Builder (Attr, Inline(Str), Inlines, trimInlines) import Text.Pandoc.Class.PandocMonad (PandocMonad, readFileFromDirs, report) @@ -95,13 +95,20 @@ ( extensionEnabled , Extension(Ext_auto_identifiers, Ext_ascii_identifiers) , ReaderOptions(readerTabStop, readerExtensions) ) -import Text.Pandoc.Shared (escapeURI, mapLeft, schemes, tshow, uniqueIdent) +import Text.Pandoc.Shared (tshow, uniqueIdent) +import Text.Pandoc.URI (schemes, escapeURI) import Text.Pandoc.Sources -import Text.Pandoc.XML (fromEntities) +import Text.Pandoc.XML (fromEntities, lookupEntity) import Text.Parsec ( (<|>) + , Parsec , ParsecT , SourcePos + , sourceLine + , sourceColumn + , sourceName + , ParseError + , errorPos , Stream(..) , between , choice @@ -128,15 +135,15 @@ ) import Text.Parsec.Pos (initialPos, newPos) import Text.Pandoc.Error - ( PandocError(PandocParseError, PandocParsecError) ) + ( PandocError(PandocParseError) ) import Text.Pandoc.Parsing.Capabilities import Text.Pandoc.Parsing.State -import Text.Pandoc.Parsing.Types ( Parser, ParserT, Future (..)) - +import Text.Pandoc.Parsing.Future (Future (..)) import qualified Data.Set as Set import qualified Data.Text as T import qualified Text.Pandoc.Builder as B import qualified Text.Pandoc.UTF8 as UTF8 (putStrLn) +import qualified Data.Bifunctor as Bifunctor -- | Remove whitespace from start and end; just like @'trimInlines'@, -- but lifted into the 'Future' type. @@ -158,7 +165,7 @@ -- | Parse any line of text, returning the contents without the -- final newline. -anyLine :: Monad m => ParserT Sources st m Text +anyLine :: Monad m => ParsecT Sources st m Text anyLine = do -- This is much faster than: -- manyTill anyChar newline @@ -181,13 +188,13 @@ return this -- | Parse any line, include the final newline in the output -anyLineNewline :: Monad m => ParserT Sources st m Text +anyLineNewline :: Monad m => ParsecT Sources st m Text anyLineNewline = (<> "\n") <$> anyLine -- | Parse indent by specified number of spaces (or equiv. tabs) indentWith :: (Stream s m Char, UpdateSourcePos s Char) => HasReaderOptions st - => Int -> ParserT s st m Text + => Int -> ParsecT s st m Text indentWith num = do tabStop <- getOption readerTabStop if num < tabStop @@ -197,28 +204,28 @@ -- | Like @many@, but packs its result. manyChar :: Stream s m t - => ParserT s st m Char - -> ParserT s st m Text + => ParsecT s st m Char + -> ParsecT s st m Text manyChar = fmap T.pack . many -- | Like @many1@, but packs its result. many1Char :: Stream s m t - => ParserT s st m Char - -> ParserT s st m Text + => ParsecT s st m Char + -> ParsecT s st m Text many1Char = fmap T.pack . many1 -- | Like @manyTill@, but packs its result. manyTillChar :: Stream s m t - => ParserT s st m Char - -> ParserT s st m a - -> ParserT s st m Text + => ParsecT s st m Char + -> ParsecT s st m a + -> ParsecT s st m Text manyTillChar p = fmap T.pack . manyTill p -- | Like @manyTill@, but reads at least one item. many1Till :: (Show end, Stream s m t) - => ParserT s st m a - -> ParserT s st m end - -> ParserT s st m [a] + => ParsecT s st m a + -> ParsecT s st m end + -> ParsecT s st m [a] many1Till p end = do notFollowedBy' end first <- p @@ -227,15 +234,15 @@ -- | Like @many1Till@, but packs its result many1TillChar :: (Show end, Stream s m t) - => ParserT s st m Char - -> ParserT s st m end - -> ParserT s st m Text + => ParsecT s st m Char + -> ParsecT s st m end + -> ParsecT s st m Text many1TillChar p = fmap T.pack . many1Till p -- | Like @manyTill@, but also returns the result of end parser. -manyUntil :: ParserT s u m a - -> ParserT s u m b - -> ParserT s u m ([a], b) +manyUntil :: ParsecT s u m a + -> ParsecT s u m b + -> ParsecT s u m ([a], b) manyUntil p end = scan where scan = (do e <- end @@ -246,9 +253,9 @@ return (x:xs, e)) -- | Like @manyUntil@, but also packs its result. -manyUntilChar :: ParserT s u m Char - -> ParserT s u m b - -> ParserT s u m (Text, b) +manyUntilChar :: ParsecT s u m Char + -> ParsecT s u m b + -> ParsecT s u m (Text, b) manyUntilChar p = fmap go . manyUntil p where go (x, y) = (T.pack x, y) @@ -263,7 +270,7 @@ -- | A more general form of @notFollowedBy@. This one allows any -- type of parser to be specified, and succeeds only if that parser fails. -- It does not consume any input. -notFollowedBy' :: (Show b, Stream s m a) => ParserT s st m b -> ParserT s st m () +notFollowedBy' :: (Show b, Stream s m a) => ParsecT s st m b -> ParsecT s st m () notFollowedBy' p = try $ join $ do a <- try p return (unexpected (show a)) <|> @@ -271,12 +278,12 @@ -- (This version due to Andrew Pimlott on the Haskell mailing list.) oneOfStrings' :: (Stream s m Char, UpdateSourcePos s Char) - => (Char -> Char -> Bool) -> [Text] -> ParserT s st m Text + => (Char -> Char -> Bool) -> [Text] -> ParsecT s st m Text oneOfStrings' f = fmap T.pack . oneOfStrings'' f . fmap T.unpack -- TODO: This should be re-implemented in a Text-aware way oneOfStrings'' :: (Stream s m Char, UpdateSourcePos s Char) - => (Char -> Char -> Bool) -> [String] -> ParserT s st m String + => (Char -> Char -> Bool) -> [String] -> ParsecT s st m String oneOfStrings'' _ [] = Prelude.fail "no strings" oneOfStrings'' matches strs = try $ do c <- anyChar @@ -292,7 +299,7 @@ -- two strings one of which is a prefix of the other, the longer -- string will be matched if possible. oneOfStrings :: (Stream s m Char, UpdateSourcePos s Char) - => [Text] -> ParserT s st m Text + => [Text] -> ParsecT s st m Text oneOfStrings = oneOfStrings' (==) -- | Parses one of a list of strings (tried in order), case insensitive. @@ -300,7 +307,7 @@ -- TODO: This will not be accurate with general Unicode (neither -- Text.toLower nor Text.toCaseFold can be implemented with a map) oneOfStringsCI :: (Stream s m Char, UpdateSourcePos s Char) - => [Text] -> ParserT s st m Text + => [Text] -> ParsecT s st m Text oneOfStringsCI = oneOfStrings' ciMatch where ciMatch x y = toLower' x == toLower' y -- this optimizes toLower by checking common ASCII case @@ -312,12 +319,12 @@ -- | Parses a space or tab. spaceChar :: (Stream s m Char, UpdateSourcePos s Char) - => ParserT s st m Char + => ParsecT s st m Char spaceChar = satisfy $ \c -> c == ' ' || c == '\t' -- | Parses a nonspace, nonnewline character. nonspaceChar :: (Stream s m Char, UpdateSourcePos s Char) - => ParserT s st m Char + => ParsecT s st m Char nonspaceChar = satisfy (not . isSpaceChar) isSpaceChar :: Char -> Bool @@ -329,23 +336,23 @@ -- | Skips zero or more spaces or tabs. skipSpaces :: (Stream s m Char, UpdateSourcePos s Char) - => ParserT s st m () + => ParsecT s st m () skipSpaces = skipMany spaceChar -- | Skips zero or more spaces or tabs, then reads a newline. blankline :: (Stream s m Char, UpdateSourcePos s Char) - => ParserT s st m Char + => ParsecT s st m Char blankline = try $ skipSpaces >> newline -- | Parses one or more blank lines and returns a string of newlines. blanklines :: (Stream s m Char, UpdateSourcePos s Char) - => ParserT s st m Text + => ParsecT s st m Text blanklines = T.pack <$> many1 blankline -- | Gobble n spaces; if tabs are encountered, expand them -- and gobble some or all of their spaces, leaving the rest. gobbleSpaces :: (HasReaderOptions st, Monad m) - => Int -> ParserT Sources st m () + => Int -> ParsecT Sources st m () gobbleSpaces 0 = return () gobbleSpaces n | n < 0 = error "gobbleSpaces called with negative number" @@ -353,7 +360,7 @@ char ' ' <|> eatOneSpaceOfTab gobbleSpaces (n - 1) -eatOneSpaceOfTab :: (HasReaderOptions st, Monad m) => ParserT Sources st m Char +eatOneSpaceOfTab :: (HasReaderOptions st, Monad m) => ParsecT Sources st m Char eatOneSpaceOfTab = do lookAhead (char '\t') pos <- getPosition @@ -372,7 +379,7 @@ -- | Gobble up to n spaces; if tabs are encountered, expand them -- and gobble some or all of their spaces, leaving the rest. gobbleAtMostSpaces :: (HasReaderOptions st, Monad m) - => Int -> ParserT Sources st m Int + => Int -> ParsecT Sources st m Int gobbleAtMostSpaces 0 = return 0 gobbleAtMostSpaces n | n < 0 = error "gobbleAtMostSpaces called with negative number" @@ -382,20 +389,20 @@ -- | Parses material enclosed between start and end parsers. enclosed :: (Show end, Stream s m Char, UpdateSourcePos s Char) - => ParserT s st m t -- ^ start parser - -> ParserT s st m end -- ^ end parser - -> ParserT s st m a -- ^ content parser (to be used repeatedly) - -> ParserT s st m [a] + => ParsecT s st m t -- ^ start parser + -> ParsecT s st m end -- ^ end parser + -> ParsecT s st m a -- ^ content parser (to be used repeatedly) + -> ParsecT s st m [a] enclosed start end parser = try $ start >> notFollowedBy space >> many1Till parser end -- | Parse string, case insensitive. stringAnyCase :: (Stream s m Char, UpdateSourcePos s Char) - => Text -> ParserT s st m Text + => Text -> ParsecT s st m Text stringAnyCase = fmap T.pack . stringAnyCase' . T.unpack stringAnyCase' :: (Stream s m Char, UpdateSourcePos s Char) - => String -> ParserT s st m String + => String -> ParsecT s st m String stringAnyCase' [] = string "" stringAnyCase' (x:xs) = do firstChar <- char (toUpper x) <|> char (toLower x) @@ -405,9 +412,9 @@ -- TODO rewrite by just adding to Sources stream? -- | Parse contents of 'str' using 'parser' and return result. parseFromString :: Monad m - => ParserT Sources st m r + => ParsecT Sources st m r -> Text - -> ParserT Sources st m r + -> ParsecT Sources st m r parseFromString parser str = do oldPos <- getPosition oldInput <- getInput @@ -422,9 +429,9 @@ -- | Like 'parseFromString' but specialized for 'ParserState'. -- This resets 'stateLastStrPos', which is almost always what we want. parseFromString' :: (Monad m, HasLastStrPosition u) - => ParserT Sources u m a + => ParsecT Sources u m a -> Text - -> ParserT Sources u m a + -> ParsecT Sources u m a parseFromString' parser str = do oldLastStrPos <- getLastStrPos <$> getState updateState $ setLastStrPos Nothing @@ -433,7 +440,7 @@ return res -- | Parse raw line block up to and including blank lines. -lineClump :: Monad m => ParserT Sources st m Text +lineClump :: Monad m => ParsecT Sources st m Text lineClump = blanklines <|> (T.unlines <$> many1 (notFollowedBy blankline >> anyLine)) @@ -442,27 +449,22 @@ -- pairs of open and close, which must be different. For example, -- @charsInBalanced '(' ')' anyChar@ will parse "(hello (there))" -- and return "hello (there)". -charsInBalanced :: (Stream s m Char, UpdateSourcePos s Char) => Char -> Char -> ParserT s st m Char - -> ParserT s st m Text +charsInBalanced :: (Stream s m Char, UpdateSourcePos s Char) + => Char -> Char -> ParsecT s st m Text -> ParsecT s st m Text charsInBalanced open close parser = try $ do char open let isDelim c = c == open || c == close - raw <- many $ T.pack <$> many1 (notFollowedBy (satisfy isDelim) >> parser) + raw <- many $ mconcat <$> many1 (notFollowedBy (satisfy isDelim) >> parser) <|> (do res <- charsInBalanced open close parser return $ T.singleton open <> res <> T.singleton close) char close - return $ T.concat raw - --- old charsInBalanced would be: --- charsInBalanced open close (noneOf "\n" <|> char '\n' >> notFollowedBy blankline) --- old charsInBalanced' would be: --- charsInBalanced open close anyChar + return $ mconcat raw -- Parsers for email addresses and URIs -- | Parses an email address; returns original and corresponding -- escaped mailto: URI. -emailAddress :: (Stream s m Char, UpdateSourcePos s Char) => ParserT s st m (Text, Text) +emailAddress :: (Stream s m Char, UpdateSourcePos s Char) => ParsecT s st m (Text, Text) emailAddress = try $ toResult <$> mailbox <*> (char '@' *> domain) where toResult mbox dom = let full = fromEntities $ T.pack $ mbox ++ '@':dom in (full, escapeURI $ "mailto:" <> full) @@ -485,11 +487,11 @@ isEmailPunct c = T.any (== c) "!\"#$%&'*+-/=?^_{|}~;" -uriScheme :: (Stream s m Char, UpdateSourcePos s Char) => ParserT s st m Text +uriScheme :: (Stream s m Char, UpdateSourcePos s Char) => ParsecT s st m Text uriScheme = oneOfStringsCI (Set.toList schemes) -- | Parses a URI. Returns pair of original and URI-escaped version. -uri :: (Stream s m Char, UpdateSourcePos s Char) => ParserT s st m (Text, Text) +uri :: (Stream s m Char, UpdateSourcePos s Char) => ParsecT s st m (Text, Text) uri = try $ do scheme <- uriScheme char ':' @@ -523,7 +525,7 @@ wordChar = satisfy isWordChar percentEscaped = try $ (:) <$> char '%' <*> many1 hexDigit - entity = try $ pure <$> characterReference + entity = try $ T.unpack <$> characterReference punct = try $ many1 (char ',') <|> fmap pure (satisfy (\c -> not (isSpace c) && c /= '<' && c /= '>')) uriChunk = many1 wordChar <|> percentEscaped @@ -537,8 +539,8 @@ -- and the source column at the beginning). Vertical displacement -- (source row) is ignored. withHorizDisplacement :: (Stream s m Char, UpdateSourcePos s Char) - => ParserT s st m a -- ^ Parser to apply - -> ParserT s st m (a, Int) -- ^ (result, displacement) + => ParsecT s st m a -- ^ Parsec to apply + -> ParsecT s st m (a, Int) -- ^ (result, displacement) withHorizDisplacement parser = do pos1 <- getPosition result <- parser @@ -573,28 +575,24 @@ -- | Parses backslash, then applies character parser. escaped :: (Stream s m Char, UpdateSourcePos s Char) - => ParserT s st m Char -- ^ Parser for character to escape - -> ParserT s st m Char + => ParsecT s st m Char -- ^ Parsec for character to escape + -> ParsecT s st m Char escaped parser = try $ char '\\' >> parser -- | Parse character entity. -characterReference :: (Stream s m Char, UpdateSourcePos s Char) => ParserT s st m Char +characterReference :: (Stream s m Char, UpdateSourcePos s Char) => ParsecT s st m Text characterReference = try $ do char '&' - ent <- many1Till nonspaceChar (char ';') - let ent' = case ent of - '#':'X':xs -> '#':'x':xs -- workaround tagsoup bug - '#':_ -> ent - _ -> ent ++ ";" - case lookupEntity ent' of - Just (c : _) -> return c + ent <- many1TillChar nonspaceChar (char ';') + case lookupEntity (ent <> ";") of + Just t -> return t _ -> Prelude.fail "entity not found" -- | Parses a character reference and returns a Str element. -charRef :: (Stream s m Char, UpdateSourcePos s Char) => ParserT s st m Inline -charRef = Str . T.singleton <$> characterReference +charRef :: (Stream s m Char, UpdateSourcePos s Char) => ParsecT s st m Inline +charRef = Str <$> characterReference -lineBlockLine :: Monad m => ParserT Sources st m Text +lineBlockLine :: Monad m => ParsecT Sources st m Text lineBlockLine = try $ do char '|' char ' ' @@ -604,11 +602,11 @@ continuations <- many (try $ char ' ' >> anyLine) return $ white <> T.unwords (line : continuations) -blankLineBlockLine :: (Stream s m Char, UpdateSourcePos s Char) => ParserT s st m Char +blankLineBlockLine :: (Stream s m Char, UpdateSourcePos s Char) => ParsecT s st m Char blankLineBlockLine = try (char '|' >> blankline) -- | Parses an RST-style line block and returns a list of strings. -lineBlockLines :: Monad m => ParserT Sources st m [Text] +lineBlockLines :: Monad m => ParsecT Sources st m [Text] lineBlockLines = try $ do lines' <- many1 (lineBlockLine <|> (T.singleton <$> blankLineBlockLine)) skipMany blankline @@ -617,19 +615,20 @@ -- | Removes the ParsecT layer from the monad transformer stack readWithM :: (Monad m, ToSources t) - => ParserT Sources st m a -- ^ parser + => ParsecT Sources st m a -- ^ parser -> st -- ^ initial state -> t -- ^ input -> m (Either PandocError a) readWithM parser state input = - mapLeft (PandocParsecError sources) + Bifunctor.first (fromParsecError sources) <$> runParserT parser state (initialSourceName sources) sources where sources = toSources input + -- | Parse a string with a given parser and state readWith :: ToSources t - => Parser Sources st a + => Parsec Sources st a -> st -> t -> Either PandocError a @@ -637,7 +636,7 @@ -- | Parse a string with @parser@ (for testing). testStringWith :: Show a - => ParserT Sources ParserState Identity a + => ParsecT Sources ParserState Identity a -> Text -> IO () testStringWith parser str = UTF8.putStrLn $ tshow $ @@ -652,7 +651,7 @@ -- (explicit or automatically generated). registerHeader :: (Stream s m a, HasReaderOptions st, HasLogMessages st, HasIdentifierList st) - => Attr -> Inlines -> ParserT s st m Attr + => Attr -> Inlines -> ParsecT s st m Attr registerHeader (ident,classes,kvs) header' = do ids <- extractIdentifierList <$> getState exts <- getOption readerExtensions @@ -673,19 +672,6 @@ updateState $ updateIdentifierList $ Set.insert ident return (ident,classes,kvs) --- This is used to prevent exponential blowups for things like: --- a**a*a**a*a**a*a**a*a**a*a**a*a** -nested :: Stream s m a - => ParserT s ParserState m a - -> ParserT s ParserState m a -nested p = do - nestlevel <- stateMaxNestingLevel <$> getState - guard $ nestlevel > 0 - updateState $ \st -> st{ stateMaxNestingLevel = stateMaxNestingLevel st - 1 } - res <- p - updateState $ \st -> st{ stateMaxNestingLevel = nestlevel } - return res - token :: (Stream s m t) => (t -> Text) -> (t -> SourcePos) @@ -694,7 +680,7 @@ token pp pos match = tokenPrim (T.unpack . pp) (\_ t _ -> pos t) match infixr 5 <+?> -(<+?>) :: (Monoid a) => ParserT s st m a -> ParserT s st m a -> ParserT s st m a +(<+?>) :: (Monoid a) => ParsecT s st m a -> ParsecT s st m a -> ParsecT s st m a a <+?> b = a >>= flip fmap (try b <|> return mempty) . mappend extractIdClass :: Attr -> Attr @@ -705,13 +691,13 @@ kvs' = filter (\(k,_) -> k /= "id" || k /= "class") kvs insertIncludedFile :: (PandocMonad m, HasIncludeFiles st) - => ParserT a st m b -- ^ parser to apply + => ParsecT a st m b -- ^ parser to apply -> (Text -> a) -- ^ convert Text to stream type -> [FilePath] -- ^ search path (directories) -> FilePath -- ^ path of file to include -> Maybe Int -- ^ start line (negative counts from end) -> Maybe Int -- ^ end line (negative counts from end) - -> ParserT a st m b + -> ParsecT a st m b insertIncludedFile parser toStream dirs f mbstartline mbendline = do oldPos <- getPosition oldInput <- getInput @@ -749,3 +735,28 @@ Nothing -> numLines Just x | x >= 0 -> x | otherwise -> numLines + x -- negative from end + +fromParsecError :: Sources -> ParseError -> PandocError +fromParsecError (Sources inputs) err' = PandocParseError msg + where + msg = "Error at " <> tshow err' <> errorContext + errPos = errorPos err' + errLine = sourceLine errPos + errColumn = sourceColumn errPos + errFile = sourceName errPos + errorContext = + case sortOn (Down . sourceLine . fst) + [ (pos,t) + | (pos,t) <- inputs + , sourceName pos == errFile + , sourceLine pos <= errLine + ] of + [] -> "" + ((pos,txt):_) -> + let ls = T.lines txt <> [""] + ln = (errLine - sourceLine pos) + 1 + in if length ls > ln && ln >= 1 + then T.concat ["\n", ls !! (ln - 1) + ,"\n", T.replicate (errColumn - 1) " " + ,"^"] + else "" diff --git a/src/Text/Pandoc/Parsing/GridTable.hs b/src/Text/Pandoc/Parsing/GridTable.hs --- a/src/Text/Pandoc/Parsing/GridTable.hs +++ b/src/Text/Pandoc/Parsing/GridTable.hs @@ -3,7 +3,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Parsing.GridTable - Copyright : Copyright (C) 2006-2022 John MacFarlane + Copyright : Copyright (C) 2006-2023 John MacFarlane License : GPL-2.0-or-later Maintainer : John MacFarlane @@ -31,9 +31,8 @@ import Text.Pandoc.Definition import Text.Pandoc.Parsing.Capabilities import Text.Pandoc.Parsing.General -import Text.Pandoc.Parsing.Types import Text.Pandoc.Sources -import Text.Parsec (Stream (..), optional, sepEndBy1, try) +import Text.Parsec (Stream (..), ParsecT, optional, sepEndBy1, try) import qualified Data.Text as T import qualified Text.GridTable as GT @@ -103,8 +102,8 @@ -- blank lines, and ending with a footer (dashed line followed by blank -- line). gridTableWith :: (Monad m, Monad mf, HasLastStrPosition st, HasReaderOptions st) - => ParserT Sources st m (mf Blocks) -- ^ Block list parser - -> ParserT Sources st m (mf Blocks) + => ParsecT Sources st m (mf Blocks) -- ^ Block list parser + -> ParsecT Sources st m (mf Blocks) gridTableWith blocks = fmap tableFromComponents <$> gridTableWith' NoNormalization blocks @@ -113,8 +112,8 @@ gridTableWith' :: (Monad m, Monad mf, HasReaderOptions st, HasLastStrPosition st) => TableNormalization - -> ParserT Sources st m (mf Blocks) -- ^ Block list parser - -> ParserT Sources st m (mf TableComponents) + -> ParsecT Sources st m (mf Blocks) -- ^ Block list parser + -> ParsecT Sources st m (mf TableComponents) gridTableWith' normalization blocks = do tbl <- GT.gridTable <* optional blanklines let blkTbl = GT.mapCells @@ -135,9 +134,13 @@ let caption = B.emptyCaption return $ do rows'' <- mapM sequence rows' - let (hRows, bRows) = - splitAt (maybe 0 GT.fromRowIndex $ GT.arrayTableHead tbl) - (map (B.Row B.nullAttr) rows'') + let headLen = maybe 0 GT.fromRowIndex $ GT.arrayTableHead tbl + let (hRows, bRows') = + splitAt headLen (map (B.Row B.nullAttr) rows'') + let (bRows, fRows) = + case GT.arrayTableFoot tbl of + Just fIdx -> splitAt (GT.fromRowIndex fIdx - headLen - 1) bRows' + Nothing -> (bRows', []) let thead = B.TableHead B.nullAttr $ case (hRows, normalization) of -- normalize header if necessary: remove header if it contains -- only a single row in which all cells are empty. @@ -151,7 +154,7 @@ in [B.Row nullAttr cells | not (null cells) && not (all simple cells)] _ -> hRows - let tfoot = B.TableFoot B.nullAttr [] + let tfoot = B.TableFoot B.nullAttr fRows let tbody = B.TableBody B.nullAttr 0 [] bRows return $ TableComponents nullAttr caption colspecs thead [tbody] tfoot @@ -177,7 +180,7 @@ fractionalColumnWidths :: GT.ArrayTable a -> Int -> [Double] fractionalColumnWidths gt charColumns = - let widths = map ((+1) . snd) $ -- include width of separator + let widths = map ((+1) . snd) -- include width of separator (elems $ GT.arrayTableColSpecs gt) norm = fromIntegral $ max (sum widths + length widths - 2) charColumns in map (\w -> fromIntegral w / norm) widths @@ -188,22 +191,22 @@ -- 'lineParser', and 'footerParser'. tableWith :: (Stream s m Char, UpdateSourcePos s Char, HasReaderOptions st, Monad mf) - => ParserT s st m (mf [Blocks], [Alignment], [Int]) -- ^ header parser - -> ([Int] -> ParserT s st m (mf [Blocks])) -- ^ row parser - -> ParserT s st m sep -- ^ line parser - -> ParserT s st m end -- ^ footer parser - -> ParserT s st m (mf Blocks) + => ParsecT s st m (mf [Blocks], [Alignment], [Int]) -- ^ header parser + -> ([Int] -> ParsecT s st m (mf [Blocks])) -- ^ row parser + -> ParsecT s st m sep -- ^ line parser + -> ParsecT s st m end -- ^ footer parser + -> ParsecT s st m (mf Blocks) tableWith hp rp lp fp = fmap tableFromComponents <$> tableWith' NoNormalization hp rp lp fp tableWith' :: (Stream s m Char, UpdateSourcePos s Char, HasReaderOptions st, Monad mf) => TableNormalization - -> ParserT s st m (mf [Blocks], [Alignment], [Int]) -- ^ header parser - -> ([Int] -> ParserT s st m (mf [Blocks])) -- ^ row parser - -> ParserT s st m sep -- ^ line parser - -> ParserT s st m end -- ^ footer parser - -> ParserT s st m (mf TableComponents) + -> ParsecT s st m (mf [Blocks], [Alignment], [Int]) -- ^ header parser + -> ([Int] -> ParsecT s st m (mf [Blocks])) -- ^ row parser + -> ParsecT s st m sep -- ^ line parser + -> ParsecT s st m end -- ^ footer parser + -> ParsecT s st m (mf TableComponents) tableWith' n11n headerParser rowParser lineParser footerParser = try $ do (heads, aligns, indices) <- headerParser lines' <- sequence <$> rowParser indices `sepEndBy1` lineParser diff --git a/src/Text/Pandoc/Parsing/Lists.hs b/src/Text/Pandoc/Parsing/Lists.hs --- a/src/Text/Pandoc/Parsing/Lists.hs +++ b/src/Text/Pandoc/Parsing/Lists.hs @@ -2,7 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Parsing.Lists -Copyright : © 2006-2022 John MacFarlane +Copyright : © 2006-2023 John MacFarlane License : GPL-2.0-or-later Maintainer : John MacFarlane @@ -37,6 +37,7 @@ import Text.Pandoc.Sources import Text.Parsec ( (<|>) + , ParsecT , Stream(..) , choice , getState @@ -48,7 +49,6 @@ , updateState ) import Text.Pandoc.Parsing.State -import Text.Pandoc.Parsing.Types (ParserT) import qualified Data.Map as M import qualified Data.Text as T @@ -56,7 +56,7 @@ -- | Parses a roman numeral (uppercase or lowercase), returns number. romanNumeral :: (Stream s m Char, UpdateSourcePos s Char) => Bool -- ^ Uppercase if true - -> ParserT s st m Int + -> ParsecT s st m Int romanNumeral upperCase = do let rchar uc = char $ if upperCase then uc else toLower uc let one = rchar 'I' @@ -88,19 +88,19 @@ else return total -- | Parses an uppercase roman numeral and returns (UpperRoman, number). -upperRoman :: (Stream s m Char, UpdateSourcePos s Char) => ParserT s st m (ListNumberStyle, Int) +upperRoman :: (Stream s m Char, UpdateSourcePos s Char) => ParsecT s st m (ListNumberStyle, Int) upperRoman = do num <- romanNumeral True return (UpperRoman, num) -- | Parses a lowercase roman numeral and returns (LowerRoman, number). -lowerRoman :: (Stream s m Char, UpdateSourcePos s Char) => ParserT s st m (ListNumberStyle, Int) +lowerRoman :: (Stream s m Char, UpdateSourcePos s Char) => ParsecT s st m (ListNumberStyle, Int) lowerRoman = do num <- romanNumeral False return (LowerRoman, num) -- | Parses a decimal numeral and returns (Decimal, number). -decimal :: (Stream s m Char, UpdateSourcePos s Char) => ParserT s st m (ListNumberStyle, Int) +decimal :: (Stream s m Char, UpdateSourcePos s Char) => ParsecT s st m (ListNumberStyle, Int) decimal = do num <- many1 digit return (Decimal, fromMaybe 1 $ safeRead $ T.pack num) @@ -110,7 +110,7 @@ -- example number is incremented in parser state, and the label -- (if present) is added to the label table. exampleNum :: (Stream s m Char, UpdateSourcePos s Char) - => ParserT s ParserState m (ListNumberStyle, Int) + => ParsecT s ParserState m (ListNumberStyle, Int) exampleNum = do char '@' lab <- mconcat . map T.pack <$> @@ -128,30 +128,30 @@ return (Example, num) -- | Parses a '#' returns (DefaultStyle, 1). -defaultNum :: (Stream s m Char, UpdateSourcePos s Char) => ParserT s st m (ListNumberStyle, Int) +defaultNum :: (Stream s m Char, UpdateSourcePos s Char) => ParsecT s st m (ListNumberStyle, Int) defaultNum = do char '#' return (DefaultStyle, 1) -- | Parses a lowercase letter and returns (LowerAlpha, number). -lowerAlpha :: (Stream s m Char, UpdateSourcePos s Char) => ParserT s st m (ListNumberStyle, Int) +lowerAlpha :: (Stream s m Char, UpdateSourcePos s Char) => ParsecT s st m (ListNumberStyle, Int) lowerAlpha = do ch <- satisfy isAsciiLower return (LowerAlpha, ord ch - ord 'a' + 1) -- | Parses an uppercase letter and returns (UpperAlpha, number). -upperAlpha :: (Stream s m Char, UpdateSourcePos s Char) => ParserT s st m (ListNumberStyle, Int) +upperAlpha :: (Stream s m Char, UpdateSourcePos s Char) => ParsecT s st m (ListNumberStyle, Int) upperAlpha = do ch <- satisfy isAsciiUpper return (UpperAlpha, ord ch - ord 'A' + 1) -- | Parses a roman numeral i or I -romanOne :: (Stream s m Char, UpdateSourcePos s Char) => ParserT s st m (ListNumberStyle, Int) +romanOne :: (Stream s m Char, UpdateSourcePos s Char) => ParsecT s st m (ListNumberStyle, Int) romanOne = (char 'i' >> return (LowerRoman, 1)) <|> (char 'I' >> return (UpperRoman, 1)) -- | Parses an ordered list marker and returns list attributes. -anyOrderedListMarker :: (Stream s m Char, UpdateSourcePos s Char) => ParserT s ParserState m ListAttributes +anyOrderedListMarker :: (Stream s m Char, UpdateSourcePos s Char) => ParsecT s ParserState m ListAttributes anyOrderedListMarker = choice [delimParser numParser | delimParser <- [inPeriod, inOneParen, inTwoParens], numParser <- [decimal, exampleNum, defaultNum, romanOne, @@ -159,8 +159,8 @@ -- | Parses a list number (num) followed by a period, returns list attributes. inPeriod :: (Stream s m Char, UpdateSourcePos s Char) - => ParserT s st m (ListNumberStyle, Int) - -> ParserT s st m ListAttributes + => ParsecT s st m (ListNumberStyle, Int) + -> ParsecT s st m ListAttributes inPeriod num = try $ do (style, start) <- num char '.' @@ -171,8 +171,8 @@ -- | Parses a list number (num) followed by a paren, returns list attributes. inOneParen :: (Stream s m Char, UpdateSourcePos s Char) - => ParserT s st m (ListNumberStyle, Int) - -> ParserT s st m ListAttributes + => ParsecT s st m (ListNumberStyle, Int) + -> ParsecT s st m ListAttributes inOneParen num = try $ do (style, start) <- num char ')' @@ -180,8 +180,8 @@ -- | Parses a list number (num) enclosed in parens, returns list attributes. inTwoParens :: (Stream s m Char, UpdateSourcePos s Char) - => ParserT s st m (ListNumberStyle, Int) - -> ParserT s st m ListAttributes + => ParsecT s st m (ListNumberStyle, Int) + -> ParsecT s st m ListAttributes inTwoParens num = try $ do char '(' (style, start) <- num @@ -193,7 +193,7 @@ orderedListMarker :: (Stream s m Char, UpdateSourcePos s Char) => ListNumberStyle -> ListNumberDelim - -> ParserT s ParserState m Int + -> ParsecT s ParserState m Int orderedListMarker style delim = do let num = defaultNum <|> -- # can continue any kind of list case style of diff --git a/src/Text/Pandoc/Parsing/Math.hs b/src/Text/Pandoc/Parsing/Math.hs --- a/src/Text/Pandoc/Parsing/Math.hs +++ b/src/Text/Pandoc/Parsing/Math.hs @@ -2,7 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Parsing.Math -Copyright : © 2006-2022 John MacFarlane +Copyright : © 2006-2023 John MacFarlane License : GPL-2.0-or-later Maintainer : John MacFarlane @@ -17,20 +17,19 @@ import Control.Monad (mzero, when) import Data.Text (Text) -import Text.Parsec ((<|>), Stream(..), notFollowedBy, skipMany, try) +import Text.Parsec ((<|>), ParsecT, Stream(..), notFollowedBy, skipMany, try) import Text.Pandoc.Options ( Extension(Ext_tex_math_dollars, Ext_tex_math_single_backslash, Ext_tex_math_double_backslash) ) import Text.Pandoc.Parsing.Capabilities (HasReaderOptions, guardEnabled) import Text.Pandoc.Parsing.General -import Text.Pandoc.Parsing.Types (ParserT) import Text.Pandoc.Shared (trimMath) import Text.Pandoc.Sources (UpdateSourcePos, anyChar, char, digit, newline, satisfy, space, string) import qualified Data.Text as T -mathInlineWith :: (Stream s m Char, UpdateSourcePos s Char) => Text -> Text -> ParserT s st m Text +mathInlineWith :: (Stream s m Char, UpdateSourcePos s Char) => Text -> Text -> ParsecT s st m Text mathInlineWith op cl = try $ do textStr op when (op == "$") $ notFollowedBy space @@ -51,10 +50,10 @@ notFollowedBy digit -- to prevent capture of $5 return $ trimMath $ T.concat words' where - inBalancedBraces :: (Stream s m Char, UpdateSourcePos s Char) => Int -> Text -> ParserT s st m Text + inBalancedBraces :: (Stream s m Char, UpdateSourcePos s Char) => Int -> Text -> ParsecT s st m Text inBalancedBraces n = fmap T.pack . inBalancedBraces' n . T.unpack - inBalancedBraces' :: (Stream s m Char, UpdateSourcePos s Char) => Int -> String -> ParserT s st m String + inBalancedBraces' :: (Stream s m Char, UpdateSourcePos s Char) => Int -> String -> ParsecT s st m String inBalancedBraces' 0 "" = do c <- anyChar if c == '{' @@ -71,14 +70,14 @@ '{' -> inBalancedBraces' (numOpen + 1) (c:xs) _ -> inBalancedBraces' numOpen (c:xs) -mathDisplayWith :: (Stream s m Char, UpdateSourcePos s Char) => Text -> Text -> ParserT s st m Text +mathDisplayWith :: (Stream s m Char, UpdateSourcePos s Char) => Text -> Text -> ParsecT s st m Text mathDisplayWith op cl = try $ fmap T.pack $ do textStr op many1Till (satisfy (/= '\n') <|> (newline <* notFollowedBy' blankline)) (try $ textStr cl) mathDisplay :: (HasReaderOptions st, Stream s m Char, UpdateSourcePos s Char) - => ParserT s st m Text + => ParsecT s st m Text mathDisplay = (guardEnabled Ext_tex_math_dollars >> mathDisplayWith "$$" "$$") <|> (guardEnabled Ext_tex_math_single_backslash >> @@ -87,7 +86,7 @@ mathDisplayWith "\\\\[" "\\\\]") mathInline :: (HasReaderOptions st, Stream s m Char, UpdateSourcePos s Char) - => ParserT s st m Text + => ParsecT s st m Text mathInline = (guardEnabled Ext_tex_math_dollars >> mathInlineWith "$" "$") <|> (guardEnabled Ext_tex_math_single_backslash >> diff --git a/src/Text/Pandoc/Parsing/Smart.hs b/src/Text/Pandoc/Parsing/Smart.hs --- a/src/Text/Pandoc/Parsing/Smart.hs +++ b/src/Text/Pandoc/Parsing/Smart.hs @@ -2,7 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Parsing.Smart -Copyright : © 2006-2022 John MacFarlane +Copyright : © 2006-2023 John MacFarlane License : GPL-2.0-or-later Maintainer : John MacFarlane @@ -33,17 +33,17 @@ import Text.Pandoc.Sources import Text.Pandoc.Parsing.Capabilities import Text.Pandoc.Parsing.General -import Text.Pandoc.Parsing.Types (ParserT) import Text.Parsec ( (<|>) , Stream(..) + , ParsecT , choice , lookAhead , manyTill , notFollowedBy , try ) - +import qualified Data.Text as T import qualified Text.Pandoc.Builder as B -- | Parses various ASCII punctuation, quotes, and apostrophe in a smart @@ -53,8 +53,8 @@ smartPunctuation :: (HasReaderOptions st, HasLastStrPosition st, HasQuoteContext st m, Stream s m Char, UpdateSourcePos s Char) - => ParserT s st m Inlines - -> ParserT s st m Inlines + => ParsecT s st m Inlines + -> ParsecT s st m Inlines smartPunctuation inlineParser = do guardEnabled Ext_smart choice [ quoted inlineParser, apostrophe, doubleCloseQuote, dash, ellipses ] @@ -63,16 +63,16 @@ -- quoting conventions. quoted :: (HasLastStrPosition st, HasQuoteContext st m, Stream s m Char, UpdateSourcePos s Char) - => ParserT s st m Inlines - -> ParserT s st m Inlines + => ParsecT s st m Inlines + -> ParsecT s st m Inlines quoted inlineParser = doubleQuoted inlineParser <|> singleQuoted inlineParser -- | Parses inline text in single quotes, assumes English quoting -- conventions. singleQuoted :: (HasLastStrPosition st, HasQuoteContext st m, Stream s m Char, UpdateSourcePos s Char) - => ParserT s st m Inlines - -> ParserT s st m Inlines + => ParsecT s st m Inlines + -> ParsecT s st m Inlines singleQuoted inlineParser = do singleQuoteStart (B.singleQuoted . mconcat <$> @@ -84,8 +84,8 @@ -- conventions. doubleQuoted :: (HasQuoteContext st m, HasLastStrPosition st, Stream s m Char, UpdateSourcePos s Char) - => ParserT s st m Inlines - -> ParserT s st m Inlines + => ParsecT s st m Inlines + -> ParsecT s st m Inlines doubleQuoted inlineParser = do doubleQuoteStart (B.doubleQuoted . mconcat <$> @@ -93,11 +93,12 @@ (withQuoteContext InDoubleQuote (manyTill inlineParser doubleQuoteEnd))) <|> pure (B.str "\8220") -charOrRef :: (Stream s m Char, UpdateSourcePos s Char) => [Char] -> ParserT s st m Char +charOrRef :: (Stream s m Char, UpdateSourcePos s Char) => [Char] -> ParsecT s st m Char charOrRef cs = - oneOf cs <|> try (do c <- characterReference - guard (c `elem` cs) - return c) + oneOf cs <|> try (do t <- characterReference + case T.unpack t of + [c] | c `elem` cs -> return c + _ -> fail "unexpected character reference") -- | Succeeds if the parser is -- @@ -109,7 +110,7 @@ -- Gobbles the quote character on success. singleQuoteStart :: (HasLastStrPosition st, HasQuoteContext st m, Stream s m Char, UpdateSourcePos s Char) - => ParserT s st m () + => ParsecT s st m () singleQuoteStart = do failIfInQuoteContext InSingleQuote -- single quote start can't be right after str @@ -119,7 +120,7 @@ void $ lookAhead (satisfy (not . isSpaceChar)) singleQuoteEnd :: (Stream s m Char, UpdateSourcePos s Char) - => ParserT s st m () + => ParsecT s st m () singleQuoteEnd = try $ do charOrRef "'\8217\146" notFollowedBy alphaNum @@ -137,7 +138,7 @@ doubleQuoteStart :: (HasLastStrPosition st, HasQuoteContext st m, Stream s m Char, UpdateSourcePos s Char) - => ParserT s st m () + => ParsecT s st m () doubleQuoteStart = do failIfInQuoteContext InDoubleQuote guard =<< notAfterString @@ -146,24 +147,24 @@ -- | Parses a closing quote character. doubleQuoteEnd :: (Stream s m Char, UpdateSourcePos s Char) - => ParserT s st m () + => ParsecT s st m () doubleQuoteEnd = void (charOrRef "\"\8221\148") -- | Parses an ASCII apostrophe (@'@) or right single quotation mark and -- returns a RIGHT SINGLE QUOtatiON MARK character. apostrophe :: (Stream s m Char, UpdateSourcePos s Char) - => ParserT s st m Inlines + => ParsecT s st m Inlines apostrophe = (char '\'' <|> char '\8217') >> return (B.str "\8217") -- | Parses an ASCII quotation mark character and returns a RIGHT DOUBLE -- QUOTATION MARK. doubleCloseQuote :: (Stream s m Char, UpdateSourcePos s Char) - => ParserT s st m Inlines + => ParsecT s st m Inlines doubleCloseQuote = B.str "\8221" <$ char '"' -- | Parses three dots as HORIZONTAL ELLIPSIS. ellipses :: (Stream s m Char, UpdateSourcePos s Char) - => ParserT s st m Inlines + => ParsecT s st m Inlines ellipses = try (string "..." >> return (B.str "\8230")) -- | Parses two hyphens as EN DASH and three as EM DASH. @@ -172,7 +173,7 @@ -- parsed as EM DASH, and one hyphen is parsed as EN DASH if it is -- followed by a digit. dash :: (HasReaderOptions st, Stream s m Char, UpdateSourcePos s Char) - => ParserT s st m Inlines + => ParsecT s st m Inlines dash = try $ do oldDashes <- extensionEnabled Ext_old_dashes <$> getOption readerExtensions if oldDashes diff --git a/src/Text/Pandoc/Parsing/State.hs b/src/Text/Pandoc/Parsing/State.hs --- a/src/Text/Pandoc/Parsing/State.hs +++ b/src/Text/Pandoc/Parsing/State.hs @@ -3,7 +3,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Parsing - Copyright : Copyright (C) 2006-2022 John MacFarlane + Copyright : Copyright (C) 2006-2023 John MacFarlane License : GPL-2.0-or-later Maintainer : John MacFarlane @@ -32,8 +32,8 @@ import Text.Pandoc.Logging (LogMessage) import Text.Pandoc.Options (ReaderOptions) import Text.Pandoc.Parsing.Capabilities -import Text.Pandoc.Parsing.Types -import Text.Pandoc.Readers.LaTeX.Types (Macro) +import Text.Pandoc.Parsing.Future +import Text.Pandoc.TeX (Macro) import qualified Data.Map as M import qualified Data.Set as Set @@ -46,7 +46,6 @@ , stateQuoteContext :: QuoteContext -- ^ Inside quoted environment? , stateAllowLinks :: Bool -- ^ Allow parsing of links , stateAllowLineBreaks :: Bool -- ^ Allow parsing of line breaks - , stateMaxNestingLevel :: Int -- ^ Max # of nested Strong/Emph , stateLastStrPos :: Maybe SourcePos -- ^ Position after last str parsed , stateKeys :: KeyTable -- ^ List of reference keys , stateHeaderKeys :: KeyTable -- ^ List of implicit header ref keys @@ -141,7 +140,6 @@ , stateQuoteContext = NoQuote , stateAllowLinks = True , stateAllowLineBreaks = True - , stateMaxNestingLevel = 6 , stateLastStrPos = Nothing , stateKeys = M.empty , stateHeaderKeys = M.empty diff --git a/src/Text/Pandoc/Parsing/Types.hs b/src/Text/Pandoc/Parsing/Types.hs deleted file mode 100644 --- a/src/Text/Pandoc/Parsing/Types.hs +++ /dev/null @@ -1,58 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{- | - Module : Text.Pandoc.Parsing - Copyright : Copyright (C) 2006-2022 John MacFarlane - License : GPL-2.0-or-later - Maintainer : John MacFarlane - -Types and type-related functions for parsers. --} - -module Text.Pandoc.Parsing.Types - ( Parser - , ParserT - , Future (..) - , runF - , askF - , asksF - , returnF - ) -where - -import Prelude hiding (Applicative(..)) -import Control.Applicative (Applicative(..)) -import Control.Monad.Reader - ( asks, runReader, MonadReader(ask), Reader, ReaderT(ReaderT) ) -import Text.Parsec ( Parsec , ParsecT ) - --- | Generic parser type used by many pandoc readers. -type Parser t s = Parsec t s - --- | Generic parser transformer used by many pandoc readers. -type ParserT = ParsecT - --- | Reader monad wrapping the parser state. This is used to possibly --- delay evaluation until all relevant information has been parsed and --- made available in the parser state. -newtype Future s a = Future { runDelayed :: Reader s a } - deriving (Monad, Applicative, Functor) - -instance Semigroup a => Semigroup (Future s a) where - (<>) = liftA2 (<>) - -instance (Semigroup a, Monoid a) => Monoid (Future s a) where - mempty = return mempty - mappend = (<>) - --- | Run a delayed action with the given state. -runF :: Future s a -> s -> a -runF = runReader . runDelayed - -askF :: Future s s -askF = Future ask - -asksF :: (s -> a) -> Future s a -asksF f = Future $ asks f - -returnF :: Monad m => a -> m (Future s a) -returnF = return . return diff --git a/src/Text/Pandoc/Process.hs b/src/Text/Pandoc/Process.hs --- a/src/Text/Pandoc/Process.hs +++ b/src/Text/Pandoc/Process.hs @@ -1,6 +1,6 @@ {- | Module : Text.Pandoc.Process - Copyright : Copyright (C) 2013-2022 John MacFarlane + Copyright : Copyright (C) 2013-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane diff --git a/src/Text/Pandoc/Readers.hs b/src/Text/Pandoc/Readers.hs --- a/src/Text/Pandoc/Readers.hs +++ b/src/Text/Pandoc/Readers.hs @@ -1,10 +1,11 @@ +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} {- | Module : Text.Pandoc.Readers - Copyright : Copyright (C) 2006-2022 John MacFarlane + Copyright : Copyright (C) 2006-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane @@ -25,7 +26,7 @@ Reader (..) , readers , readDocx - , readOdt + , readODT , readMarkdown , readCommonMark , readCreole @@ -64,17 +65,16 @@ , getDefaultExtensions ) where -import Control.Monad (unless) import Control.Monad.Except (throwError) import Data.Aeson import qualified Data.ByteString.Lazy as BL import Data.Text (Text) import qualified Data.Text as T -import Text.Pandoc.Shared (tshow) import Text.Pandoc.Class import Text.Pandoc.Definition import Text.Pandoc.Error import Text.Pandoc.Extensions +import qualified Text.Pandoc.Format as Format import Text.Pandoc.Options import Text.Pandoc.Readers.CommonMark import Text.Pandoc.Readers.Markdown @@ -93,7 +93,7 @@ import Text.Pandoc.Readers.MediaWiki import Text.Pandoc.Readers.Muse import Text.Pandoc.Readers.Native -import Text.Pandoc.Readers.Odt +import Text.Pandoc.Readers.ODT import Text.Pandoc.Readers.OPML import Text.Pandoc.Readers.Org import Text.Pandoc.Readers.RST @@ -145,7 +145,7 @@ ,("twiki" , TextReader readTWiki) ,("tikiwiki" , TextReader readTikiWiki) ,("docx" , ByteStringReader readDocx) - ,("odt" , ByteStringReader readOdt) + ,("odt" , ByteStringReader readODT) ,("t2t" , TextReader readTxt2Tags) ,("epub" , ByteStringReader readEPUB) ,("muse" , TextReader readMuse) @@ -162,29 +162,14 @@ ,("rtf" , TextReader readRTF) ] --- | Retrieve reader, extensions based on formatSpec (format+extensions). -getReader :: PandocMonad m => Text -> m (Reader m, Extensions) -getReader s = - case parseFormatSpec s of - Left e -> throwError $ PandocAppError $ - "Error parsing reader format " <> tshow s <> ": " <> tshow e - Right (readerName, extsToEnable, extsToDisable) -> - case lookup readerName readers of - Nothing -> throwError $ PandocUnknownReaderError - readerName - Just r -> do - let allExts = getAllExtensions readerName - let exts = foldr disableExtension - (foldr enableExtension - (getDefaultExtensions readerName) - extsToEnable) extsToDisable - mapM_ (\ext -> - unless (extensionEnabled ext allExts) $ - throwError $ - PandocUnsupportedExtensionError - (T.drop 4 $ T.pack $ show ext) readerName) - (extsToEnable ++ extsToDisable) - return (r, exts) +-- | Retrieve reader, extensions based on format spec (format+extensions). +getReader :: PandocMonad m => Format.FlavoredFormat -> m (Reader m, Extensions) +getReader flvrd = do + let readerName = Format.formatName flvrd + case lookup readerName readers of + Nothing -> throwError $ PandocUnknownReaderError readerName + Just r -> (r,) <$> + Format.applyExtensionsDiff (Format.getExtensionsConfig readerName) flvrd -- | Read pandoc document from JSON format. readJSON :: (PandocMonad m, ToSources a) diff --git a/src/Text/Pandoc/Readers/BibTeX.hs b/src/Text/Pandoc/Readers/BibTeX.hs --- a/src/Text/Pandoc/Readers/BibTeX.hs +++ b/src/Text/Pandoc/Readers/BibTeX.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Readers.BibTeX - Copyright : Copyright (C) 2020-2022 John MacFarlane + Copyright : Copyright (C) 2020-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane @@ -23,6 +23,7 @@ import Text.Pandoc.Options import Text.Pandoc.Definition import Text.Pandoc.Builder (setMeta, cite, str) +import Text.Pandoc.Parsing (fromParsecError) import Citeproc (Lang(..), parseLang) import Citeproc.Locale (getLocale) import Text.Pandoc.Error (PandocError(..)) @@ -63,7 +64,7 @@ Left _ -> throwError $ PandocCiteprocError e Right l -> return l case BibTeX.readBibtexString variant locale (const True) t of - Left e -> throwError $ PandocParsecError (toSources t) e + Left e -> throwError $ fromParsecError (toSources t) e Right refs -> return $ setMeta "references" (map referenceToMetaValue refs) . setMeta "nocite" diff --git a/src/Text/Pandoc/Readers/CSV.hs b/src/Text/Pandoc/Readers/CSV.hs --- a/src/Text/Pandoc/Readers/CSV.hs +++ b/src/Text/Pandoc/Readers/CSV.hs @@ -3,7 +3,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {- | Module : Text.Pandoc.Readers.CSV - Copyright : Copyright (C) 2006-2022 John MacFarlane + Copyright : Copyright (C) 2006-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane @@ -21,11 +21,11 @@ import Text.Pandoc.Definition import qualified Text.Pandoc.Builder as B import Text.Pandoc.Class (PandocMonad) -import Text.Pandoc.Error import Text.Pandoc.Sources (ToSources(..), sourcesToText) import Text.Pandoc.Options (ReaderOptions) import Control.Monad.Except (throwError) import Data.Text (Text) +import Text.Pandoc.Parsing (fromParsecError) readCSV :: (PandocMonad m, ToSources a) => ReaderOptions -- ^ Reader options @@ -68,4 +68,4 @@ aligns = replicate numcols AlignDefault widths = replicate numcols ColWidthDefault Right [] -> return $ B.doc mempty - Left e -> throwError $ PandocParsecError (toSources [("",txt)]) e + Left e -> throwError $ fromParsecError (toSources [("",txt)]) e diff --git a/src/Text/Pandoc/Readers/CommonMark.hs b/src/Text/Pandoc/Readers/CommonMark.hs --- a/src/Text/Pandoc/Readers/CommonMark.hs +++ b/src/Text/Pandoc/Readers/CommonMark.hs @@ -3,7 +3,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {- | Module : Text.Pandoc.Readers.CommonMark - Copyright : Copyright (C) 2015-2022 John MacFarlane + Copyright : Copyright (C) 2015-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane @@ -25,15 +25,16 @@ import Text.Pandoc.Definition import Text.Pandoc.Builder as B import Text.Pandoc.Options -import Text.Pandoc.Error import Text.Pandoc.Readers.Metadata (yamlMetaBlock) -import Control.Monad.Except +import Control.Monad (MonadPlus(mzero)) +import Control.Monad.Except ( MonadError(throwError) ) import Data.Functor.Identity (runIdentity) import Data.Typeable import Text.Pandoc.Parsing (runParserT, getInput, getPosition, runF, defaultParserState, option, many1, anyChar, - Sources(..), ToSources(..), ParserT, Future, - sourceName, sourceLine, incSourceLine) + Sources(..), ToSources(..), ParsecT, Future, + sourceName, sourceLine, incSourceLine, + fromParsecError) import Text.Pandoc.Walk (walk) import qualified Data.Text as T import qualified Data.Attoparsec.Text as A @@ -80,7 +81,7 @@ metaValueParser :: Monad m - => ReaderOptions -> ParserT Sources st m (Future st MetaValue) + => ReaderOptions -> ParsecT Sources st m (Future st MetaValue) metaValueParser opts = do inp <- option "" $ T.pack <$> many1 anyChar let toks = concatMap sourceToToks (unSources (toSources inp)) @@ -95,10 +96,10 @@ else id) <$> if isEnabled Ext_sourcepos opts then case runIdentity (parseCommonmarkWith (specFor opts) toks) of - Left err -> throwError $ PandocParsecError s err + Left err -> throwError $ fromParsecError s err Right (Cm bls :: Cm SourceRange Blocks) -> return $ B.doc bls else case runIdentity (parseCommonmarkWith (specFor opts) toks) of - Left err -> throwError $ PandocParsecError s err + Left err -> throwError $ fromParsecError s err Right (Cm bls :: Cm () Blocks) -> return $ B.doc bls stripBlockComments :: Block -> Block @@ -156,6 +157,9 @@ [ (footnoteSpec <>) | isEnabled Ext_footnotes opts ] ++ [ (definitionListSpec <>) | isEnabled Ext_definition_lists opts ] ++ [ (taskListSpec <>) | isEnabled Ext_task_lists opts ] ++ + [ (wikilinksSpec TitleAfterPipe <>) + | isEnabled Ext_wikilinks_title_after_pipe opts ] ++ + [ (wikilinksSpec TitleBeforePipe <>) + | isEnabled Ext_wikilinks_title_before_pipe opts ] ++ [ (rebaseRelativePathsSpec <>) | isEnabled Ext_rebase_relative_paths opts ] - diff --git a/src/Text/Pandoc/Readers/Creole.hs b/src/Text/Pandoc/Readers/Creole.hs --- a/src/Text/Pandoc/Readers/Creole.hs +++ b/src/Text/Pandoc/Readers/Creole.hs @@ -13,7 +13,8 @@ module Text.Pandoc.Readers.Creole ( readCreole ) where -import Control.Monad.Except (guard, liftM2, throwError) +import Control.Monad +import Control.Monad.Except (throwError) import qualified Data.Foldable as F import Data.Maybe (fromMaybe) import Data.Text (Text) @@ -36,7 +37,7 @@ Left e -> throwError e Right d -> return d -type CRLParser = ParserT Sources ParserState +type CRLParser = ParsecT Sources ParserState -- -- Utility functions diff --git a/src/Text/Pandoc/Readers/CslJson.hs b/src/Text/Pandoc/Readers/CslJson.hs --- a/src/Text/Pandoc/Readers/CslJson.hs +++ b/src/Text/Pandoc/Readers/CslJson.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Readers.CslJson - Copyright : Copyright (C) 2020-2022 John MacFarlane + Copyright : Copyright (C) 2020-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane diff --git a/src/Text/Pandoc/Readers/Custom.hs b/src/Text/Pandoc/Readers/Custom.hs deleted file mode 100644 --- a/src/Text/Pandoc/Readers/Custom.hs +++ /dev/null @@ -1,83 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{- | - Module : Text.Pandoc.Readers.Custom - Copyright : Copyright (C) 2021-2022 John MacFarlane - License : GNU GPL, version 2 or above - - Maintainer : John MacFarlane - Stability : alpha - Portability : portable - -Supports custom parsers written in Lua which produce a Pandoc AST. --} -module Text.Pandoc.Readers.Custom ( readCustom ) where -import Control.Exception -import Control.Monad (when) -import Control.Monad.IO.Class (MonadIO) -import Data.Maybe (fromMaybe) -import HsLua as Lua hiding (Operation (Div)) -import Text.Pandoc.Definition -import Text.Pandoc.Class (PandocMonad, findFileWithDataFallback, report) -import Text.Pandoc.Logging -import Text.Pandoc.Lua (Global (..), runLua, setGlobals) -import Text.Pandoc.Lua.PandocLua -import Text.Pandoc.Lua.Marshal.Pandoc (peekPandoc) -import Text.Pandoc.Options -import Text.Pandoc.Sources (ToSources(..), sourcesToText) -import qualified Data.Text as T - --- | Convert custom markup to Pandoc. -readCustom :: (PandocMonad m, MonadIO m, ToSources s) - => FilePath -> ReaderOptions -> s -> m Pandoc -readCustom luaFile opts srcs = do - let globals = [ PANDOC_SCRIPT_FILE luaFile ] - luaFile' <- fromMaybe luaFile <$> findFileWithDataFallback "readers" luaFile - res <- runLua $ do - setGlobals globals - stat <- dofileTrace luaFile' - -- check for error in lua script (later we'll change the return type - -- to handle this more gracefully): - when (stat /= Lua.OK) - Lua.throwErrorAsException - parseCustom - case res of - Left msg -> throw msg - Right doc -> return doc - where - parseCustom = do - let input = toSources srcs - getglobal "Reader" - push input - push opts - pcallTrace 2 1 >>= \case - OK -> forcePeek $ peekPandoc top - ErrRun -> do - -- Caught a runtime error. Check if parsing might work if we - -- pass a string instead of a Sources list, then retry. - runPeek (peekText top) >>= \case - Failure {} -> - -- not a string error object. Bail! - throwErrorAsException - Success errmsg -> do - if "string expected, got pandoc Sources" `T.isInfixOf` errmsg - then do - pop 1 - _ <- unPandocLua $ do - report $ Deprecated "old Reader function signature" $ - T.unlines - [ "Reader functions should accept a sources list; " - , "functions expecting `string` input are deprecated. " - , "Use `tostring` to convert the first argument to a " - , "string." - ] - getglobal "Reader" - push $ sourcesToText input -- push sources as string - push opts - callTrace 2 1 - forcePeek $ peekPandoc top - else - -- nothing we can do here - throwErrorAsException - _ -> -- not a runtime error, we won't be able to recover from that - throwErrorAsException diff --git a/src/Text/Pandoc/Readers/DocBook.hs b/src/Text/Pandoc/Readers/DocBook.hs --- a/src/Text/Pandoc/Readers/DocBook.hs +++ b/src/Text/Pandoc/Readers/DocBook.hs @@ -1,9 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TemplateHaskell #-} {- | Module : Text.Pandoc.Readers.DocBook - Copyright : Copyright (C) 2006-2022 John MacFarlane + Copyright : Copyright (C) 2006-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane @@ -13,7 +14,13 @@ Conversion of DocBook XML to 'Pandoc' document. -} module Text.Pandoc.Readers.DocBook ( readDocBook ) where +import Control.Monad (MonadPlus(mplus)) import Control.Monad.State.Strict + ( MonadTrans(lift), + StateT(runStateT), + MonadState(get), + gets, + modify ) import Data.ByteString (ByteString) import Data.FileEmbed import Data.Char (isSpace, isLetter, chr) @@ -31,7 +38,7 @@ import qualified Data.Text as T import qualified Data.Text.Lazy as TL import Control.Monad.Except (throwError) -import Text.HTML.TagSoup.Entity (lookupEntity) +import Text.Pandoc.XML (lookupEntity) import Text.Pandoc.Error (PandocError(..)) import Text.Pandoc.Builder import Text.Pandoc.Class.PandocMonad (PandocMonad, report) @@ -798,33 +805,39 @@ getMediaobject e = do figTitle <- gets dbFigureTitle ident <- gets dbFigureId - (imageUrl, attr) <- - case filterElements (named "imageobject") e of - [] -> return (mempty, nullAttr) - (z:_) -> case filterChild (named "imagedata") z of - Nothing -> return (mempty, nullAttr) - Just i -> let atVal a = attrValue a i - w = case atVal "width" of - "" -> [] - d -> [("width", d)] - h = case atVal "depth" of - "" -> [] - d -> [("height", d)] - id' = case atVal "id" of - x | T.null x -> ident - | otherwise -> x - cs = T.words $ atVal "role" - atr = (id', cs, w ++ h) - in return (atVal "fileref", atr) + let (imageUrl, tit, attr) = + case filterElements (named "imageobject") e of + [] -> (mempty, mempty, nullAttr) + (z:_) -> + let tit' = maybe "" strContent $ + filterChild (named "objectinfo") z >>= + filterChild (named "title") + (imageUrl', attr') = + case filterChild (named "imagedata") z of + Nothing -> (mempty, nullAttr) + Just i -> let atVal a = attrValue a i + w = case atVal "width" of + "" -> [] + d -> [("width", d)] + h = case atVal "depth" of + "" -> [] + d -> [("height", d)] + id' = case atVal "id" of + x | T.null x -> ident + | otherwise -> x + cs = T.words $ atVal "role" + atr = (id', cs, w ++ h) + in (atVal "fileref", atr) + in (imageUrl', tit', attr') let getCaption el = case filterChild (\x -> named "caption" x || named "textobject" x || named "alt" x) el of Nothing -> return mempty - Just z -> mconcat <$> + Just z -> trimInlines . mconcat <$> mapM parseInline (elContent z) let (capt, title) = if null figTitle - then (getCaption e, "") - else (return figTitle, "fig:") + then (getCaption e, tit) + else (return figTitle, "fig:" <> tit) fmap (imageWith attr imageUrl title) capt getBlocks :: PandocMonad m => Element -> DB m Blocks @@ -1166,7 +1179,7 @@ parseInline :: PandocMonad m => Content -> DB m Inlines parseInline (Text (CData _ s _)) = return $ text s parseInline (CRef ref) = - return $ text $ maybe (T.toUpper ref) T.pack $ lookupEntity (T.unpack ref) + return $ text $ fromMaybe (T.toUpper ref) $ lookupEntity ref parseInline (Elem e) = case qName (elName e) of "anchor" -> do @@ -1265,7 +1278,10 @@ "ulink" -> innerInlines (link (attrValue "url" e) "") "link" -> do ils <- innerInlines id - let href = case findAttr (QName "href" (Just "http://www.w3.org/1999/xlink") Nothing) e of + let href = case findAttrBy + (\case + QName "href" _ _ -> True + _ -> False) e of Just h -> h _ -> "#" <> attrValue "linkend" e let ils' = if ils == mempty then str href else ils diff --git a/src/Text/Pandoc/Readers/Docx.hs b/src/Text/Pandoc/Readers/Docx.hs --- a/src/Text/Pandoc/Readers/Docx.hs +++ b/src/Text/Pandoc/Readers/Docx.hs @@ -59,8 +59,17 @@ ) where import Codec.Archive.Zip +import Control.Monad ( liftM, unless ) import Control.Monad.Reader + ( asks, + MonadReader(local), + MonadTrans(lift), + ReaderT(runReaderT) ) import Control.Monad.State.Strict + ( StateT, + gets, + modify, + evalStateT ) import Data.Bifunctor (bimap, first) import qualified Data.ByteString.Lazy as B import Data.Default (Default) @@ -117,6 +126,7 @@ , docxAnchorSet :: Set.Set T.Text , docxImmedPrevAnchor :: Maybe T.Text , docxMediaBag :: MediaBag + , docxNumberedHeadings :: Bool , docxDropCap :: Inlines -- keep track of (numId, lvl) values for -- restarting @@ -131,6 +141,7 @@ , docxAnchorSet = mempty , docxImmedPrevAnchor = Nothing , docxMediaBag = mempty + , docxNumberedHeadings = False , docxDropCap = mempty , docxListState = M.empty , docxPrevPara = mempty @@ -294,6 +305,8 @@ emph . go rPr{isItalic = Nothing, isItalicCTL = Nothing} | Just True <- bold rPr = strong . go rPr{isBold = Nothing, isBoldCTL = Nothing} + | Just _ <- rHighlight rPr = + spanWith ("",["mark"],[]) . go rPr{rHighlight = Nothing} | Just True <- isSmallCaps rPr = smallcaps . go rPr{isSmallCaps = Nothing} | Just True <- isStrike rPr = @@ -455,6 +468,8 @@ return $ link target "" ils parPartToInlines' (PlainOMath exps) = return $ math $ writeTeX exps +parPartToInlines' (OMathPara exps) = + return $ displayMath $ writeTeX exps parPartToInlines' (Field info children) = case info of HyperlinkField url -> parPartToInlines' $ ExternalHyperLink url children @@ -662,10 +677,17 @@ T.concat $ map parPartToText parparts | Just (style, n) <- pHeading pPr = do - ils <-local (\s-> s{docxInHeaderBlock=True}) + ils <- local (\s-> s{docxInHeaderBlock=True}) (smushInlines <$> mapM parPartToInlines parparts) + let classes = map normalizeToClassName . delete style + $ getStyleNames (pStyle pPr) + + hasNumbering <- gets docxNumberedHeadings + let addNum = if hasNumbering && not (numbered pPr) + then (++ ["unnumbered"]) + else id makeHeaderAnchor $ - headerWith ("", map normalizeToClassName . delete style $ getStyleNames (pStyle pPr), []) n ils + headerWith ("", addNum classes, []) n ils | otherwise = do ils <- trimSps . smushInlines <$> mapM parPartToInlines parparts prevParaIls <- gets docxPrevPara @@ -773,8 +795,6 @@ (TableHead nullAttr headerCells) [TableBody nullAttr 0 [] bodyCells] (TableFoot nullAttr []) -bodyPartToBlocks (OMathPara e) = - return $ para $ displayMath (writeTeX e) -- replace targets with generated anchors. rewriteLink' :: PandocMonad m => Inline -> DocxContext m Inline @@ -812,6 +832,9 @@ let (metabps, blkbps) = sepBodyParts bps meta <- bodyPartsToMeta metabps captions <- catMaybes <$> mapM bodyPartToTableCaption blkbps + let isNumberedPara (Paragraph pPr _) = numbered pPr + isNumberedPara _ = False + modify (\s -> s { docxNumberedHeadings = any isNumberedPara blkbps }) modify (\s -> s { docxTableCaptions = captions }) blks <- smushBlocks <$> mapM bodyPartToBlocks blkbps blks' <- rewriteLinks $ blocksToDefinitions $ blocksToBullets $ toList blks diff --git a/src/Text/Pandoc/Readers/Docx/Combine.hs b/src/Text/Pandoc/Readers/Docx/Combine.hs --- a/src/Text/Pandoc/Readers/Docx/Combine.hs +++ b/src/Text/Pandoc/Readers/Docx/Combine.hs @@ -2,7 +2,7 @@ {- | Module : Text.Pandoc.Readers.Docx.Combine Copyright : © 2014-2020 Jesse Rosenthal , - 2014-2022 John MacFarlane , + 2014-2023 John MacFarlane , 2020 Nikolay Yakimov License : GNU GPL, version 2 or above diff --git a/src/Text/Pandoc/Readers/Docx/Fields.hs b/src/Text/Pandoc/Readers/Docx/Fields.hs --- a/src/Text/Pandoc/Readers/Docx/Fields.hs +++ b/src/Text/Pandoc/Readers/Docx/Fields.hs @@ -17,8 +17,7 @@ import Data.Functor (($>), void) import qualified Data.Text as T -import Text.Parsec -import Text.Parsec.Text (Parser) +import Text.Pandoc.Parsing type URL = T.Text type Anchor = T.Text @@ -33,6 +32,8 @@ | UnknownField deriving (Show) +type Parser = Parsec T.Text () + parseFieldInfo :: T.Text -> Either ParseError FieldInfo parseFieldInfo = parse fieldInfo "" @@ -132,6 +133,6 @@ farg <- fieldArgument switches <- spaces *> many pagerefSwitch let isLink = case switches of - ("\\h", _) : _ -> True + ("\\h", _) : _ -> True _ -> False return (farg, isLink) diff --git a/src/Text/Pandoc/Readers/Docx/Parse.hs b/src/Text/Pandoc/Readers/Docx/Parse.hs --- a/src/Text/Pandoc/Readers/Docx/Parse.hs +++ b/src/Text/Pandoc/Readers/Docx/Parse.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {- | @@ -59,6 +60,7 @@ import Text.Pandoc.Readers.Docx.Parse.Styles import Codec.Archive.Zip import Control.Applicative ((<|>)) +import Control.Monad import Control.Monad.Except import Control.Monad.Reader import Control.Monad.State.Strict @@ -219,6 +221,7 @@ data ParagraphStyle = ParagraphStyle { pStyle :: [ParStyle] , indentation :: Maybe ParIndentation + , numbered :: Bool , dropCap :: Bool , pChange :: Maybe TrackedChange , pBidi :: Maybe Bool @@ -228,6 +231,7 @@ defaultParagraphStyle :: ParagraphStyle defaultParagraphStyle = ParagraphStyle { pStyle = [] , indentation = Nothing + , numbered = False , dropCap = False , pChange = Nothing , pBidi = Just False @@ -238,7 +242,6 @@ | ListItem ParagraphStyle T.Text T.Text (Maybe Level) [ParPart] | Tbl T.Text TblGrid TblLook [Row] | TblCaption ParagraphStyle [ParPart] - | OMathPara [Exp] deriving Show type TblGrid = [Integer] @@ -278,12 +281,12 @@ -> Maybe Integer -- Number of columns left below -> Maybe [(Int, Cell)] -- (rowspan so far, cell) for the row below this one -> [(Int, Cell)] -- (rowspan so far, cell) for this row - g cells _ Nothing = zip (repeat 1) cells + g cells _ Nothing = map (1,) cells g cells columnsLeftBelow (Just rowBelow) = case cells of [] -> [] thisCell@(Cell thisGridSpan _ _) : restOfRow -> case rowBelow of - [] -> zip (repeat 1) cells + [] -> map (1,) cells (spanSoFarBelow, Cell gridSpanBelow vmerge _) : _ -> let spanSoFar = case vmerge of Restart -> 1 @@ -309,6 +312,7 @@ , isStrike = isStrike a <|> isStrike b , isRTL = isRTL a <|> isRTL b , isForceCTL = isForceCTL a <|> isForceCTL b + , rHighlight = rHighlight a <|> rHighlight b , rVertAlign = rVertAlign a <|> rVertAlign b , rUnderline = rUnderline a <|> rUnderline b , rParentStyle = rParentStyle a @@ -328,6 +332,7 @@ | Chart -- placeholder for now | Diagram -- placeholder for now | PlainOMath [Exp] + | OMathPara [Exp] | Field FieldInfo [ParPart] deriving Show @@ -688,50 +693,62 @@ pNumInfo :: ParagraphStyle -> Maybe (T.Text, T.Text) pNumInfo = getParStyleField numInfo . pStyle +mkListItem :: ParagraphStyle -> Text -> Text -> [ParPart] -> D BodyPart +mkListItem parstyle numId lvl parparts = do + lvlInfo <- lookupLevel numId lvl <$> asks envNumbering + return $ ListItem parstyle numId lvl lvlInfo parparts + pStyleIndentation :: ParagraphStyle -> Maybe ParIndentation pStyleIndentation style = (getParStyleField indent . pStyle) style elemToBodyPart :: NameSpaces -> Element -> D BodyPart elemToBodyPart ns element - | isElem ns "w" "p" element - , (c:_) <- findChildrenByName ns "m" "oMathPara" element = do - expsLst <- eitherToD $ readOMML $ showElement c - return $ OMathPara expsLst + | isElem ns "m" "oMathPara" element = do + expsLst <- eitherToD $ readOMML $ showElement element + parstyle <- elemToParagraphStyle ns element + <$> asks envParStyles + <*> asks envNumbering + return $ Paragraph parstyle [OMathPara expsLst] elemToBodyPart ns element | isElem ns "w" "p" element , Just (numId, lvl) <- getNumInfo ns element = do - parstyle <- elemToParagraphStyle ns element <$> asks envParStyles + parstyle <- elemToParagraphStyle ns element + <$> asks envParStyles + <*> asks envNumbering parparts <- mconcat <$> mapD (elemToParPart ns) (elChildren element) - levelInfo <- lookupLevel numId lvl <$> asks envNumbering - return $ ListItem parstyle numId lvl levelInfo parparts + case pHeading parstyle of + Nothing -> mkListItem parstyle numId lvl parparts + Just _ -> do + return $ Paragraph parstyle parparts elemToBodyPart ns element | isElem ns "w" "p" element = do - parstyle <- elemToParagraphStyle ns element <$> asks envParStyles + parstyle <- elemToParagraphStyle ns element + <$> asks envParStyles + <*> asks envNumbering parparts' <- mconcat <$> mapD (elemToParPart ns) (elChildren element) fldCharState <- gets stateFldCharState modify $ \st -> st {stateFldCharState = emptyFldCharContents fldCharState} -- Word uses list enumeration for numbered headings, so we only -- want to infer a list from the styles if it is NOT a heading. - let parparts = parparts' ++ (openFldCharsToParParts fldCharState) in - case pHeading parstyle of - Nothing | Just (numId, lvl) <- pNumInfo parstyle -> do - levelInfo <- lookupLevel numId lvl <$> asks envNumbering - return $ ListItem parstyle numId lvl levelInfo parparts - _ -> let - hasCaptionStyle = elem "Caption" (pStyleId <$> pStyle parstyle) + let parparts = parparts' ++ (openFldCharsToParParts fldCharState) + case pHeading parstyle of + Nothing | Just (numId, lvl) <- pNumInfo parstyle -> do + mkListItem parstyle numId lvl parparts + _ -> let + hasCaptionStyle = elem "Caption" (pStyleId <$> pStyle parstyle) - hasSimpleTableField = fromMaybe False $ do - fldSimple <- findChildByName ns "w" "fldSimple" element - instr <- findAttrByName ns "w" "instr" fldSimple - pure ("Table" `elem` T.words instr) + hasSimpleTableField = fromMaybe False $ do + fldSimple <- findChildByName ns "w" "fldSimple" element + instr <- findAttrByName ns "w" "instr" fldSimple + pure ("Table" `elem` T.words instr) - hasComplexTableField = fromMaybe False $ do - instrText <- findElementByName ns "w" "instrText" element - pure ("Table" `elem` T.words (strContent instrText)) + hasComplexTableField = fromMaybe False $ do + instrText <- findElementByName ns "w" "instrText" element + pure ("Table" `elem` T.words (strContent instrText)) - in if hasCaptionStyle && (hasSimpleTableField || hasComplexTableField) - then return $ TblCaption parstyle parparts - else return $ Paragraph parstyle parparts + in if hasCaptionStyle && (hasSimpleTableField || hasComplexTableField) + then return $ TblCaption parstyle parparts + else return $ Paragraph parstyle parparts elemToBodyPart ns element | isElem ns "w" "tbl" element = do @@ -985,6 +1002,9 @@ elemToParPart' ns element | isElem ns "m" "oMath" element = fmap (return . PlainOMath) (eitherToD $ readOMML $ showElement element) +elemToParPart' ns element + | isElem ns "m" "oMathPara" element = + fmap (return . OMathPara) (eitherToD $ readOMML $ showElement element) elemToParPart' _ _ = throwError WrongElem elemToCommentStart :: NameSpaces -> Element -> D [ParPart] @@ -1115,15 +1135,22 @@ Just $ TrackedChange Deletion (ChangeInfo cId cAuthor mcDate) getTrackedChange _ _ = Nothing -elemToParagraphStyle :: NameSpaces -> Element -> ParStyleMap -> ParagraphStyle -elemToParagraphStyle ns element sty +elemToParagraphStyle :: NameSpaces -> Element + -> ParStyleMap + -> Numbering + -> ParagraphStyle +elemToParagraphStyle ns element sty numbering | Just pPr <- findChildByName ns "w" "pPr" element = let style = mapMaybe (fmap ParaStyleId . findAttrByName ns "w" "val") (findChildrenByName ns "w" "pStyle" pPr) + pStyle' = mapMaybe (`M.lookup` sty) style in ParagraphStyle - {pStyle = mapMaybe (`M.lookup` sty) style + {pStyle = pStyle' + , numbered = case getNumInfo ns element of + Just (numId, lvl) -> isJust $ lookupLevel numId lvl numbering + Nothing -> isJust $ getParStyleField numInfo pStyle' , indentation = getIndentation ns element , dropCap = @@ -1143,7 +1170,7 @@ getTrackedChange ns , pBidi = checkOnOff ns pPr (elemName ns "w" "bidi") } -elemToParagraphStyle _ _ _ = defaultParagraphStyle + | otherwise = defaultParagraphStyle elemToRunStyleD :: NameSpaces -> Element -> D RunStyle elemToRunStyleD ns element diff --git a/src/Text/Pandoc/Readers/Docx/Parse/Styles.hs b/src/Text/Pandoc/Readers/Docx/Parse/Styles.hs --- a/src/Text/Pandoc/Readers/Docx/Parse/Styles.hs +++ b/src/Text/Pandoc/Readers/Docx/Parse/Styles.hs @@ -111,6 +111,7 @@ , isStrike :: Maybe Bool , isRTL :: Maybe Bool , isForceCTL :: Maybe Bool + , rHighlight :: Maybe Text , rVertAlign :: Maybe VertAlign , rUnderline :: Maybe Text , rParentStyle :: Maybe CharStyle @@ -140,6 +141,7 @@ , isStrike = Nothing , isRTL = Nothing , isForceCTL = Nothing + , rHighlight = Nothing , rVertAlign = Nothing , rUnderline = Nothing , rParentStyle = Nothing @@ -275,6 +277,9 @@ , isStrike = checkOnOff ns rPr (elemName ns "w" "strike") , isRTL = checkOnOff ns rPr (elemName ns "w" "rtl") , isForceCTL = checkOnOff ns rPr (elemName ns "w" "cs") + , rHighlight = + findChildByName ns "w" "highlight" rPr >>= + findAttrByName ns "w" "val" , rVertAlign = findChildByName ns "w" "vertAlign" rPr >>= findAttrByName ns "w" "val" >>= diff --git a/src/Text/Pandoc/Readers/Docx/Util.hs b/src/Text/Pandoc/Readers/Docx/Util.hs --- a/src/Text/Pandoc/Readers/Docx/Util.hs +++ b/src/Text/Pandoc/Readers/Docx/Util.hs @@ -2,7 +2,7 @@ {- | Module : Text.Pandoc.Readers.Docx.StyleMaps Copyright : © 2014-2020 Jesse Rosenthal , - 2014-2022 John MacFarlane , + 2014-2023 John MacFarlane , 2015 Nikolay Yakimov License : GNU GPL, version 2 or above @@ -67,4 +67,3 @@ findAttrByName ns pref name el = let ns' = ns <> elemToNameSpaces el in findAttr (elemName ns' pref name) el - diff --git a/src/Text/Pandoc/Readers/DokuWiki.hs b/src/Text/Pandoc/Readers/DokuWiki.hs --- a/src/Text/Pandoc/Readers/DokuWiki.hs +++ b/src/Text/Pandoc/Readers/DokuWiki.hs @@ -26,9 +26,8 @@ import qualified Text.Pandoc.Builder as B import Text.Pandoc.Class.PandocMonad (PandocMonad (..)) import Text.Pandoc.Definition -import Text.Pandoc.Error (PandocError (PandocParsecError)) import Text.Pandoc.Options -import Text.Pandoc.Parsing hiding (enclosed, nested) +import Text.Pandoc.Parsing hiding (enclosed) import Text.Pandoc.Shared (trim, stringify, tshow) import Data.List (isPrefixOf, isSuffixOf) import qualified Safe @@ -43,26 +42,17 @@ res <- runParserT parseDokuWiki def {stateOptions = opts } (initialSourceName sources) sources case res of - Left e -> throwError $ PandocParsecError sources e + Left e -> throwError $ fromParsecError sources e Right d -> return d -type DWParser = ParserT Sources ParserState +type DWParser = ParsecT Sources ParserState -- * Utility functions -- | Parse end-of-line, which can be either a newline or end-of-file. -eol :: (Stream s m Char, UpdateSourcePos s Char) => ParserT s st m () +eol :: (Stream s m Char, UpdateSourcePos s Char) => ParsecT s st m () eol = void newline <|> eof -nested :: PandocMonad m => DWParser m a -> DWParser m a -nested p = do - nestlevel <- stateMaxNestingLevel <$> getState - guard $ nestlevel > 0 - updateState $ \st -> st{ stateMaxNestingLevel = stateMaxNestingLevel st - 1 } - res <- p - updateState $ \st -> st{ stateMaxNestingLevel = nestlevel } - return res - guardColumnOne :: PandocMonad m => DWParser m () guardColumnOne = getPosition >>= \pos -> guard (sourceColumn pos == 1) @@ -164,7 +154,7 @@ nestedInlines end = innerSpace <|> nestedInline where innerSpace = try $ whitespace <* notFollowedBy end - nestedInline = notFollowedBy whitespace >> nested inline + nestedInline = notFollowedBy whitespace >> inline bold :: PandocMonad m => DWParser m B.Inlines bold = try $ B.strong <$> enclosed (string "**") nestedInlines @@ -254,7 +244,7 @@ nocache = try $ mempty <$ string "~~NOCACHE~~" str :: PandocMonad m => DWParser m B.Inlines -str = B.str <$> (many1Char alphaNum <|> countChar 1 characterReference) +str = B.str <$> (many1Char alphaNum <|> characterReference) symbol :: PandocMonad m => DWParser m B.Inlines symbol = B.str <$> countChar 1 nonspaceChar diff --git a/src/Text/Pandoc/Readers/EPUB.hs b/src/Text/Pandoc/Readers/EPUB.hs --- a/src/Text/Pandoc/Readers/EPUB.hs +++ b/src/Text/Pandoc/Readers/EPUB.hs @@ -40,7 +40,8 @@ import Text.Pandoc.MIME (MimeType) import Text.Pandoc.Options (ReaderOptions (..)) import Text.Pandoc.Readers.HTML (readHtml) -import Text.Pandoc.Shared (addMetaField, collapseFilePath, escapeURI, tshow) +import Text.Pandoc.Shared (addMetaField, collapseFilePath, tshow) +import Text.Pandoc.URI (escapeURI) import qualified Text.Pandoc.UTF8 as UTF8 (toTextLazy) import Text.Pandoc.Walk (query, walk) import Text.Pandoc.XML.Light diff --git a/src/Text/Pandoc/Readers/EndNote.hs b/src/Text/Pandoc/Readers/EndNote.hs --- a/src/Text/Pandoc/Readers/EndNote.hs +++ b/src/Text/Pandoc/Readers/EndNote.hs @@ -2,7 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Readers.EndNote - Copyright : Copyright (C) 2022 John MacFarlane + Copyright : Copyright (C) 2022-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane @@ -30,7 +30,7 @@ import Text.Pandoc.Class (PandocMonad) import Text.Pandoc.Citeproc.MetaValue (referenceToMetaValue) import Text.Pandoc.Sources (Sources(..), ToSources(..), sourcesToText) -import Text.Pandoc.Citeproc.BibTeX (toName) +import Text.Pandoc.Citeproc.Name (toName, NameOpts(..)) import Control.Applicative ((<|>)) import Control.Monad.Except (throwError) import Control.Monad (mzero, unless) @@ -74,10 +74,10 @@ readEndNoteXMLCitation :: PandocMonad m => Sources -> m (Citeproc.Citation Text) readEndNoteXMLCitation sources = do - tree <- either (throwError . PandocXMLError "") return $ + tree <- either (throwError . PandocXMLError "EndNote references") return $ parseXMLElement (TL.fromStrict . sourcesToText $ sources) unless (qName (elName tree) == "EndNote") $ - throwError $ PandocXMLError "" "Expected EndNote element" + throwError $ PandocXMLError "EndNote references" "Expected EndNote element" let items = map toCitationItem $ filterElementsName (name "Cite") tree return $ Citeproc.Citation{ Citeproc.citationId = Nothing @@ -88,7 +88,7 @@ readEndNoteXMLReferences :: PandocMonad m => Sources -> m [Reference Text] readEndNoteXMLReferences sources = do - tree <- either (throwError . PandocXMLError "") return $ + tree <- either (throwError . PandocXMLError "EndNote references") return $ parseXMLElement (TL.fromStrict . sourcesToText $ sources) let records = filterElementsName (name "record") tree return $ map recordToReference records @@ -140,7 +140,9 @@ filterChildrenName (name "contributors") e >>= filterChildrenName (name "authors") >>= filterChildrenName (name "author") >>= - toName [] . B.toList . B.text . T.strip . getText + toName NameOpts{ nameOptsPrefixIsNonDroppingParticle = False + , nameOptsUseJuniorComma = False } + . B.toList . B.text . T.strip . getText titles = do x <- filterChildrenName (name "titles") e (key, name') <- [("title", "title"), diff --git a/src/Text/Pandoc/Readers/FB2.hs b/src/Text/Pandoc/Readers/FB2.hs --- a/src/Text/Pandoc/Readers/FB2.hs +++ b/src/Text/Pandoc/Readers/FB2.hs @@ -34,7 +34,7 @@ import qualified Data.Text.Lazy as TL import Data.Default import Data.Maybe -import Text.HTML.TagSoup.Entity (lookupEntity) +import Text.Pandoc.XML (lookupEntity) import Text.Pandoc.Builder import Text.Pandoc.Class.PandocMonad (PandocMonad, insertMedia, report) import Text.Pandoc.Error @@ -88,7 +88,7 @@ _ -> t convertEntity :: Text -> Text -convertEntity e = maybe (T.toUpper e) T.pack $ lookupEntity (T.unpack e) +convertEntity e = fromMaybe (T.toUpper e) $ lookupEntity e parseInline :: PandocMonad m => Content -> FB2 m Inlines parseInline (Elem e) = diff --git a/src/Text/Pandoc/Readers/HTML.hs b/src/Text/Pandoc/Readers/HTML.hs --- a/src/Text/Pandoc/Readers/HTML.hs +++ b/src/Text/Pandoc/Readers/HTML.hs @@ -5,7 +5,7 @@ {-# LANGUAGE ViewPatterns #-} {- | Module : Text.Pandoc.Readers.HTML - Copyright : Copyright (C) 2006-2022 John MacFarlane + Copyright : Copyright (C) 2006-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane @@ -21,10 +21,11 @@ , isBlockTag , isTextTag , isCommentTag + , toAttr ) where import Control.Applicative ((<|>)) -import Control.Monad (guard, msum, mzero, unless, void) +import Control.Monad (guard, mzero, unless, void) import Control.Monad.Except (throwError, catchError) import Control.Monad.Reader (ask, asks, lift, local, runReaderT) import Data.Text.Encoding.Base64 (encodeBase64) @@ -35,6 +36,7 @@ import Data.List (foldl') import qualified Data.Map as M import Data.Maybe (fromMaybe, isJust, isNothing) +import Data.Either (partitionEithers) import Data.Monoid (First (..)) import qualified Data.Set as Set import Data.Text (Text) @@ -62,10 +64,10 @@ extensionEnabled) import Text.Pandoc.Parsing hiding ((<|>)) import Text.Pandoc.Shared ( - addMetaField, blocksToInlines', escapeURI, extractSpaces, - htmlSpanLikeElements, renderTags', safeRead, tshow, formatCode) + addMetaField, extractSpaces, htmlSpanLikeElements, renderTags', + safeRead, tshow, formatCode) +import Text.Pandoc.URI (escapeURI) import Text.Pandoc.Walk -import Text.Parsec.Error import Text.TeXMath (readMathML, writeTeX) -- | Convert HTML-formatted string to 'Pandoc' document. @@ -580,24 +582,15 @@ <|> return (B.para contents) pFigure :: PandocMonad m => TagParser m Blocks -pFigure = try $ do - TagOpen _ _ <- pSatisfy (matchTagOpen "figure" []) - skipMany pBlank - let pImg = (\x -> (Just x, Nothing)) <$> - (pInTag TagsOmittable "p" pImage <* skipMany pBlank) - pCapt = (\x -> (Nothing, Just x)) <$> do - bs <- pInTags "figcaption" block - return $ blocksToInlines' $ B.toList bs - pSkip = (Nothing, Nothing) <$ pSatisfy (not . matchTagClose "figure") - res <- many (pImg <|> pCapt <|> pSkip) - let mbimg = msum $ map fst res - let mbcap = msum $ map snd res - TagClose _ <- pSatisfy (matchTagClose "figure") - let caption = fromMaybe mempty mbcap - case B.toList <$> mbimg of - Just [Image attr _ (url, tit)] -> - return $ B.simpleFigureWith attr caption url tit - _ -> mzero +pFigure = do + TagOpen tag attrList <- pSatisfy $ matchTagOpen "figure" [] + let parser = Left <$> pInTags "figcaption" block <|> + (Right <$> block) + (captions, rest) <- partitionEithers <$> manyTill parser (pCloses tag <|> eof) + -- Concatenate all captions together + return $ B.figureWith (toAttr attrList) + (B.simpleCaption (mconcat captions)) + (mconcat rest) pCodeBlock :: PandocMonad m => TagParser m Blocks pCodeBlock = try $ do @@ -661,6 +654,7 @@ "img" -> pImage "svg" -> pSvg "bdo" -> pBdo + "tt" -> pCode "code" -> pCode "samp" -> pCodeWithClass "samp" "sample" "var" -> pCodeWithClass "var" "variable" @@ -1026,7 +1020,7 @@ -- | Matches a stretch of HTML in balanced tags. htmlInBalanced :: Monad m => (Tag Text -> Bool) - -> ParserT Sources st m Text + -> ParsecT Sources st m Text htmlInBalanced f = try $ do lookAhead (char '<') sources <- getInput @@ -1075,7 +1069,7 @@ -- | Matches a tag meeting a certain condition. htmlTag :: (HasReaderOptions st, Monad m) => (Tag Text -> Bool) - -> ParserT Sources st m (Tag Text, Text) + -> ParsecT Sources st m (Tag Text, Text) htmlTag f = try $ do lookAhead (char '<') startpos <- getPosition diff --git a/src/Text/Pandoc/Readers/HTML/Parsing.hs b/src/Text/Pandoc/Readers/HTML/Parsing.hs --- a/src/Text/Pandoc/Readers/HTML/Parsing.hs +++ b/src/Text/Pandoc/Readers/HTML/Parsing.hs @@ -2,7 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Readers.HTML.Parsing - Copyright : Copyright (C) 2006-2022 John MacFarlane + Copyright : Copyright (C) 2006-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane diff --git a/src/Text/Pandoc/Readers/HTML/Table.hs b/src/Text/Pandoc/Readers/HTML/Table.hs --- a/src/Text/Pandoc/Readers/HTML/Table.hs +++ b/src/Text/Pandoc/Readers/HTML/Table.hs @@ -3,8 +3,8 @@ {-# LANGUAGE ViewPatterns #-} {- | Module : Text.Pandoc.Readers.HTML.Table - Copyright : © 2006-2022 John MacFarlane, - 2020-2022 Albert Krewinkel + Copyright : © 2006-2023 John MacFarlane, + 2020-2023 Albert Krewinkel License : GNU GPL, version 2 or above Maintainer : Albert Krewinkel diff --git a/src/Text/Pandoc/Readers/HTML/TagCategories.hs b/src/Text/Pandoc/Readers/HTML/TagCategories.hs --- a/src/Text/Pandoc/Readers/HTML/TagCategories.hs +++ b/src/Text/Pandoc/Readers/HTML/TagCategories.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Readers.HTML.TagCategories - Copyright : Copyright (C) 2006-2022 John MacFarlane + Copyright : Copyright (C) 2006-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane diff --git a/src/Text/Pandoc/Readers/HTML/Types.hs b/src/Text/Pandoc/Readers/HTML/Types.hs --- a/src/Text/Pandoc/Readers/HTML/Types.hs +++ b/src/Text/Pandoc/Readers/HTML/Types.hs @@ -2,7 +2,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {- | Module : Text.Pandoc.Readers.HTML.Types - Copyright : Copyright (C) 2006-2022 John MacFarlane + Copyright : Copyright (C) 2006-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane @@ -33,12 +33,12 @@ import Text.Pandoc.Parsing ( HasIdentifierList (..), HasLastStrPosition (..), HasLogMessages (..) , HasMacros (..), HasQuoteContext (..), HasReaderOptions (..) - , ParserT, ParserState, QuoteContext (NoQuote) + , ParsecT, ParserState, QuoteContext (NoQuote) ) -import Text.Pandoc.Readers.LaTeX.Types (Macro) +import Text.Pandoc.TeX (Macro) -- | HTML parser type -type HTMLParser m s = ParserT s HTMLState (ReaderT HTMLLocal m) +type HTMLParser m s = ParsecT s HTMLState (ReaderT HTMLLocal m) -- | HTML parser, expecting @Tag Text@ as tokens. type TagParser m = HTMLParser m [Tag Text] diff --git a/src/Text/Pandoc/Readers/Ipynb.hs b/src/Text/Pandoc/Readers/Ipynb.hs --- a/src/Text/Pandoc/Readers/Ipynb.hs +++ b/src/Text/Pandoc/Readers/Ipynb.hs @@ -4,7 +4,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {- | Module : Text.Pandoc.Readers.Ipynb - Copyright : Copyright (C) 2019-2022 John MacFarlane + Copyright : Copyright (C) 2019-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane @@ -81,13 +81,13 @@ Nothing -> mempty Just (MimeAttachments m) -> M.toList m let ident = fromMaybe mempty $ cellId c - mapM_ addAttachment attachments + mapM_ (addAttachment (cellId c)) attachments case cellType c of Ipynb.Markdown -> do bs <- if isEnabled Ext_raw_markdown opts then return [RawBlock (Format "markdown") source] else do - Pandoc _ bs <- walk fixImage <$> readMarkdown opts source + Pandoc _ bs <- walk (fixImage (cellId c)) <$> readMarkdown opts source return bs return $ B.divWith (ident,["cell","markdown"],kvs) $ B.fromList bs @@ -121,14 +121,17 @@ <> outputBlocks -- Remove attachment: prefix from images... -fixImage :: Inline -> Inline -fixImage (Image attr lab (src,tit)) - | "attachment:" `T.isPrefixOf` src = Image attr lab (T.drop 11 src, tit) -fixImage x = x +fixImage :: Maybe Text -> Inline -> Inline +fixImage mbident (Image attr lab (src,tit)) + | "attachment:" `T.isPrefixOf` src = + let src' = T.drop 11 src + qualifiedSrc = maybe src' (<> ("-" <> src')) mbident + in Image attr lab (qualifiedSrc, tit) +fixImage _ x = x -addAttachment :: PandocMonad m => (Text, MimeBundle) -> m () -addAttachment (fname, mimeBundle) = do - let fp = T.unpack fname +addAttachment :: PandocMonad m => Maybe Text -> (Text, MimeBundle) -> m () +addAttachment mbident (fname, mimeBundle) = do + let fp = T.unpack $ maybe fname (<> ("-" <> fname)) mbident case M.toList (unMimeBundle mimeBundle) of (mimeType, BinaryData bs):_ -> insertMedia fp (Just mimeType) (BL.fromStrict bs) diff --git a/src/Text/Pandoc/Readers/JATS.hs b/src/Text/Pandoc/Readers/JATS.hs --- a/src/Text/Pandoc/Readers/JATS.hs +++ b/src/Text/Pandoc/Readers/JATS.hs @@ -14,7 +14,8 @@ -} module Text.Pandoc.Readers.JATS ( readJATS ) where -import Control.Monad.State.Strict +import Control.Monad.State.Strict ( StateT(runStateT), gets, modify ) +import Control.Monad (forM_, when, unless, MonadPlus(mplus)) import Control.Monad.Except (throwError) import Text.Pandoc.Error (PandocError(..)) import Data.Char (isDigit, isSpace) @@ -26,7 +27,7 @@ import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Lazy as TL -import Text.HTML.TagSoup.Entity (lookupEntity) +import Text.Pandoc.XML (lookupEntity) import Text.Pandoc.Builder import Text.Pandoc.Class.PandocMonad (PandocMonad) import Text.Pandoc.Options @@ -37,7 +38,6 @@ import qualified Data.Set as S (fromList, member) import Data.Set ((\\)) import Text.Pandoc.Sources (ToSources(..), sourcesToText) -import qualified Data.Foldable as DF type JATS m = StateT JATSState m @@ -231,29 +231,17 @@ terms' <- mapM getInlines terms items' <- mapM getBlocks items return (mconcat $ intersperse (str "; ") terms', items') - parseFigure = - -- if a simple caption and single graphic, we emit a standard - -- implicit figure. otherwise, we emit a div with the contents - case filterChildren (named "graphic") e of - [g] -> do - capt <- case filterChild (named "caption") e of - Just t -> mconcat . - intersperse linebreak <$> - mapM getInlines - (filterChildren (const True) t) - Nothing -> return mempty - - let figAttributes = DF.toList $ - ("alt", ) . strContent <$> - filterChild (named "alt-text") e - - return $ simpleFigureWith - (attrValue "id" e, [], figAttributes) - capt - (attrValue "href" g) - (attrValue "title" g) + parseFigure = do + capt <- case filterChild (named "caption") e of + Just t -> mconcat . intersperse linebreak <$> + mapM getInlines (filterChildren (const True) t) + Nothing -> return mempty + contents <- getBlocks e - _ -> divWith (attrValue "id" e, ["fig"], []) <$> getBlocks e + return $ figureWith + (attrValue "id" e, [], []) + (simpleCaption $ plain capt) + contents parseFootnoteGroup = do forM_ (filterChildren (named "fn") e) $ \fn -> do let id' = attrValue "id" fn @@ -444,6 +432,7 @@ "issue" -> Just . ("issue",) . toMetaValue <$> getInlines el "isbn" -> Just . ("ISBN",) . toMetaValue <$> getInlines el "issn" -> Just . ("ISSN",) . toMetaValue <$> getInlines el + "uri" -> Just . ("url",) . toMetaValue <$> getInlines el "fpage" -> case filterChild (named "lpage") c of Just lp -> Just . ("page",) . toMetaValue <$> @@ -494,8 +483,8 @@ parseInline :: PandocMonad m => Content -> JATS m Inlines parseInline (Text (CData _ s _)) = return $ text s -parseInline (CRef ref) = return $ maybe (text $ T.toUpper ref) (text . T.pack) - $ lookupEntity (T.unpack ref) +parseInline (CRef ref) = return $ maybe (text $ T.toUpper ref) text + $ lookupEntity ref parseInline (Elem e) = case qName (elName e) of "italic" -> innerInlines emph diff --git a/src/Text/Pandoc/Readers/Jira.hs b/src/Text/Pandoc/Readers/Jira.hs --- a/src/Text/Pandoc/Readers/Jira.hs +++ b/src/Text/Pandoc/Readers/Jira.hs @@ -1,9 +1,9 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {- | - Module : Text.Pandoc.Readers.Org - Copyright : © 2019-2022 Albert Krewinkel - License : GNU GPL, version 2 or above + Module : Text.Pandoc.Readers.Jira + Copyright : © 2019-2023 Albert Krewinkel + License : GPL-2.0-or-later Maintainer : Albert Krewinkel @@ -12,8 +12,8 @@ module Text.Pandoc.Readers.Jira ( readJira ) where import Control.Monad.Except (throwError) -import Data.Text (Text, append, pack, singleton, unpack) -import Text.HTML.TagSoup.Entity (lookupEntity) +import Data.Text (Text, append, pack, singleton) +import Text.Pandoc.XML (lookupEntity) import Text.Jira.Parser (parse) import Text.Pandoc.Class.PandocMonad (PandocMonad (..)) import Text.Pandoc.Builder hiding (cell) @@ -137,9 +137,9 @@ Jira.Styled style inlns -> fromStyle style $ fromInlines inlns where fromInlines = foldMap jiraToPandocInlines - fromEntity e = case lookupEntity (unpack e ++ ";") of + fromEntity e = case lookupEntity (e <> ";") of Nothing -> "&" `append` e `append` ";" - Just cs -> pack cs + Just t ->t fromStyle = \case Jira.Emphasis -> emph diff --git a/src/Text/Pandoc/Readers/LaTeX.hs b/src/Text/Pandoc/Readers/LaTeX.hs --- a/src/Text/Pandoc/Readers/LaTeX.hs +++ b/src/Text/Pandoc/Readers/LaTeX.hs @@ -4,7 +4,7 @@ {-# LANGUAGE ViewPatterns #-} {- | Module : Text.Pandoc.Readers.LaTeX - Copyright : Copyright (C) 2006-2022 John MacFarlane + Copyright : Copyright (C) 2006-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane @@ -24,6 +24,7 @@ import Control.Applicative (many, optional, (<|>)) import Control.Monad import Control.Monad.Except (throwError) +import Data.Containers.ListUtils (nubOrd) import Data.Char (isDigit, isLetter, isAlphaNum, toUpper, chr) import Data.Default import Data.List (intercalate) @@ -32,6 +33,7 @@ import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as T +import Data.Either (partitionEithers) import Skylighting (defaultSyntaxMap) import System.FilePath (addExtension, replaceExtension, takeExtension) import Text.Collate.Lang (renderLang) @@ -40,14 +42,14 @@ readFileFromDirs, report, setResourcePath, getZonedTime) import Data.Time (ZonedTime(..), LocalTime(..), showGregorian) -import Text.Pandoc.Error (PandocError (PandocParseError, PandocParsecError)) +import Text.Pandoc.Error (PandocError (PandocParseError)) import Text.Pandoc.Highlighting (languagesByExtension) import Text.Pandoc.ImageSize (numUnit, showFl) import Text.Pandoc.Logging import Text.Pandoc.Options import Text.Pandoc.Parsing hiding (blankline, many, mathDisplay, mathInline, optional, space, spaces, withRaw, (<|>)) -import Text.Pandoc.Readers.LaTeX.Types (Tok (..), TokType (..)) +import Text.Pandoc.TeX (Tok (..), TokType (..)) import Text.Pandoc.Readers.LaTeX.Parsing import Text.Pandoc.Readers.LaTeX.Citation (citationCommands, cites) import Text.Pandoc.Readers.LaTeX.Math (dollarsMath, inlineEnvironments, @@ -87,7 +89,7 @@ (TokStream False (tokenizeSources sources)) case parsed of Right result -> return result - Left e -> throwError $ PandocParsecError sources e + Left e -> throwError $ fromParsecError sources e parseLaTeX :: PandocMonad m => LP m Pandoc parseLaTeX = do @@ -134,7 +136,7 @@ rawLaTeXBlock :: (PandocMonad m, HasMacros s, HasReaderOptions s) - => ParserT Sources s m Text + => ParsecT Sources s m Text rawLaTeXBlock = do lookAhead (try (char '\\' >> letter)) toks <- getInputTokens @@ -165,7 +167,7 @@ (txt <> untokenize rawargs) rawLaTeXInline :: (PandocMonad m, HasMacros s, HasReaderOptions s) - => ParserT Sources s m Text + => ParsecT Sources s m Text rawLaTeXInline = do lookAhead (try (char '\\' >> letter)) toks <- getInputTokens @@ -179,7 +181,7 @@ finalbraces <- mconcat <$> many (try (string "{}")) -- see #5439 return $ raw <> T.pack finalbraces -inlineCommand :: PandocMonad m => ParserT Sources ParserState m Inlines +inlineCommand :: PandocMonad m => ParsecT Sources ParserState m Inlines inlineCommand = do lookAhead (try (char '\\' >> letter)) toks <- getInputTokens @@ -301,7 +303,7 @@ else pure "" overlay <- option "" overlaySpecification let name' = name <> star <> overlay - let names = ordNub [name', name] -- check non-starred as fallback + let names = nubOrd [name', name] -- check non-starred as fallback let raw = do guard $ isInlineCommand name || not (isBlockCommand name) rawcommand <- getRawCommand name (cmd <> star) @@ -315,7 +317,7 @@ unescapeURL :: Text -> Text unescapeURL = T.concat . go . T.splitOn "\\" where - isEscapable c = c `elemText` "#$%&~_^\\{}" + isEscapable c = T.any (== c) "#$%&~_^\\{}" go (x:xs) = x : map unescapeInterior xs go [] = [] unescapeInterior t @@ -348,7 +350,6 @@ , ("textrm", extractSpaces (spanWith ("",["roman"],[])) <$> tok) , ("textup", extractSpaces (spanWith ("",["upright"],[])) <$> tok) , ("texttt", formatCode nullAttr <$> tok) - , ("sout", extractSpaces strikeout <$> tok) , ("alert", skipopts >> spanWith ("",["alert"],[]) <$> tok) -- beamer , ("textsuperscript", extractSpaces superscript <$> tok) , ("textsubscript", extractSpaces subscript <$> tok) @@ -422,8 +423,11 @@ -- include , ("input", rawInlineOr "input" $ include "input") -- soul package + , ("st", extractSpaces strikeout <$> tok) , ("ul", underline <$> tok) + , ("hl", extractSpaces (spanWith ("",["mark"],[])) <$> tok) -- ulem package + , ("sout", extractSpaces strikeout <$> tok) , ("uline", underline <$> tok) -- plain tex stuff that should just be passed through as raw tex , ("ifdim", ifdim) @@ -669,7 +673,7 @@ (TokStream False toks) case parsed of Right result -> return result - Left e -> throwError $ PandocParsecError (toSources toks) e + Left e -> throwError $ fromParsecError (toSources toks) e -- block elements: @@ -755,8 +759,11 @@ case M.lookup (T.pack fp) fileContentsMap of Just t -> return (Just t) Nothing -> do - dirs <- map T.unpack . splitTextBy (==':') . fromMaybe "." - <$> lookupEnv "TEXINPUTS" + dirs <- map (\t -> if T.null t + then "." + else T.unpack t) + . T.split (==':') . fromMaybe "" + <$> lookupEnv "TEXINPUTS" readFileFromDirs dirs fp ensureExtension :: (FilePath -> Bool) -> FilePath -> FilePath -> FilePath @@ -840,7 +847,7 @@ guard $ name /= "begin" && name /= "end" && name /= "and" star <- option "" ("*" <$ symbol '*' <* sp) let name' = name <> star - let names = ordNub [name', name] + let names = nubOrd [name', name] let rawDefiniteBlock = do guard $ isBlockCommand name rawcontents <- getRawCommand name (txt <> star) @@ -918,7 +925,7 @@ , ("dedication", mempty <$ (skipopts *> tok >>= addMeta "dedication")) -- sectioning , ("part", section nullAttr (-1)) - , ("part*", section nullAttr (-1)) + , ("part*", section ("",["unnumbered"],[]) (-1)) , ("chapter", section nullAttr 0) , ("chapter*", section ("",["unnumbered"],[]) 0) , ("section", section nullAttr 1) @@ -1005,8 +1012,8 @@ , ("letter", env "letter" letterContents) , ("minipage", env "minipage" $ skipopts *> spaces *> optional braced *> spaces *> blocks) - , ("figure", env "figure" $ skipopts *> figure) - , ("subfigure", env "subfigure" $ skipopts *> tok *> figure) + , ("figure", env "figure" $ skipopts *> figure') + , ("subfigure", env "subfigure" $ skipopts *> tok *> figure') , ("center", divWith ("", ["center"], []) <$> env "center" blocks) , ("quote", blockQuote <$> env "quote" blocks) , ("quotation", blockQuote <$> env "quotation" blocks) @@ -1158,36 +1165,33 @@ _ -> mempty return $ addr <> bs -- sig added by \closing -figure :: PandocMonad m => LP m Blocks -figure = try $ do +figure' :: PandocMonad m => LP m Blocks +figure' = try $ do resetCaption - blocks >>= addImageCaption - -addImageCaption :: PandocMonad m => Blocks -> LP m Blocks -addImageCaption = walkM go - where go p@(Para [Image attr@(_, cls, kvs) _ (src, tit)]) - | not ("fig:" `T.isPrefixOf` tit) = do - st <- getState - case sCaption st of - Nothing -> return p - Just figureCaption -> do - let mblabel = sLastLabel st - let attr' = case mblabel of - Just lab -> (lab, cls, kvs) - Nothing -> attr - case attr' of - ("", _, _) -> return () - (ident, _, _) -> do - num <- getNextNumber sLastFigureNum - setState - st{ sLastFigureNum = num - , sLabels = M.insert ident - [Str (renderDottedNum num)] (sLabels st) } + innerContent <- many $ try (Left <$> label) <|> (Right <$> block) + let content = walk go $ mconcat $ snd $ partitionEithers innerContent + st <- getState + let caption' = case sCaption st of + Nothing -> B.emptyCaption + Just capt -> capt + let mblabel = sLastLabel st + let attr = case mblabel of + Just lab -> (lab, [], []) + Nothing -> nullAttr + case mblabel of + Nothing -> pure () + Just lab -> do + num <- getNextNumber sLastFigureNum + setState + st { sLastFigureNum = num + , sLabels = M.insert lab [Str (renderDottedNum num)] (sLabels st) + } + return $ B.figureWith attr caption' content - return $ SimpleFigure attr' - (maybe id removeLabel mblabel (B.toList figureCaption)) - (src, tit) - go x = return x + where + -- Remove the `Image` caption b.c. it's on the `Figure` + go (Para [Image attr _ target]) = Plain [Image attr [] target] + go x = x coloredBlock :: PandocMonad m => Text -> LP m Blocks coloredBlock stylename = try $ do @@ -1324,4 +1328,3 @@ blocks :: PandocMonad m => LP m Blocks blocks = mconcat <$> many block - diff --git a/src/Text/Pandoc/Readers/LaTeX/Citation.hs b/src/Text/Pandoc/Readers/LaTeX/Citation.hs --- a/src/Text/Pandoc/Readers/LaTeX/Citation.hs +++ b/src/Text/Pandoc/Readers/LaTeX/Citation.hs @@ -15,7 +15,6 @@ import Control.Monad (mzero) import Control.Monad.Trans (lift) import Control.Monad.Except (throwError) -import Text.Pandoc.Error (PandocError(PandocParsecError)) import Text.Pandoc.Parsing hiding (blankline, many, mathDisplay, mathInline, optional, space, spaces, withRaw, (<|>)) @@ -121,7 +120,7 @@ (TokStream False toks) case parsed of Right result -> return result - Left e -> throwError $ PandocParsecError (toSources toks) e + Left e -> throwError $ fromParsecError (toSources toks) e @@ -208,4 +207,3 @@ inNote :: Inlines -> Inlines inNote ils = note $ para $ ils <> str "." - diff --git a/src/Text/Pandoc/Readers/LaTeX/Inline.hs b/src/Text/Pandoc/Readers/LaTeX/Inline.hs --- a/src/Text/Pandoc/Readers/LaTeX/Inline.hs +++ b/src/Text/Pandoc/Readers/LaTeX/Inline.hs @@ -2,7 +2,7 @@ {-# LANGUAGE ViewPatterns #-} {- | Module : Text.Pandoc.Readers.LaTeX.Inline - Copyright : Copyright (C) 2006-2022 John MacFarlane + Copyright : Copyright (C) 2006-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane @@ -27,10 +27,11 @@ import qualified Data.Text as T import Text.Pandoc.Builder import Text.Pandoc.Shared (toRomanNumeral, safeRead) -import Text.Pandoc.Readers.LaTeX.Types (Tok (..), TokType (..)) +import Text.Pandoc.TeX (Tok (..), TokType (..)) import Control.Applicative (optional, (<|>)) import Control.Monad (guard, mzero, mplus, unless) -import Text.Pandoc.Class.PandocMonad (PandocMonad (..), translateTerm) +import Text.Pandoc.Class.PandocMonad (PandocMonad (..)) +import Text.Pandoc.Translations (translateTerm) import Text.Pandoc.Readers.LaTeX.Parsing import Text.Pandoc.Extensions (extensionEnabled, Extension(..)) import Text.Pandoc.Parsing (getOption, updateState, getState, notFollowedBy, @@ -394,5 +395,3 @@ return . mconcat $ [spanWith ("",[],[("acronym-label", untokenize acro), ("acronym-form", "plural+" <> form)]) $ mconcat [str $ untokenize acro, plural]] - - diff --git a/src/Text/Pandoc/Readers/LaTeX/Lang.hs b/src/Text/Pandoc/Readers/LaTeX/Lang.hs --- a/src/Text/Pandoc/Readers/LaTeX/Lang.hs +++ b/src/Text/Pandoc/Readers/LaTeX/Lang.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Readers.LaTeX.Lang - Copyright : Copyright (C) 2018-2022 John MacFarlane + Copyright : Copyright (C) 2018-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane @@ -24,7 +24,8 @@ import qualified Data.Text as T import Text.Pandoc.Shared (extractSpaces) import Text.Collate.Lang (Lang(..), renderLang) -import Text.Pandoc.Class (PandocMonad(..), setTranslations) +import Text.Pandoc.Class (PandocMonad(..)) +import Text.Pandoc.Translations (setTranslations) import Text.Pandoc.Readers.LaTeX.Parsing import Text.Pandoc.Parsing (updateState, option, getState, QuoteContext(..), withQuoteContext) diff --git a/src/Text/Pandoc/Readers/LaTeX/Macro.hs b/src/Text/Pandoc/Readers/LaTeX/Macro.hs --- a/src/Text/Pandoc/Readers/LaTeX/Macro.hs +++ b/src/Text/Pandoc/Readers/LaTeX/Macro.hs @@ -6,7 +6,7 @@ import Text.Pandoc.Extensions (Extension(..)) import Text.Pandoc.Logging (LogMessage(MacroAlreadyDefined)) import Text.Pandoc.Readers.LaTeX.Parsing -import Text.Pandoc.Readers.LaTeX.Types +import Text.Pandoc.TeX import Text.Pandoc.Class import Text.Pandoc.Shared (safeRead) import Text.Pandoc.Parsing hiding (blankline, mathDisplay, mathInline, @@ -216,7 +216,7 @@ let result = (name, Macro GroupScope ExpandWhenUsed argspecs optarg (bg:startcontents), - Macro GroupScope ExpandWhenUsed [] Nothing + Macro GroupScope ExpandWhenUsed argspecs optarg (endcontents ++ [eg])) (do lookupMacro name case mtype of diff --git a/src/Text/Pandoc/Readers/LaTeX/Math.hs b/src/Text/Pandoc/Readers/LaTeX/Math.hs --- a/src/Text/Pandoc/Readers/LaTeX/Math.hs +++ b/src/Text/Pandoc/Readers/LaTeX/Math.hs @@ -16,7 +16,7 @@ import Text.Pandoc.Builder as B import qualified Data.Sequence as Seq import Text.Pandoc.Readers.LaTeX.Parsing -import Text.Pandoc.Readers.LaTeX.Types +import Text.Pandoc.TeX import Text.Pandoc.Class import Text.Pandoc.Shared (trimMath, stripTrailingNewlines) import Text.Pandoc.Parsing hiding (blankline, mathDisplay, mathInline, @@ -214,9 +214,8 @@ qedSign = B.str "\xa0\x25FB" italicize :: Block -> Block -italicize x@(Para [Image{}]) = x -- see #6925 +italicize x@(Para [Image{}]) = x -- see #6925 +italicize x@(Plain [Image{}]) = x -- ditto italicize (Para ils) = Para [Emph ils] italicize (Plain ils) = Plain [Emph ils] italicize x = x - - diff --git a/src/Text/Pandoc/Readers/LaTeX/Parsing.hs b/src/Text/Pandoc/Readers/LaTeX/Parsing.hs --- a/src/Text/Pandoc/Readers/LaTeX/Parsing.hs +++ b/src/Text/Pandoc/Readers/LaTeX/Parsing.hs @@ -7,7 +7,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {- | Module : Text.Pandoc.Readers.LaTeX.Parsing - Copyright : Copyright (C) 2006-2022 John MacFarlane + Copyright : Copyright (C) 2006-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane @@ -34,7 +34,6 @@ , getInputTokens , untokenize , untoken - , toksToString , satisfyTok , peekTok , parseFromToks @@ -118,11 +117,9 @@ import Text.Pandoc.Options import Text.Pandoc.Parsing hiding (blankline, many, mathDisplay, mathInline, space, spaces, withRaw, (<|>)) -import Text.Pandoc.Readers.LaTeX.Types (ExpansionPoint (..), Macro (..), +import Text.Pandoc.TeX (ExpansionPoint (..), Macro (..), ArgSpec (..), Tok (..), TokType (..)) import Text.Pandoc.Shared -import Text.Parsec.Pos -import Text.Parsec (Stream(uncons)) import Text.Pandoc.Walk newtype DottedNum = DottedNum [Int] @@ -160,7 +157,7 @@ , sLogMessages :: [LogMessage] , sIdentifiers :: Set.Set Text , sVerbatimMode :: Bool - , sCaption :: Maybe Inlines + , sCaption :: Maybe Caption , sInListItem :: Bool , sInTableCell :: Bool , sLastHeaderNum :: DottedNum @@ -264,7 +261,7 @@ uncons (TokStream _ []) = return Nothing uncons (TokStream _ (t:ts)) = return $ Just (t, TokStream False ts) -type LP m = ParserT TokStream LaTeXState m +type LP m = ParsecT TokStream LaTeXState m withVerbatimMode :: PandocMonad m => LP m a -> LP m a withVerbatimMode parser = do @@ -279,7 +276,7 @@ rawLaTeXParser :: (PandocMonad m, HasMacros s, HasReaderOptions s, Show a) => [Tok] -> LP m a -> LP m a - -> ParserT Sources s m (a, Text) + -> ParsecT Sources s m (a, Text) rawLaTeXParser toks parser valParser = do pstate <- getState let lstate = def{ sOptions = extractReaderOptions pstate } @@ -319,7 +316,7 @@ return (val, result') applyMacros :: (PandocMonad m, HasMacros s, HasReaderOptions s) - => Text -> ParserT Sources s m Text + => Text -> ParsecT Sources s m Text applyMacros s = (guardDisabled Ext_latex_macros >> return s) <|> do let retokenize = untokenize <$> many anyTok pstate <- getState @@ -347,7 +344,7 @@ -- Return tokens from input sources. Ensure that starting position is -- correct. -getInputTokens :: PandocMonad m => ParserT Sources s m [Tok] +getInputTokens :: PandocMonad m => ParsecT Sources s m [Tok] getInputTokens = do pos <- getPosition ss <- getInput @@ -414,14 +411,24 @@ Tok pos (CtrlSeq (T.singleton d)) (T.pack [c,d]) : totoks (incSourceColumn pos 2) rest' | c == '#' -> - let (t1, t2) = T.span (\d -> d >= '0' && d <= '9') rest - in case safeRead t1 of - Just i -> - Tok pos (Arg i) ("#" <> t1) - : totoks (incSourceColumn pos (1 + T.length t1)) t2 - Nothing -> - Tok pos Symbol "#" - : totoks (incSourceColumn pos 1) t2 + case T.uncons rest of + Just ('#', t3) -> + let (t1, t2) = T.span (\d -> d >= '0' && d <= '9') t3 + in case safeRead t1 of + Just i -> + Tok pos (DeferredArg i) ("##" <> t1) + : totoks (incSourceColumn pos (2 + T.length t1)) t2 + Nothing -> Tok pos Symbol "#" + : Tok (incSourceColumn pos 1) Symbol "#" + : totoks (incSourceColumn pos 1) t2 + _ -> + let (t1, t2) = T.span (\d -> d >= '0' && d <= '9') rest + in case safeRead t1 of + Just i -> + Tok pos (Arg i) ("#" <> t1) + : totoks (incSourceColumn pos (1 + T.length t1)) t2 + Nothing -> Tok pos Symbol "#" + : totoks (incSourceColumn pos 1) rest | c == '^' -> case T.uncons rest of Just ('^', rest') -> @@ -475,9 +482,6 @@ untoken :: Tok -> Text untoken t = untokenAccum t mempty -toksToString :: [Tok] -> String -toksToString = T.unpack . untokenize - parseFromToks :: PandocMonad m => LP m a -> [Tok] -> LP m a parseFromToks parser toks = do oldInput <- getInput @@ -571,6 +575,8 @@ x <- try $ spaces >> bracedOrToken getargs (M.insert i x argmap) rest + addTok False _args spos (Tok _ (DeferredArg i) txt) acc = + Tok spos (Arg i) txt : acc addTok False args spos (Tok _ (Arg i) _) acc = case M.lookup i args of Nothing -> mzero @@ -875,7 +881,7 @@ guard $ rest `elem` ["", "pt","pc","in","bp","cm","mm","dd","cc","sp"] return $ T.pack ['=' | ch] <> minus <> s -ignore :: (Monoid a, PandocMonad m) => Text -> ParserT s u m a +ignore :: (Monoid a, PandocMonad m) => Text -> ParsecT s u m a ignore raw = do pos <- getPosition report $ SkippedContent raw pos @@ -1066,10 +1072,11 @@ setCaption :: PandocMonad m => LP m Inlines -> LP m () setCaption inline = try $ do - skipopts + mbshort <- Just . toList <$> bracketed inline <|> pure Nothing ils <- tokWith inline optional $ try $ spaces *> label - updateState $ \st -> st{ sCaption = Just ils } + updateState $ \st -> st{ sCaption = Just $ + Caption mbshort [Plain $ toList ils] } resetCaption :: PandocMonad m => LP m () resetCaption = updateState $ \st -> st{ sCaption = Nothing diff --git a/src/Text/Pandoc/Readers/LaTeX/SIunitx.hs b/src/Text/Pandoc/Readers/LaTeX/SIunitx.hs --- a/src/Text/Pandoc/Readers/LaTeX/SIunitx.hs +++ b/src/Text/Pandoc/Readers/LaTeX/SIunitx.hs @@ -28,7 +28,7 @@ symbol, untokenize, LP ) -import Text.Pandoc.Readers.LaTeX.Types +import Text.Pandoc.TeX ( Tok(Tok), TokType(Word, CtrlSeq) ) import Text.Pandoc.Class.PandocMonad ( PandocMonad ) import Text.Pandoc.Parsing @@ -43,7 +43,7 @@ try, skipMany1, runParser, - Parser ) + Parsec ) import Control.Applicative ((<|>)) import Control.Monad (void) import qualified Data.Map as M @@ -122,7 +122,7 @@ mconcat (intersperse (str "," <> space) (init xs)) <> text ", & " <> last xs -parseNum :: Parser Text () Inlines +parseNum :: Parsec Text () Inlines parseNum = (mconcat <$> many parseNumPart) <* eof minus :: Text @@ -132,7 +132,7 @@ hyphenToMinus (Str t) = Str (T.replace "-" minus t) hyphenToMinus x = x -parseNumPart :: Parser Text () Inlines +parseNumPart :: Parsec Text () Inlines parseNumPart = parseDecimalNum <|> parseComma <|> @@ -145,7 +145,7 @@ where parseDecimalNum, parsePlusMinus, parsePM, parseComma, parseI, parseX, - parseExp, parseSpace :: Parser Text () Inlines + parseExp, parseSpace :: Parsec Text () Inlines parseDecimalNum = try $ do pref <- option mempty $ (mempty <$ char '+') <|> (minus <$ char '-') basenum' <- many1 (satisfy (\c -> isDigit c || c == '.')) @@ -469,5 +469,3 @@ , ("watt", str "W") , ("weber", str "Wb") ] - - diff --git a/src/Text/Pandoc/Readers/LaTeX/Table.hs b/src/Text/Pandoc/Readers/LaTeX/Table.hs --- a/src/Text/Pandoc/Readers/LaTeX/Table.hs +++ b/src/Text/Pandoc/Readers/LaTeX/Table.hs @@ -7,7 +7,7 @@ import Data.Functor (($>)) import Text.Pandoc.Class import Text.Pandoc.Readers.LaTeX.Parsing -import Text.Pandoc.Readers.LaTeX.Types +import Text.Pandoc.TeX import Text.Pandoc.Builder as B import qualified Data.Map as M import Data.Text (Text) @@ -40,17 +40,18 @@ hline :: PandocMonad m => LP m () hline = try $ do spaces - controlSeq "hline" <|> - (controlSeq "cline" <* braced) <|> - -- booktabs rules: - controlSeq "toprule" <|> - controlSeq "bottomrule" <|> - controlSeq "midrule" <|> - controlSeq "endhead" <|> - controlSeq "endfirsthead" - spaces + hasParenArg <- + (False <$ controlSeq "hline") <|> + (False <$ controlSeq "cline") <|> + (True <$ controlSeq "cmidrule") <|> + -- booktabs rules: + (True <$ controlSeq "toprule") <|> + (True <$ controlSeq "bottomrule") <|> + (True <$ controlSeq "midrule") <|> + (True <$ controlSeq "endhead") <|> + (True <$ controlSeq "endfirsthead") optional rawopt - return () + when hasParenArg $ void $ optional (parenWrapped (() <$ singleChar)) lbreak :: PandocMonad m => LP m Tok lbreak = (controlSeq "\\" <|> controlSeq "tabularnewline") @@ -354,18 +355,18 @@ addTableCaption = walkM go where go (Table attr c spec th tb tf) = do st <- getState + let capt = fromMaybe c $ sCaption st let mblabel = sLastLabel st - capt <- case (sCaption st, mblabel) of - (Just ils, Nothing) -> return $ caption Nothing (plain ils) - (Just ils, Just lab) -> do + case mblabel of + Nothing -> return () + Just lab -> do num <- getNextNumber sLastTableNum setState st{ sLastTableNum = num , sLabels = M.insert lab [Str (renderDottedNum num)] (sLabels st) } - return $ caption Nothing (plain ils) -- add number?? - (Nothing, _) -> return c + -- add num to caption? let attr' = case (attr, mblabel) of ((_,classes,kvs), Just ident) -> (ident,classes,kvs) diff --git a/src/Text/Pandoc/Readers/LaTeX/Types.hs b/src/Text/Pandoc/Readers/LaTeX/Types.hs deleted file mode 100644 --- a/src/Text/Pandoc/Readers/LaTeX/Types.hs +++ /dev/null @@ -1,54 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{- | - Module : Text.Pandoc.Readers.LaTeX.Types - Copyright : Copyright (C) 2017-2022 John MacFarlane - License : GNU GPL, version 2 or above - - Maintainer : John MacFarlane - Stability : alpha - Portability : portable - -Types for LaTeX tokens and macros. --} -module Text.Pandoc.Readers.LaTeX.Types ( Tok(..) - , TokType(..) - , Macro(..) - , ArgSpec(..) - , ExpansionPoint(..) - , MacroScope(..) - , SourcePos - ) -where -import Data.Text (Text) -import Text.Parsec.Pos (SourcePos, sourceName) -import Text.Pandoc.Sources -import Data.List (groupBy) - -data TokType = CtrlSeq Text | Spaces | Newline | Symbol | Word | Comment | - Esc1 | Esc2 | Arg Int - deriving (Eq, Ord, Show) - -data Tok = Tok SourcePos TokType Text - deriving (Eq, Ord, Show) - -instance ToSources [Tok] where - toSources = Sources - . map (\ts -> case ts of - Tok p _ _ : _ -> (p, mconcat $ map tokToText ts) - _ -> error "toSources [Tok] encountered empty group") - . groupBy (\(Tok p1 _ _) (Tok p2 _ _) -> sourceName p1 == sourceName p2) - -tokToText :: Tok -> Text -tokToText (Tok _ _ t) = t - -data ExpansionPoint = ExpandWhenDefined | ExpandWhenUsed - deriving (Eq, Ord, Show) - -data MacroScope = GlobalScope | GroupScope - deriving (Eq, Ord, Show) - -data Macro = Macro MacroScope ExpansionPoint [ArgSpec] (Maybe [Tok]) [Tok] - deriving Show - -data ArgSpec = ArgNum Int | Pattern [Tok] - deriving Show diff --git a/src/Text/Pandoc/Readers/Man.hs b/src/Text/Pandoc/Readers/Man.hs --- a/src/Text/Pandoc/Readers/Man.hs +++ b/src/Text/Pandoc/Readers/Man.hs @@ -16,7 +16,7 @@ import Data.Char (toLower) import Data.Default (Default) -import Control.Monad (liftM, mzero, guard, void) +import Control.Monad (mzero, guard, void) import Control.Monad.Trans (lift) import Control.Monad.Except (throwError) import Data.Maybe (catMaybes, isJust) @@ -24,15 +24,12 @@ import qualified Data.Text as T import Text.Pandoc.Builder as B import Text.Pandoc.Class.PandocMonad (PandocMonad(..), report) -import Text.Pandoc.Error (PandocError (PandocParsecError)) import Text.Pandoc.Logging (LogMessage(..)) import Text.Pandoc.Options import Text.Pandoc.Parsing import Text.Pandoc.Walk (query) -import Text.Pandoc.Shared (mapLeft) import Text.Pandoc.Readers.Roff -- TODO explicit imports -import qualified Text.Parsec as Parsec -import Text.Parsec.Pos (updatePosString) +import qualified Text.Pandoc.Parsing as P import qualified Data.Foldable as Foldable data ManState = ManState { readerOptions :: ReaderOptions @@ -45,7 +42,7 @@ , metadata = nullMeta , tableCellsPlain = True } -type ManParser m = ParserT [RoffToken] ManState m +type ManParser m = P.ParsecT [RoffToken] ManState m -- | Read man (troff) from an input string and return a Pandoc document. @@ -57,21 +54,18 @@ let Sources inps = toSources s tokenz <- mconcat <$> mapM (uncurry lexRoff) inps let state = def {readerOptions = opts} :: ManState - let fixError (PandocParsecError _ e) = PandocParsecError (Sources inps) e - fixError e = e eitherdoc <- readWithMTokens parseMan state (Foldable.toList . unRoffTokens $ tokenz) - either (throwError . fixError) return eitherdoc + either (throwError . fromParsecError (Sources inps)) return eitherdoc readWithMTokens :: PandocMonad m - => ParserT [RoffToken] ManState m a -- ^ parser + => ParsecT [RoffToken] ManState m a -- ^ parser -> ManState -- ^ initial state -> [RoffToken] -- ^ input - -> m (Either PandocError a) + -> m (Either ParseError a) readWithMTokens parser state input = - let leftF = PandocParsecError mempty - in mapLeft leftF `liftM` runParserT parser state "source" input + runParserT parser state "source" input parseMan :: PandocMonad m => ManParser m Pandoc @@ -180,14 +174,16 @@ -- Parser: [RoffToken] -> Pandoc -- -msatisfy :: Monad m => (RoffToken -> Bool) -> ParserT [RoffToken] st m RoffToken -msatisfy predic = tokenPrim show nextPos testTok +msatisfy :: Monad m + => (RoffToken -> Bool) -> P.ParsecT [RoffToken] st m RoffToken +msatisfy predic = P.tokenPrim show nextPos testTok where testTok t = if predic t then Just t else Nothing nextPos _pos _x (ControlLine _ _ pos':_) = pos' - nextPos pos _x _xs = updatePosString - (setSourceColumn - (setSourceLine pos $ sourceLine pos + 1) 1) "" + nextPos pos _x _xs = P.updatePosString + (P.setSourceColumn + (P.setSourceLine pos $ + P.sourceLine pos + 1) 1) "" mtoken :: PandocMonad m => ManParser m RoffToken mtoken = msatisfy (const True) @@ -431,7 +427,7 @@ (arg1 : _) -> do let cs = linePartsToText arg1 let cs' = if not (T.any (== '.') cs || T.any (== ')') cs) then cs <> "." else cs - let lt = case Parsec.runParser anyOrderedListMarker defaultParserState + let lt = case P.runParser anyOrderedListMarker defaultParserState "list marker" cs' of Right (start, listtype, listdelim) | cs == cs' -> Ordered (start, listtype, listdelim) diff --git a/src/Text/Pandoc/Readers/Markdown.hs b/src/Text/Pandoc/Readers/Markdown.hs --- a/src/Text/Pandoc/Readers/Markdown.hs +++ b/src/Text/Pandoc/Readers/Markdown.hs @@ -6,7 +6,7 @@ {-# LANGUAGE ViewPatterns #-} {- | Module : Text.Pandoc.Readers.Markdown - Copyright : Copyright (C) 2006-2022 John MacFarlane + Copyright : Copyright (C) 2006-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane @@ -24,7 +24,6 @@ import Control.Monad.Except (throwError) import Data.Bifunctor (second) import Data.Char (isAlphaNum, isPunctuation, isSpace) -import Text.DocLayout (realLength) import Data.List (transpose, elemIndex, sortOn, foldl') import qualified Data.Map as M import Data.Maybe @@ -35,6 +34,7 @@ import System.FilePath (addExtension, takeExtension, takeDirectory) import qualified System.FilePath.Windows as Windows import qualified System.FilePath.Posix as Posix +import Text.DocLayout (realLength) import Text.HTML.TagSoup hiding (Row) import Text.Pandoc.Builder (Blocks, Inlines) import qualified Text.Pandoc.Builder as B @@ -51,11 +51,12 @@ isCommentTag, isInlineTag, isTextTag) import Text.Pandoc.Readers.LaTeX (applyMacros, rawLaTeXBlock, rawLaTeXInline) import Text.Pandoc.Shared +import Text.Pandoc.URI (escapeURI, isURI) import Text.Pandoc.XML (fromEntities) import Text.Pandoc.Readers.Metadata (yamlBsToMeta, yamlBsToRefs, yamlMetaBlock) -- import Debug.Trace (traceShowId) -type MarkdownParser m = ParserT Sources ParserState m +type MarkdownParser m = ParsecT Sources ParserState m type F = Future ParserState @@ -157,14 +158,14 @@ ctx <- stateParserContext <$> getState guard (ctx == ListItemState) -spnl :: PandocMonad m => ParserT Sources st m () +spnl :: PandocMonad m => ParsecT Sources st m () spnl = try $ do skipSpaces optional newline skipSpaces notFollowedBy (char '\n') -spnl' :: PandocMonad m => ParserT Sources st m Text +spnl' :: PandocMonad m => ParsecT Sources st m Text spnl' = try $ do xs <- many spaceChar ys <- option "" $ try $ (:) <$> newline @@ -188,11 +189,11 @@ tabStop <- getOption readerTabStop gobbleAtMostSpaces (tabStop - 1) <* notFollowedBy spaceChar -litChar :: PandocMonad m => MarkdownParser m Char -litChar = escapedChar' +litChar :: PandocMonad m => MarkdownParser m Text +litChar = T.singleton <$> escapedChar' <|> characterReference - <|> noneOf "\n" - <|> try (newline >> notFollowedBy blankline >> return ' ') + <|> T.singleton <$> noneOf "\n" + <|> try (newline >> notFollowedBy blankline >> return " ") -- | Parse a sequence of inline elements between square brackets, -- including inlines between balanced pairs of square brackets. @@ -351,12 +352,14 @@ let sourceURL = fmap T.unwords $ many $ try $ do skipMany spaceChar notFollowedBy' referenceTitle - notFollowedBy' $ guardEnabled Ext_link_attributes >> attributes + notFollowedBy' $ guardEnabled Ext_link_attributes >> + attributes notFollowedBy' $ guardEnabled Ext_mmd_link_attributes >> try (spnl <* keyValAttr) notFollowedBy' (() <$ reference) - many1Char $ notFollowedBy space >> litChar - let betweenAngles = try $ char '<' >> manyTillChar litChar (char '>') + mconcat <$> many1 (notFollowedBy space *> litChar) + let betweenAngles = try $ char '<' >> + mconcat <$> (manyTill litChar (char '>')) rebase <- option False (True <$ guardEnabled Ext_rebase_relative_paths) src <- (if rebase then rebasePath pos else id) <$> (try betweenAngles <|> sourceURL) @@ -394,8 +397,8 @@ char c notFollowedBy spaces let pEnder = try $ char c >> notFollowedBy (satisfy isAlphaNum) - let regChunk = many1Char (noneOf ['\\','\n','&',c]) <|> countChar 1 litChar - let nestedChunk = (\x -> T.singleton c <> x <> T.singleton c) <$> quotedTitle c + let regChunk = many1Char (noneOf ['\\','\n','&',c]) <|> litChar + let nestedChunk = (\x -> (c `T.cons` x) `T.snoc` c) <$> quotedTitle c T.unwords . T.words . T.concat <$> manyTill (nestedChunk <|> regChunk) pEnder -- | PHP Markdown Extra style abbreviation key. Currently @@ -582,15 +585,16 @@ | T.null raw = return () | otherwise = do let key = toKey $ "[" <> raw <> "]" - updateState $ \s -> - s { stateHeaderKeys = M.insert key (("#" <> ident,""), attr) + updateState $ \s -> -- don't override existing headers + s { stateHeaderKeys = M.insertWith (\_new old -> old) + key (("#" <> ident,""), attr) (stateHeaderKeys s) } -- -- hrule block -- -hrule :: PandocMonad m => ParserT Sources st m (F Blocks) +hrule :: PandocMonad m => ParsecT Sources st m (F Blocks) hrule = try $ do skipSpaces start <- satisfy isHruleChar @@ -610,7 +614,7 @@ blockDelimiter :: PandocMonad m => (Char -> Bool) -> Maybe Int - -> ParserT Sources ParserState m Int + -> ParsecT Sources ParserState m Int blockDelimiter f len = try $ do skipNonindentSpaces c <- lookAhead (satisfy f) @@ -651,8 +655,8 @@ keyValAttr = try $ do key <- identifier char '=' - val <- T.pack <$> enclosed (char '"') (char '"') litChar - <|> T.pack <$> enclosed (char '\'') (char '\'') litChar + val <- mconcat <$> enclosed (char '"') (char '"') litChar + <|> mconcat <$> enclosed (char '\'') (char '\'') litChar <|> ("" <$ try (string "\"\"")) <|> ("" <$ try (string "''")) <|> manyChar (escapedChar' <|> noneOf " \t\n\r}") @@ -688,9 +692,17 @@ rawattr <- (Left <$> (guardEnabled Ext_raw_attribute >> try rawAttribute)) <|> - (Right <$> option ("",[],[]) - ((guardEnabled Ext_fenced_code_attributes >> try attributes) - <|> ((\x -> ("",[toLanguageId x],[])) <$> many1Char nonspaceChar))) + (Right <$> do + let pLangId = many1Char . satisfy $ \x -> + x `notElem` ['`', '{', '}'] && not (isSpace x) + mbLanguageId <- optionMaybe (toLanguageId <$> pLangId) + skipMany spaceChar + mbAttr <- optionMaybe + (guardEnabled Ext_fenced_code_attributes *> try attributes) + return $ case mbAttr of + Nothing -> ("", maybeToList mbLanguageId, []) + Just (elementId, classes, attrs) -> + (elementId, (maybe id (:) mbLanguageId) classes, attrs)) blankline contents <- T.intercalate "\n" <$> manyTill (gobbleAtMostSpaces indentLevel >> anyLine) @@ -754,7 +766,7 @@ blanklines return $ T.intercalate "\n" lns' -birdTrackLine :: PandocMonad m => Char -> ParserT Sources st m Text +birdTrackLine :: PandocMonad m => Char -> ParsecT Sources st m Text birdTrackLine c = try $ do char c -- allow html tags on left margin: @@ -1039,7 +1051,7 @@ [Image attr figCaption (src, tit)] | extensionEnabled Ext_implicit_figures exts , not (null figCaption) -> do - B.simpleFigureWith attr (B.fromList figCaption) src tit + implicitFigure attr (B.fromList figCaption) src tit _ -> constr inlns @@ -1047,19 +1059,22 @@ $ try $ do newline (mempty <$ blanklines) - <|> (guardDisabled Ext_blank_before_blockquote >> () <$ lookAhead blockQuote) - <|> (guardEnabled Ext_backtick_code_blocks >> () <$ lookAhead codeBlockFenced) - <|> (guardDisabled Ext_blank_before_header >> () <$ lookAhead header) - <|> (guardEnabled Ext_lists_without_preceding_blankline >> - -- Avoid creating a paragraph in a nested list. - notFollowedBy' inList >> - () <$ lookAhead listStart) + <|> (guardDisabled Ext_blank_before_blockquote + <* lookAhead blockQuote) + <|> (guardEnabled Ext_backtick_code_blocks + <* lookAhead codeBlockFenced) + <|> (guardDisabled Ext_blank_before_header + <* lookAhead header) + <|> (guardEnabled Ext_lists_without_preceding_blankline + -- Avoid creating a paragraph in a nested list. + <* notFollowedBy' inList + <* lookAhead listStart) <|> do guardEnabled Ext_native_divs inHtmlBlock <- stateInHtmlBlock <$> getState case inHtmlBlock of - Just "div" -> () <$ - lookAhead (htmlTag (~== TagClose ("div" :: Text))) - _ -> mzero + Just "div" -> () <$ + lookAhead (htmlTag (~== TagClose ("div" :: Text))) + _ -> mzero <|> do guardEnabled Ext_fenced_divs divLevel <- stateFencedDivLevel <$> getState if divLevel > 0 @@ -1070,6 +1085,17 @@ plain :: PandocMonad m => MarkdownParser m (F Blocks) plain = fmap B.plain . trimInlinesF <$> inlines1 +implicitFigure :: Attr -> Inlines -> Text -> Text -> Blocks +implicitFigure (ident, classes, attribs) capt url title = + let alt = case "alt" `lookup` attribs of + Just alt' -> B.text alt' + _ -> capt + attribs' = filter ((/= "alt") . fst) attribs + figattr = (ident, mempty, mempty) + caption = B.simpleCaption $ B.plain capt + figbody = B.plain $ B.imageWith ("", classes, attribs') url title alt + in B.figureWith figattr caption figbody + -- -- raw html -- @@ -1199,7 +1225,7 @@ -- and the length including trailing space. dashedLine :: PandocMonad m => Char - -> ParserT Sources st m (Int, Int) + -> ParsecT Sources st m (Int, Int) dashedLine ch = do dashes <- many1 (char ch) sp <- many spaceChar @@ -1295,7 +1321,8 @@ guardEnabled Ext_table_captions try $ do skipNonindentSpaces - (string ":" <* notFollowedBy (satisfy isPunctuation)) <|> string "Table:" + (string ":" <* notFollowedBy (satisfy isPunctuation)) <|> + (oneOf ['T','t'] >> string "able:") trimInlinesF <$> inlines1 <* blanklines -- Parse a simple table with '---' header and one line per row. @@ -1345,8 +1372,8 @@ [] -> [] (x:xs) -> reverse (x+1:xs) rawHeadsList <- if headless - then fmap (map (:[]) . tail . - splitTextByIndices (init indices')) $ lookAhead anyLine + then map (:[]) . tail . splitTextByIndices (init indices') + <$> lookAhead anyLine else return $ transpose $ map (tail . splitTextByIndices (init indices')) rawContent @@ -1391,13 +1418,15 @@ let lineWidths = map (sum . map realLength) (heads' : lines'') columns <- getOption readerColumns -- add numcols + 1 for the pipes themselves - let widths = if maximumBounded (sum seplengths : lineWidths) + (numcols + 1) > columns + let widths = if maximumBounded (sum seplengths : lineWidths) + (numcols + 1) + > columns then map (\len -> fromIntegral len / fromIntegral (sum seplengths)) seplengths else replicate (length aligns) 0.0 (headCells :: F [Blocks]) <- sequence <$> mapM cellContents heads' - (rows :: F [[Blocks]]) <- sequence <$> mapM (fmap sequence . mapM cellContents) lines'' + (rows :: F [[Blocks]]) <- sequence <$> + mapM (fmap sequence . mapM cellContents) lines'' return $ toTableComponents' NormalizeHeader aligns widths <$> headCells <*> rows @@ -1413,7 +1442,8 @@ skipMany spaceChar openPipe <- (True <$ char '|') <|> return False -- split into cells - let chunk = void (code <|> math <|> rawHtmlInline <|> escapedChar <|> rawLaTeXInline') + let chunk = void (code <|> math <|> rawHtmlInline <|> + escapedChar <|> rawLaTeXInline') <|> void (noneOf "|\n\r") cells <- (snd <$> withRaw (many chunk)) `sepBy1` char '|' closePipe <- (True <$ char '|') <|> return False @@ -1428,7 +1458,7 @@ return $ B.plain <$> result) <|> return mempty -pipeTableHeaderPart :: PandocMonad m => ParserT Sources st m (Alignment, Int) +pipeTableHeaderPart :: PandocMonad m => ParsecT Sources st m (Alignment, Int) pipeTableHeaderPart = try $ do skipMany spaceChar left <- optionMaybe (char ':') @@ -1444,7 +1474,7 @@ (Just _,Just _) -> AlignCenter, len) -- Succeed only if current line contains a pipe. -scanForPipe :: PandocMonad m => ParserT Sources st m () +scanForPipe :: PandocMonad m => ParsecT Sources st m () scanForPipe = do Sources inps <- getInput let ln = case inps of @@ -1497,10 +1527,11 @@ '_' -> strongOrEmph '*' -> strongOrEmph '^' -> superscript <|> inlineNote -- in this order bc ^[link](/foo)^ - '[' -> note <|> cite <|> bracketedSpan <|> link + '[' -> note <|> cite <|> bracketedSpan <|> wikilink <|> link '!' -> image '$' -> math '~' -> strikeout <|> subscript + '=' -> mark '<' -> autoLink <|> spanHtml <|> rawHtmlInline <|> ltSign '\\' -> math <|> escapedNewline <|> escapedChar <|> rawLaTeXInline' '@' -> cite <|> exampleRef @@ -1576,7 +1607,7 @@ <|> try (do lookAhead $ char '\\' notFollowedBy' (() <$ rawTeXBlock) char '\\') - return $ return $ B.str $ T.singleton result + return $ return $ B.str $! T.singleton result -- parses inline code, between n `s and n `s code :: PandocMonad m => MarkdownParser m (F Inlines) @@ -1601,8 +1632,8 @@ (guardEnabled Ext_inline_code_attributes >> try attributes)) return $ return $ case rawattr of - Left syn -> B.rawInline syn result - Right attr -> B.codeWith attr result + Left syn -> B.rawInline syn $! result + Right attr -> B.codeWith attr $! result math :: PandocMonad m => MarkdownParser m (F Inlines) math = (return . B.displayMath <$> (mathDisplay >>= applyMacros)) @@ -1680,7 +1711,8 @@ -> MarkdownParser m (F Inlines) inlinesBetween start end = trimInlinesF . mconcat <$> try (start >> many1Till inner end) - where inner = innerSpace <|> (notFollowedBy' (() <$ whitespace) >> inline) + where inner = innerSpace <|> + (notFollowedBy' (() <$ whitespace) >> inline) innerSpace = try $ whitespace <* notFollowedBy' end strikeout :: PandocMonad m => MarkdownParser m (F Inlines) @@ -1690,6 +1722,13 @@ >> notFollowedBy (char '~') strikeEnd = try $ string "~~" +mark :: PandocMonad m => MarkdownParser m (F Inlines) +mark = fmap (B.spanWith ("",["mark"],[])) <$> + (guardEnabled Ext_mark >> inlinesBetween markStart markEnd) + where markStart = string "==" >> lookAhead nonspaceChar + >> notFollowedBy (char '=') + markEnd = try $ string "==" + superscript :: PandocMonad m => MarkdownParser m (F Inlines) superscript = do fmap B.superscript <$> try (do @@ -1718,10 +1757,11 @@ whitespace :: PandocMonad m => MarkdownParser m (F Inlines) whitespace = spaceChar >> return <$> (lb <|> regsp) "whitespace" - where lb = spaceChar >> skipMany spaceChar >> option B.space (endline >> return B.linebreak) + where lb = spaceChar >> skipMany spaceChar + >> option B.space (endline >> return B.linebreak) regsp = skipMany spaceChar >> return B.space -nonEndline :: PandocMonad m => ParserT Sources st m Char +nonEndline :: PandocMonad m => ParsecT Sources st m Char nonEndline = satisfy (/='\n') str :: PandocMonad m => MarkdownParser m (F Inlines) @@ -1790,11 +1830,11 @@ skipSpaces let urlChunk = try parenthesizedChars - <|> (notFollowedBy (oneOf " )") >> countChar 1 litChar) + <|> (notFollowedBy (oneOf " )") >> litChar) <|> try (many1Char spaceChar <* notFollowedBy (oneOf "\"')")) let sourceURL = T.unwords . T.words . T.concat <$> many urlChunk let betweenAngles = try $ - char '<' >> manyTillChar litChar (char '>') + char '<' >> mconcat <$> (manyTill litChar (char '>')) src <- try betweenAngles <|> sourceURL tit <- option "" $ try $ spnl >> linkTitle skipSpaces @@ -1804,6 +1844,21 @@ linkTitle :: PandocMonad m => MarkdownParser m Text linkTitle = quotedTitle '"' <|> quotedTitle '\'' +wikilink :: PandocMonad m => MarkdownParser m (F Inlines) +wikilink = + (guardEnabled Ext_wikilinks_title_after_pipe *> wikilink' swap) <|> + (guardEnabled Ext_wikilinks_title_before_pipe *> wikilink' id) + where + swap (a, b) = (b, a) + wikilink' order = try $ do + string "[[" + notFollowedBy' (char '[') + raw <- many1TillChar (noneOf "\n\r\f\t") (try $ string "]]") + let (title, url) = case T.break (== '|') raw of + (before, "") -> (before, before) + (before, after) -> order (before, T.drop 1 after) + return . pure . B.link url "wikilink" $ B.str title + link :: PandocMonad m => MarkdownParser m (F Inlines) link = try $ do st <- getState @@ -2005,7 +2060,7 @@ s <- rawLaTeXInline return $ return $ B.rawInline "tex" s -- "tex" because it might be context -rawConTeXtEnvironment :: PandocMonad m => ParserT Sources st m Text +rawConTeXtEnvironment :: PandocMonad m => ParsecT Sources st m Text rawConTeXtEnvironment = try $ do string "\\start" completion <- inBrackets (letter <|> digit <|> spaceChar) @@ -2014,7 +2069,7 @@ (try $ string "\\stop" >> textStr completion) return $ "\\start" <> completion <> T.concat contents <> "\\stop" <> completion -inBrackets :: PandocMonad m => ParserT Sources st m Char -> ParserT Sources st m Text +inBrackets :: PandocMonad m => ParsecT Sources st m Char -> ParsecT Sources st m Text inBrackets parser = do char '[' contents <- manyChar parser @@ -2043,7 +2098,8 @@ updateState $ \st -> st{ stateInHtmlBlock = Just "div" } bls <- option "" (blankline >> option "" blanklines) contents <- mconcat <$> - many (notFollowedBy' (htmlTag (~== TagClose ("div" :: Text))) >> block) + many (notFollowedBy' (htmlTag (~== TagClose ("div" :: Text))) + >> block) closed <- option False (True <$ htmlTag (~== TagClose ("div" :: Text))) if closed then do diff --git a/src/Text/Pandoc/Readers/MediaWiki.hs b/src/Text/Pandoc/Readers/MediaWiki.hs --- a/src/Text/Pandoc/Readers/MediaWiki.hs +++ b/src/Text/Pandoc/Readers/MediaWiki.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Readers.MediaWiki - Copyright : Copyright (C) 2012-2022 John MacFarlane + Copyright : Copyright (C) 2012-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane @@ -19,7 +19,7 @@ import Control.Monad import Control.Monad.Except (throwError) -import Data.Char (isDigit, isSpace) +import Data.Char (isAscii, isDigit, isLetter, isSpace) import qualified Data.Foldable as F import Data.List (intersperse) import Data.Maybe (fromMaybe, maybeToList) @@ -34,8 +34,8 @@ import Text.Pandoc.Definition import Text.Pandoc.Logging import Text.Pandoc.Options -import Text.Pandoc.Parsing hiding (nested, tableCaption) -import Text.Pandoc.Readers.HTML (htmlTag, isBlockTag, isCommentTag) +import Text.Pandoc.Parsing hiding (tableCaption) +import Text.Pandoc.Readers.HTML (htmlTag, isBlockTag, isCommentTag, toAttr) import Text.Pandoc.Shared (safeRead, stringify, stripTrailingNewlines, trim, splitTextBy, tshow, formatCode) import Text.Pandoc.XML (fromEntities) @@ -69,7 +69,7 @@ , mwInTT :: Bool } -type MWParser m = ParserT Sources MWState m +type MWParser m = ParsecT Sources MWState m instance HasReaderOptions MWState where extractReaderOptions = mwOptions @@ -86,17 +86,6 @@ -- auxiliary functions -- --- This is used to prevent exponential blowups for things like: --- ''a'''a''a'''a''a'''a''a'''a -nested :: PandocMonad m => MWParser m a -> MWParser m a -nested p = do - nestlevel <- mwMaxNestingLevel `fmap` getState - guard $ nestlevel > 0 - updateState $ \st -> st{ mwMaxNestingLevel = mwMaxNestingLevel st - 1 } - res <- p - updateState $ \st -> st{ mwMaxNestingLevel = nestlevel } - return res - specialChars :: [Char] specialChars = "'[]<=&*{}|\":\\" @@ -222,22 +211,21 @@ optional rowsep hasheader <- option False $ True <$ lookAhead (skipSpaces *> char '!') (cellspecs',hdr) <- unzip <$> tableRow - let widths = map ((tableWidth *) . snd) cellspecs' + let widths = map (tableWidth *) cellspecs' let restwidth = tableWidth - sum widths let zerocols = length $ filter (==0.0) widths let defaultwidth = if zerocols == 0 || zerocols == length widths then ColWidthDefault else ColWidth $ restwidth / fromIntegral zerocols let widths' = map (\w -> if w > 0 then ColWidth w else defaultwidth) widths - let cellspecs = zip (map fst cellspecs') widths' + let cellspecs = zip (calculateAlignments hdr) widths' rows' <- many $ try $ rowsep *> (map snd <$> tableRow) optional blanklines tableEnd - let cols = length hdr let (headers,rows) = if hasheader then (hdr, rows') - else (replicate cols mempty, hdr:rows') - let toRow = Row nullAttr . map B.simpleCell + else ([], hdr:rows') + let toRow = Row nullAttr toHeaderRow l = [toRow l | not (null l)] return $ B.table (B.simpleCaption $ B.plain caption) cellspecs @@ -245,6 +233,12 @@ [TableBody nullAttr 0 [] $ map toRow rows] (TableFoot nullAttr []) +calculateAlignments :: [Cell] -> [Alignment] +calculateAlignments = map cellAligns + where + cellAligns :: Cell -> Alignment + cellAligns (Cell _ align _ _ _) = align + parseAttrs :: PandocMonad m => MWParser m [(Text,Text)] parseAttrs = many1 parseAttr @@ -252,7 +246,9 @@ parseAttr = try $ do skipMany spaceChar k <- many1Char letter + skipMany spaceChar char '=' + skipMany spaceChar v <- (char '"' >> many1TillChar (satisfy (/='\n')) (char '"')) <|> many1Char (satisfy $ \c -> not (isSpace c) && c /= '|') return (k,v) @@ -289,6 +285,7 @@ tableCaption :: PandocMonad m => MWParser m Inlines tableCaption = try $ do + optional rowsep guardColumnOne skipSpaces sym "|+" @@ -296,14 +293,14 @@ trimInlines . mconcat <$> many (notFollowedBy (cellsep <|> rowsep) *> inline) -tableRow :: PandocMonad m => MWParser m [((Alignment, Double), Blocks)] +tableRow :: PandocMonad m => MWParser m [(Double, Cell)] tableRow = try $ skipMany htmlComment *> many tableCell -tableCell :: PandocMonad m => MWParser m ((Alignment, Double), Blocks) +tableCell :: PandocMonad m => MWParser m (Double, Cell) tableCell = try $ do cellsep skipMany spaceChar - attrs <- option [] $ try $ parseAttrs <* skipSpaces <* char '|' <* + attribs <- option [] $ try $ parseAttrs <* skipSpaces <* char '|' <* notFollowedBy (char '|') skipMany spaceChar pos' <- getPosition @@ -311,15 +308,23 @@ ((snd <$> withRaw table) <|> countChar 1 anyChar)) bs <- parseFromString (do setPosition pos' mconcat <$> many block) ls - let align = case lookup "align" attrs of + let align = case lookup "align" attribs of Just "left" -> AlignLeft Just "right" -> AlignRight Just "center" -> AlignCenter _ -> AlignDefault - let width = case lookup "width" attrs of + let width = case lookup "width" attribs of Just xs -> fromMaybe 0.0 $ parseWidth xs Nothing -> 0.0 - return ((align, width), bs) + let rowspan = RowSpan . fromMaybe 1 $ + safeRead =<< lookup "rowspan" attribs + let colspan = ColSpan . fromMaybe 1 $ + safeRead =<< lookup "colspan" attribs + let handledAttribs = ["align", "colspan", "rowspan"] + attribs' = [ (k, v) | (k, v) <- attribs + , k `notElem` handledAttribs + ] + return (width, B.cellWith (toAttr attribs') align rowspan colspan bs) parseWidth :: Text -> Maybe Double parseWidth s = @@ -659,7 +664,7 @@ -- [[Help:Contents|] -> "Contents" <|> return (B.text $ T.drop 1 $ T.dropWhile (/=':') pagename) ) sym "]]" - linktrail <- B.text <$> manyChar letter + linktrail <- B.text <$> manyChar (satisfy (\c -> isAscii c && isLetter c)) let link = B.link (addUnderscores pagename) "wikilink" (label <> linktrail) if "Category:" `T.isPrefixOf` pagename then do @@ -690,12 +695,12 @@ trimInlines . mconcat <$> try (start >> many1Till inline end) emph :: PandocMonad m => MWParser m Inlines -emph = B.emph <$> nested (inlinesBetween start end) +emph = B.emph <$> inlinesBetween start end where start = sym "''" end = try $ notFollowedBy' (() <$ strong) >> sym "''" strong :: PandocMonad m => MWParser m Inlines -strong = B.strong <$> nested (inlinesBetween start end) +strong = B.strong <$> inlinesBetween start end where start = sym "'''" end = sym "'''" @@ -704,6 +709,6 @@ guardEnabled Ext_smart inTT <- mwInTT <$> getState guard (not inTT) - B.doubleQuoted <$> nested (inlinesBetween openDoubleQuote closeDoubleQuote) + B.doubleQuoted <$> inlinesBetween openDoubleQuote closeDoubleQuote where openDoubleQuote = sym "\"" >> lookAhead nonspaceChar closeDoubleQuote = try $ sym "\"" diff --git a/src/Text/Pandoc/Readers/Metadata.hs b/src/Text/Pandoc/Readers/Metadata.hs --- a/src/Text/Pandoc/Readers/Metadata.hs +++ b/src/Text/Pandoc/Readers/Metadata.hs @@ -2,7 +2,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {- | Module : Text.Pandoc.Readers.Metadata - Copyright : Copyright (C) 2006-2022 John MacFarlane + Copyright : Copyright (C) 2006-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane @@ -28,16 +28,16 @@ import Data.Aeson.Types (parse) import Text.Pandoc.Shared (tshow, blocksToInlines) import Text.Pandoc.Class.PandocMonad (PandocMonad (..)) -import Text.Pandoc.Definition hiding (Null) +import Text.Pandoc.Definition import Text.Pandoc.Error import Text.Pandoc.Parsing hiding (tableWith, parse) import qualified Text.Pandoc.UTF8 as UTF8 yamlBsToMeta :: (PandocMonad m, HasLastStrPosition st) - => ParserT Sources st m (Future st MetaValue) + => ParsecT Sources st m (Future st MetaValue) -> B.ByteString - -> ParserT Sources st m (Future st Meta) + -> ParsecT Sources st m (Future st Meta) yamlBsToMeta pMetaValue bstr = do case Yaml.decodeAllEither' bstr of Right (Object o:_) -> fmap Meta <$> yamlMap pMetaValue o @@ -50,10 +50,10 @@ -- Returns filtered list of references. yamlBsToRefs :: (PandocMonad m, HasLastStrPosition st) - => ParserT Sources st m (Future st MetaValue) + => ParsecT Sources st m (Future st MetaValue) -> (Text -> Bool) -- ^ Filter for id -> B.ByteString - -> ParserT Sources st m (Future st [MetaValue]) + -> ParsecT Sources st m (Future st [MetaValue]) yamlBsToRefs pMetaValue idpred bstr = case Yaml.decodeAllEither' bstr of Right (Object m : _) -> do @@ -74,27 +74,33 @@ $ T.pack $ Yaml.prettyPrintParseException err' normalizeMetaValue :: (PandocMonad m, HasLastStrPosition st) - => ParserT Sources st m (Future st MetaValue) + => ParsecT Sources st m (Future st MetaValue) -> Text - -> ParserT Sources st m (Future st MetaValue) + -> ParsecT Sources st m (Future st MetaValue) normalizeMetaValue pMetaValue x = -- Note: a standard quoted or unquoted YAML value will -- not end in a newline, but a "block" set off with -- `|` or `>` will. if "\n" `T.isSuffixOf` (T.dropWhileEnd isSpaceChar x) -- see #6823 - then parseFromString' pMetaValue (x <> "\n") - else parseFromString' asInlines x - where asInlines = fmap b2i <$> pMetaValue + then parseFromString' pMetaValue (x <> "\n\n") + else try (parseFromString' asInlines x') -- see #8358 + <|> -- see #8465 + parseFromString' asInlines (x' <> "\n\n") + where x' = T.dropWhile isSpaceOrNlChar x + asInlines = fmap b2i <$> pMetaValue b2i (MetaBlocks bs) = MetaInlines (blocksToInlines bs) b2i y = y isSpaceChar ' ' = True isSpaceChar '\t' = True isSpaceChar _ = False + isSpaceOrNlChar '\r' = True + isSpaceOrNlChar '\n' = True + isSpaceOrNlChar c = isSpaceChar c yamlToMetaValue :: (PandocMonad m, HasLastStrPosition st) - => ParserT Sources st m (Future st MetaValue) + => ParsecT Sources st m (Future st MetaValue) -> Value - -> ParserT Sources st m (Future st MetaValue) + -> ParsecT Sources st m (Future st MetaValue) yamlToMetaValue pMetaValue v = case v of String t -> normalizeMetaValue pMetaValue t @@ -112,9 +118,9 @@ Object o -> fmap MetaMap <$> yamlMap pMetaValue o yamlMap :: (PandocMonad m, HasLastStrPosition st) - => ParserT Sources st m (Future st MetaValue) + => ParsecT Sources st m (Future st MetaValue) -> Object - -> ParserT Sources st m (Future st (M.Map Text MetaValue)) + -> ParsecT Sources st m (Future st (M.Map Text MetaValue)) yamlMap pMetaValue o = do case fromJSON (Object o) of Error err' -> throwError $ PandocParseError $ T.pack err' @@ -131,8 +137,8 @@ -- | Parse a YAML metadata block using the supplied 'MetaValue' parser. yamlMetaBlock :: (HasLastStrPosition st, PandocMonad m) - => ParserT Sources st m (Future st MetaValue) - -> ParserT Sources st m (Future st Meta) + => ParsecT Sources st m (Future st MetaValue) + -> ParsecT Sources st m (Future st Meta) yamlMetaBlock parser = try $ do string "---" blankline @@ -143,5 +149,5 @@ optional blanklines yamlBsToMeta parser $ UTF8.fromText rawYaml -stopLine :: Monad m => ParserT Sources st m () +stopLine :: Monad m => ParsecT Sources st m () stopLine = try $ (string "---" <|> string "...") >> blankline >> return () diff --git a/src/Text/Pandoc/Readers/Muse.hs b/src/Text/Pandoc/Readers/Muse.hs --- a/src/Text/Pandoc/Readers/Muse.hs +++ b/src/Text/Pandoc/Readers/Muse.hs @@ -23,7 +23,7 @@ import Control.Monad.Except (throwError) import Data.Bifunctor import Data.Default -import Data.List (transpose, uncons) +import Data.List (transpose) import qualified Data.Map as M import qualified Data.Set as Set import Data.Maybe (fromMaybe, isNothing, maybeToList) @@ -33,7 +33,6 @@ import qualified Text.Pandoc.Builder as B import Text.Pandoc.Class.PandocMonad (PandocMonad (..)) import Text.Pandoc.Definition -import Text.Pandoc.Error (PandocError (PandocParsecError)) import Text.Pandoc.Logging import Text.Pandoc.Options import Text.Pandoc.Parsing @@ -49,7 +48,7 @@ res <- flip runReaderT def $ runParserT parseMuse def{ museOptions = opts } (initialSourceName sources) sources case res of - Left e -> throwError $ PandocParsecError sources e + Left e -> throwError $ fromParsecError sources e Right d -> return d type F = Future MuseState @@ -83,7 +82,7 @@ , museInPara = False } -type MuseParser m = ParserT Sources MuseState (ReaderT MuseEnv m) +type MuseParser m = ParsecT Sources MuseState (ReaderT MuseEnv m) instance HasReaderOptions MuseState where extractReaderOptions = museOptions @@ -156,7 +155,7 @@ -- * Parsers -- | Parse end-of-line, which can be either a newline or end-of-file. -eol :: (Stream s m Char, UpdateSourcePos s Char) => ParserT s st m () +eol :: (Stream s m Char, UpdateSourcePos s Char) => ParsecT s st m () eol = void newline <|> eof getIndent :: PandocMonad m @@ -652,7 +651,10 @@ [TableBody nullAttr 0 [] $ map toRow $ rows ++ body ++ footers] (TableFoot nullAttr []) where attrs = (AlignDefault, ColWidthDefault) <$ transpose (headers ++ body ++ footers) - (headRow, rows) = fromMaybe ([], []) $ uncons headers + (headRow, rows) = + case headers of + (r:rs) -> (r, rs) + [] -> ([], []) toRow = Row nullAttr . map B.simpleCell toHeaderRow l = [toRow l | not (null l)] diff --git a/src/Text/Pandoc/Readers/Native.hs b/src/Text/Pandoc/Readers/Native.hs --- a/src/Text/Pandoc/Readers/Native.hs +++ b/src/Text/Pandoc/Readers/Native.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Readers.Native - Copyright : Copyright (C) 2011-2022 John MacFarlane + Copyright : Copyright (C) 2011-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane diff --git a/src/Text/Pandoc/Readers/ODT.hs b/src/Text/Pandoc/Readers/ODT.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/Readers/ODT.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE OverloadedStrings #-} +{- | + Module : Text.Pandoc.Reader.ODT + Copyright : Copyright (C) 2015 Martin Linnemann + License : GNU GPL, version 2 or above + + Maintainer : Martin Linnemann + Stability : alpha + Portability : portable + +Entry point to the odt reader. +-} + +module Text.Pandoc.Readers.ODT ( readODT ) where + +import Codec.Archive.Zip +import Text.Pandoc.XML.Light + +import qualified Data.ByteString.Lazy as B + +import System.FilePath + +import Control.Monad.Except (throwError) + +import qualified Data.Text as T + +import Text.Pandoc.Class.PandocMonad (PandocMonad) +import qualified Text.Pandoc.Class.PandocMonad as P +import Text.Pandoc.Definition +import Text.Pandoc.Error +import Text.Pandoc.MediaBag +import Text.Pandoc.Options +import qualified Text.Pandoc.UTF8 as UTF8 + +import Text.Pandoc.Readers.ODT.ContentReader +import Text.Pandoc.Readers.ODT.StyleReader + +import Text.Pandoc.Readers.ODT.Generic.Fallible +import Text.Pandoc.Readers.ODT.Generic.XMLConverter +import Text.Pandoc.Shared (filteredFilesFromArchive) + +readODT :: PandocMonad m + => ReaderOptions + -> B.ByteString + -> m Pandoc +readODT opts bytes = case readODT' opts bytes of + Right (doc, mb) -> do + P.setMediaBag mb + return doc + Left e -> throwError e + +-- +readODT' :: ReaderOptions + -> B.ByteString + -> Either PandocError (Pandoc, MediaBag) +readODT' _ bytes = bytesToODT bytes-- of +-- Right (pandoc, mediaBag) -> Right (pandoc , mediaBag) +-- Left err -> Left err + +-- +bytesToODT :: B.ByteString -> Either PandocError (Pandoc, MediaBag) +bytesToODT bytes = case toArchiveOrFail bytes of + Right archive -> archiveToODT archive + Left err -> Left $ PandocParseError + $ "Could not unzip ODT: " <> T.pack err + +-- +archiveToODT :: Archive -> Either PandocError (Pandoc, MediaBag) +archiveToODT archive = do + let onFailure msg Nothing = Left $ PandocParseError msg + onFailure _ (Just x) = Right x + contentEntry <- onFailure "Could not find content.xml" + (findEntryByPath "content.xml" archive) + stylesEntry <- onFailure "Could not find styles.xml" + (findEntryByPath "styles.xml" archive) + contentElem <- entryToXmlElem contentEntry + stylesElem <- entryToXmlElem stylesEntry + styles <- either + (\_ -> Left $ PandocParseError "Could not read styles") + Right + (chooseMax (readStylesAt stylesElem ) (readStylesAt contentElem)) + let filePathIsODTMedia :: FilePath -> Bool + filePathIsODTMedia fp = + let (dir, name) = splitFileName fp + in (dir == "Pictures/") || (dir /= "./" && name == "content.xml") + let media = filteredFilesFromArchive archive filePathIsODTMedia + let startState = readerState styles media + either (\_ -> Left $ PandocParseError "Could not convert opendocument") Right + (runConverter' read_body startState contentElem) + + +-- +entryToXmlElem :: Entry -> Either PandocError Element +entryToXmlElem entry = + case parseXMLElement . UTF8.toTextLazy . fromEntry $ entry of + Right x -> Right x + Left msg -> Left $ PandocXMLError (T.pack $ eRelativePath entry) msg diff --git a/src/Text/Pandoc/Readers/ODT/Arrows/State.hs b/src/Text/Pandoc/Readers/ODT/Arrows/State.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/Readers/ODT/Arrows/State.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TupleSections #-} +{- | + Module : Text.Pandoc.Readers.ODT.Arrows.State + Copyright : Copyright (C) 2015 Martin Linnemann + License : GNU GPL, version 2 or above + + Maintainer : Martin Linnemann + Stability : alpha + Portability : portable + +An arrow that transports a state. It is in essence a more powerful version of +the standard state monad. As it is such a simple extension, there are +other version out there that do exactly the same. +The implementation is duplicated, though, to add some useful features. +Most of these might be implemented without access to innards, but it's much +faster and easier to implement this way. +-} + +module Text.Pandoc.Readers.ODT.Arrows.State where + +import Control.Arrow +import qualified Control.Category as Cat +import Control.Monad +import Data.List (foldl') +import Text.Pandoc.Readers.ODT.Arrows.Utils +import Text.Pandoc.Readers.ODT.Generic.Fallible + + +newtype ArrowState state a b = ArrowState + { runArrowState :: (state, a) -> (state, b) } + +-- | Constructor +withState :: (state -> a -> (state, b)) -> ArrowState state a b +withState = ArrowState . uncurry + +-- | Constructor +modifyState :: (state -> state ) -> ArrowState state a a +modifyState = ArrowState . first + +-- | Constructor +ignoringState :: ( a -> b ) -> ArrowState state a b +ignoringState = ArrowState . second + +-- | Constructor +fromState :: (state -> (state, b)) -> ArrowState state a b +fromState = ArrowState . (.fst) + +-- | Constructor +extractFromState :: (state -> b ) -> ArrowState state x b +extractFromState f = ArrowState $ \(state,_) -> (state, f state) + +-- | Constructor +tryModifyState :: (state -> Either f state) + -> ArrowState state a (Either f a) +tryModifyState f = ArrowState $ \(state,a) + -> (state,).Left ||| (,Right a) $ f state + +instance Cat.Category (ArrowState s) where + id = ArrowState id + arrow2 . arrow1 = ArrowState $ runArrowState arrow2 . runArrowState arrow1 + +instance Arrow (ArrowState state) where + arr = ignoringState + first a = ArrowState $ \(s,(aF,aS)) + -> second (,aS) $ runArrowState a (s,aF) + second a = ArrowState $ \(s,(aF,aS)) + -> second (aF,) $ runArrowState a (s,aS) + +instance ArrowChoice (ArrowState state) where + left a = ArrowState $ \(s,e) -> case e of + Left l -> second Left $ runArrowState a (s,l) + Right r -> (s, Right r) + right a = ArrowState $ \(s,e) -> case e of + Left l -> (s, Left l) + Right r -> second Right $ runArrowState a (s,r) + +instance ArrowApply (ArrowState state) where + app = ArrowState $ \(s, (f,b)) -> runArrowState f (s,b) + +-- | Switches the type of the state temporarily. +-- Drops the intermediate result state, behaving like a fallible +-- identity arrow, save for side effects in the state. +withSubStateF :: ArrowState s x (Either f s') + -> ArrowState s' s (Either f s ) + -> ArrowState s x (Either f x ) +withSubStateF unlift a = keepingTheValue (withSubStateF' unlift a) + >>^ spreadChoice + >>^ fmap fst + +-- | Switches the type of the state temporarily. +-- Returns the resulting sub-state. +withSubStateF' :: ArrowState s x (Either f s') + -> ArrowState s' s (Either f s ) + -> ArrowState s x (Either f s') +withSubStateF' unlift a = ArrowState go + where go p@(s,_) = tryRunning unlift + ( tryRunning a (second Right) ) + p + where tryRunning a' b v = case runArrowState a' v of + (_ , Left f) -> (s, Left f) + (x , Right y) -> b (y,x) + +-- | Fold a state arrow through something 'Foldable'. Collect the results +-- in a 'Monoid'. +-- Intermediate form of a fold between one with "only" a 'Monoid' +-- and one with any function. +foldS :: (Foldable f, Monoid m) => ArrowState s x m -> ArrowState s (f x) m +foldS a = ArrowState $ \(s,f) -> foldr a' (s,mempty) f + where a' x (s',m) = second (mappend m) $ runArrowState a (s',x) + +-- | Fold a state arrow through something 'Foldable'. Collect the results in a +-- 'MonadPlus'. +iterateS :: (Foldable f, MonadPlus m) + => ArrowState s x y + -> ArrowState s (f x) (m y) +iterateS a = ArrowState $ \(s,f) -> foldr a' (s,mzero) f + where a' x (s',m) = second (mplus m.return) $ runArrowState a (s',x) + +-- | Fold a state arrow through something 'Foldable'. Collect the results in a +-- 'MonadPlus'. +iterateSL :: (Foldable f, MonadPlus m) + => ArrowState s x y + -> ArrowState s (f x) (m y) +iterateSL a = ArrowState $ \(s,f) -> foldl' a' (s,mzero) f + where a' (s',m) x = second (mplus m.return) $ runArrowState a (s',x) + + +-- | Fold a fallible state arrow through something 'Foldable'. +-- Collect the results in a 'MonadPlus'. +-- If the iteration fails, the state will be reset to the initial one. +iterateS' :: (Foldable f, MonadPlus m) + => ArrowState s x (Either e y ) + -> ArrowState s (f x) (Either e (m y)) +iterateS' a = ArrowState $ \(s,f) -> foldr (a' s) (s,Right mzero) f + where a' s x (s',Right m) = case runArrowState a (s',x) of + (s'',Right m') -> (s'',Right $ mplus m $ return m') + (_ ,Left e ) -> (s ,Left e ) + a' _ _ e = e diff --git a/src/Text/Pandoc/Readers/ODT/Arrows/Utils.hs b/src/Text/Pandoc/Readers/ODT/Arrows/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/Readers/ODT/Arrows/Utils.hs @@ -0,0 +1,208 @@ +{- | + Module : Text.Pandoc.Readers.ODT.Arrows.Utils + Copyright : Copyright (C) 2015 Martin Linnemann + License : GNU GPL, version 2 or above + + Maintainer : Martin Linnemann + Stability : alpha + Portability : portable + +Utility functions for Arrows (Kleisli monads). + +Some general notes on notation: + +* "^" is meant to stand for a pure function that is lifted into an arrow +based on its usage for that purpose in "Control.Arrow". +* "?" is meant to stand for the usage of a 'FallibleArrow' or a pure function +with an equivalent return value. +* "_" stands for the dropping of a value. +-} + +-- We export everything +module Text.Pandoc.Readers.ODT.Arrows.Utils where + +import Prelude hiding (Applicative(..)) +import Control.Arrow +import Control.Monad (join) + +import Text.Pandoc.Readers.ODT.Generic.Fallible +import Text.Pandoc.Readers.ODT.Generic.Utils + +and2 :: (Arrow a) => a b c -> a b c' -> a b (c,c') +and2 = (&&&) + +and3 :: (Arrow a) + => a b c0->a b c1->a b c2 + -> a b (c0,c1,c2 ) +and4 :: (Arrow a) + => a b c0->a b c1->a b c2->a b c3 + -> a b (c0,c1,c2,c3 ) +and5 :: (Arrow a) + => a b c0->a b c1->a b c2->a b c3->a b c4 + -> a b (c0,c1,c2,c3,c4 ) +and6 :: (Arrow a) + => a b c0->a b c1->a b c2->a b c3->a b c4->a b c5 + -> a b (c0,c1,c2,c3,c4,c5 ) + +and3 a b c = and2 a b &&& c + >>^ \((z,y ) , x) -> (z,y,x ) +and4 a b c d = and3 a b c &&& d + >>^ \((z,y,x ) , w) -> (z,y,x,w ) +and5 a b c d e = and4 a b c d &&& e + >>^ \((z,y,x,w ) , v) -> (z,y,x,w,v ) +and6 a b c d e f = and5 a b c d e &&& f + >>^ \((z,y,x,w,v ) , u) -> (z,y,x,w,v,u ) + +liftA2 :: (Arrow a) => (x -> y -> z) -> a b x -> a b y -> a b z +liftA2 f a b = a &&& b >>^ uncurry f + +liftA3 :: (Arrow a) => (z->y->x -> r) + -> a b z->a b y->a b x + -> a b r +liftA4 :: (Arrow a) => (z->y->x->w -> r) + -> a b z->a b y->a b x->a b w + -> a b r +liftA5 :: (Arrow a) => (z->y->x->w->v -> r) + -> a b z->a b y->a b x->a b w->a b v + -> a b r +liftA6 :: (Arrow a) => (z->y->x->w->v->u -> r) + -> a b z->a b y->a b x->a b w->a b v->a b u + -> a b r + +liftA3 fun a b c = and3 a b c >>^ uncurry3 fun +liftA4 fun a b c d = and4 a b c d >>^ uncurry4 fun +liftA5 fun a b c d e = and5 a b c d e >>^ uncurry5 fun +liftA6 fun a b c d e f = and6 a b c d e f >>^ uncurry6 fun + +liftA :: (Arrow a) => (y -> z) -> a b y -> a b z +liftA fun a = a >>^ fun + + +-- | Duplicate a value to subsequently feed it into different arrows. +-- Can almost always be replaced with '(&&&)', 'keepingTheValue', +-- or even '(|||)'. +-- Equivalent to +-- > returnA &&& returnA +duplicate :: (Arrow a) => a b (b,b) +duplicate = arr $ join (,) + +-- | Applies a function to the uncurried result-pair of an arrow-application. +-- (The %-symbol was chosen to evoke an association with pairs.) +(>>%) :: (Arrow a) => a x (b,c) -> (b -> c -> d) -> a x d +a >>% f = a >>^ uncurry f + +infixr 2 >>% + + +-- | Duplicate a value and apply an arrow to the second instance. +-- Equivalent to +-- > \a -> duplicate >>> second a +-- or +-- > \a -> returnA &&& a +keepingTheValue :: (Arrow a) => a b c -> a b (b,c) +keepingTheValue a = returnA &&& a + +( ^||| ) :: (ArrowChoice a) => (b -> d) -> a c d -> a (Either b c) d +( |||^ ) :: (ArrowChoice a) => a b d -> (c -> d) -> a (Either b c) d +( ^|||^ ) :: (ArrowChoice a) => (b -> d) -> (c -> d) -> a (Either b c) d + +l ^||| r = arr l ||| r +l |||^ r = l ||| arr r +l ^|||^ r = arr l ||| arr r + +infixr 2 ^||| , |||^, ^|||^ + +( ^&&& ) :: (Arrow a) => (b -> c) -> a b c' -> a b (c,c') +( &&&^ ) :: (Arrow a) => a b c -> (b -> c') -> a b (c,c') + +l ^&&& r = arr l &&& r +l &&&^ r = l &&& arr r + +infixr 3 ^&&&, &&&^ + + +-- | Converts @Right a@ into @Just a@ and @Left _@ into @Nothing@. +choiceToMaybe :: (ArrowChoice a) => a (Either l r) (Maybe r) +choiceToMaybe = arr eitherToMaybe + +-- | Converts @Nothing@ into @Left ()@ and @Just a@ into @Right a@. +maybeToChoice :: (ArrowChoice a) => a (Maybe b) (Fallible b) +maybeToChoice = arr maybeToEither + +-- | Lifts a constant value into an arrow +returnV :: (Arrow a) => c -> a x c +returnV = arr.const + +-- | Defines Left as failure, Right as success +type FallibleArrow a input failure success = a input (Either failure success) + +-- +liftAsSuccess :: (ArrowChoice a) + => a x success + -> FallibleArrow a x failure success +liftAsSuccess a = a >>^ Right + +-- | Execute the second arrow if the first succeeds +(>>?) :: (ArrowChoice a) + => FallibleArrow a x failure success + -> FallibleArrow a success failure success' + -> FallibleArrow a x failure success' +a >>? b = a >>> Left ^||| b + +-- | Execute the lifted second arrow if the first succeeds +(>>?^) :: (ArrowChoice a) + => FallibleArrow a x failure success + -> (success -> success') + -> FallibleArrow a x failure success' +a >>?^ f = a >>^ Left ^|||^ Right . f + +-- | Execute the lifted second arrow if the first succeeds +(>>?^?) :: (ArrowChoice a) + => FallibleArrow a x failure success + -> (success -> Either failure success') + -> FallibleArrow a x failure success' +a >>?^? b = a >>> Left ^|||^ b + +-- | Execute the second arrow if the lifted first arrow succeeds +(^>>?) :: (ArrowChoice a) + => (x -> Either failure success) + -> FallibleArrow a success failure success' + -> FallibleArrow a x failure success' +a ^>>? b = a ^>> Left ^||| b + +-- | Execute the second, non-fallible arrow if the first arrow succeeds +(>>?!) :: (ArrowChoice a) + => FallibleArrow a x failure success + -> a success success' + -> FallibleArrow a x failure success' +a >>?! f = a >>> right f + +--- +(>>?%) :: (ArrowChoice a) + => FallibleArrow a x f (b,b') + -> (b -> b' -> c) + -> FallibleArrow a x f c +a >>?% f = a >>?^ uncurry f + + +--- +(>>?%?) :: (ArrowChoice a) + => FallibleArrow a x f (b,b') + -> (b -> b' -> Either f c) + -> FallibleArrow a x f c +a >>?%? f = a >>?^? uncurry f + +infixr 1 >>?, >>?^, >>?^? +infixr 1 ^>>?, >>?! +infixr 1 >>?%, >>?%? + +-- | An arrow version of a short-circuit (<|>) +ifFailedDo :: (ArrowChoice a) + => FallibleArrow a x f y + -> FallibleArrow a x f y + -> FallibleArrow a x f y +ifFailedDo a b = keepingTheValue a >>> repackage ^>> (b |||^ Right) + where repackage (x , Left _) = Left x + repackage (_ , Right y) = Right y + +infixr 1 `ifFailedDo` diff --git a/src/Text/Pandoc/Readers/ODT/Base.hs b/src/Text/Pandoc/Readers/ODT/Base.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/Readers/ODT/Base.hs @@ -0,0 +1,22 @@ +{- | + Module : Text.Pandoc.Readers.ODT.Base + Copyright : Copyright (C) 2015 Martin Linnemann + License : GNU GPL, version 2 or above + + Maintainer : Martin Linnemann + Stability : alpha + Portability : portable + +Core types of the odt reader. +-} + +module Text.Pandoc.Readers.ODT.Base where + +import Text.Pandoc.Readers.ODT.Generic.XMLConverter +import Text.Pandoc.Readers.ODT.Namespaces + +type ODTConverterState s = XMLConverterState Namespace s + +type XMLReader s a b = FallibleXMLConverter Namespace s a b + +type XMLReaderSafe s a b = XMLConverter Namespace s a b diff --git a/src/Text/Pandoc/Readers/ODT/ContentReader.hs b/src/Text/Pandoc/Readers/ODT/ContentReader.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/Readers/ODT/ContentReader.hs @@ -0,0 +1,976 @@ +{-# LANGUAGE Arrows #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{- | + Module : Text.Pandoc.Readers.ODT.ContentReader + Copyright : Copyright (C) 2015 Martin Linnemann + License : GNU GPL, version 2 or above + + Maintainer : Martin Linnemann + Stability : alpha + Portability : portable + +The core of the odt reader that converts odt features into Pandoc types. +-} + +module Text.Pandoc.Readers.ODT.ContentReader +( readerState +, read_body +) where + +import Prelude hiding (Applicative(..)) +import Control.Applicative hiding (liftA, liftA2, liftA3) +import Control.Arrow +import Control.Monad ((<=<)) + +import qualified Data.ByteString.Lazy as B +import Data.Foldable (fold) +import Data.List (find) +import qualified Data.Map as M +import qualified Data.Text as T +import Data.Maybe +import Data.Monoid (Alt (..)) + +import Text.TeXMath (readMathML, writeTeX) +import qualified Text.Pandoc.XML.Light as XML + +import Text.Pandoc.Builder hiding (underline) +import Text.Pandoc.MediaBag (MediaBag, insertMedia) +import Text.Pandoc.Shared +import Text.Pandoc.Extensions (extensionsFromList, Extension(..)) +import qualified Text.Pandoc.UTF8 as UTF8 + +import Text.Pandoc.Readers.ODT.Base +import Text.Pandoc.Readers.ODT.Namespaces +import Text.Pandoc.Readers.ODT.StyleReader + +import Text.Pandoc.Readers.ODT.Arrows.State (foldS) +import Text.Pandoc.Readers.ODT.Arrows.Utils +import Text.Pandoc.Readers.ODT.Generic.Fallible +import Text.Pandoc.Readers.ODT.Generic.Utils +import Text.Pandoc.Readers.ODT.Generic.XMLConverter + +import Network.URI (parseRelativeReference, URI(uriPath)) +import qualified Data.Set as Set + +-------------------------------------------------------------------------------- +-- State +-------------------------------------------------------------------------------- + +type Anchor = T.Text +type Media = [(FilePath, B.ByteString)] + +data ReaderState + = ReaderState { -- | A collection of styles read somewhere else. + -- It is only queried here, not modified. + styleSet :: Styles + -- | A stack of the styles of parent elements. + -- Used to look up inherited style properties. + , styleTrace :: [Style] + -- | Keeps track of the current depth in nested lists + , currentListLevel :: ListLevel + -- | Lists may provide their own style, but they don't have + -- to. If they do not, the style of a parent list may be used + -- or even a default list style from the paragraph style. + -- This value keeps track of the closest list style there + -- currently is. + , currentListStyle :: Maybe ListStyle + -- | A map from internal anchor names to "pretty" ones. + -- The mapping is a purely cosmetic one. + , bookmarkAnchors :: M.Map Anchor Anchor + -- | A map of files / binary data from the archive + , envMedia :: Media + -- | Hold binary resources used in the document + , odtMediaBag :: MediaBag + } + deriving ( Show ) + +readerState :: Styles -> Media -> ReaderState +readerState styles media = ReaderState styles [] 0 Nothing M.empty media mempty + +-- +pushStyle' :: Style -> ReaderState -> ReaderState +pushStyle' style state = state { styleTrace = style : styleTrace state } + +-- +popStyle' :: ReaderState -> ReaderState +popStyle' state = case styleTrace state of + _:trace -> state { styleTrace = trace } + _ -> state + +-- +modifyListLevel :: (ListLevel -> ListLevel) -> (ReaderState -> ReaderState) +modifyListLevel f state = state { currentListLevel = f (currentListLevel state) } + +-- +shiftListLevel :: ListLevel -> (ReaderState -> ReaderState) +shiftListLevel diff = modifyListLevel (+ diff) + +-- +swapCurrentListStyle :: Maybe ListStyle -> ReaderState + -> (ReaderState, Maybe ListStyle) +swapCurrentListStyle mListStyle state = ( state { currentListStyle = mListStyle } + , currentListStyle state + ) + +-- +lookupPrettyAnchor :: Anchor -> ReaderState -> Maybe Anchor +lookupPrettyAnchor anchor ReaderState{..} = M.lookup anchor bookmarkAnchors + +-- +putPrettyAnchor :: Anchor -> Anchor -> ReaderState -> ReaderState +putPrettyAnchor ugly pretty state@ReaderState{..} + = state { bookmarkAnchors = M.insert ugly pretty bookmarkAnchors } + +-- +usedAnchors :: ReaderState -> [Anchor] +usedAnchors ReaderState{..} = M.elems bookmarkAnchors + +getMediaBag :: ReaderState -> MediaBag +getMediaBag ReaderState{..} = odtMediaBag + +getMediaEnv :: ReaderState -> Media +getMediaEnv ReaderState{..} = envMedia + +insertMedia' :: (FilePath, B.ByteString) -> ReaderState -> ReaderState +insertMedia' (fp, bs) state@ReaderState{..} + = state { odtMediaBag = insertMedia fp Nothing bs odtMediaBag } + +-------------------------------------------------------------------------------- +-- Reader type and associated tools +-------------------------------------------------------------------------------- + +type ODTReader a b = XMLReader ReaderState a b + +type ODTReaderSafe a b = XMLReaderSafe ReaderState a b + +-- | Extract something from the styles +fromStyles :: (a -> Styles -> b) -> ODTReaderSafe a b +fromStyles f = keepingTheValue + (getExtraState >>^ styleSet) + >>% f + +-- +getStyleByName :: ODTReader StyleName Style +getStyleByName = fromStyles lookupStyle >>^ maybeToChoice + +-- +findStyleFamily :: ODTReader Style StyleFamily +findStyleFamily = fromStyles getStyleFamily >>^ maybeToChoice + +-- +lookupListStyle :: ODTReader StyleName ListStyle +lookupListStyle = fromStyles lookupListStyleByName >>^ maybeToChoice + +-- +switchCurrentListStyle :: ODTReaderSafe (Maybe ListStyle) (Maybe ListStyle) +switchCurrentListStyle = keepingTheValue getExtraState + >>% swapCurrentListStyle + >>> first setExtraState + >>^ snd + +-- +pushStyle :: ODTReaderSafe Style Style +pushStyle = keepingTheValue ( + ( keepingTheValue getExtraState + >>% pushStyle' + ) + >>> setExtraState + ) + >>^ fst + +-- +popStyle :: ODTReaderSafe x x +popStyle = keepingTheValue ( + getExtraState + >>> arr popStyle' + >>> setExtraState + ) + >>^ fst + +-- +getCurrentListLevel :: ODTReaderSafe _x ListLevel +getCurrentListLevel = getExtraState >>^ currentListLevel + +-- +updateMediaWithResource :: ODTReaderSafe (FilePath, B.ByteString) (FilePath, B.ByteString) +updateMediaWithResource = keepingTheValue ( + (keepingTheValue getExtraState + >>% insertMedia' + ) + >>> setExtraState + ) + >>^ fst + +lookupResource :: ODTReaderSafe FilePath (FilePath, B.ByteString) +lookupResource = proc target -> do + state <- getExtraState -< () + case lookup target (getMediaEnv state) of + Just bs -> returnV (target, bs) -<< () + Nothing -> returnV ("", B.empty) -< () + +type AnchorPrefix = T.Text + +-- | An adaptation of 'uniqueIdent' from "Text.Pandoc.Shared" that generates a +-- unique identifier but without assuming that the id should be for a header. +-- Second argument is a list of already used identifiers. +uniqueIdentFrom :: AnchorPrefix -> [Anchor] -> Anchor +uniqueIdentFrom baseIdent usedIdents = + let numIdent n = baseIdent <> "-" <> T.pack (show n) + in if baseIdent `elem` usedIdents + then maybe baseIdent numIdent + $ find (\x -> numIdent x `notElem` usedIdents) ([1..60000] :: [Int]) + -- if we have more than 60,000, allow repeats + else baseIdent + +-- | First argument: basis for a new "pretty" anchor if none exists yet +-- Second argument: a key ("ugly" anchor) +-- Returns: saved "pretty" anchor or created new one +getPrettyAnchor :: ODTReaderSafe (AnchorPrefix, Anchor) Anchor +getPrettyAnchor = proc (baseIdent, uglyAnchor) -> do + state <- getExtraState -< () + case lookupPrettyAnchor uglyAnchor state of + Just prettyAnchor -> returnA -< prettyAnchor + Nothing -> do + let newPretty = uniqueIdentFrom baseIdent (usedAnchors state) + modifyExtraState (putPrettyAnchor uglyAnchor newPretty) -<< newPretty + +-- | Input: basis for a new header anchor +-- Output: saved new anchor +getHeaderAnchor :: ODTReaderSafe Inlines Anchor +getHeaderAnchor = proc title -> do + state <- getExtraState -< () + let exts = extensionsFromList [Ext_auto_identifiers] + let anchor = uniqueIdent exts (toList title) + (Set.fromList $ usedAnchors state) + modifyExtraState (putPrettyAnchor anchor anchor) -<< anchor + + +-------------------------------------------------------------------------------- +-- Working with styles +-------------------------------------------------------------------------------- + +-- +readStyleByName :: ODTReader _x (StyleName, Style) +readStyleByName = + findAttr NsText "style-name" >>? keepingTheValue getStyleByName >>^ liftE + where + liftE :: (StyleName, Fallible Style) -> Fallible (StyleName, Style) + liftE (name, Right v) = Right (name, v) + liftE (_, Left v) = Left v + +-- +isStyleToTrace :: ODTReader Style Bool +isStyleToTrace = findStyleFamily >>?^ (==FaText) + +-- +withNewStyle :: ODTReaderSafe x Inlines -> ODTReaderSafe x Inlines +withNewStyle a = proc x -> do + fStyle <- readStyleByName -< () + case fStyle of + Right (styleName, _) | isCodeStyle styleName -> do + inlines <- a -< x + arr inlineCode -<< inlines + Right (_, style) -> do + mFamily <- arr styleFamily -< style + fTextProps <- arr ( maybeToChoice + . textProperties + . styleProperties + ) -< style + case fTextProps of + Right textProps -> do + state <- getExtraState -< () + let triple = (state, textProps, mFamily) + modifier <- arr modifierFromStyleDiff -< triple + fShouldTrace <- isStyleToTrace -< style + case fShouldTrace of + Right shouldTrace -> + if shouldTrace + then do + pushStyle -< style + inlines <- a -< x + popStyle -< () + arr modifier -<< inlines + else + -- In case anything goes wrong + a -< x + Left _ -> a -< x + Left _ -> a -< x + Left _ -> a -< x + where + isCodeStyle :: StyleName -> Bool + isCodeStyle "Source_Text" = True + isCodeStyle _ = False + + inlineCode :: Inlines -> Inlines + inlineCode = code . T.concat . map stringify . toList + +type PropertyTriple = (ReaderState, TextProperties, Maybe StyleFamily) +type InlineModifier = Inlines -> Inlines + +-- | Given data about the local style changes, calculates how to modify +-- an instance of 'Inlines' +modifierFromStyleDiff :: PropertyTriple -> InlineModifier +modifierFromStyleDiff propertyTriple = + composition $ + getVPosModifier propertyTriple + : map (first ($ propertyTriple) >>> ifThen_else ignore) + [ (hasEmphChanged , emph ) + , (hasChanged isStrong , strong ) + , (hasChanged strikethrough , strikeout ) + ] + where + ifThen_else else' (if',then') = if if' then then' else else' + + ignore = id :: InlineModifier + + getVPosModifier :: PropertyTriple -> InlineModifier + getVPosModifier triple@(_,textProps,_) = + let getVPos = Just . verticalPosition + in case lookupPreviousValueM getVPos triple of + Nothing -> ignore + Just oldVPos -> getVPosModifier' (oldVPos, verticalPosition textProps) + + getVPosModifier' (oldVPos , newVPos ) | oldVPos == newVPos = ignore + getVPosModifier' ( _ , VPosSub ) = subscript + getVPosModifier' ( _ , VPosSuper ) = superscript + getVPosModifier' ( _ , _ ) = ignore + + hasEmphChanged :: PropertyTriple -> Bool + hasEmphChanged = swing any [ hasChanged isEmphasised + , hasChangedM pitch + , hasChanged underline + ] + + hasChanged property triple@(_, property -> newProperty, _) = + (/= Just newProperty) (lookupPreviousValue property triple) + + hasChangedM property triple@(_, textProps,_) = + fromMaybe False $ (/=) <$> property textProps <*> lookupPreviousValueM property triple + + lookupPreviousValue f = lookupPreviousStyleValue (fmap f . textProperties) + + lookupPreviousValueM f = lookupPreviousStyleValue (f <=< textProperties) + + lookupPreviousStyleValue f (ReaderState{..},_,mFamily) + = findBy f (extendedStylePropertyChain styleTrace styleSet) + <|> (f . lookupDefaultStyle' styleSet =<< mFamily) + + +type ParaModifier = Blocks -> Blocks + +_MINIMUM_INDENTATION_FOR_BLOCKQUOTES_IN_MM_ :: Int +_MINIMUM_INDENTATION_FOR_BLOCKQUOTES_IN_PERCENT_ :: Int +_MINIMUM_INDENTATION_FOR_BLOCKQUOTES_IN_MM_ = 5 +_MINIMUM_INDENTATION_FOR_BLOCKQUOTES_IN_PERCENT_ = 5 + +-- | Returns either 'id' or 'blockQuote' depending on the current indentation +getParaModifier :: Style -> ParaModifier +getParaModifier Style{..} | Just props <- paraProperties styleProperties + , isBlockQuote (indentation props) + (margin_left props) + = blockQuote + | otherwise + = id + where + isBlockQuote mIndent mMargin + | LengthValueMM indent <- mIndent + , indent > _MINIMUM_INDENTATION_FOR_BLOCKQUOTES_IN_MM_ + = True + | LengthValueMM margin <- mMargin + , margin > _MINIMUM_INDENTATION_FOR_BLOCKQUOTES_IN_MM_ + = True + | LengthValueMM indent <- mIndent + , LengthValueMM margin <- mMargin + = indent + margin > _MINIMUM_INDENTATION_FOR_BLOCKQUOTES_IN_MM_ + + | PercentValue indent <- mIndent + , indent > _MINIMUM_INDENTATION_FOR_BLOCKQUOTES_IN_PERCENT_ + = True + | PercentValue margin <- mMargin + , margin > _MINIMUM_INDENTATION_FOR_BLOCKQUOTES_IN_PERCENT_ + = True + | PercentValue indent <- mIndent + , PercentValue margin <- mMargin + = indent + margin > _MINIMUM_INDENTATION_FOR_BLOCKQUOTES_IN_PERCENT_ + + | otherwise + = False + +-- +constructPara :: ODTReaderSafe Blocks Blocks -> ODTReaderSafe Blocks Blocks +constructPara reader = proc blocks -> do + fStyle <- readStyleByName -< blocks + case fStyle of + Left _ -> reader -< blocks + Right (styleName, _) | isTableCaptionStyle styleName -> do + blocks' <- reader -< blocks + arr tableCaptionP -< blocks' + Right (_, style) -> do + let modifier = getParaModifier style + blocks' <- reader -< blocks + arr modifier -<< blocks' + where + isTableCaptionStyle :: StyleName -> Bool + isTableCaptionStyle "Table" = True + isTableCaptionStyle _ = False + tableCaptionP b = divWith ("", ["caption"], []) b + +type ListConstructor = [Blocks] -> Blocks + +getListConstructor :: ListLevelStyle -> ListConstructor +getListConstructor ListLevelStyle{..} = + case listLevelType of + LltBullet -> bulletList + LltImage -> bulletList + LltNumbered -> let listNumberStyle = toListNumberStyle listItemFormat + listNumberDelim = toListNumberDelim listItemPrefix + listItemSuffix + in orderedListWith (listItemStart, listNumberStyle, listNumberDelim) + where + toListNumberStyle LinfNone = DefaultStyle + toListNumberStyle LinfNumber = Decimal + toListNumberStyle LinfRomanLC = LowerRoman + toListNumberStyle LinfRomanUC = UpperRoman + toListNumberStyle LinfAlphaLC = LowerAlpha + toListNumberStyle LinfAlphaUC = UpperAlpha + toListNumberStyle (LinfString _) = Example + + toListNumberDelim Nothing (Just ".") = Period + toListNumberDelim (Just "" ) (Just ".") = Period + toListNumberDelim Nothing (Just ")") = OneParen + toListNumberDelim (Just "" ) (Just ")") = OneParen + toListNumberDelim (Just "(") (Just ")") = TwoParens + toListNumberDelim _ _ = DefaultDelim + + +-- | Determines which style to use for a list, which level to use of that +-- style, and which type of list to create as a result of this information. +-- Then prepares the state for eventual child lists and constructs the list from +-- the results. +-- Two main cases are handled: The list may provide its own style or it may +-- rely on a parent list's style. I the former case the current style in the +-- state must be switched before and after the call to the child converter +-- while in the latter the child converter can be called directly. +-- If anything goes wrong, a default ordered-list-constructor is used. +constructList :: ODTReaderSafe x [Blocks] -> ODTReaderSafe x Blocks +constructList reader = proc x -> do + modifyExtraState (shiftListLevel 1) -< () + listLevel <- getCurrentListLevel -< () + fStyleName <- findAttr NsText "style-name" -< () + case fStyleName of + Right styleName -> do + fListStyle <- lookupListStyle -< styleName + case fListStyle of + Right listStyle -> do + fLLS <- arr (uncurry getListLevelStyle) -< (listLevel,listStyle) + case fLLS of + Just listLevelStyle -> do + oldListStyle <- switchCurrentListStyle -< Just listStyle + blocks <- constructListWith listLevelStyle -<< x + switchCurrentListStyle -< oldListStyle + returnA -< blocks + Nothing -> constructOrderedList -< x + Left _ -> constructOrderedList -< x + Left _ -> do + state <- getExtraState -< () + mListStyle <- arr currentListStyle -< state + case mListStyle of + Just listStyle -> do + fLLS <- arr (uncurry getListLevelStyle) -< (listLevel,listStyle) + case fLLS of + Just listLevelStyle -> constructListWith listLevelStyle -<< x + Nothing -> constructOrderedList -< x + Nothing -> constructOrderedList -< x + where + constructOrderedList = + reader + >>> modifyExtraState (shiftListLevel (-1)) + >>^ orderedList + constructListWith listLevelStyle = + reader + >>> getListConstructor listLevelStyle + ^>> modifyExtraState (shiftListLevel (-1)) + +-------------------------------------------------------------------------------- +-- Readers +-------------------------------------------------------------------------------- + +type ElementMatcher result = (Namespace, ElementName, ODTReader result result) + +type InlineMatcher = ElementMatcher Inlines + +type BlockMatcher = ElementMatcher Blocks + +newtype FirstMatch a = FirstMatch (Alt Maybe a) + deriving (Foldable, Monoid, Semigroup) + +firstMatch :: a -> FirstMatch a +firstMatch = FirstMatch . Alt . Just + +-- +matchingElement :: (Monoid e) + => Namespace -> ElementName + -> ODTReaderSafe e e + -> ElementMatcher e +matchingElement ns name reader = (ns, name, asResultAccumulator reader) + where + asResultAccumulator :: (ArrowChoice a, Monoid m) => a m m -> a m (Fallible m) + asResultAccumulator a = liftAsSuccess $ keepingTheValue a >>% mappend + +-- +matchChildContent' :: (Monoid result) + => [ElementMatcher result] + -> ODTReaderSafe _x result +matchChildContent' ls = returnV mempty >>> matchContent' ls + +-- +matchChildContent :: (Monoid result) + => [ElementMatcher result] + -> ODTReaderSafe (result, XML.Content) result + -> ODTReaderSafe _x result +matchChildContent ls fallback = returnV mempty >>> matchContent ls fallback + +-------------------------------------------- +-- Matchers +-------------------------------------------- + +---------------------- +-- Basics +---------------------- + +-- +-- | Open Document allows several consecutive spaces if they are marked up +read_plain_text :: ODTReaderSafe (Inlines, XML.Content) Inlines +read_plain_text = fst ^&&& read_plain_text' >>% recover + where + -- fallible version + read_plain_text' :: ODTReader (Inlines, XML.Content) Inlines + read_plain_text' = ( second ( arr extractText ) + >>^ spreadChoice >>?! second text + ) + >>?% mappend + -- + extractText :: XML.Content -> Fallible T.Text + extractText (XML.Text cData) = succeedWith (XML.cdData cData) + extractText _ = failEmpty + +read_text_seq :: InlineMatcher +read_text_seq = matchingElement NsText "sequence" + $ matchChildContent [] read_plain_text + + +-- specifically. I honor that, although the current implementation of 'mappend' +-- for 'Inlines' in "Text.Pandoc.Builder" will collapse them again. +-- The rational is to be prepared for future modifications. +read_spaces :: InlineMatcher +read_spaces = matchingElement NsText "s" ( + readAttrWithDefault NsText "c" 1 -- how many spaces? + >>^ fromList.(`replicate` Space) + ) +-- +read_line_break :: InlineMatcher +read_line_break = matchingElement NsText "line-break" + $ returnV linebreak +-- +read_tab :: InlineMatcher +read_tab = matchingElement NsText "tab" + $ returnV space +-- +read_span :: InlineMatcher +read_span = matchingElement NsText "span" + $ withNewStyle + $ matchChildContent [ read_span + , read_spaces + , read_line_break + , read_tab + , read_link + , read_note + , read_citation + , read_bookmark + , read_bookmark_start + , read_reference_start + , read_bookmark_ref + , read_reference_ref + ] read_plain_text + +-- +read_paragraph :: BlockMatcher +read_paragraph = matchingElement NsText "p" + $ constructPara + $ liftA para + $ withNewStyle + $ matchChildContent [ read_span + , read_spaces + , read_line_break + , read_tab + , read_link + , read_note + , read_citation + , read_bookmark + , read_bookmark_start + , read_reference_start + , read_bookmark_ref + , read_reference_ref + , read_frame + , read_text_seq + ] read_plain_text + + +---------------------- +-- Headers +---------------------- + +-- +read_header :: BlockMatcher +read_header = matchingElement NsText "h" + $ proc blocks -> do + level <- ( readAttrWithDefault NsText "outline-level" 1 + ) -< blocks + children <- ( matchChildContent [ read_span + , read_spaces + , read_line_break + , read_tab + , read_link + , read_note + , read_citation + , read_bookmark + , read_bookmark_start + , read_reference_start + , read_bookmark_ref + , read_reference_ref + , read_frame + ] read_plain_text + ) -< blocks + anchor <- getHeaderAnchor -< children + let idAttr = (anchor, [], []) -- no classes, no key-value pairs + arr (uncurry3 headerWith) -< (idAttr, level, children) + +---------------------- +-- Lists +---------------------- + +-- +read_list :: BlockMatcher +read_list = matchingElement NsText "list" +-- $ withIncreasedListLevel + $ constructList +-- $ liftA bulletList + $ matchChildContent' [ read_list_item + , read_list_header + ] +-- +read_list_item :: ElementMatcher [Blocks] +read_list_item = read_list_element "list-item" + +read_list_header :: ElementMatcher [Blocks] +read_list_header = read_list_element "list-header" + +read_list_element :: ElementName -> ElementMatcher [Blocks] +read_list_element listElement = matchingElement NsText listElement + $ liftA (compactify.(:[])) + ( matchChildContent' [ read_paragraph + , read_header + , read_list + , read_section + ] + ) + +---------------------- +-- Sections +---------------------- + +read_section :: ElementMatcher Blocks +read_section = matchingElement NsText "section" + $ liftA (divWith nullAttr) + $ matchChildContent' [ read_paragraph + , read_header + , read_list + , read_table + , read_section + ] + + +---------------------- +-- Links +---------------------- + +read_link :: InlineMatcher +read_link = matchingElement NsText "a" + $ liftA3 link + ( findAttrTextWithDefault NsXLink "href" "" + >>> arr fixRelativeLink ) + ( findAttrTextWithDefault NsOffice "title" "" ) + ( matchChildContent [ read_span + , read_note + , read_citation + , read_bookmark + , read_bookmark_start + , read_reference_start + , read_bookmark_ref + , read_reference_ref + ] read_plain_text ) + +fixRelativeLink :: T.Text -> T.Text +fixRelativeLink uri = + case parseRelativeReference (T.unpack uri) of + Nothing -> uri + Just u -> + case uriPath u of + '.':'.':'/':xs -> tshow $ u{ uriPath = xs } + _ -> uri + +------------------------- +-- Footnotes +------------------------- + +read_note :: InlineMatcher +read_note = matchingElement NsText "note" + $ liftA note + $ matchChildContent' [ read_note_body ] + +read_note_body :: BlockMatcher +read_note_body = matchingElement NsText "note-body" + $ matchChildContent' [ read_paragraph ] + +------------------------- +-- Citations +------------------------- + +read_citation :: InlineMatcher +read_citation = matchingElement NsText "bibliography-mark" + $ liftA2 cite + ( liftA2 makeCitation + ( findAttrTextWithDefault NsText "identifier" "" ) + ( readAttrWithDefault NsText "number" 0 ) + ) + ( matchChildContent [] read_plain_text ) + where + makeCitation :: T.Text -> Int -> [Citation] + makeCitation citeId num = [Citation citeId [] [] NormalCitation num 0] + + +---------------------- +-- Tables +---------------------- + +-- +read_table :: BlockMatcher +read_table = matchingElement NsTable "table" + $ liftA simpleTable' + $ matchChildContent' [ read_table_row + ] + +-- | A simple table without a caption or headers +-- | Infers the number of headers from rows +simpleTable' :: [[Blocks]] -> Blocks +simpleTable' [] = simpleTable [] [] +simpleTable' (x : rest) = simpleTable (fmap (const defaults) x) (x : rest) + where defaults = fromList [] + +-- +read_table_row :: ElementMatcher [[Blocks]] +read_table_row = matchingElement NsTable "table-row" + $ liftA (:[]) + $ matchChildContent' [ read_table_cell + ] + +-- +read_table_cell :: ElementMatcher [Blocks] +read_table_cell = matchingElement NsTable "table-cell" + $ liftA (compactify.(:[])) + $ matchChildContent' [ read_paragraph + ] + +---------------------- +-- Frames +---------------------- + +-- +read_frame :: InlineMatcher +read_frame = matchingElement NsDraw "frame" + $ filterChildrenName' NsDraw (`elem` ["image", "object", "text-box"]) + >>> foldS read_frame_child + >>> arr fold + +read_frame_child :: ODTReaderSafe XML.Element (FirstMatch Inlines) +read_frame_child = + proc child -> case elName child of + "image" -> read_frame_img -< child + "object" -> read_frame_mathml -< child + "text-box" -> read_frame_text_box -< child + _ -> returnV mempty -< () + +read_frame_img :: ODTReaderSafe XML.Element (FirstMatch Inlines) +read_frame_img = + proc img -> do + src <- executeIn (findAttr' NsXLink "href") -< img + case fold src of + "" -> returnV mempty -< () + src' -> do + let exts = extensionsFromList [Ext_auto_identifiers] + resource <- lookupResource -< T.unpack src' + _ <- updateMediaWithResource -< resource + w <- findAttrText' NsSVG "width" -< () + h <- findAttrText' NsSVG "height" -< () + titleNodes <- matchChildContent' [ read_frame_title ] -< () + alt <- matchChildContent [] read_plain_text -< () + arr (firstMatch . uncurry4 imageWith) -< + (image_attributes w h, src', inlineListToIdentifier exts (toList titleNodes), alt) + +read_frame_title :: InlineMatcher +read_frame_title = matchingElement NsSVG "title" (matchChildContent [] read_plain_text) + +image_attributes :: Maybe T.Text -> Maybe T.Text -> Attr +image_attributes x y = + ( "", [], dim "width" x ++ dim "height" y) + where + dim _ (Just "") = [] + dim name (Just v) = [(name, v)] + dim _ Nothing = [] + +read_frame_mathml :: ODTReaderSafe XML.Element (FirstMatch Inlines) +read_frame_mathml = + proc obj -> do + src <- executeIn (findAttr' NsXLink "href") -< obj + case fold src of + "" -> returnV mempty -< () + src' -> do + let path = T.unpack $ + fromMaybe src' (T.stripPrefix "./" src') <> "/content.xml" + (_, mathml) <- lookupResource -< path + case readMathML (UTF8.toText $ B.toStrict mathml) of + Left _ -> returnV mempty -< () + Right exps -> arr (firstMatch . displayMath . writeTeX) -< exps + +read_frame_text_box :: ODTReaderSafe XML.Element (FirstMatch Inlines) +read_frame_text_box = proc box -> do + paragraphs <- executeIn (matchChildContent' [ read_paragraph ]) -< box + arr read_img_with_caption -< toList paragraphs + +read_img_with_caption :: [Block] -> FirstMatch Inlines +read_img_with_caption (Para [Image attr alt (src,title)] : _) = + firstMatch $ singleton (Image attr alt (src, "fig:" <> title)) -- no text, default caption +read_img_with_caption (Para (Image attr _ (src,title) : txt) : _) = + firstMatch $ singleton (Image attr txt (src, "fig:" <> 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 _ = + mempty + +---------------------- +-- Internal links +---------------------- + +_ANCHOR_PREFIX_ :: T.Text +_ANCHOR_PREFIX_ = "anchor" + +-- +readAnchorAttr :: ODTReader _x Anchor +readAnchorAttr = findAttrText NsText "name" + +-- | Beware: may fail +findAnchorName :: ODTReader AnchorPrefix Anchor +findAnchorName = ( keepingTheValue readAnchorAttr + >>^ spreadChoice + ) >>?! getPrettyAnchor + + +-- +maybeAddAnchorFrom :: ODTReader Inlines AnchorPrefix + -> ODTReaderSafe Inlines Inlines +maybeAddAnchorFrom anchorReader = + keepingTheValue (anchorReader >>? findAnchorName >>?^ toAnchorElem) + >>> + proc (inlines, fAnchorElem) -> do + case fAnchorElem of + Right anchorElem -> returnA -< anchorElem + Left _ -> returnA -< inlines + where + toAnchorElem :: Anchor -> Inlines + toAnchorElem anchorID = spanWith (anchorID, [], []) mempty + -- no classes, no key-value pairs + +-- +read_bookmark :: InlineMatcher +read_bookmark = matchingElement NsText "bookmark" + $ maybeAddAnchorFrom (liftAsSuccess $ returnV _ANCHOR_PREFIX_) + +-- +read_bookmark_start :: InlineMatcher +read_bookmark_start = matchingElement NsText "bookmark-start" + $ maybeAddAnchorFrom (liftAsSuccess $ returnV _ANCHOR_PREFIX_) + +-- +read_reference_start :: InlineMatcher +read_reference_start = matchingElement NsText "reference-mark-start" + $ maybeAddAnchorFrom readAnchorAttr + +-- | Beware: may fail +findAnchorRef :: ODTReader _x Anchor +findAnchorRef = ( findAttrText NsText "ref-name" + >>?^ (_ANCHOR_PREFIX_,) + ) >>?! getPrettyAnchor + + +-- +maybeInAnchorRef :: ODTReaderSafe Inlines Inlines +maybeInAnchorRef = proc inlines -> do + fRef <- findAnchorRef -< () + case fRef of + Right anchor -> + arr (toAnchorRef anchor) -<< inlines + Left _ -> returnA -< inlines + where + toAnchorRef :: Anchor -> Inlines -> Inlines + toAnchorRef anchor = link ("#" <> anchor) "" -- no title + +-- +read_bookmark_ref :: InlineMatcher +read_bookmark_ref = matchingElement NsText "bookmark-ref" + $ maybeInAnchorRef + <<< matchChildContent [] read_plain_text + +-- +read_reference_ref :: InlineMatcher +read_reference_ref = matchingElement NsText "reference-ref" + $ maybeInAnchorRef + <<< matchChildContent [] read_plain_text + + +---------------------- +-- Entry point +---------------------- + +read_text :: ODTReaderSafe _x Pandoc +read_text = matchChildContent' [ read_header + , read_paragraph + , read_list + , read_section + , read_table + ] + >>^ doc + +post_process :: Pandoc -> Pandoc +post_process (Pandoc m blocks) = + Pandoc m (post_process' blocks) + +post_process' :: [Block] -> [Block] +post_process' (Table attr _ specs th tb tf : Div ("", ["caption"], _) blks : xs) + = Table attr (Caption Nothing blks) specs th tb tf : post_process' xs +post_process' bs = bs + +read_body :: ODTReader _x (Pandoc, MediaBag) +read_body = executeInSub NsOffice "body" + $ executeInSub NsOffice "text" + $ liftAsSuccess + $ proc inlines -> do + txt <- read_text -< inlines + state <- getExtraState -< () + returnA -< (post_process txt, getMediaBag state) diff --git a/src/Text/Pandoc/Readers/ODT/Generic/Fallible.hs b/src/Text/Pandoc/Readers/ODT/Generic/Fallible.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/Readers/ODT/Generic/Fallible.hs @@ -0,0 +1,99 @@ +{- | + Module : Text.Pandoc.Readers.ODT.Generic.Fallible + Copyright : Copyright (C) 2015 Martin Linnemann + License : GNU GPL, version 2 or above + + Maintainer : Martin Linnemann + Stability : alpha + Portability : portable + +Data types and utilities representing failure. Most of it is based on the +"Either" type in its usual configuration (left represents failure). + +In most cases, the failure type is implied or required to be a "Monoid". + +The choice of "Either" instead of a custom type makes it easier to write +compatible instances of "ArrowChoice". +-} + +-- We export everything +module Text.Pandoc.Readers.ODT.Generic.Fallible where + +-- | Default for now. Will probably become a class at some point. +type Failure = () + +type Fallible a = Either Failure a + + +-- +maybeToEither :: Maybe a -> Fallible a +maybeToEither (Just a) = Right a +maybeToEither Nothing = Left () + +-- +eitherToMaybe :: Either _l a -> Maybe a +eitherToMaybe (Left _) = Nothing +eitherToMaybe (Right a) = Just a + +-- | > recover a === either (const a) id +recover :: a -> Either _f a -> a +recover a (Left _) = a +recover _ (Right a) = a + +-- | I would love to use 'fail'. Alas, 'Monad.fail'... +failWith :: failure -> Either failure _x +failWith f = Left f + +-- +failEmpty :: (Monoid failure) => Either failure _x +failEmpty = failWith mempty + +-- +succeedWith :: a -> Either _x a +succeedWith = Right + +-- +collapseEither :: Either failure (Either failure x) + -> Either failure x +collapseEither (Left f ) = Left f +collapseEither (Right (Left f)) = Left f +collapseEither (Right (Right x)) = Right x + +-- | If either of the values represents a non-error, the result is a +-- (possibly combined) non-error. If both values represent an error, an error +-- is returned. +chooseMax :: (Monoid a, Monoid b) => Either a b -> Either a b -> Either a b +chooseMax = chooseMaxWith mappend + +-- | If either of the values represents a non-error, the result is a +-- (possibly combined) non-error. If both values represent an error, an error +-- is returned. +chooseMaxWith :: (Monoid a) => (b -> b -> b) + -> Either a b + -> Either a b + -> Either a b +chooseMaxWith (><) (Right a) (Right b) = Right $ a >< b +chooseMaxWith _ (Left a) (Left b) = Left $ a `mappend` b +chooseMaxWith _ (Right a) _ = Right a +chooseMaxWith _ _ (Right b) = Right b + + +-- | Class of containers that can escalate contained 'Either's. +-- The word "Vector" is meant in the sense of a disease transmitter. +class ChoiceVector v where + spreadChoice :: v (Either f a) -> Either f (v a) + +instance ChoiceVector ((,) a) where + spreadChoice (_, Left f) = Left f + spreadChoice (x, Right y) = Right (x,y) + -- Wasn't there a newtype somewhere with the elements flipped? + +-- | Wrapper for a list. While the normal list instance of 'ChoiceVector' +-- fails whenever it can, this type will never fail. +newtype SuccessList a = SuccessList { collectNonFailing :: [a] } + deriving ( Eq, Ord, Show ) + +instance ChoiceVector SuccessList where + spreadChoice = Right . SuccessList . foldr unTagRight [] . collectNonFailing + where unTagRight (Right x) = (x:) + unTagRight _ = id diff --git a/src/Text/Pandoc/Readers/ODT/Generic/Namespaces.hs b/src/Text/Pandoc/Readers/ODT/Generic/Namespaces.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/Readers/ODT/Generic/Namespaces.hs @@ -0,0 +1,45 @@ +{- | + Module : Text.Pandoc.Readers.ODT.Generic.Namespaces + Copyright : Copyright (C) 2015 Martin Linnemann + License : GNU GPL, version 2 or above + + Maintainer : Martin Linnemann + Stability : alpha + Portability : portable + +A class containing a set of namespace identifiers. Used to convert between +typesafe Haskell namespace identifiers and unsafe "real world" namespaces. +-} + +module Text.Pandoc.Readers.ODT.Generic.Namespaces where + +import qualified Data.Map as M +import Data.Text (Text) + +-- +type NameSpaceIRI = Text + +-- +type NameSpaceIRIs nsID = M.Map nsID NameSpaceIRI + +-- +class (Eq nsID, Ord nsID) => NameSpaceID nsID where + + -- | Given a IRI, possibly update the map and return the id of the namespace. + -- May fail if the namespace is unknown and the application does not + -- allow unknown namespaces. + getNamespaceID :: NameSpaceIRI + -> NameSpaceIRIs nsID + -> Maybe (NameSpaceIRIs nsID, nsID) + -- | Given a namespace id, lookup its IRI. May be overridden for performance. + getIRI :: nsID + -> NameSpaceIRIs nsID + -> Maybe NameSpaceIRI + -- | The root element of an XML document has a namespace, too, and the + -- "XML.Light-parser" is eager to remove the corresponding namespace + -- attribute. + -- As a result, at least this root namespace must be provided. + getInitialIRImap :: NameSpaceIRIs nsID + + getIRI = M.lookup + getInitialIRImap = M.empty diff --git a/src/Text/Pandoc/Readers/ODT/Generic/SetMap.hs b/src/Text/Pandoc/Readers/ODT/Generic/SetMap.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/Readers/ODT/Generic/SetMap.hs @@ -0,0 +1,30 @@ +{- | + Module : Text.Pandoc.Readers.ODT.Generic.SetMap + Copyright : Copyright (C) 2015 Martin Linnemann + License : GNU GPL, version 2 or above + + Maintainer : Martin Linnemann + Stability : alpha + Portability : portable + +A map of values to sets of values. +-} + +module Text.Pandoc.Readers.ODT.Generic.SetMap where + +import qualified Data.Map as M +import qualified Data.Set as S + +type SetMap k v = M.Map k (S.Set v) + +empty :: SetMap k v +empty = M.empty + +fromList :: (Ord k, Ord v) => [(k,v)] -> SetMap k v +fromList = foldr (uncurry insert) empty + +insert :: (Ord k, Ord v) => k -> v -> SetMap k v -> SetMap k v +insert key value setMap = M.insertWith S.union key (S.singleton value) setMap + +union3 :: (Ord k) => SetMap k v -> SetMap k v -> SetMap k v -> SetMap k v +union3 sm1 sm2 sm3 = sm1 `M.union` sm2 `M.union` sm3 diff --git a/src/Text/Pandoc/Readers/ODT/Generic/Utils.hs b/src/Text/Pandoc/Readers/ODT/Generic/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/Readers/ODT/Generic/Utils.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE ViewPatterns #-} +{- | + Module : Text.Pandoc.Reader.ODT.Generic.Utils + Copyright : Copyright (C) 2015 Martin Linnemann + License : GNU GPL, version 2 or above + + Maintainer : Martin Linnemann + Stability : alpha + Portability : portable + +General utility functions for the odt reader. +-} + +module Text.Pandoc.Readers.ODT.Generic.Utils +( uncurry3 +, uncurry4 +, uncurry5 +, uncurry6 +, swap +, reverseComposition +, tryToRead +, Lookupable(..) +, readLookupable +, readPercent +, findBy +, swing +, composition +) where + +import Control.Category (Category, (<<<), (>>>)) +import qualified Control.Category as Cat (id) +import Data.Char (isSpace) +import qualified Data.Foldable as F (Foldable, foldr) +import Data.Maybe +import Data.Text (Text) +import qualified Data.Text as T + +-- | Equivalent to +-- > foldr (.) id +-- where '(.)' are 'id' are the ones from "Control.Category" +-- and 'foldr' is the one from "Data.Foldable". +-- The noun-form was chosen to be consistent with 'sum', 'product' etc +-- based on the discussion at +-- +-- (that I was not part of) +composition :: (Category cat, F.Foldable f) => f (cat a a) -> cat a a +composition = F.foldr (<<<) Cat.id + +-- | Equivalent to +-- > foldr (flip (.)) id +-- where '(.)' are 'id' are the ones from "Control.Category" +-- and 'foldr' is the one from "Data.Foldable". +-- A reversed version of 'composition'. +reverseComposition :: (Category cat, F.Foldable f) => f (cat a a) -> cat a a +reverseComposition = F.foldr (>>>) Cat.id + +-- | This function often makes it possible to switch values with the functions +-- that are applied to them. +-- +-- Examples: +-- > swing map :: [a -> b] -> a -> [b] +-- > swing any :: [a -> Bool] -> a -> Bool +-- > swing foldr :: b -> a -> [a -> b -> b] -> b +-- > swing scanr :: c -> a -> [a -> c -> c] -> c +-- > swing zipWith :: [a -> b -> c] -> a -> [b] -> [c] +-- > swing find :: [a -> Bool] -> a -> Maybe (a -> Bool) +-- +-- Stolen from +swing :: (((a -> b) -> b) -> c -> d) -> c -> a -> d +swing = flip.(.flip id) +-- swing f c a = f ($ a) c + + +-- | Alternative to 'read'/'reads'. The former of these throws errors +-- (nobody wants that) while the latter returns "to much" for simple purposes. +-- This function instead applies 'reads' and returns the first match (if any) +-- in a 'Maybe'. +tryToRead :: (Read r) => Text -> Maybe r +tryToRead = (reads . T.unpack) >>> listToMaybe >>> fmap fst + +-- | A version of 'reads' that requires a '%' sign after the number +readPercent :: ReadS Int +readPercent s = [ (i,s') | (i , r ) <- reads s + , ("%" , s') <- lex r + ] + +-- | Data that can be looked up. +-- This is mostly a utility to read data with kind *. +class Lookupable a where + lookupTable :: [(Text, a)] + +-- | Very similar to a simple 'lookup' in the 'lookupTable', but with a lexer. +readLookupable :: (Lookupable a) => Text -> Maybe a +readLookupable s = + lookup (T.takeWhile (not . isSpace) $ T.dropWhile isSpace s) lookupTable + +uncurry3 :: (a->b->c -> z) -> (a,b,c ) -> z +uncurry4 :: (a->b->c->d -> z) -> (a,b,c,d ) -> z +uncurry5 :: (a->b->c->d->e -> z) -> (a,b,c,d,e ) -> z +uncurry6 :: (a->b->c->d->e->f -> z) -> (a,b,c,d,e,f ) -> z + +uncurry3 fun (a,b,c ) = fun a b c +uncurry4 fun (a,b,c,d ) = fun a b c d +uncurry5 fun (a,b,c,d,e ) = fun a b c d e +uncurry6 fun (a,b,c,d,e,f ) = fun a b c d e f + +swap :: (a,b) -> (b,a) +swap (a,b) = (b,a) + +-- | A version of "Data.List.find" that uses a converter to a Maybe instance. +-- The returned value is the first which the converter returns in a 'Just' +-- wrapper. +findBy :: (a -> Maybe b) -> [a] -> Maybe b +findBy _ [] = Nothing +findBy f ((f -> Just x):_ ) = Just x +findBy f ( _:xs) = findBy f xs diff --git a/src/Text/Pandoc/Readers/ODT/Generic/XMLConverter.hs b/src/Text/Pandoc/Readers/ODT/Generic/XMLConverter.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/Readers/ODT/Generic/XMLConverter.hs @@ -0,0 +1,775 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternGuards #-} +{- | + Module : Text.Pandoc.Readers.ODT.Generic.XMLConverter + Copyright : Copyright (C) 2015 Martin Linnemann + License : GNU GPL, version 2 or above + + Maintainer : Martin Linnemann + Stability : alpha + Portability : portable + +A generalized XML parser based on stateful arrows. +It might be sufficient to define this reader as a comonad, but there is +not a lot of use in trying. +-} + +module Text.Pandoc.Readers.ODT.Generic.XMLConverter +( ElementName +, XMLConverterState +, XMLConverter +, FallibleXMLConverter +, runConverter' +, getExtraState +, setExtraState +, modifyExtraState +, producingExtraState +, findChild' +, filterChildrenName' +, isSet' +, isSetWithDefault +, elName +, searchAttr +, lookupAttr +, lookupAttr' +, lookupDefaultingAttr +, findAttr' +, findAttrText' +, findAttr +, findAttrText +, findAttrTextWithDefault +, readAttr +, readAttr' +, readAttrWithDefault +, getAttr +, executeIn +, executeInSub +, withEveryL +, tryAll +, matchContent' +, matchContent +) where + +import Prelude hiding (Applicative(..)) +import Control.Applicative hiding ( liftA, liftA2 ) +import Control.Monad ( MonadPlus ) +import Control.Arrow + +import Data.Bool ( bool ) +import Data.Either ( rights ) +import qualified Data.Map as M +import Data.Text (Text) +import Data.Default +import Data.Maybe +import Data.List (foldl') + +import qualified Text.Pandoc.XML.Light as XML + +import Text.Pandoc.Readers.ODT.Arrows.State +import Text.Pandoc.Readers.ODT.Arrows.Utils +import Text.Pandoc.Readers.ODT.Generic.Namespaces +import Text.Pandoc.Readers.ODT.Generic.Utils +import Text.Pandoc.Readers.ODT.Generic.Fallible + +-------------------------------------------------------------------------------- +-- Basis types for readability +-------------------------------------------------------------------------------- + +-- +type ElementName = Text +type AttributeName = Text +type AttributeValue = Text +type TextAttributeValue = Text + +-- +type NameSpacePrefix = Text + +-- +type NameSpacePrefixes nsID = M.Map nsID NameSpacePrefix + +-------------------------------------------------------------------------------- +-- Main converter state +-------------------------------------------------------------------------------- + +-- GADT so some of the NameSpaceID restrictions can be deduced +data XMLConverterState nsID extraState where + XMLConverterState :: NameSpaceID nsID + => { -- | A stack of parent elements. The top element is the current one. + -- Arguably, a real Zipper would be better. But that is an + -- optimization that can be made at a later time, e.g. when + -- replacing Text.XML.Light. + parentElements :: [XML.Element] + -- | A map from internal namespace IDs to the namespace prefixes + -- used in XML elements + , namespacePrefixes :: NameSpacePrefixes nsID + -- | A map from internal namespace IDs to namespace IRIs + -- (Only necessary for matching namespace IDs and prefixes) + , namespaceIRIs :: NameSpaceIRIs nsID + -- | A place to put "something else". This feature is used heavily + -- to keep the main code cleaner. More specifically, the main reader + -- is divided into different stages. Each stage lifts something up + -- here, which the next stage can then use. This could of course be + -- generalized to a state-tree or used for the namespace IRIs. The + -- border between states and values is an imaginary one, after all. + -- But the separation as it is seems to be enough for now. + , moreState :: extraState + } + -> XMLConverterState nsID extraState + +-- +createStartState :: (NameSpaceID nsID) + => XML.Element + -> extraState + -> XMLConverterState nsID extraState +createStartState element extraState = + XMLConverterState + { parentElements = [element] + , namespacePrefixes = M.empty + , namespaceIRIs = getInitialIRImap + , moreState = extraState + } + +-- | Functor over extra state +instance Functor (XMLConverterState nsID) where + fmap f ( XMLConverterState parents prefixes iRIs extraState ) + = XMLConverterState parents prefixes iRIs (f extraState) + +-- +replaceExtraState :: extraState + -> XMLConverterState nsID _x + -> XMLConverterState nsID extraState +replaceExtraState x s + = fmap (const x) s + +-- +currentElement :: XMLConverterState nsID extraState + -> XML.Element +currentElement state = head (parentElements state) + +-- | Replace the current position by another, modifying the extra state +-- in the process +swapStack' :: XMLConverterState nsID extraState + -> [XML.Element] + -> ( XMLConverterState nsID extraState , [XML.Element] ) +swapStack' state stack + = ( state { parentElements = stack } + , parentElements state + ) + +-- +pushElement :: XML.Element + -> XMLConverterState nsID extraState + -> XMLConverterState nsID extraState +pushElement e state = state { parentElements = e:parentElements state } + +-- | Pop the top element from the call stack, unless it is the last one. +popElement :: XMLConverterState nsID extraState + -> Maybe (XMLConverterState nsID extraState) +popElement state + | _:es@(_:_) <- parentElements state = Just $ state { parentElements = es } + | otherwise = Nothing + +-------------------------------------------------------------------------------- +-- Main type +-------------------------------------------------------------------------------- + +-- It might be a good idea to pack the converters in a GADT +-- Downside: data instead of type +-- Upside: 'Failure' could be made a parameter as well. + +-- +type XMLConverter nsID extraState input output + = ArrowState (XMLConverterState nsID extraState ) input output + +type FallibleXMLConverter nsID extraState input output + = XMLConverter nsID extraState input (Fallible output) + +-- +runConverter :: XMLConverter nsID extraState input output + -> XMLConverterState nsID extraState + -> input + -> output +runConverter converter state input = snd $ runArrowState converter (state,input) + +runConverter' :: (NameSpaceID nsID) + => FallibleXMLConverter nsID extraState () success + -> extraState + -> XML.Element + -> Fallible success +runConverter' converter extraState element = runConverter (readNSattributes >>? converter) (createStartState element extraState) () + +-- +getCurrentElement :: XMLConverter nsID extraState x XML.Element +getCurrentElement = extractFromState currentElement + +-- +getExtraState :: XMLConverter nsID extraState x extraState +getExtraState = extractFromState moreState + +-- +setExtraState :: XMLConverter nsID extraState extraState extraState +setExtraState = withState $ \state extra + -> (replaceExtraState extra state , extra) + + +-- | Lifts a function to the extra state. +modifyExtraState :: (extraState -> extraState) + -> XMLConverter nsID extraState x x +modifyExtraState = modifyState.fmap + + +-- | First sets the extra state to the new value. Then modifies the original +-- extra state with a converter that uses the new state. Finally, the +-- intermediate state is dropped and the extra state is lifted into the +-- state as it was at the beginning of the function. +-- As a result, exactly the extra state and nothing else is changed. +-- The resulting converter even behaves like an identity converter on the +-- value level. +-- +-- (The -ing form is meant to be mnemonic in a sequence of arrows as in +-- convertingExtraState () converter >>> doOtherStuff) +-- +convertingExtraState :: extraState' + -> FallibleXMLConverter nsID extraState' extraState extraState + -> FallibleXMLConverter nsID extraState x x +convertingExtraState v a = withSubStateF setVAsExtraState modifyWithA + where + setVAsExtraState = liftAsSuccess $ extractFromState id >>^ replaceExtraState v + modifyWithA = keepingTheValue (moreState ^>> a) + >>^ spreadChoice >>?% flip replaceExtraState + +-- | First sets the extra state to the new value. Then produces a new +-- extra state with a converter that uses the new state. Finally, the +-- intermediate state is dropped and the extra state is lifted into the +-- state as it was at the beginning of the function. +-- As a result, exactly the extra state and nothing else is changed. +-- The resulting converter even behaves like an identity converter on the +-- value level. +-- +-- Equivalent to +-- +-- > \v x a -> convertingExtraState v (returnV x >>> a) +-- +-- (The -ing form is meant to be mnemonic in a sequence of arrows as in +-- producingExtraState () () producer >>> doOtherStuff) +-- +producingExtraState :: extraState' + -> a + -> FallibleXMLConverter nsID extraState' a extraState + -> FallibleXMLConverter nsID extraState x x +producingExtraState v x a = convertingExtraState v (returnV x >>> a) + + +-------------------------------------------------------------------------------- +-- Work in namespaces +-------------------------------------------------------------------------------- + +-- | Arrow version of 'getIRI' +lookupNSiri :: (NameSpaceID nsID) + => nsID + -> XMLConverter nsID extraState x (Maybe NameSpaceIRI) +lookupNSiri nsID = extractFromState + $ \state -> getIRI nsID $ namespaceIRIs state + +-- +lookupNSprefix :: (NameSpaceID nsID) + => nsID + -> XMLConverter nsID extraState x (Maybe NameSpacePrefix) +lookupNSprefix nsID = extractFromState + $ \state -> M.lookup nsID $ namespacePrefixes state + +-- | Extracts namespace attributes from the current element and tries to +-- update the current mapping accordingly +readNSattributes :: (NameSpaceID nsID) + => FallibleXMLConverter nsID extraState x () +readNSattributes = fromState $ \state -> maybe (state, failEmpty ) + ( , succeedWith ()) + (extractNSAttrs state ) + where + extractNSAttrs :: (NameSpaceID nsID) + => XMLConverterState nsID extraState + -> Maybe (XMLConverterState nsID extraState) + extractNSAttrs startState + = foldl' (\state d -> state >>= addNS d) + (Just startState) + nsAttribs + where nsAttribs = mapMaybe readNSattr (XML.elAttribs element) + element = currentElement startState + readNSattr (XML.Attr (XML.QName name _ (Just "xmlns")) iri) + = Just (name, iri) + readNSattr _ = Nothing + addNS (prefix, iri) state = fmap updateState + $ getNamespaceID iri + $ namespaceIRIs state + where updateState (iris,nsID) + = state { namespaceIRIs = iris + , namespacePrefixes = M.insert nsID prefix + $ namespacePrefixes state + } + +-------------------------------------------------------------------------------- +-- Common namespace accessors +-------------------------------------------------------------------------------- + +-- | Given a namespace id and an element name, creates a 'XML.QName' for +-- internal use +qualifyName :: (NameSpaceID nsID) + => nsID -> ElementName + -> XMLConverter nsID extraState x XML.QName +qualifyName nsID name = lookupNSiri nsID + &&& lookupNSprefix nsID + >>% XML.QName name + +-- | Checks if a given element matches both a specified namespace id +-- and a predicate +elemNameMatches :: (NameSpaceID nsID) + => nsID -> (ElementName -> Bool) + -> XMLConverter nsID extraState XML.Element Bool +elemNameMatches nsID f = keepingTheValue (lookupNSiri nsID) >>% hasMatchingName + where hasMatchingName e iri = let name = XML.elName e + in f (XML.qName name) + && XML.qURI name == iri + +-- | Checks if a given element matches both a specified namespace id +-- and a specified element name +elemNameIs :: (NameSpaceID nsID) + => nsID -> ElementName + -> XMLConverter nsID extraState XML.Element Bool +elemNameIs nsID name = elemNameMatches nsID (== name) + +-------------------------------------------------------------------------------- +-- General content +-------------------------------------------------------------------------------- + +elName :: XML.Element -> ElementName +elName = XML.qName . XML.elName + +-- +elContent :: XMLConverter nsID extraState x [XML.Content] +elContent = getCurrentElement + >>^ XML.elContent + +-------------------------------------------------------------------------------- +-- Children +-------------------------------------------------------------------------------- + +-- +-- +findChildren :: (NameSpaceID nsID) + => nsID -> ElementName + -> XMLConverter nsID extraState x [XML.Element] +findChildren nsID name = qualifyName nsID name + &&& getCurrentElement + >>% XML.findChildren + +-- +findChild' :: (NameSpaceID nsID) + => nsID + -> ElementName + -> XMLConverter nsID extraState x (Maybe XML.Element) +findChild' nsID name = qualifyName nsID name + &&& getCurrentElement + >>% XML.findChild + +-- +findChild :: (NameSpaceID nsID) + => nsID -> ElementName + -> FallibleXMLConverter nsID extraState x XML.Element +findChild nsID name = findChild' nsID name + >>> maybeToChoice + +filterChildrenName' :: (NameSpaceID nsID) + => nsID + -> (ElementName -> Bool) + -> XMLConverter nsID extraState x [XML.Element] +filterChildrenName' nsID f = getCurrentElement + >>> arr XML.elChildren + >>> iterateS (keepingTheValue (elemNameMatches nsID f)) + >>> arr (map fst . filter snd) + +-------------------------------------------------------------------------------- +-- Attributes +-------------------------------------------------------------------------------- + +-- +isSet' :: (NameSpaceID nsID) + => nsID -> AttributeName + -> XMLConverter nsID extraState x (Maybe Bool) +isSet' nsID attrName = findAttr' nsID attrName + >>^ (>>= stringToBool') + +isSetWithDefault :: (NameSpaceID nsID) + => nsID -> AttributeName + -> Bool + -> XMLConverter nsID extraState x Bool +isSetWithDefault nsID attrName def' + = isSet' nsID attrName + >>^ fromMaybe def' + +-- | Lookup value in a dictionary, fail if no attribute found or value +-- not in dictionary +searchAttrIn :: (NameSpaceID nsID) + => nsID -> AttributeName + -> [(AttributeValue,a)] + -> FallibleXMLConverter nsID extraState x a +searchAttrIn nsID attrName dict + = findAttr nsID attrName + >>?^? maybeToChoice.(`lookup` dict ) + +-- | Lookup value in a dictionary. If attribute or value not found, +-- return default value +searchAttr :: (NameSpaceID nsID) + => nsID -> AttributeName + -> a + -> [(AttributeValue,a)] + -> XMLConverter nsID extraState x a +searchAttr nsID attrName defV dict + = searchAttrIn nsID attrName dict + >>> const defV ^|||^ id + +-- | Read a 'Lookupable' attribute. Fail if no match. +lookupAttr :: (NameSpaceID nsID, Lookupable a) + => nsID -> AttributeName + -> FallibleXMLConverter nsID extraState x a +lookupAttr nsID attrName = lookupAttr' nsID attrName + >>^ maybeToChoice + + +-- | Read a 'Lookupable' attribute. Return the result as a 'Maybe'. +lookupAttr' :: (NameSpaceID nsID, Lookupable a) + => nsID -> AttributeName + -> XMLConverter nsID extraState x (Maybe a) +lookupAttr' nsID attrName + = findAttr' nsID attrName + >>^ (>>= readLookupable) + +-- | Read a 'Lookupable' attribute with explicit default +lookupAttrWithDefault :: (NameSpaceID nsID, Lookupable a) + => nsID -> AttributeName + -> a + -> XMLConverter nsID extraState x a +lookupAttrWithDefault nsID attrName deflt + = lookupAttr' nsID attrName + >>^ fromMaybe deflt + +-- | Read a 'Lookupable' attribute with implicit default +lookupDefaultingAttr :: (NameSpaceID nsID, Lookupable a, Default a) + => nsID -> AttributeName + -> XMLConverter nsID extraState x a +lookupDefaultingAttr nsID attrName + = lookupAttrWithDefault nsID attrName def + +-- | Return value as a (Maybe Text) +findAttr' :: (NameSpaceID nsID) + => nsID -> AttributeName + -> XMLConverter nsID extraState x (Maybe AttributeValue) +findAttr' nsID attrName = qualifyName nsID attrName + &&& getCurrentElement + >>% XML.findAttr + +-- | Return value as a (Maybe Text) +findAttrText' :: (NameSpaceID nsID) + => nsID -> AttributeName + -> XMLConverter nsID extraState x (Maybe TextAttributeValue) +findAttrText' nsID attrName + = qualifyName nsID attrName + &&& getCurrentElement + >>% XML.findAttr + +-- | Return value as string or fail +findAttr :: (NameSpaceID nsID) + => nsID -> AttributeName + -> FallibleXMLConverter nsID extraState x AttributeValue +findAttr nsID attrName = findAttr' nsID attrName + >>> maybeToChoice + +-- | Return value as text or fail +findAttrText :: (NameSpaceID nsID) + => nsID -> AttributeName + -> FallibleXMLConverter nsID extraState x TextAttributeValue +findAttrText nsID attrName + = findAttr' nsID attrName + >>> maybeToChoice + +-- | Return value as string or return provided default value +findAttrTextWithDefault :: (NameSpaceID nsID) + => nsID -> AttributeName + -> TextAttributeValue + -> XMLConverter nsID extraState x TextAttributeValue +findAttrTextWithDefault nsID attrName deflt + = findAttr' nsID attrName + >>^ fromMaybe deflt + +-- | Read and return value or fail +readAttr :: (NameSpaceID nsID, Read attrValue) + => nsID -> AttributeName + -> FallibleXMLConverter nsID extraState x attrValue +readAttr nsID attrName = readAttr' nsID attrName + >>> maybeToChoice + +-- | Read and return value or return Nothing +readAttr' :: (NameSpaceID nsID, Read attrValue) + => nsID -> AttributeName + -> XMLConverter nsID extraState x (Maybe attrValue) +readAttr' nsID attrName = findAttr' nsID attrName + >>^ (>>= tryToRead) + +-- | Read and return value or return provided default value +readAttrWithDefault :: (NameSpaceID nsID, Read attrValue) + => nsID -> AttributeName + -> attrValue + -> XMLConverter nsID extraState x attrValue +readAttrWithDefault nsID attrName deflt + = findAttr' nsID attrName + >>^ (>>= tryToRead) + >>^ fromMaybe deflt + +-- | Read and return value or return default value from 'Default' instance +getAttr :: (NameSpaceID nsID, Read attrValue, Default attrValue) + => nsID -> AttributeName + -> XMLConverter nsID extraState x attrValue +getAttr nsID attrName = readAttrWithDefault nsID attrName def + +-------------------------------------------------------------------------------- +-- Movements +-------------------------------------------------------------------------------- + +-- +jumpThere :: XMLConverter nsID extraState XML.Element XML.Element +jumpThere = withState (\state element + -> ( pushElement element state , element ) + ) + +-- +swapStack :: XMLConverter nsID extraState [XML.Element] [XML.Element] +swapStack = withState swapStack' + +-- +jumpBack :: FallibleXMLConverter nsID extraState _x _x +jumpBack = tryModifyState (popElement >>> maybeToChoice) + +-- | Support function for "procedural" converters: jump to an element, execute +-- a converter, jump back. +-- This version is safer than 'executeThere', because it does not rely on the +-- internal stack. As a result, the converter can not move around in arbitrary +-- ways. The downside is of course that some of the environment is not +-- accessible to the converter. +switchingTheStack :: XMLConverter nsID moreState a b + -> XMLConverter nsID moreState (a, XML.Element) b +switchingTheStack a = second ( (:[]) ^>> swapStack ) + >>> first a + >>> second swapStack + >>^ fst + +-- | Support function for "procedural" converters: jumps to an element, executes +-- a converter, jumps back. +-- Make sure that the converter is well-behaved; that is it should +-- return to the exact position it started from in /every possible path/ of +-- execution, even if it "fails". If it does not, you may encounter +-- strange bugs. If you are not sure about the behaviour or want to use +-- shortcuts, you can often use 'switchingTheStack' instead. +executeThere :: FallibleXMLConverter nsID moreState a b + -> FallibleXMLConverter nsID moreState (a, XML.Element) b +executeThere a = second jumpThere + >>> fst + ^>> a + >>> jumpBack -- >>? jumpBack would not ensure the jump. + >>^ collapseEither + + +-- | Do something in a specific element, then come back +executeIn :: XMLConverter nsID extraState XML.Element s + -> XMLConverter nsID extraState XML.Element s +executeIn a = duplicate >>> switchingTheStack a + +-- | Do something in a sub-element, then come back +executeInSub :: (NameSpaceID nsID) + => nsID -> ElementName + -> FallibleXMLConverter nsID extraState f s + -> FallibleXMLConverter nsID extraState f s +executeInSub nsID name a = keepingTheValue + (findChild nsID name) + >>> ignoringState liftFailure + >>? switchingTheStack a + where liftFailure (_, Left f) = Left f + liftFailure (x, Right e) = Right (x, e) + +-------------------------------------------------------------------------------- +-- Iterating over children +-------------------------------------------------------------------------------- + +-- Helper converter to prepare different types of iterations. +-- It lifts the children (of a certain type) of the current element +-- into the value level and pairs each one with the current input value. +prepareIteration :: (NameSpaceID nsID) + => nsID -> ElementName + -> XMLConverter nsID extraState b [(b, XML.Element)] +prepareIteration nsID name = keepingTheValue + (findChildren nsID name) + >>% distributeValue + +-- +withEveryL :: (NameSpaceID nsID) + => nsID -> ElementName + -> FallibleXMLConverter nsID extraState a b + -> FallibleXMLConverter nsID extraState a [b] +withEveryL = withEvery + +-- | Applies a converter to every child element of a specific type. +-- Collects results in a 'MonadPlus'. +-- Fails completely if any conversion fails. +withEvery :: (NameSpaceID nsID, MonadPlus m) + => nsID -> ElementName + -> FallibleXMLConverter nsID extraState a b + -> FallibleXMLConverter nsID extraState a (m b) +withEvery nsID name a = prepareIteration nsID name + >>> iterateS' (switchingTheStack a) + +-- | Applies a converter to every child element of a specific type. +-- Collects all successful results in a list. +tryAll :: (NameSpaceID nsID) + => nsID -> ElementName + -> FallibleXMLConverter nsID extraState b a + -> XMLConverter nsID extraState b [a] +tryAll nsID name a = prepareIteration nsID name + >>> iterateS (switchingTheStack a) + >>^ rights + +-------------------------------------------------------------------------------- +-- Matching children +-------------------------------------------------------------------------------- + +type IdXMLConverter nsID moreState x + = XMLConverter nsID moreState x x + +type MaybeCConverter nsID moreState x + = Maybe (IdXMLConverter nsID moreState (x, XML.Content)) + +-- Chainable converter that helps deciding which converter to actually use. +type ContentMatchConverter nsID extraState x + = IdXMLConverter nsID + extraState + (MaybeCConverter nsID extraState x, XML.Content) + +-- Helper function: The @c@ is actually a converter that is to be selected by +-- matching XML content to the first two parameters. +-- The fold used to match elements however is very simple, so to use it, +-- this function wraps the converter in another converter that unifies +-- the accumulator. Think of a lot of converters with the resulting type +-- chained together. The accumulator not only transports the element +-- unchanged to the next matcher, it also does the actual selecting by +-- combining the intermediate results with '(<|>)'. +makeMatcherC :: (NameSpaceID nsID) + => nsID -> ElementName + -> FallibleXMLConverter nsID extraState a a + -> ContentMatchConverter nsID extraState a +makeMatcherC nsID name c = ( second ( contentToElem + >>> returnV Nothing + ||| ( elemNameIs nsID name + >>^ bool Nothing (Just cWithJump) + ) + ) + >>% (<|>) + ) &&&^ snd + where cWithJump = ( fst + ^&&& ( second contentToElem + >>> spreadChoice + ^>>? executeThere c + ) + >>% recover) + &&&^ snd + contentToElem :: FallibleXMLConverter nsID extraState XML.Content XML.Element + contentToElem = arr $ \case + XML.Elem e' -> succeedWith e' + _ -> failEmpty + +-- Creates and chains a bunch of matchers +prepareMatchersC :: (NameSpaceID nsID) + => [(nsID, ElementName, FallibleXMLConverter nsID extraState x x)] + -> ContentMatchConverter nsID extraState x +--prepareMatchersC = foldSs . (map $ uncurry3 makeMatcherC) +prepareMatchersC = reverseComposition . map (uncurry3 makeMatcherC) + +-- | Takes a list of element-data - converter groups and +-- * Finds all content of the current element +-- * Matches each group to each piece of content in order +-- (at most one group per piece of content) +-- * Filters non-matched content +-- * Chains all found converters in content-order +-- * Applies the chain to the input element +matchContent' :: (NameSpaceID nsID) + => [(nsID, ElementName, FallibleXMLConverter nsID extraState a a)] + -> XMLConverter nsID extraState a a +matchContent' lookups = matchContent lookups (arr fst) + +-- | Takes a list of element-data - converter groups and +-- * Finds all content of the current element +-- * Matches each group to each piece of content in order +-- (at most one group per piece of content) +-- * Adds a default converter for all non-matched content +-- * Chains all found converters in content-order +-- * Applies the chain to the input element +matchContent :: (NameSpaceID nsID) + => [(nsID, ElementName, FallibleXMLConverter nsID extraState a a)] + -> XMLConverter nsID extraState (a,XML.Content) a + -> XMLConverter nsID extraState a a +matchContent lookups fallback + = let matcher = prepareMatchersC lookups + in keepingTheValue ( + elContent + >>> map (Nothing,) + ^>> iterateSL matcher + >>^ map swallowOrFallback + -- >>> foldSs + >>> reverseComposition + ) + >>> swap + ^>> app + where + -- let the converter swallow the content and drop the content + -- in the return value + swallowOrFallback (Just converter,content) = (,content) ^>> converter >>^ fst + swallowOrFallback (Nothing ,content) = (,content) ^>> fallback + +-------------------------------------------------------------------------------- +-- Internals +-------------------------------------------------------------------------------- + +stringToBool' :: Text -> Maybe Bool +stringToBool' val | val `elem` trueValues = Just True + | val `elem` falseValues = Just False + | otherwise = Nothing + where trueValues = ["true" ,"on" ,"1"] + falseValues = ["false","off","0"] + + +distributeValue :: a -> [b] -> [(a,b)] +distributeValue = map.(,) + +-------------------------------------------------------------------------------- + +{- +NOTES +It might be a good idea to refactor the namespace stuff. +E.g.: if a namespace constructor took a string as a parameter, things like +> a ?>/< (NsText,"body") +would be nicer. +Together with a rename and some trickery, something like +> |< NsText "body" >< NsText "p" ?> a | +might even be possible. + +Some day, XML.Light should be replaced by something better. +While doing that, it might be useful to replace String as the type of element +names with something else, too. (Of course with OverloadedStrings). +While doing that, maybe the types can be created in a way that something like +> NsText:"body" +could be used. Overloading (:) does not sounds like the best idea, but if the +element name type was a list, this might be possible. +Of course that would be a bit hackish, so the "right" way would probably be +something like +> InNS NsText "body" +but isn't that a bit boring? ;) +-} diff --git a/src/Text/Pandoc/Readers/ODT/Namespaces.hs b/src/Text/Pandoc/Readers/ODT/Namespaces.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/Readers/ODT/Namespaces.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE OverloadedStrings #-} +{- | + Module : Text.Pandoc.Reader.ODT.Namespaces + Copyright : Copyright (C) 2015 Martin Linnemann + License : GNU GPL, version 2 or above + + Maintainer : Martin Linnemann + Stability : alpha + Portability : portable + +Namespaces used in odt files. +-} + +module Text.Pandoc.Readers.ODT.Namespaces ( Namespace (..) + ) where + +import qualified Data.Map as M (empty, insert) +import Data.Maybe (fromMaybe, listToMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import Text.Pandoc.Readers.ODT.Generic.Namespaces + + +instance NameSpaceID Namespace where + + getInitialIRImap = nsIDmap + + getNamespaceID "" m = Just(m, NsXML) + getNamespaceID iri m = asPair $ fromMaybe (NsOther iri) (findID iri) + where asPair nsID = Just (M.insert nsID iri m, nsID) + + +findID :: NameSpaceIRI -> Maybe Namespace +findID iri = listToMaybe [nsID | (iri',nsID) <- nsIDs, iri' `T.isPrefixOf` iri] + +nsIDmap :: NameSpaceIRIs Namespace +nsIDmap = foldr (uncurry $ flip M.insert) M.empty nsIDs + +data Namespace = -- Open Document core + NsOffice | NsStyle | NsText | NsTable | NsForm + | NsDraw | Ns3D | NsAnim | NsChart | NsConfig + | NsDB | NsMeta | NsNumber | NsScript | NsManifest + | NsPresentation + -- Metadata + | NsODF + -- Compatible elements + | NsXSL_FO | NsSVG | NsSmil + -- External standards + | NsMathML | NsXForms | NsXLink | NsXHtml | NsGRDDL + | NsDublinCore + -- Metadata manifest + | NsPKG + -- Others + | NsOpenFormula + -- Core XML (basically only for the 'id'-attribute) + | NsXML + -- Fallback + | NsOther Text + deriving ( Eq, Ord, Show ) + +-- | Not the actual iri's, but large prefixes of them - this way there are +-- less versioning problems and the like. +nsIDs :: [(Text, Namespace)] +nsIDs = [ + ("urn:oasis:names:tc:opendocument:xmlns:animation" , NsAnim ), + ("urn:oasis:names:tc:opendocument:xmlns:chart" , NsChart ), + ("urn:oasis:names:tc:opendocument:xmlns:config" , NsConfig ), + ("urn:oasis:names:tc:opendocument:xmlns:database" , NsDB ), + ("urn:oasis:names:tc:opendocument:xmlns:dr3d" , Ns3D ), + ("urn:oasis:names:tc:opendocument:xmlns:drawing" , NsDraw ), + ("urn:oasis:names:tc:opendocument:xmlns:form" , NsForm ), + ("urn:oasis:names:tc:opendocument:xmlns:manifest" , NsManifest ), + ("urn:oasis:names:tc:opendocument:xmlns:meta" , NsMeta ), + ("urn:oasis:names:tc:opendocument:xmlns:datastyle" , NsNumber ), + ("urn:oasis:names:tc:opendocument:xmlns:of" , NsOpenFormula ), + ("urn:oasis:names:tc:opendocument:xmlns:office:1.0" , NsOffice ), + ("urn:oasis:names:tc:opendocument:xmlns:presentation" , NsPresentation ), + ("urn:oasis:names:tc:opendocument:xmlns:script" , NsScript ), + ("urn:oasis:names:tc:opendocument:xmlns:style" , NsStyle ), + ("urn:oasis:names:tc:opendocument:xmlns:table" , NsTable ), + ("urn:oasis:names:tc:opendocument:xmlns:text" , NsText ), + ("urn:oasis:names:tc:opendocument:xmlns:xsl-fo-compatible", NsXSL_FO ), + ("urn:oasis:names:tc:opendocument:xmlns:smil-compatible" , NsSmil ), + ("urn:oasis:names:tc:opendocument:xmlns:svg-compatible" , NsSVG ), + ("http://docs.oasis-open.org/ns/office/1.2/meta/odf" , NsODF ), + ("http://docs.oasis-open.org/ns/office/1.2/meta/pkg" , NsPKG ), + ("http://purl.org/dc/elements" , NsDublinCore ), + ("http://www.w3.org/2003/g/data-view" , NsGRDDL ), + ("http://www.w3.org/1998/Math/MathML" , NsMathML ), + ("http://www.w3.org/1999/xhtml" , NsXHtml ), + ("http://www.w3.org/2002/xforms" , NsXForms ), + ("http://www.w3.org/1999/xlink" , NsXLink ) + ] diff --git a/src/Text/Pandoc/Readers/ODT/StyleReader.hs b/src/Text/Pandoc/Readers/ODT/StyleReader.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/Readers/ODT/StyleReader.hs @@ -0,0 +1,640 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE Arrows #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE OverloadedStrings #-} +{- | + Module : Text.Pandoc.Readers.ODT.StyleReader + Copyright : Copyright (C) 2015 Martin Linnemann + License : GNU GPL, version 2 or above + + Maintainer : Martin Linnemann + Stability : alpha + Portability : portable + +Reader for the style information in an odt document. +-} + +module Text.Pandoc.Readers.ODT.StyleReader +( Style (..) +, StyleName +, StyleFamily (..) +, Styles (..) +, StyleProperties (..) +, TextProperties (..) +, ParaProperties (..) +, VerticalTextPosition (..) +, ListItemNumberFormat (..) +, ListLevel +, ListStyle (..) +, ListLevelStyle (..) +, ListLevelType (..) +, LengthOrPercent (..) +, lookupStyle +, getListLevelStyle +, getStyleFamily +, lookupDefaultStyle' +, lookupListStyleByName +, extendedStylePropertyChain +, readStylesAt +) where + +import Prelude hiding (Applicative(..)) +import Control.Applicative hiding (liftA, liftA2, liftA3) +import Control.Arrow + +import Data.Default +import qualified Data.Foldable as F +import Data.List (unfoldr, foldl') +import qualified Data.Map as M +import Data.Maybe +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Set as S + +import qualified Text.Pandoc.XML.Light as XML + +import Text.Pandoc.Shared (safeRead, tshow) + +import Text.Pandoc.Readers.ODT.Arrows.Utils + +import Text.Pandoc.Readers.ODT.Generic.Fallible +import qualified Text.Pandoc.Readers.ODT.Generic.SetMap as SM +import Text.Pandoc.Readers.ODT.Generic.Utils +import Text.Pandoc.Readers.ODT.Generic.XMLConverter + +import Text.Pandoc.Readers.ODT.Base +import Text.Pandoc.Readers.ODT.Namespaces + +readStylesAt :: XML.Element -> Fallible Styles +readStylesAt e = runConverter' readAllStyles mempty e + +-------------------------------------------------------------------------------- +-- Reader for font declarations and font pitches +-------------------------------------------------------------------------------- + +-- Pandoc has no support for different font pitches. Yet knowing them can be +-- very helpful in cases where Pandoc has more semantics than OpenDocument. +-- In these cases, the pitch can help deciding as what to define a block of +-- text. So let's start with a type for font pitches: + +data FontPitch = PitchVariable | PitchFixed + deriving ( Eq, Show ) + +instance Lookupable FontPitch where + lookupTable = [ ("variable" , PitchVariable) + , ("fixed" , PitchFixed ) + ] + +instance Default FontPitch where + def = PitchVariable + +-- The font pitch can be specified in a style directly. Normally, however, +-- it is defined in the font. That is also the specs' recommendation. +-- +-- Thus, we want + +type FontFaceName = Text + +type FontPitches = M.Map FontFaceName FontPitch + +-- To get there, the fonts have to be read and the pitches extracted. +-- But the resulting map are only needed at one later place, so it should not be +-- transported on the value level, especially as we already use a state arrow. +-- So instead, the resulting map is lifted into the state of the reader. +-- (An alternative might be ImplicitParams, but again, we already have a state.) +-- +-- So the main style readers will have the types +type StyleReader a b = XMLReader FontPitches a b +-- and +type StyleReaderSafe a b = XMLReaderSafe FontPitches a b +-- respectively. +-- +-- But before we can work with these, we need to define the reader that reads +-- the fonts: + +-- | A reader for font pitches +fontPitchReader :: XMLReader _s _x FontPitches +fontPitchReader = executeInSub NsOffice "font-face-decls" ( + withEveryL NsStyle "font-face" (liftAsSuccess ( + findAttr' NsStyle "name" + &&& + lookupDefaultingAttr NsStyle "font-pitch" + )) + >>?^ ( M.fromList . foldl' accumLegalPitches [] ) + ) `ifFailedDo` returnV (Right M.empty) + where accumLegalPitches ls (Nothing,_) = ls + accumLegalPitches ls (Just n,p) = (n,p):ls + + +-- | A wrapper around the font pitch reader that lifts the result into the +-- state. +readFontPitches :: StyleReader x x +readFontPitches = producingExtraState () () fontPitchReader + + +-- | Looking up a pitch in the state of the arrow. +-- +-- The function does the following: +-- * Look for the font pitch in an attribute. +-- * If that fails, look for the font name, look up the font in the state +-- and use the pitch from there. +-- * Return the result in a Maybe +-- +findPitch :: XMLReaderSafe FontPitches _x (Maybe FontPitch) +findPitch = ( lookupAttr NsStyle "font-pitch" + `ifFailedDo` findAttr NsStyle "font-name" + >>? ( keepingTheValue getExtraState + >>% M.lookup + >>^ maybeToChoice + ) + ) + >>> choiceToMaybe + +-------------------------------------------------------------------------------- +-- Definitions of main data +-------------------------------------------------------------------------------- + +type StyleName = Text + +-- | There are two types of styles: named styles with a style family and an +-- optional style parent, and default styles for each style family, +-- defining default style properties +data Styles = Styles + { stylesByName :: M.Map StyleName Style + , listStylesByName :: M.Map StyleName ListStyle + , defaultStyleMap :: M.Map StyleFamily StyleProperties + } + deriving ( Show ) + +-- Styles from a monoid under union +instance Semigroup Styles where + (Styles sBn1 dSm1 lsBn1) <> (Styles sBn2 dSm2 lsBn2) + = Styles (M.union sBn1 sBn2) + (M.union dSm1 dSm2) + (M.union lsBn1 lsBn2) +instance Monoid Styles where + mempty = Styles M.empty M.empty M.empty + mappend = (<>) + +-- Not all families from the specifications are implemented, only those we need. +-- But there are none that are not mentioned here. +data StyleFamily = FaText | FaParagraph +-- | FaTable | FaTableCell | FaTableColumn | FaTableRow +-- | FaGraphic | FaDrawing | FaChart +-- | FaPresentation +-- | FaRuby + deriving ( Eq, Ord, Show ) + +instance Lookupable StyleFamily where + lookupTable = [ ( "text" , FaText ) + , ( "paragraph" , FaParagraph ) +-- , ( "table" , FaTable ) +-- , ( "table-cell" , FaTableCell ) +-- , ( "table-column" , FaTableColumn ) +-- , ( "table-row" , FaTableRow ) +-- , ( "graphic" , FaGraphic ) +-- , ( "drawing-page" , FaDrawing ) +-- , ( "chart" , FaChart ) +-- , ( "presentation" , FaPresentation ) +-- , ( "ruby" , FaRuby ) + ] + +-- | A named style +data Style = Style { styleFamily :: Maybe StyleFamily + , styleParentName :: Maybe StyleName + , listStyle :: Maybe StyleName + , styleProperties :: StyleProperties + } + deriving ( Eq, Show ) + +data StyleProperties = SProps { textProperties :: Maybe TextProperties + , paraProperties :: Maybe ParaProperties +-- , tableColProperties :: Maybe TColProperties +-- , tableRowProperties :: Maybe TRowProperties +-- , tableCellProperties :: Maybe TCellProperties +-- , tableProperties :: Maybe TableProperties +-- , graphicProperties :: Maybe GraphProperties + } + deriving ( Eq, Show ) + +instance Default StyleProperties where + def = SProps { textProperties = Just def + , paraProperties = Just def + } + +data TextProperties = PropT { isEmphasised :: Bool + , isStrong :: Bool + , pitch :: Maybe FontPitch + , verticalPosition :: VerticalTextPosition + , underline :: Maybe UnderlineMode + , strikethrough :: Maybe UnderlineMode + } + deriving ( Eq, Show ) + +instance Default TextProperties where + def = PropT { isEmphasised = False + , isStrong = False + , pitch = Just def + , verticalPosition = def + , underline = Nothing + , strikethrough = Nothing + } + +data ParaProperties = PropP { paraNumbering :: ParaNumbering + , indentation :: LengthOrPercent + , margin_left :: LengthOrPercent + } + deriving ( Eq, Show ) + +instance Default ParaProperties where + def = PropP { paraNumbering = NumberingNone + , indentation = def + , margin_left = def + } + +---- +-- All the little data types that make up the properties +---- + +data VerticalTextPosition = VPosNormal | VPosSuper | VPosSub + deriving ( Eq, Show ) + +instance Default VerticalTextPosition where + def = VPosNormal + +instance Read VerticalTextPosition where + readsPrec _ s = [ (VPosSub , s') | ("sub" , s') <- lexS ] + ++ [ (VPosSuper , s') | ("super" , s') <- lexS ] + ++ [ (signumToVPos n , s') | ( n , s') <- readPercent s ] + where + lexS = lex s + signumToVPos n | n < 0 = VPosSub + | n > 0 = VPosSuper + | otherwise = VPosNormal + +data UnderlineMode = UnderlineModeNormal | UnderlineModeSkipWhitespace + deriving ( Eq, Show ) + +instance Lookupable UnderlineMode where + lookupTable = [ ( "continuous" , UnderlineModeNormal ) + , ( "skip-white-space" , UnderlineModeSkipWhitespace ) + ] + + +data ParaNumbering = NumberingNone | NumberingKeep | NumberingRestart Int + deriving ( Eq, Show ) + +data LengthOrPercent = LengthValueMM Int | PercentValue Int + deriving ( Eq, Show ) + +instance Default LengthOrPercent where + def = LengthValueMM 0 + +instance Read LengthOrPercent where + readsPrec _ s = + [ (PercentValue percent , s' ) | (percent , s' ) <- readPercent s] + ++ [ (LengthValueMM lengthMM , s'') | (length' , s' ) <- reads s + , (unit , s'') <- reads s' + , let lengthMM = estimateInMillimeter + length' unit + ] + +data XslUnit = XslUnitMM | XslUnitCM + | XslUnitInch + | XslUnitPoints | XslUnitPica + | XslUnitPixel + | XslUnitEM + +instance Show XslUnit where + show XslUnitMM = "mm" + show XslUnitCM = "cm" + show XslUnitInch = "in" + show XslUnitPoints = "pt" + show XslUnitPica = "pc" + show XslUnitPixel = "px" + show XslUnitEM = "em" + +instance Read XslUnit where + readsPrec _ "mm" = [(XslUnitMM , "")] + readsPrec _ "cm" = [(XslUnitCM , "")] + readsPrec _ "in" = [(XslUnitInch , "")] + readsPrec _ "pt" = [(XslUnitPoints , "")] + readsPrec _ "pc" = [(XslUnitPica , "")] + readsPrec _ "px" = [(XslUnitPixel , "")] + readsPrec _ "em" = [(XslUnitEM , "")] + readsPrec _ _ = [] + +-- | Rough conversion of measures into millimetres. +-- Pixels and em's are actually implementation dependent/relative measures, +-- so I could not really easily calculate anything exact here even if I wanted. +-- But I do not care about exactness right now, as I only use measures +-- to determine if a paragraph is "indented" or not. +estimateInMillimeter :: Int -> XslUnit -> Int +estimateInMillimeter n XslUnitMM = n +estimateInMillimeter n XslUnitCM = n * 10 +estimateInMillimeter n XslUnitInch = n * 25 -- \* 25.4 +estimateInMillimeter n XslUnitPoints = n `div` 3 -- \* 1/72 * 25.4 +estimateInMillimeter n XslUnitPica = n * 4 -- \* 12 * 1/72 * 25.4 +estimateInMillimeter n XslUnitPixel = n `div`3 -- \* 1/72 * 25.4 +estimateInMillimeter n XslUnitEM = n * 7 -- \* 16 * 1/72 * 25.4 + + +---- +-- List styles +---- + +type ListLevel = Int + +newtype ListStyle = ListStyle { levelStyles :: M.Map ListLevel ListLevelStyle + } + deriving ( Eq, Show ) + +-- +getListLevelStyle :: ListLevel -> ListStyle -> Maybe ListLevelStyle +getListLevelStyle level ListStyle{..} = + let (lower , exactHit , _) = M.splitLookup level levelStyles + in exactHit <|> fmap fst (M.maxView lower) + -- findBy (`M.lookup` levelStyles) [level, (level-1) .. 1] + -- \^ simpler, but in general less efficient + +data ListLevelStyle = ListLevelStyle { listLevelType :: ListLevelType + , listItemPrefix :: Maybe Text + , listItemSuffix :: Maybe Text + , listItemFormat :: ListItemNumberFormat + , listItemStart :: Int + } + deriving ( Eq, Ord ) + +instance Show ListLevelStyle where + show ListLevelStyle{..} = " listItemPrefix) + ++ show listItemFormat + ++ maybeToString (T.unpack <$> listItemSuffix) + ++ ">" + where maybeToString = fromMaybe "" + +data ListLevelType = LltBullet | LltImage | LltNumbered + deriving ( Eq, Ord, Show ) + +data ListItemNumberFormat = LinfNone + | LinfNumber + | LinfRomanLC | LinfRomanUC + | LinfAlphaLC | LinfAlphaUC + | LinfString String + deriving ( Eq, Ord ) + +instance Show ListItemNumberFormat where + show LinfNone = "" + show LinfNumber = "1" + show LinfRomanLC = "i" + show LinfRomanUC = "I" + show LinfAlphaLC = "a" + show LinfAlphaUC = "A" + show (LinfString s) = s + +instance Default ListItemNumberFormat where + def = LinfNone + +instance Read ListItemNumberFormat where + readsPrec _ "" = [(LinfNone , "")] + readsPrec _ "1" = [(LinfNumber , "")] + readsPrec _ "i" = [(LinfRomanLC , "")] + readsPrec _ "I" = [(LinfRomanUC , "")] + readsPrec _ "a" = [(LinfAlphaLC , "")] + readsPrec _ "A" = [(LinfAlphaUC , "")] + readsPrec _ s = [(LinfString s , "")] + +-------------------------------------------------------------------------------- +-- Readers +-- +-- ...it seems like a whole lot of this should be automatically derivable +-- or at least moveable into a class. Most of this is data concealed in +-- code. +-------------------------------------------------------------------------------- + +-- +readAllStyles :: StyleReader _x Styles +readAllStyles = ( readFontPitches + >>?! ( readAutomaticStyles + &&& readStyles )) + >>?%? chooseMax + -- all top elements are always on the same hierarchy level + +-- +readStyles :: StyleReader _x Styles +readStyles = executeInSub NsOffice "styles" $ liftAsSuccess + $ liftA3 Styles + ( tryAll NsStyle "style" readStyle >>^ M.fromList ) + ( tryAll NsText "list-style" readListStyle >>^ M.fromList ) + ( tryAll NsStyle "default-style" readDefaultStyle >>^ M.fromList ) + +-- +readAutomaticStyles :: StyleReader _x Styles +readAutomaticStyles = executeInSub NsOffice "automatic-styles" $ liftAsSuccess + $ liftA3 Styles + ( tryAll NsStyle "style" readStyle >>^ M.fromList ) + ( tryAll NsText "list-style" readListStyle >>^ M.fromList ) + ( returnV M.empty ) + +-- +readDefaultStyle :: StyleReader _x (StyleFamily, StyleProperties) +readDefaultStyle = lookupAttr NsStyle "family" + >>?! keepingTheValue readStyleProperties + +-- +readStyle :: StyleReader _x (StyleName,Style) +readStyle = findAttr NsStyle "name" + >>?! keepingTheValue + ( liftA4 Style + ( lookupAttr' NsStyle "family" ) + ( findAttr' NsStyle "parent-style-name" ) + ( findAttr' NsStyle "list-style-name" ) + readStyleProperties + ) + +-- +readStyleProperties :: StyleReaderSafe _x StyleProperties +readStyleProperties = liftA2 SProps + ( readTextProperties >>> choiceToMaybe ) + ( readParaProperties >>> choiceToMaybe ) + +-- +readTextProperties :: StyleReader _x TextProperties +readTextProperties = + executeInSub NsStyle "text-properties" $ liftAsSuccess + ( liftA6 PropT + ( searchAttr NsXSL_FO "font-style" False isFontEmphasised ) + ( searchAttr NsXSL_FO "font-weight" False isFontBold ) + findPitch + ( getAttr NsStyle "text-position" ) + readUnderlineMode + readStrikeThroughMode + ) + where isFontEmphasised = [("normal",False),("italic",True),("oblique",True)] + isFontBold = ("normal",False):("bold",True) + :map ((,True) . tshow) ([100,200..900]::[Int]) + +readUnderlineMode :: StyleReaderSafe _x (Maybe UnderlineMode) +readUnderlineMode = readLineMode "text-underline-mode" + "text-underline-style" + +readStrikeThroughMode :: StyleReaderSafe _x (Maybe UnderlineMode) +readStrikeThroughMode = readLineMode "text-line-through-mode" + "text-line-through-style" + +readLineMode :: Text -> Text -> StyleReaderSafe _x (Maybe UnderlineMode) +readLineMode modeAttr styleAttr = proc x -> do + isUL <- searchAttr NsStyle styleAttr False isLinePresent -< x + mode <- lookupAttr' NsStyle modeAttr -< x + if isUL + then case mode of + Just m -> returnA -< Just m + Nothing -> returnA -< Just UnderlineModeNormal + else returnA -< Nothing + where + isLinePresent = ("none",False) : map (,True) + [ "dash" , "dot-dash" , "dot-dot-dash" , "dotted" + , "long-dash" , "solid" , "wave" + ] + +-- +readParaProperties :: StyleReader _x ParaProperties +readParaProperties = + executeInSub NsStyle "paragraph-properties" $ liftAsSuccess + ( liftA3 PropP + ( liftA2 readNumbering + ( isSet' NsText "number-lines" ) + ( readAttr' NsText "line-number" ) + ) + ( liftA2 readIndentation + ( isSetWithDefault NsStyle "auto-text-indent" False ) + ( getAttr NsXSL_FO "text-indent" ) + ) + ( getAttr NsXSL_FO "margin-left" ) + ) + where readNumbering (Just True) (Just n) = NumberingRestart n + readNumbering (Just True) _ = NumberingKeep + readNumbering _ _ = NumberingNone + + readIndentation False indent = indent + readIndentation True _ = def + +---- +-- List styles +---- + +-- +readListStyle :: StyleReader _x (StyleName, ListStyle) +readListStyle = + findAttr NsStyle "name" + >>?! keepingTheValue + ( liftA ListStyle + $ 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 :: Namespace -> ElementName + -> ListLevelType + -> StyleReaderSafe _x (SM.SetMap Int ListLevelStyle) +readListLevelStyles namespace elementName levelType = + tryAll namespace elementName (readListLevelStyle levelType) + >>^ SM.fromList + +-- +readListLevelStyle :: ListLevelType -> StyleReader _x (Int, ListLevelStyle) +readListLevelStyle levelType = readAttr NsText "level" + >>?! keepingTheValue + ( liftA5 toListLevelStyle + ( returnV levelType ) + ( findAttr' NsStyle "num-prefix" ) + ( findAttr' NsStyle "num-suffix" ) + ( getAttr NsStyle "num-format" ) + ( findAttrText' NsText "start-value" ) + ) + where + toListLevelStyle _ p s LinfNone b = ListLevelStyle LltBullet p s LinfNone (startValue b) + toListLevelStyle _ p s f@(LinfString _) b = ListLevelStyle LltBullet p s f (startValue b) + toListLevelStyle t p s f b = ListLevelStyle t p s f (startValue b) + startValue mbx = fromMaybe 1 (mbx >>= safeRead) + +-- +chooseMostSpecificListLevelStyle :: S.Set ListLevelStyle -> Maybe ListLevelStyle +chooseMostSpecificListLevelStyle ls = F.foldr select Nothing ls + where + select l Nothing = Just l + select ( ListLevelStyle t1 p1 s1 f1 b1 ) + ( Just ( ListLevelStyle t2 p2 s2 f2 _ )) + = Just $ ListLevelStyle (select' t1 t2) (p1 <|> p2) (s1 <|> s2) + (selectLinf f1 f2) b1 + select' LltNumbered _ = LltNumbered + select' _ LltNumbered = LltNumbered + select' _ _ = LltBullet + selectLinf LinfNone f2 = f2 + selectLinf f1 LinfNone = f1 + selectLinf (LinfString _) f2 = f2 + selectLinf f1 (LinfString _) = f1 + selectLinf f1 _ = f1 + + +-------------------------------------------------------------------------------- +-- Tools to access style data +-------------------------------------------------------------------------------- + +-- +lookupStyle :: StyleName -> Styles -> Maybe Style +lookupStyle name Styles{..} = M.lookup name stylesByName + +-- +lookupDefaultStyle' :: Styles -> StyleFamily -> StyleProperties +lookupDefaultStyle' Styles{..} family = fromMaybe def + (M.lookup family defaultStyleMap) + +-- +lookupListStyleByName :: StyleName -> Styles -> Maybe ListStyle +lookupListStyleByName name Styles{..} = M.lookup name listStylesByName + + +-- | Returns a chain of parent of the current style. The direct parent will +-- be the first element of the list, followed by its parent and so on. +-- The current style is not in the list. +parents :: Style -> Styles -> [Style] +parents style styles = unfoldr findNextParent style -- Ha! + where findNextParent Style{..} + = fmap duplicate $ (`lookupStyle` styles) =<< styleParentName + +-- | Looks up the style family of the current style. Normally, every style +-- should have one. But if not, all parents are searched. +getStyleFamily :: Style -> Styles -> Maybe StyleFamily +getStyleFamily style@Style{..} styles + = styleFamily + <|> 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 +-- parent style. This function makes this chain of inheritance +-- concrete and easily accessible by encapsulating the necessary lookups. +-- The resulting list contains the direct properties of the style as the first +-- element, the ones of the direct parent element as the next one, and so on. +-- +-- Note: There should also be default properties for each style family. These +-- are @not@ contained in this list because properties inherited from +-- parent elements take precedence over default styles. +-- +-- This function is primarily meant to be used through convenience wrappers. +-- +stylePropertyChain :: Style -> Styles -> [StyleProperties] +stylePropertyChain style styles + = map styleProperties (style : parents 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 diff --git a/src/Text/Pandoc/Readers/OPML.hs b/src/Text/Pandoc/Readers/OPML.hs --- a/src/Text/Pandoc/Readers/OPML.hs +++ b/src/Text/Pandoc/Readers/OPML.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Readers.OPML - Copyright : Copyright (C) 2013-2022 John MacFarlane + Copyright : Copyright (C) 2013-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane diff --git a/src/Text/Pandoc/Readers/Odt.hs b/src/Text/Pandoc/Readers/Odt.hs deleted file mode 100644 --- a/src/Text/Pandoc/Readers/Odt.hs +++ /dev/null @@ -1,97 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{- | - Module : Text.Pandoc.Reader.Odt - Copyright : Copyright (C) 2015 Martin Linnemann - License : GNU GPL, version 2 or above - - Maintainer : Martin Linnemann - Stability : alpha - Portability : portable - -Entry point to the odt reader. --} - -module Text.Pandoc.Readers.Odt ( readOdt ) where - -import Codec.Archive.Zip -import Text.Pandoc.XML.Light - -import qualified Data.ByteString.Lazy as B - -import System.FilePath - -import Control.Monad.Except (throwError) - -import qualified Data.Text as T - -import Text.Pandoc.Class.PandocMonad (PandocMonad) -import qualified Text.Pandoc.Class.PandocMonad as P -import Text.Pandoc.Definition -import Text.Pandoc.Error -import Text.Pandoc.MediaBag -import Text.Pandoc.Options -import qualified Text.Pandoc.UTF8 as UTF8 - -import Text.Pandoc.Readers.Odt.ContentReader -import Text.Pandoc.Readers.Odt.StyleReader - -import Text.Pandoc.Readers.Odt.Generic.Fallible -import Text.Pandoc.Readers.Odt.Generic.XMLConverter -import Text.Pandoc.Shared (filteredFilesFromArchive) - -readOdt :: PandocMonad m - => ReaderOptions - -> B.ByteString - -> m Pandoc -readOdt opts bytes = case readOdt' opts bytes of - Right (doc, mb) -> do - P.setMediaBag mb - return doc - Left e -> throwError e - --- -readOdt' :: ReaderOptions - -> B.ByteString - -> Either PandocError (Pandoc, MediaBag) -readOdt' _ bytes = bytesToOdt bytes-- of --- Right (pandoc, mediaBag) -> Right (pandoc , mediaBag) --- Left err -> Left err - --- -bytesToOdt :: B.ByteString -> Either PandocError (Pandoc, MediaBag) -bytesToOdt bytes = case toArchiveOrFail bytes of - Right archive -> archiveToOdt archive - Left err -> Left $ PandocParseError - $ "Could not unzip ODT: " <> T.pack err - --- -archiveToOdt :: Archive -> Either PandocError (Pandoc, MediaBag) -archiveToOdt archive = do - let onFailure msg Nothing = Left $ PandocParseError msg - onFailure _ (Just x) = Right x - contentEntry <- onFailure "Could not find content.xml" - (findEntryByPath "content.xml" archive) - stylesEntry <- onFailure "Could not find styles.xml" - (findEntryByPath "styles.xml" archive) - contentElem <- entryToXmlElem contentEntry - stylesElem <- entryToXmlElem stylesEntry - styles <- either - (\_ -> Left $ PandocParseError "Could not read styles") - Right - (chooseMax (readStylesAt stylesElem ) (readStylesAt contentElem)) - let filePathIsOdtMedia :: FilePath -> Bool - filePathIsOdtMedia fp = - let (dir, name) = splitFileName fp - in (dir == "Pictures/") || (dir /= "./" && name == "content.xml") - let media = filteredFilesFromArchive archive filePathIsOdtMedia - let startState = readerState styles media - either (\_ -> Left $ PandocParseError "Could not convert opendocument") Right - (runConverter' read_body startState contentElem) - - --- -entryToXmlElem :: Entry -> Either PandocError Element -entryToXmlElem entry = - case parseXMLElement . UTF8.toTextLazy . fromEntry $ entry of - Right x -> Right x - Left msg -> Left $ PandocXMLError (T.pack $ eRelativePath entry) msg diff --git a/src/Text/Pandoc/Readers/Odt/Arrows/State.hs b/src/Text/Pandoc/Readers/Odt/Arrows/State.hs deleted file mode 100644 --- a/src/Text/Pandoc/Readers/Odt/Arrows/State.hs +++ /dev/null @@ -1,139 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TupleSections #-} -{- | - Module : Text.Pandoc.Readers.Odt.Arrows.State - Copyright : Copyright (C) 2015 Martin Linnemann - License : GNU GPL, version 2 or above - - Maintainer : Martin Linnemann - Stability : alpha - Portability : portable - -An arrow that transports a state. It is in essence a more powerful version of -the standard state monad. As it is such a simple extension, there are -other version out there that do exactly the same. -The implementation is duplicated, though, to add some useful features. -Most of these might be implemented without access to innards, but it's much -faster and easier to implement this way. --} - -module Text.Pandoc.Readers.Odt.Arrows.State where - -import Control.Arrow -import qualified Control.Category as Cat -import Control.Monad -import Data.List (foldl') -import Text.Pandoc.Readers.Odt.Arrows.Utils -import Text.Pandoc.Readers.Odt.Generic.Fallible - - -newtype ArrowState state a b = ArrowState - { runArrowState :: (state, a) -> (state, b) } - --- | Constructor -withState :: (state -> a -> (state, b)) -> ArrowState state a b -withState = ArrowState . uncurry - --- | Constructor -modifyState :: (state -> state ) -> ArrowState state a a -modifyState = ArrowState . first - --- | Constructor -ignoringState :: ( a -> b ) -> ArrowState state a b -ignoringState = ArrowState . second - --- | Constructor -fromState :: (state -> (state, b)) -> ArrowState state a b -fromState = ArrowState . (.fst) - --- | Constructor -extractFromState :: (state -> b ) -> ArrowState state x b -extractFromState f = ArrowState $ \(state,_) -> (state, f state) - --- | Constructor -tryModifyState :: (state -> Either f state) - -> ArrowState state a (Either f a) -tryModifyState f = ArrowState $ \(state,a) - -> (state,).Left ||| (,Right a) $ f state - -instance Cat.Category (ArrowState s) where - id = ArrowState id - arrow2 . arrow1 = ArrowState $ runArrowState arrow2 . runArrowState arrow1 - -instance Arrow (ArrowState state) where - arr = ignoringState - first a = ArrowState $ \(s,(aF,aS)) - -> second (,aS) $ runArrowState a (s,aF) - second a = ArrowState $ \(s,(aF,aS)) - -> second (aF,) $ runArrowState a (s,aS) - -instance ArrowChoice (ArrowState state) where - left a = ArrowState $ \(s,e) -> case e of - Left l -> second Left $ runArrowState a (s,l) - Right r -> (s, Right r) - right a = ArrowState $ \(s,e) -> case e of - Left l -> (s, Left l) - Right r -> second Right $ runArrowState a (s,r) - -instance ArrowApply (ArrowState state) where - app = ArrowState $ \(s, (f,b)) -> runArrowState f (s,b) - --- | Switches the type of the state temporarily. --- Drops the intermediate result state, behaving like a fallible --- identity arrow, save for side effects in the state. -withSubStateF :: ArrowState s x (Either f s') - -> ArrowState s' s (Either f s ) - -> ArrowState s x (Either f x ) -withSubStateF unlift a = keepingTheValue (withSubStateF' unlift a) - >>^ spreadChoice - >>^ fmap fst - --- | Switches the type of the state temporarily. --- Returns the resulting sub-state. -withSubStateF' :: ArrowState s x (Either f s') - -> ArrowState s' s (Either f s ) - -> ArrowState s x (Either f s') -withSubStateF' unlift a = ArrowState go - where go p@(s,_) = tryRunning unlift - ( tryRunning a (second Right) ) - p - where tryRunning a' b v = case runArrowState a' v of - (_ , Left f) -> (s, Left f) - (x , Right y) -> b (y,x) - --- | Fold a state arrow through something 'Foldable'. Collect the results --- in a 'Monoid'. --- Intermediate form of a fold between one with "only" a 'Monoid' --- and one with any function. -foldS :: (Foldable f, Monoid m) => ArrowState s x m -> ArrowState s (f x) m -foldS a = ArrowState $ \(s,f) -> foldr a' (s,mempty) f - where a' x (s',m) = second (mappend m) $ runArrowState a (s',x) - --- | Fold a state arrow through something 'Foldable'. Collect the results in a --- 'MonadPlus'. -iterateS :: (Foldable f, MonadPlus m) - => ArrowState s x y - -> ArrowState s (f x) (m y) -iterateS a = ArrowState $ \(s,f) -> foldr a' (s,mzero) f - where a' x (s',m) = second (mplus m.return) $ runArrowState a (s',x) - --- | Fold a state arrow through something 'Foldable'. Collect the results in a --- 'MonadPlus'. -iterateSL :: (Foldable f, MonadPlus m) - => ArrowState s x y - -> ArrowState s (f x) (m y) -iterateSL a = ArrowState $ \(s,f) -> foldl' a' (s,mzero) f - where a' (s',m) x = second (mplus m.return) $ runArrowState a (s',x) - - --- | Fold a fallible state arrow through something 'Foldable'. --- Collect the results in a 'MonadPlus'. --- If the iteration fails, the state will be reset to the initial one. -iterateS' :: (Foldable f, MonadPlus m) - => ArrowState s x (Either e y ) - -> ArrowState s (f x) (Either e (m y)) -iterateS' a = ArrowState $ \(s,f) -> foldr (a' s) (s,Right mzero) f - where a' s x (s',Right m) = case runArrowState a (s',x) of - (s'',Right m') -> (s'',Right $ mplus m $ return m') - (_ ,Left e ) -> (s ,Left e ) - a' _ _ e = e diff --git a/src/Text/Pandoc/Readers/Odt/Arrows/Utils.hs b/src/Text/Pandoc/Readers/Odt/Arrows/Utils.hs deleted file mode 100644 --- a/src/Text/Pandoc/Readers/Odt/Arrows/Utils.hs +++ /dev/null @@ -1,214 +0,0 @@ -{- | - Module : Text.Pandoc.Readers.Odt.Arrows.Utils - Copyright : Copyright (C) 2015 Martin Linnemann - License : GNU GPL, version 2 or above - - Maintainer : Martin Linnemann - Stability : alpha - Portability : portable - -Utility functions for Arrows (Kleisli monads). - -Some general notes on notation: - -* "^" is meant to stand for a pure function that is lifted into an arrow -based on its usage for that purpose in "Control.Arrow". -* "?" is meant to stand for the usage of a 'FallibleArrow' or a pure function -with an equivalent return value. -* "_" stands for the dropping of a value. --} - --- We export everything -module Text.Pandoc.Readers.Odt.Arrows.Utils where - -import Prelude hiding (Applicative(..)) -import Control.Arrow -import Control.Monad (join) - -import Text.Pandoc.Readers.Odt.Generic.Fallible -import Text.Pandoc.Readers.Odt.Generic.Utils - -and2 :: (Arrow a) => a b c -> a b c' -> a b (c,c') -and2 = (&&&) - -and3 :: (Arrow a) - => a b c0->a b c1->a b c2 - -> a b (c0,c1,c2 ) -and4 :: (Arrow a) - => a b c0->a b c1->a b c2->a b c3 - -> a b (c0,c1,c2,c3 ) -and5 :: (Arrow a) - => a b c0->a b c1->a b c2->a b c3->a b c4 - -> a b (c0,c1,c2,c3,c4 ) -and6 :: (Arrow a) - => a b c0->a b c1->a b c2->a b c3->a b c4->a b c5 - -> a b (c0,c1,c2,c3,c4,c5 ) - -and3 a b c = and2 a b &&& c - >>^ \((z,y ) , x) -> (z,y,x ) -and4 a b c d = and3 a b c &&& d - >>^ \((z,y,x ) , w) -> (z,y,x,w ) -and5 a b c d e = and4 a b c d &&& e - >>^ \((z,y,x,w ) , v) -> (z,y,x,w,v ) -and6 a b c d e f = and5 a b c d e &&& f - >>^ \((z,y,x,w,v ) , u) -> (z,y,x,w,v,u ) - -liftA2 :: (Arrow a) => (x -> y -> z) -> a b x -> a b y -> a b z -liftA2 f a b = a &&& b >>^ uncurry f - -liftA3 :: (Arrow a) => (z->y->x -> r) - -> a b z->a b y->a b x - -> a b r -liftA4 :: (Arrow a) => (z->y->x->w -> r) - -> a b z->a b y->a b x->a b w - -> a b r -liftA5 :: (Arrow a) => (z->y->x->w->v -> r) - -> a b z->a b y->a b x->a b w->a b v - -> a b r -liftA6 :: (Arrow a) => (z->y->x->w->v->u -> r) - -> a b z->a b y->a b x->a b w->a b v->a b u - -> a b r - -liftA3 fun a b c = and3 a b c >>^ uncurry3 fun -liftA4 fun a b c d = and4 a b c d >>^ uncurry4 fun -liftA5 fun a b c d e = and5 a b c d e >>^ uncurry5 fun -liftA6 fun a b c d e f = and6 a b c d e f >>^ uncurry6 fun - -liftA :: (Arrow a) => (y -> z) -> a b y -> a b z -liftA fun a = a >>^ fun - - --- | Duplicate a value to subsequently feed it into different arrows. --- Can almost always be replaced with '(&&&)', 'keepingTheValue', --- or even '(|||)'. --- Equivalent to --- > returnA &&& returnA -duplicate :: (Arrow a) => a b (b,b) -duplicate = arr $ join (,) - --- | Applies a function to the uncurried result-pair of an arrow-application. --- (The %-symbol was chosen to evoke an association with pairs.) -(>>%) :: (Arrow a) => a x (b,c) -> (b -> c -> d) -> a x d -a >>% f = a >>^ uncurry f - -infixr 2 >>% - - --- | Duplicate a value and apply an arrow to the second instance. --- Equivalent to --- > \a -> duplicate >>> second a --- or --- > \a -> returnA &&& a -keepingTheValue :: (Arrow a) => a b c -> a b (b,c) -keepingTheValue a = returnA &&& a - -( ^||| ) :: (ArrowChoice a) => (b -> d) -> a c d -> a (Either b c) d -( |||^ ) :: (ArrowChoice a) => a b d -> (c -> d) -> a (Either b c) d -( ^|||^ ) :: (ArrowChoice a) => (b -> d) -> (c -> d) -> a (Either b c) d - -l ^||| r = arr l ||| r -l |||^ r = l ||| arr r -l ^|||^ r = arr l ||| arr r - -infixr 2 ^||| , |||^, ^|||^ - -( ^&&& ) :: (Arrow a) => (b -> c) -> a b c' -> a b (c,c') -( &&&^ ) :: (Arrow a) => a b c -> (b -> c') -> a b (c,c') - -l ^&&& r = arr l &&& r -l &&&^ r = l &&& arr r - -infixr 3 ^&&&, &&&^ - - --- | Converts @Right a@ into @Just a@ and @Left _@ into @Nothing@. -choiceToMaybe :: (ArrowChoice a) => a (Either l r) (Maybe r) -choiceToMaybe = arr eitherToMaybe - --- | Converts @Nothing@ into @Left ()@ and @Just a@ into @Right a@. -maybeToChoice :: (ArrowChoice a) => a (Maybe b) (Fallible b) -maybeToChoice = arr maybeToEither - --- | Lifts a constant value into an arrow -returnV :: (Arrow a) => c -> a x c -returnV = arr.const - --- | Defines Left as failure, Right as success -type FallibleArrow a input failure success = a input (Either failure success) - --- -liftAsSuccess :: (ArrowChoice a) - => a x success - -> FallibleArrow a x failure success -liftAsSuccess a = a >>^ Right - --- | Execute the second arrow if the first succeeds -(>>?) :: (ArrowChoice a) - => FallibleArrow a x failure success - -> FallibleArrow a success failure success' - -> FallibleArrow a x failure success' -a >>? b = a >>> Left ^||| b - --- | Execute the lifted second arrow if the first succeeds -(>>?^) :: (ArrowChoice a) - => FallibleArrow a x failure success - -> (success -> success') - -> FallibleArrow a x failure success' -a >>?^ f = a >>^ Left ^|||^ Right . f - --- | Execute the lifted second arrow if the first succeeds -(>>?^?) :: (ArrowChoice a) - => FallibleArrow a x failure success - -> (success -> Either failure success') - -> FallibleArrow a x failure success' -a >>?^? b = a >>> Left ^|||^ b - --- | Execute the second arrow if the lifted first arrow succeeds -(^>>?) :: (ArrowChoice a) - => (x -> Either failure success) - -> FallibleArrow a success failure success' - -> FallibleArrow a x failure success' -a ^>>? b = a ^>> Left ^||| b - --- | Execute the second, non-fallible arrow if the first arrow succeeds -(>>?!) :: (ArrowChoice a) - => FallibleArrow a x failure success - -> a success success' - -> FallibleArrow a x failure success' -a >>?! f = a >>> right f - ---- -(>>?%) :: (ArrowChoice a) - => FallibleArrow a x f (b,b') - -> (b -> b' -> c) - -> FallibleArrow a x f c -a >>?% f = a >>?^ uncurry f - ---- -(^>>?%) :: (ArrowChoice a) - => (x -> Either f (b,b')) - -> (b -> b' -> c) - -> FallibleArrow a x f c -a ^>>?% f = arr a >>?^ uncurry f - ---- -(>>?%?) :: (ArrowChoice a) - => FallibleArrow a x f (b,b') - -> (b -> b' -> Either f c) - -> FallibleArrow a x f c -a >>?%? f = a >>?^? uncurry f - -infixr 1 >>?, >>?^, >>?^? -infixr 1 ^>>?, >>?! -infixr 1 >>?%, ^>>?%, >>?%? - --- | An arrow version of a short-circuit (<|>) -ifFailedDo :: (ArrowChoice a) - => FallibleArrow a x f y - -> FallibleArrow a x f y - -> FallibleArrow a x f y -ifFailedDo a b = keepingTheValue a >>> repackage ^>> (b |||^ Right) - where repackage (x , Left _) = Left x - repackage (_ , Right y) = Right y - -infixr 1 `ifFailedDo` diff --git a/src/Text/Pandoc/Readers/Odt/Base.hs b/src/Text/Pandoc/Readers/Odt/Base.hs deleted file mode 100644 --- a/src/Text/Pandoc/Readers/Odt/Base.hs +++ /dev/null @@ -1,22 +0,0 @@ -{- | - Module : Text.Pandoc.Readers.Odt.Base - Copyright : Copyright (C) 2015 Martin Linnemann - License : GNU GPL, version 2 or above - - Maintainer : Martin Linnemann - Stability : alpha - Portability : portable - -Core types of the odt reader. --} - -module Text.Pandoc.Readers.Odt.Base where - -import Text.Pandoc.Readers.Odt.Generic.XMLConverter -import Text.Pandoc.Readers.Odt.Namespaces - -type OdtConverterState s = XMLConverterState Namespace s - -type XMLReader s a b = FallibleXMLConverter Namespace s a b - -type XMLReaderSafe s a b = XMLConverter Namespace s a b diff --git a/src/Text/Pandoc/Readers/Odt/ContentReader.hs b/src/Text/Pandoc/Readers/Odt/ContentReader.hs deleted file mode 100644 --- a/src/Text/Pandoc/Readers/Odt/ContentReader.hs +++ /dev/null @@ -1,950 +0,0 @@ -{-# LANGUAGE Arrows #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE OverloadedStrings #-} -{- | - Module : Text.Pandoc.Readers.Odt.ContentReader - Copyright : Copyright (C) 2015 Martin Linnemann - License : GNU GPL, version 2 or above - - Maintainer : Martin Linnemann - Stability : alpha - Portability : portable - -The core of the odt reader that converts odt features into Pandoc types. --} - -module Text.Pandoc.Readers.Odt.ContentReader -( readerState -, read_body -) where - -import Prelude hiding (Applicative(..)) -import Control.Applicative hiding (liftA, liftA2, liftA3) -import Control.Arrow -import Control.Monad ((<=<)) - -import qualified Data.ByteString.Lazy as B -import Data.Foldable (fold) -import Data.List (find) -import qualified Data.Map as M -import qualified Data.Text as T -import Data.Maybe -import Data.Monoid (Alt (..)) - -import Text.TeXMath (readMathML, writeTeX) -import qualified Text.Pandoc.XML.Light as XML - -import Text.Pandoc.Builder hiding (underline) -import Text.Pandoc.MediaBag (MediaBag, insertMedia) -import Text.Pandoc.Shared -import Text.Pandoc.Extensions (extensionsFromList, Extension(..)) -import qualified Text.Pandoc.UTF8 as UTF8 - -import Text.Pandoc.Readers.Odt.Base -import Text.Pandoc.Readers.Odt.Namespaces -import Text.Pandoc.Readers.Odt.StyleReader - -import Text.Pandoc.Readers.Odt.Arrows.State (foldS) -import Text.Pandoc.Readers.Odt.Arrows.Utils -import Text.Pandoc.Readers.Odt.Generic.Fallible -import Text.Pandoc.Readers.Odt.Generic.Utils -import Text.Pandoc.Readers.Odt.Generic.XMLConverter - -import qualified Data.Set as Set - --------------------------------------------------------------------------------- --- State --------------------------------------------------------------------------------- - -type Anchor = T.Text -type Media = [(FilePath, B.ByteString)] - -data ReaderState - = ReaderState { -- | A collection of styles read somewhere else. - -- It is only queried here, not modified. - styleSet :: Styles - -- | A stack of the styles of parent elements. - -- Used to look up inherited style properties. - , styleTrace :: [Style] - -- | Keeps track of the current depth in nested lists - , currentListLevel :: ListLevel - -- | Lists may provide their own style, but they don't have - -- to. If they do not, the style of a parent list may be used - -- or even a default list style from the paragraph style. - -- This value keeps track of the closest list style there - -- currently is. - , currentListStyle :: Maybe ListStyle - -- | A map from internal anchor names to "pretty" ones. - -- The mapping is a purely cosmetic one. - , bookmarkAnchors :: M.Map Anchor Anchor - -- | A map of files / binary data from the archive - , envMedia :: Media - -- | Hold binary resources used in the document - , odtMediaBag :: MediaBag - } - deriving ( Show ) - -readerState :: Styles -> Media -> ReaderState -readerState styles media = ReaderState styles [] 0 Nothing M.empty media mempty - --- -pushStyle' :: Style -> ReaderState -> ReaderState -pushStyle' style state = state { styleTrace = style : styleTrace state } - --- -popStyle' :: ReaderState -> ReaderState -popStyle' state = case styleTrace state of - _:trace -> state { styleTrace = trace } - _ -> state - --- -modifyListLevel :: (ListLevel -> ListLevel) -> (ReaderState -> ReaderState) -modifyListLevel f state = state { currentListLevel = f (currentListLevel state) } - --- -shiftListLevel :: ListLevel -> (ReaderState -> ReaderState) -shiftListLevel diff = modifyListLevel (+ diff) - --- -swapCurrentListStyle :: Maybe ListStyle -> ReaderState - -> (ReaderState, Maybe ListStyle) -swapCurrentListStyle mListStyle state = ( state { currentListStyle = mListStyle } - , currentListStyle state - ) - --- -lookupPrettyAnchor :: Anchor -> ReaderState -> Maybe Anchor -lookupPrettyAnchor anchor ReaderState{..} = M.lookup anchor bookmarkAnchors - --- -putPrettyAnchor :: Anchor -> Anchor -> ReaderState -> ReaderState -putPrettyAnchor ugly pretty state@ReaderState{..} - = state { bookmarkAnchors = M.insert ugly pretty bookmarkAnchors } - --- -usedAnchors :: ReaderState -> [Anchor] -usedAnchors ReaderState{..} = M.elems bookmarkAnchors - -getMediaBag :: ReaderState -> MediaBag -getMediaBag ReaderState{..} = odtMediaBag - -getMediaEnv :: ReaderState -> Media -getMediaEnv ReaderState{..} = envMedia - -insertMedia' :: (FilePath, B.ByteString) -> ReaderState -> ReaderState -insertMedia' (fp, bs) state@ReaderState{..} - = state { odtMediaBag = insertMedia fp Nothing bs odtMediaBag } - --------------------------------------------------------------------------------- --- Reader type and associated tools --------------------------------------------------------------------------------- - -type OdtReader a b = XMLReader ReaderState a b - -type OdtReaderSafe a b = XMLReaderSafe ReaderState a b - --- | Extract something from the styles -fromStyles :: (a -> Styles -> b) -> OdtReaderSafe a b -fromStyles f = keepingTheValue - (getExtraState >>^ styleSet) - >>% f - --- -getStyleByName :: OdtReader StyleName Style -getStyleByName = fromStyles lookupStyle >>^ maybeToChoice - --- -findStyleFamily :: OdtReader Style StyleFamily -findStyleFamily = fromStyles getStyleFamily >>^ maybeToChoice - --- -lookupListStyle :: OdtReader StyleName ListStyle -lookupListStyle = fromStyles lookupListStyleByName >>^ maybeToChoice - --- -switchCurrentListStyle :: OdtReaderSafe (Maybe ListStyle) (Maybe ListStyle) -switchCurrentListStyle = keepingTheValue getExtraState - >>% swapCurrentListStyle - >>> first setExtraState - >>^ snd - --- -pushStyle :: OdtReaderSafe Style Style -pushStyle = keepingTheValue ( - ( keepingTheValue getExtraState - >>% pushStyle' - ) - >>> setExtraState - ) - >>^ fst - --- -popStyle :: OdtReaderSafe x x -popStyle = keepingTheValue ( - getExtraState - >>> arr popStyle' - >>> setExtraState - ) - >>^ fst - --- -getCurrentListLevel :: OdtReaderSafe _x ListLevel -getCurrentListLevel = getExtraState >>^ currentListLevel - --- -updateMediaWithResource :: OdtReaderSafe (FilePath, B.ByteString) (FilePath, B.ByteString) -updateMediaWithResource = keepingTheValue ( - (keepingTheValue getExtraState - >>% insertMedia' - ) - >>> setExtraState - ) - >>^ fst - -lookupResource :: OdtReaderSafe FilePath (FilePath, B.ByteString) -lookupResource = proc target -> do - state <- getExtraState -< () - case lookup target (getMediaEnv state) of - Just bs -> returnV (target, bs) -<< () - Nothing -> returnV ("", B.empty) -< () - -type AnchorPrefix = T.Text - --- | An adaptation of 'uniqueIdent' from "Text.Pandoc.Shared" that generates a --- unique identifier but without assuming that the id should be for a header. --- Second argument is a list of already used identifiers. -uniqueIdentFrom :: AnchorPrefix -> [Anchor] -> Anchor -uniqueIdentFrom baseIdent usedIdents = - let numIdent n = baseIdent <> "-" <> T.pack (show n) - in if baseIdent `elem` usedIdents - then maybe baseIdent numIdent - $ find (\x -> numIdent x `notElem` usedIdents) ([1..60000] :: [Int]) - -- if we have more than 60,000, allow repeats - else baseIdent - --- | First argument: basis for a new "pretty" anchor if none exists yet --- Second argument: a key ("ugly" anchor) --- Returns: saved "pretty" anchor or created new one -getPrettyAnchor :: OdtReaderSafe (AnchorPrefix, Anchor) Anchor -getPrettyAnchor = proc (baseIdent, uglyAnchor) -> do - state <- getExtraState -< () - case lookupPrettyAnchor uglyAnchor state of - Just prettyAnchor -> returnA -< prettyAnchor - Nothing -> do - let newPretty = uniqueIdentFrom baseIdent (usedAnchors state) - modifyExtraState (putPrettyAnchor uglyAnchor newPretty) -<< newPretty - --- | Input: basis for a new header anchor --- Output: saved new anchor -getHeaderAnchor :: OdtReaderSafe Inlines Anchor -getHeaderAnchor = proc title -> do - state <- getExtraState -< () - let exts = extensionsFromList [Ext_auto_identifiers] - let anchor = uniqueIdent exts (toList title) - (Set.fromList $ usedAnchors state) - modifyExtraState (putPrettyAnchor anchor anchor) -<< anchor - - --------------------------------------------------------------------------------- --- Working with styles --------------------------------------------------------------------------------- - --- -readStyleByName :: OdtReader _x (StyleName, Style) -readStyleByName = - findAttr NsText "style-name" >>? keepingTheValue getStyleByName >>^ liftE - where - liftE :: (StyleName, Fallible Style) -> Fallible (StyleName, Style) - liftE (name, Right v) = Right (name, v) - liftE (_, Left v) = Left v - --- -isStyleToTrace :: OdtReader Style Bool -isStyleToTrace = findStyleFamily >>?^ (==FaText) - --- -withNewStyle :: OdtReaderSafe x Inlines -> OdtReaderSafe x Inlines -withNewStyle a = proc x -> do - fStyle <- readStyleByName -< () - case fStyle of - Right (styleName, _) | isCodeStyle styleName -> do - inlines <- a -< x - arr inlineCode -<< inlines - Right (_, style) -> do - mFamily <- arr styleFamily -< style - fTextProps <- arr ( maybeToChoice - . textProperties - . styleProperties - ) -< style - case fTextProps of - Right textProps -> do - state <- getExtraState -< () - let triple = (state, textProps, mFamily) - modifier <- arr modifierFromStyleDiff -< triple - fShouldTrace <- isStyleToTrace -< style - case fShouldTrace of - Right shouldTrace -> - if shouldTrace - then do - pushStyle -< style - inlines <- a -< x - popStyle -< () - arr modifier -<< inlines - else - -- In case anything goes wrong - a -< x - Left _ -> a -< x - Left _ -> a -< x - Left _ -> a -< x - where - isCodeStyle :: StyleName -> Bool - isCodeStyle "Source_Text" = True - isCodeStyle _ = False - - inlineCode :: Inlines -> Inlines - inlineCode = code . T.concat . map stringify . toList - -type PropertyTriple = (ReaderState, TextProperties, Maybe StyleFamily) -type InlineModifier = Inlines -> Inlines - --- | Given data about the local style changes, calculates how to modify --- an instance of 'Inlines' -modifierFromStyleDiff :: PropertyTriple -> InlineModifier -modifierFromStyleDiff propertyTriple = - composition $ - getVPosModifier propertyTriple - : map (first ($ propertyTriple) >>> ifThen_else ignore) - [ (hasEmphChanged , emph ) - , (hasChanged isStrong , strong ) - , (hasChanged strikethrough , strikeout ) - ] - where - ifThen_else else' (if',then') = if if' then then' else else' - - ignore = id :: InlineModifier - - getVPosModifier :: PropertyTriple -> InlineModifier - getVPosModifier triple@(_,textProps,_) = - let getVPos = Just . verticalPosition - in case lookupPreviousValueM getVPos triple of - Nothing -> ignore - Just oldVPos -> getVPosModifier' (oldVPos, verticalPosition textProps) - - getVPosModifier' (oldVPos , newVPos ) | oldVPos == newVPos = ignore - getVPosModifier' ( _ , VPosSub ) = subscript - getVPosModifier' ( _ , VPosSuper ) = superscript - getVPosModifier' ( _ , _ ) = ignore - - hasEmphChanged :: PropertyTriple -> Bool - hasEmphChanged = swing any [ hasChanged isEmphasised - , hasChangedM pitch - , hasChanged underline - ] - - hasChanged property triple@(_, property -> newProperty, _) = - (/= Just newProperty) (lookupPreviousValue property triple) - - hasChangedM property triple@(_, textProps,_) = - fromMaybe False $ (/=) <$> property textProps <*> lookupPreviousValueM property triple - - lookupPreviousValue f = lookupPreviousStyleValue (fmap f . textProperties) - - lookupPreviousValueM f = lookupPreviousStyleValue (f <=< textProperties) - - lookupPreviousStyleValue f (ReaderState{..},_,mFamily) - = findBy f (extendedStylePropertyChain styleTrace styleSet) - <|> (f . lookupDefaultStyle' styleSet =<< mFamily) - - -type ParaModifier = Blocks -> Blocks - -_MINIMUM_INDENTATION_FOR_BLOCKQUOTES_IN_MM_ :: Int -_MINIMUM_INDENTATION_FOR_BLOCKQUOTES_IN_PERCENT_ :: Int -_MINIMUM_INDENTATION_FOR_BLOCKQUOTES_IN_MM_ = 5 -_MINIMUM_INDENTATION_FOR_BLOCKQUOTES_IN_PERCENT_ = 5 - --- | Returns either 'id' or 'blockQuote' depending on the current indentation -getParaModifier :: Style -> ParaModifier -getParaModifier Style{..} | Just props <- paraProperties styleProperties - , isBlockQuote (indentation props) - (margin_left props) - = blockQuote - | otherwise - = id - where - isBlockQuote mIndent mMargin - | LengthValueMM indent <- mIndent - , indent > _MINIMUM_INDENTATION_FOR_BLOCKQUOTES_IN_MM_ - = True - | LengthValueMM margin <- mMargin - , margin > _MINIMUM_INDENTATION_FOR_BLOCKQUOTES_IN_MM_ - = True - | LengthValueMM indent <- mIndent - , LengthValueMM margin <- mMargin - = indent + margin > _MINIMUM_INDENTATION_FOR_BLOCKQUOTES_IN_MM_ - - | PercentValue indent <- mIndent - , indent > _MINIMUM_INDENTATION_FOR_BLOCKQUOTES_IN_PERCENT_ - = True - | PercentValue margin <- mMargin - , margin > _MINIMUM_INDENTATION_FOR_BLOCKQUOTES_IN_PERCENT_ - = True - | PercentValue indent <- mIndent - , PercentValue margin <- mMargin - = indent + margin > _MINIMUM_INDENTATION_FOR_BLOCKQUOTES_IN_PERCENT_ - - | otherwise - = False - --- -constructPara :: OdtReaderSafe Blocks Blocks -> OdtReaderSafe Blocks Blocks -constructPara reader = proc blocks -> do - fStyle <- readStyleByName -< blocks - case fStyle of - Left _ -> reader -< blocks - Right (styleName, _) | isTableCaptionStyle styleName -> do - blocks' <- reader -< blocks - arr tableCaptionP -< blocks' - Right (_, style) -> do - let modifier = getParaModifier style - blocks' <- reader -< blocks - arr modifier -<< blocks' - where - isTableCaptionStyle :: StyleName -> Bool - isTableCaptionStyle "Table" = True - isTableCaptionStyle _ = False - tableCaptionP b = divWith ("", ["caption"], []) b - -type ListConstructor = [Blocks] -> Blocks - -getListConstructor :: ListLevelStyle -> ListConstructor -getListConstructor ListLevelStyle{..} = - case listLevelType of - LltBullet -> bulletList - LltImage -> bulletList - LltNumbered -> let listNumberStyle = toListNumberStyle listItemFormat - listNumberDelim = toListNumberDelim listItemPrefix - listItemSuffix - in orderedListWith (listItemStart, listNumberStyle, listNumberDelim) - where - toListNumberStyle LinfNone = DefaultStyle - toListNumberStyle LinfNumber = Decimal - toListNumberStyle LinfRomanLC = LowerRoman - toListNumberStyle LinfRomanUC = UpperRoman - toListNumberStyle LinfAlphaLC = LowerAlpha - toListNumberStyle LinfAlphaUC = UpperAlpha - toListNumberStyle (LinfString _) = Example - - toListNumberDelim Nothing (Just ".") = Period - toListNumberDelim (Just "" ) (Just ".") = Period - toListNumberDelim Nothing (Just ")") = OneParen - toListNumberDelim (Just "" ) (Just ")") = OneParen - toListNumberDelim (Just "(") (Just ")") = TwoParens - toListNumberDelim _ _ = DefaultDelim - - --- | Determines which style to use for a list, which level to use of that --- style, and which type of list to create as a result of this information. --- Then prepares the state for eventual child lists and constructs the list from --- the results. --- Two main cases are handled: The list may provide its own style or it may --- rely on a parent list's style. I the former case the current style in the --- state must be switched before and after the call to the child converter --- while in the latter the child converter can be called directly. --- If anything goes wrong, a default ordered-list-constructor is used. -constructList :: OdtReaderSafe x [Blocks] -> OdtReaderSafe x Blocks -constructList reader = proc x -> do - modifyExtraState (shiftListLevel 1) -< () - listLevel <- getCurrentListLevel -< () - fStyleName <- findAttr NsText "style-name" -< () - case fStyleName of - Right styleName -> do - fListStyle <- lookupListStyle -< styleName - case fListStyle of - Right listStyle -> do - fLLS <- arr (uncurry getListLevelStyle) -< (listLevel,listStyle) - case fLLS of - Just listLevelStyle -> do - oldListStyle <- switchCurrentListStyle -< Just listStyle - blocks <- constructListWith listLevelStyle -<< x - switchCurrentListStyle -< oldListStyle - returnA -< blocks - Nothing -> constructOrderedList -< x - Left _ -> constructOrderedList -< x - Left _ -> do - state <- getExtraState -< () - mListStyle <- arr currentListStyle -< state - case mListStyle of - Just listStyle -> do - fLLS <- arr (uncurry getListLevelStyle) -< (listLevel,listStyle) - case fLLS of - Just listLevelStyle -> constructListWith listLevelStyle -<< x - Nothing -> constructOrderedList -< x - Nothing -> constructOrderedList -< x - where - constructOrderedList = - reader - >>> modifyExtraState (shiftListLevel (-1)) - >>^ orderedList - constructListWith listLevelStyle = - reader - >>> getListConstructor listLevelStyle - ^>> modifyExtraState (shiftListLevel (-1)) - --------------------------------------------------------------------------------- --- Readers --------------------------------------------------------------------------------- - -type ElementMatcher result = (Namespace, ElementName, OdtReader result result) - -type InlineMatcher = ElementMatcher Inlines - -type BlockMatcher = ElementMatcher Blocks - -newtype FirstMatch a = FirstMatch (Alt Maybe a) - deriving (Foldable, Monoid, Semigroup) - -firstMatch :: a -> FirstMatch a -firstMatch = FirstMatch . Alt . Just - --- -matchingElement :: (Monoid e) - => Namespace -> ElementName - -> OdtReaderSafe e e - -> ElementMatcher e -matchingElement ns name reader = (ns, name, asResultAccumulator reader) - where - asResultAccumulator :: (ArrowChoice a, Monoid m) => a m m -> a m (Fallible m) - asResultAccumulator a = liftAsSuccess $ keepingTheValue a >>% mappend - --- -matchChildContent' :: (Monoid result) - => [ElementMatcher result] - -> OdtReaderSafe _x result -matchChildContent' ls = returnV mempty >>> matchContent' ls - --- -matchChildContent :: (Monoid result) - => [ElementMatcher result] - -> OdtReaderSafe (result, XML.Content) result - -> OdtReaderSafe _x result -matchChildContent ls fallback = returnV mempty >>> matchContent ls fallback - --------------------------------------------- --- Matchers --------------------------------------------- - ----------------------- --- Basics ----------------------- - --- --- | Open Document allows several consecutive spaces if they are marked up -read_plain_text :: OdtReaderSafe (Inlines, XML.Content) Inlines -read_plain_text = fst ^&&& read_plain_text' >>% recover - where - -- fallible version - read_plain_text' :: OdtReader (Inlines, XML.Content) Inlines - read_plain_text' = ( second ( arr extractText ) - >>^ spreadChoice >>?! second text - ) - >>?% mappend - -- - extractText :: XML.Content -> Fallible T.Text - extractText (XML.Text cData) = succeedWith (XML.cdData cData) - extractText _ = failEmpty - -read_text_seq :: InlineMatcher -read_text_seq = matchingElement NsText "sequence" - $ matchChildContent [] read_plain_text - - --- specifically. I honor that, although the current implementation of 'mappend' --- for 'Inlines' in "Text.Pandoc.Builder" will collapse them again. --- The rational is to be prepared for future modifications. -read_spaces :: InlineMatcher -read_spaces = matchingElement NsText "s" ( - readAttrWithDefault NsText "c" 1 -- how many spaces? - >>^ fromList.(`replicate` Space) - ) --- -read_line_break :: InlineMatcher -read_line_break = matchingElement NsText "line-break" - $ returnV linebreak --- -read_tab :: InlineMatcher -read_tab = matchingElement NsText "tab" - $ returnV space --- -read_span :: InlineMatcher -read_span = matchingElement NsText "span" - $ withNewStyle - $ matchChildContent [ read_span - , read_spaces - , read_line_break - , read_tab - , read_link - , read_note - , read_citation - , read_bookmark - , read_bookmark_start - , read_reference_start - , read_bookmark_ref - , read_reference_ref - ] read_plain_text - --- -read_paragraph :: BlockMatcher -read_paragraph = matchingElement NsText "p" - $ constructPara - $ liftA para - $ withNewStyle - $ matchChildContent [ read_span - , read_spaces - , read_line_break - , read_tab - , read_link - , read_note - , read_citation - , read_bookmark - , read_bookmark_start - , read_reference_start - , read_bookmark_ref - , read_reference_ref - , read_frame - , read_text_seq - ] read_plain_text - - ----------------------- --- Headers ----------------------- - --- -read_header :: BlockMatcher -read_header = matchingElement NsText "h" - $ proc blocks -> do - level <- ( readAttrWithDefault NsText "outline-level" 1 - ) -< blocks - children <- ( matchChildContent [ read_span - , read_spaces - , read_line_break - , read_tab - , read_link - , read_note - , read_citation - , read_bookmark - , read_bookmark_start - , read_reference_start - , read_bookmark_ref - , read_reference_ref - , read_frame - ] read_plain_text - ) -< blocks - anchor <- getHeaderAnchor -< children - let idAttr = (anchor, [], []) -- no classes, no key-value pairs - arr (uncurry3 headerWith) -< (idAttr, level, children) - ----------------------- --- Lists ----------------------- - --- -read_list :: BlockMatcher -read_list = matchingElement NsText "list" --- $ withIncreasedListLevel - $ constructList --- $ liftA bulletList - $ matchChildContent' [ read_list_item - , read_list_header - ] --- -read_list_item :: ElementMatcher [Blocks] -read_list_item = read_list_element "list-item" - -read_list_header :: ElementMatcher [Blocks] -read_list_header = read_list_element "list-header" - -read_list_element :: ElementName -> ElementMatcher [Blocks] -read_list_element listElement = matchingElement NsText listElement - $ liftA (compactify.(:[])) - ( matchChildContent' [ read_paragraph - , read_header - , read_list - ] - ) - - ----------------------- --- Links ----------------------- - -read_link :: InlineMatcher -read_link = matchingElement NsText "a" - $ liftA3 link - ( findAttrTextWithDefault NsXLink "href" "" ) - ( findAttrTextWithDefault NsOffice "title" "" ) - ( matchChildContent [ read_span - , read_note - , read_citation - , read_bookmark - , read_bookmark_start - , read_reference_start - , read_bookmark_ref - , read_reference_ref - ] read_plain_text ) - - -------------------------- --- Footnotes -------------------------- - -read_note :: InlineMatcher -read_note = matchingElement NsText "note" - $ liftA note - $ matchChildContent' [ read_note_body ] - -read_note_body :: BlockMatcher -read_note_body = matchingElement NsText "note-body" - $ matchChildContent' [ read_paragraph ] - -------------------------- --- Citations -------------------------- - -read_citation :: InlineMatcher -read_citation = matchingElement NsText "bibliography-mark" - $ liftA2 cite - ( liftA2 makeCitation - ( findAttrTextWithDefault NsText "identifier" "" ) - ( readAttrWithDefault NsText "number" 0 ) - ) - ( matchChildContent [] read_plain_text ) - where - makeCitation :: T.Text -> Int -> [Citation] - makeCitation citeId num = [Citation citeId [] [] NormalCitation num 0] - - ----------------------- --- Tables ----------------------- - --- -read_table :: BlockMatcher -read_table = matchingElement NsTable "table" - $ liftA simpleTable' - $ matchChildContent' [ read_table_row - ] - --- | A simple table without a caption or headers --- | Infers the number of headers from rows -simpleTable' :: [[Blocks]] -> Blocks -simpleTable' [] = simpleTable [] [] -simpleTable' (x : rest) = simpleTable (fmap (const defaults) x) (x : rest) - where defaults = fromList [] - --- -read_table_row :: ElementMatcher [[Blocks]] -read_table_row = matchingElement NsTable "table-row" - $ liftA (:[]) - $ matchChildContent' [ read_table_cell - ] - --- -read_table_cell :: ElementMatcher [Blocks] -read_table_cell = matchingElement NsTable "table-cell" - $ liftA (compactify.(:[])) - $ matchChildContent' [ read_paragraph - ] - ----------------------- --- Frames ----------------------- - --- -read_frame :: InlineMatcher -read_frame = matchingElement NsDraw "frame" - $ filterChildrenName' NsDraw (`elem` ["image", "object", "text-box"]) - >>> foldS read_frame_child - >>> arr fold - -read_frame_child :: OdtReaderSafe XML.Element (FirstMatch Inlines) -read_frame_child = - proc child -> case elName child of - "image" -> read_frame_img -< child - "object" -> read_frame_mathml -< child - "text-box" -> read_frame_text_box -< child - _ -> returnV mempty -< () - -read_frame_img :: OdtReaderSafe XML.Element (FirstMatch Inlines) -read_frame_img = - proc img -> do - src <- executeIn (findAttr' NsXLink "href") -< img - case fold src of - "" -> returnV mempty -< () - src' -> do - let exts = extensionsFromList [Ext_auto_identifiers] - resource <- lookupResource -< T.unpack src' - _ <- updateMediaWithResource -< resource - w <- findAttrText' NsSVG "width" -< () - h <- findAttrText' NsSVG "height" -< () - titleNodes <- matchChildContent' [ read_frame_title ] -< () - alt <- matchChildContent [] read_plain_text -< () - arr (firstMatch . uncurry4 imageWith) -< - (image_attributes w h, src', inlineListToIdentifier exts (toList titleNodes), alt) - -read_frame_title :: InlineMatcher -read_frame_title = matchingElement NsSVG "title" (matchChildContent [] read_plain_text) - -image_attributes :: Maybe T.Text -> Maybe T.Text -> Attr -image_attributes x y = - ( "", [], dim "width" x ++ dim "height" y) - where - dim _ (Just "") = [] - dim name (Just v) = [(name, v)] - dim _ Nothing = [] - -read_frame_mathml :: OdtReaderSafe XML.Element (FirstMatch Inlines) -read_frame_mathml = - proc obj -> do - src <- executeIn (findAttr' NsXLink "href") -< obj - case fold src of - "" -> returnV mempty -< () - src' -> do - let path = T.unpack $ - fromMaybe src' (T.stripPrefix "./" src') <> "/content.xml" - (_, mathml) <- lookupResource -< path - case readMathML (UTF8.toText $ B.toStrict mathml) of - Left _ -> returnV mempty -< () - Right exps -> arr (firstMatch . displayMath . writeTeX) -< exps - -read_frame_text_box :: OdtReaderSafe XML.Element (FirstMatch Inlines) -read_frame_text_box = proc box -> do - paragraphs <- executeIn (matchChildContent' [ read_paragraph ]) -< box - arr read_img_with_caption -< toList paragraphs - -read_img_with_caption :: [Block] -> FirstMatch Inlines -read_img_with_caption (Para [Image attr alt (src,title)] : _) = - firstMatch $ singleton (Image attr alt (src, "fig:" <> title)) -- no text, default caption -read_img_with_caption (Para (Image attr _ (src,title) : txt) : _) = - firstMatch $ singleton (Image attr txt (src, "fig:" <> 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 _ = - mempty - ----------------------- --- Internal links ----------------------- - -_ANCHOR_PREFIX_ :: T.Text -_ANCHOR_PREFIX_ = "anchor" - --- -readAnchorAttr :: OdtReader _x Anchor -readAnchorAttr = findAttrText NsText "name" - --- | Beware: may fail -findAnchorName :: OdtReader AnchorPrefix Anchor -findAnchorName = ( keepingTheValue readAnchorAttr - >>^ spreadChoice - ) >>?! getPrettyAnchor - - --- -maybeAddAnchorFrom :: OdtReader Inlines AnchorPrefix - -> OdtReaderSafe Inlines Inlines -maybeAddAnchorFrom anchorReader = - keepingTheValue (anchorReader >>? findAnchorName >>?^ toAnchorElem) - >>> - proc (inlines, fAnchorElem) -> do - case fAnchorElem of - Right anchorElem -> returnA -< anchorElem - Left _ -> returnA -< inlines - where - toAnchorElem :: Anchor -> Inlines - toAnchorElem anchorID = spanWith (anchorID, [], []) mempty - -- no classes, no key-value pairs - --- -read_bookmark :: InlineMatcher -read_bookmark = matchingElement NsText "bookmark" - $ maybeAddAnchorFrom (liftAsSuccess $ returnV _ANCHOR_PREFIX_) - --- -read_bookmark_start :: InlineMatcher -read_bookmark_start = matchingElement NsText "bookmark-start" - $ maybeAddAnchorFrom (liftAsSuccess $ returnV _ANCHOR_PREFIX_) - --- -read_reference_start :: InlineMatcher -read_reference_start = matchingElement NsText "reference-mark-start" - $ maybeAddAnchorFrom readAnchorAttr - --- | Beware: may fail -findAnchorRef :: OdtReader _x Anchor -findAnchorRef = ( findAttrText NsText "ref-name" - >>?^ (_ANCHOR_PREFIX_,) - ) >>?! getPrettyAnchor - - --- -maybeInAnchorRef :: OdtReaderSafe Inlines Inlines -maybeInAnchorRef = proc inlines -> do - fRef <- findAnchorRef -< () - case fRef of - Right anchor -> - arr (toAnchorRef anchor) -<< inlines - Left _ -> returnA -< inlines - where - toAnchorRef :: Anchor -> Inlines -> Inlines - toAnchorRef anchor = link ("#" <> anchor) "" -- no title - --- -read_bookmark_ref :: InlineMatcher -read_bookmark_ref = matchingElement NsText "bookmark-ref" - $ maybeInAnchorRef - <<< matchChildContent [] read_plain_text - --- -read_reference_ref :: InlineMatcher -read_reference_ref = matchingElement NsText "reference-ref" - $ maybeInAnchorRef - <<< matchChildContent [] read_plain_text - - ----------------------- --- Entry point ----------------------- - -read_text :: OdtReaderSafe _x Pandoc -read_text = matchChildContent' [ read_header - , read_paragraph - , read_list - , read_table - ] - >>^ doc - -post_process :: Pandoc -> Pandoc -post_process (Pandoc m blocks) = - Pandoc m (post_process' blocks) - -post_process' :: [Block] -> [Block] -post_process' (Table attr _ specs th tb tf : Div ("", ["caption"], _) blks : xs) - = Table attr (Caption Nothing blks) specs th tb tf : post_process' xs -post_process' bs = bs - -read_body :: OdtReader _x (Pandoc, MediaBag) -read_body = executeInSub NsOffice "body" - $ executeInSub NsOffice "text" - $ liftAsSuccess - $ proc inlines -> do - txt <- read_text -< inlines - state <- getExtraState -< () - returnA -< (post_process txt, getMediaBag state) diff --git a/src/Text/Pandoc/Readers/Odt/Generic/Fallible.hs b/src/Text/Pandoc/Readers/Odt/Generic/Fallible.hs deleted file mode 100644 --- a/src/Text/Pandoc/Readers/Odt/Generic/Fallible.hs +++ /dev/null @@ -1,104 +0,0 @@ -{- | - Module : Text.Pandoc.Readers.Odt.Generic.Fallible - Copyright : Copyright (C) 2015 Martin Linnemann - License : GNU GPL, version 2 or above - - Maintainer : Martin Linnemann - Stability : alpha - Portability : portable - -Data types and utilities representing failure. Most of it is based on the -"Either" type in its usual configuration (left represents failure). - -In most cases, the failure type is implied or required to be a "Monoid". - -The choice of "Either" instead of a custom type makes it easier to write -compatible instances of "ArrowChoice". --} - --- We export everything -module Text.Pandoc.Readers.Odt.Generic.Fallible where - --- | Default for now. Will probably become a class at some point. -type Failure = () - -type Fallible a = Either Failure a - - --- -maybeToEither :: Maybe a -> Fallible a -maybeToEither (Just a) = Right a -maybeToEither Nothing = Left () - --- -eitherToMaybe :: Either _l a -> Maybe a -eitherToMaybe (Left _) = Nothing -eitherToMaybe (Right a) = Just a - --- | > fromLeft f === either f id -fromLeft :: (a -> b) -> Either a b -> b -fromLeft f (Left a) = f a -fromLeft _ (Right b) = b - --- | > recover a === fromLeft (const a) === either (const a) id -recover :: a -> Either _f a -> a -recover a (Left _) = a -recover _ (Right a) = a - --- | I would love to use 'fail'. Alas, 'Monad.fail'... -failWith :: failure -> Either failure _x -failWith f = Left f - --- -failEmpty :: (Monoid failure) => Either failure _x -failEmpty = failWith mempty - --- -succeedWith :: a -> Either _x a -succeedWith = Right - --- -collapseEither :: Either failure (Either failure x) - -> Either failure x -collapseEither (Left f ) = Left f -collapseEither (Right (Left f)) = Left f -collapseEither (Right (Right x)) = Right x - --- | If either of the values represents a non-error, the result is a --- (possibly combined) non-error. If both values represent an error, an error --- is returned. -chooseMax :: (Monoid a, Monoid b) => Either a b -> Either a b -> Either a b -chooseMax = chooseMaxWith mappend - --- | If either of the values represents a non-error, the result is a --- (possibly combined) non-error. If both values represent an error, an error --- is returned. -chooseMaxWith :: (Monoid a) => (b -> b -> b) - -> Either a b - -> Either a b - -> Either a b -chooseMaxWith (><) (Right a) (Right b) = Right $ a >< b -chooseMaxWith _ (Left a) (Left b) = Left $ a `mappend` b -chooseMaxWith _ (Right a) _ = Right a -chooseMaxWith _ _ (Right b) = Right b - - --- | Class of containers that can escalate contained 'Either's. --- The word "Vector" is meant in the sense of a disease transmitter. -class ChoiceVector v where - spreadChoice :: v (Either f a) -> Either f (v a) - -instance ChoiceVector ((,) a) where - spreadChoice (_, Left f) = Left f - spreadChoice (x, Right y) = Right (x,y) - -- Wasn't there a newtype somewhere with the elements flipped? - --- | Wrapper for a list. While the normal list instance of 'ChoiceVector' --- fails whenever it can, this type will never fail. -newtype SuccessList a = SuccessList { collectNonFailing :: [a] } - deriving ( Eq, Ord, Show ) - -instance ChoiceVector SuccessList where - spreadChoice = Right . SuccessList . foldr unTagRight [] . collectNonFailing - where unTagRight (Right x) = (x:) - unTagRight _ = id diff --git a/src/Text/Pandoc/Readers/Odt/Generic/Namespaces.hs b/src/Text/Pandoc/Readers/Odt/Generic/Namespaces.hs deleted file mode 100644 --- a/src/Text/Pandoc/Readers/Odt/Generic/Namespaces.hs +++ /dev/null @@ -1,45 +0,0 @@ -{- | - Module : Text.Pandoc.Readers.Odt.Generic.Namespaces - Copyright : Copyright (C) 2015 Martin Linnemann - License : GNU GPL, version 2 or above - - Maintainer : Martin Linnemann - Stability : alpha - Portability : portable - -A class containing a set of namespace identifiers. Used to convert between -typesafe Haskell namespace identifiers and unsafe "real world" namespaces. --} - -module Text.Pandoc.Readers.Odt.Generic.Namespaces where - -import qualified Data.Map as M -import Data.Text (Text) - --- -type NameSpaceIRI = Text - --- -type NameSpaceIRIs nsID = M.Map nsID NameSpaceIRI - --- -class (Eq nsID, Ord nsID) => NameSpaceID nsID where - - -- | Given a IRI, possibly update the map and return the id of the namespace. - -- May fail if the namespace is unknown and the application does not - -- allow unknown namespaces. - getNamespaceID :: NameSpaceIRI - -> NameSpaceIRIs nsID - -> Maybe (NameSpaceIRIs nsID, nsID) - -- | Given a namespace id, lookup its IRI. May be overridden for performance. - getIRI :: nsID - -> NameSpaceIRIs nsID - -> Maybe NameSpaceIRI - -- | The root element of an XML document has a namespace, too, and the - -- "XML.Light-parser" is eager to remove the corresponding namespace - -- attribute. - -- As a result, at least this root namespace must be provided. - getInitialIRImap :: NameSpaceIRIs nsID - - getIRI = M.lookup - getInitialIRImap = M.empty diff --git a/src/Text/Pandoc/Readers/Odt/Generic/SetMap.hs b/src/Text/Pandoc/Readers/Odt/Generic/SetMap.hs deleted file mode 100644 --- a/src/Text/Pandoc/Readers/Odt/Generic/SetMap.hs +++ /dev/null @@ -1,30 +0,0 @@ -{- | - Module : Text.Pandoc.Readers.Odt.Generic.SetMap - Copyright : Copyright (C) 2015 Martin Linnemann - License : GNU GPL, version 2 or above - - Maintainer : Martin Linnemann - Stability : alpha - Portability : portable - -A map of values to sets of values. --} - -module Text.Pandoc.Readers.Odt.Generic.SetMap where - -import qualified Data.Map as M -import qualified Data.Set as S - -type SetMap k v = M.Map k (S.Set v) - -empty :: SetMap k v -empty = M.empty - -fromList :: (Ord k, Ord v) => [(k,v)] -> SetMap k v -fromList = foldr (uncurry insert) empty - -insert :: (Ord k, Ord v) => k -> v -> SetMap k v -> SetMap k v -insert key value setMap = M.insertWith S.union key (S.singleton value) setMap - -union3 :: (Ord k) => SetMap k v -> SetMap k v -> SetMap k v -> SetMap k v -union3 sm1 sm2 sm3 = sm1 `M.union` sm2 `M.union` sm3 diff --git a/src/Text/Pandoc/Readers/Odt/Generic/Utils.hs b/src/Text/Pandoc/Readers/Odt/Generic/Utils.hs deleted file mode 100644 --- a/src/Text/Pandoc/Readers/Odt/Generic/Utils.hs +++ /dev/null @@ -1,116 +0,0 @@ -{-# LANGUAGE ViewPatterns #-} -{- | - Module : Text.Pandoc.Reader.Odt.Generic.Utils - Copyright : Copyright (C) 2015 Martin Linnemann - License : GNU GPL, version 2 or above - - Maintainer : Martin Linnemann - Stability : alpha - Portability : portable - -General utility functions for the odt reader. --} - -module Text.Pandoc.Readers.Odt.Generic.Utils -( uncurry3 -, uncurry4 -, uncurry5 -, uncurry6 -, swap -, reverseComposition -, tryToRead -, Lookupable(..) -, readLookupable -, readPercent -, findBy -, swing -, composition -) where - -import Control.Category (Category, (<<<), (>>>)) -import qualified Control.Category as Cat (id) -import Data.Char (isSpace) -import qualified Data.Foldable as F (Foldable, foldr) -import Data.Maybe -import Data.Text (Text) -import qualified Data.Text as T - --- | Equivalent to --- > foldr (.) id --- where '(.)' are 'id' are the ones from "Control.Category" --- and 'foldr' is the one from "Data.Foldable". --- The noun-form was chosen to be consistent with 'sum', 'product' etc --- based on the discussion at --- --- (that I was not part of) -composition :: (Category cat, F.Foldable f) => f (cat a a) -> cat a a -composition = F.foldr (<<<) Cat.id - --- | Equivalent to --- > foldr (flip (.)) id --- where '(.)' are 'id' are the ones from "Control.Category" --- and 'foldr' is the one from "Data.Foldable". --- A reversed version of 'composition'. -reverseComposition :: (Category cat, F.Foldable f) => f (cat a a) -> cat a a -reverseComposition = F.foldr (>>>) Cat.id - --- | This function often makes it possible to switch values with the functions --- that are applied to them. --- --- Examples: --- > swing map :: [a -> b] -> a -> [b] --- > swing any :: [a -> Bool] -> a -> Bool --- > swing foldr :: b -> a -> [a -> b -> b] -> b --- > swing scanr :: c -> a -> [a -> c -> c] -> c --- > swing zipWith :: [a -> b -> c] -> a -> [b] -> [c] --- > swing find :: [a -> Bool] -> a -> Maybe (a -> Bool) --- --- Stolen from -swing :: (((a -> b) -> b) -> c -> d) -> c -> a -> d -swing = flip.(.flip id) --- swing f c a = f ($ a) c - - --- | Alternative to 'read'/'reads'. The former of these throws errors --- (nobody wants that) while the latter returns "to much" for simple purposes. --- This function instead applies 'reads' and returns the first match (if any) --- in a 'Maybe'. -tryToRead :: (Read r) => Text -> Maybe r -tryToRead = (reads . T.unpack) >>> listToMaybe >>> fmap fst - --- | A version of 'reads' that requires a '%' sign after the number -readPercent :: ReadS Int -readPercent s = [ (i,s') | (i , r ) <- reads s - , ("%" , s') <- lex r - ] - --- | Data that can be looked up. --- This is mostly a utility to read data with kind *. -class Lookupable a where - lookupTable :: [(Text, a)] - --- | Very similar to a simple 'lookup' in the 'lookupTable', but with a lexer. -readLookupable :: (Lookupable a) => Text -> Maybe a -readLookupable s = - lookup (T.takeWhile (not . isSpace) $ T.dropWhile isSpace s) lookupTable - -uncurry3 :: (a->b->c -> z) -> (a,b,c ) -> z -uncurry4 :: (a->b->c->d -> z) -> (a,b,c,d ) -> z -uncurry5 :: (a->b->c->d->e -> z) -> (a,b,c,d,e ) -> z -uncurry6 :: (a->b->c->d->e->f -> z) -> (a,b,c,d,e,f ) -> z - -uncurry3 fun (a,b,c ) = fun a b c -uncurry4 fun (a,b,c,d ) = fun a b c d -uncurry5 fun (a,b,c,d,e ) = fun a b c d e -uncurry6 fun (a,b,c,d,e,f ) = fun a b c d e f - -swap :: (a,b) -> (b,a) -swap (a,b) = (b,a) - --- | A version of "Data.List.find" that uses a converter to a Maybe instance. --- The returned value is the first which the converter returns in a 'Just' --- wrapper. -findBy :: (a -> Maybe b) -> [a] -> Maybe b -findBy _ [] = Nothing -findBy f ((f -> Just x):_ ) = Just x -findBy f ( _:xs) = findBy f xs diff --git a/src/Text/Pandoc/Readers/Odt/Generic/XMLConverter.hs b/src/Text/Pandoc/Readers/Odt/Generic/XMLConverter.hs deleted file mode 100644 --- a/src/Text/Pandoc/Readers/Odt/Generic/XMLConverter.hs +++ /dev/null @@ -1,785 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE PatternGuards #-} -{- | - Module : Text.Pandoc.Readers.Odt.Generic.XMLConverter - Copyright : Copyright (C) 2015 Martin Linnemann - License : GNU GPL, version 2 or above - - Maintainer : Martin Linnemann - Stability : alpha - Portability : portable - -A generalized XML parser based on stateful arrows. -It might be sufficient to define this reader as a comonad, but there is -not a lot of use in trying. --} - -module Text.Pandoc.Readers.Odt.Generic.XMLConverter -( ElementName -, XMLConverterState -, XMLConverter -, FallibleXMLConverter -, runConverter' -, getExtraState -, setExtraState -, modifyExtraState -, producingExtraState -, findChild' -, filterChildrenName' -, isSet' -, isSetWithDefault -, elName -, searchAttr -, lookupAttr -, lookupAttr' -, lookupDefaultingAttr -, findAttr' -, findAttrText' -, findAttr -, findAttrText -, findAttrWithDefault -, findAttrTextWithDefault -, readAttr -, readAttr' -, readAttrWithDefault -, getAttr -, executeIn -, executeInSub -, withEveryL -, tryAll -, matchContent' -, matchContent -) where - -import Prelude hiding (Applicative(..)) -import Control.Applicative hiding ( liftA, liftA2 ) -import Control.Monad ( MonadPlus ) -import Control.Arrow - -import Data.Bool ( bool ) -import Data.Either ( rights ) -import qualified Data.Map as M -import Data.Text (Text) -import Data.Default -import Data.Maybe -import Data.List (foldl') - -import qualified Text.Pandoc.XML.Light as XML - -import Text.Pandoc.Readers.Odt.Arrows.State -import Text.Pandoc.Readers.Odt.Arrows.Utils -import Text.Pandoc.Readers.Odt.Generic.Namespaces -import Text.Pandoc.Readers.Odt.Generic.Utils -import Text.Pandoc.Readers.Odt.Generic.Fallible - --------------------------------------------------------------------------------- --- Basis types for readability --------------------------------------------------------------------------------- - --- -type ElementName = Text -type AttributeName = Text -type AttributeValue = Text -type TextAttributeValue = Text - --- -type NameSpacePrefix = Text - --- -type NameSpacePrefixes nsID = M.Map nsID NameSpacePrefix - --------------------------------------------------------------------------------- --- Main converter state --------------------------------------------------------------------------------- - --- GADT so some of the NameSpaceID restrictions can be deduced -data XMLConverterState nsID extraState where - XMLConverterState :: NameSpaceID nsID - => { -- | A stack of parent elements. The top element is the current one. - -- Arguably, a real Zipper would be better. But that is an - -- optimization that can be made at a later time, e.g. when - -- replacing Text.XML.Light. - parentElements :: [XML.Element] - -- | A map from internal namespace IDs to the namespace prefixes - -- used in XML elements - , namespacePrefixes :: NameSpacePrefixes nsID - -- | A map from internal namespace IDs to namespace IRIs - -- (Only necessary for matching namespace IDs and prefixes) - , namespaceIRIs :: NameSpaceIRIs nsID - -- | A place to put "something else". This feature is used heavily - -- to keep the main code cleaner. More specifically, the main reader - -- is divided into different stages. Each stage lifts something up - -- here, which the next stage can then use. This could of course be - -- generalized to a state-tree or used for the namespace IRIs. The - -- border between states and values is an imaginary one, after all. - -- But the separation as it is seems to be enough for now. - , moreState :: extraState - } - -> XMLConverterState nsID extraState - --- -createStartState :: (NameSpaceID nsID) - => XML.Element - -> extraState - -> XMLConverterState nsID extraState -createStartState element extraState = - XMLConverterState - { parentElements = [element] - , namespacePrefixes = M.empty - , namespaceIRIs = getInitialIRImap - , moreState = extraState - } - --- | Functor over extra state -instance Functor (XMLConverterState nsID) where - fmap f ( XMLConverterState parents prefixes iRIs extraState ) - = XMLConverterState parents prefixes iRIs (f extraState) - --- -replaceExtraState :: extraState - -> XMLConverterState nsID _x - -> XMLConverterState nsID extraState -replaceExtraState x s - = fmap (const x) s - --- -currentElement :: XMLConverterState nsID extraState - -> XML.Element -currentElement state = head (parentElements state) - --- | Replace the current position by another, modifying the extra state --- in the process -swapStack' :: XMLConverterState nsID extraState - -> [XML.Element] - -> ( XMLConverterState nsID extraState , [XML.Element] ) -swapStack' state stack - = ( state { parentElements = stack } - , parentElements state - ) - --- -pushElement :: XML.Element - -> XMLConverterState nsID extraState - -> XMLConverterState nsID extraState -pushElement e state = state { parentElements = e:parentElements state } - --- | Pop the top element from the call stack, unless it is the last one. -popElement :: XMLConverterState nsID extraState - -> Maybe (XMLConverterState nsID extraState) -popElement state - | _:es@(_:_) <- parentElements state = Just $ state { parentElements = es } - | otherwise = Nothing - --------------------------------------------------------------------------------- --- Main type --------------------------------------------------------------------------------- - --- It might be a good idea to pack the converters in a GADT --- Downside: data instead of type --- Upside: 'Failure' could be made a parameter as well. - --- -type XMLConverter nsID extraState input output - = ArrowState (XMLConverterState nsID extraState ) input output - -type FallibleXMLConverter nsID extraState input output - = XMLConverter nsID extraState input (Fallible output) - --- -runConverter :: XMLConverter nsID extraState input output - -> XMLConverterState nsID extraState - -> input - -> output -runConverter converter state input = snd $ runArrowState converter (state,input) - -runConverter' :: (NameSpaceID nsID) - => FallibleXMLConverter nsID extraState () success - -> extraState - -> XML.Element - -> Fallible success -runConverter' converter extraState element = runConverter (readNSattributes >>? converter) (createStartState element extraState) () - --- -getCurrentElement :: XMLConverter nsID extraState x XML.Element -getCurrentElement = extractFromState currentElement - --- -getExtraState :: XMLConverter nsID extraState x extraState -getExtraState = extractFromState moreState - --- -setExtraState :: XMLConverter nsID extraState extraState extraState -setExtraState = withState $ \state extra - -> (replaceExtraState extra state , extra) - - --- | Lifts a function to the extra state. -modifyExtraState :: (extraState -> extraState) - -> XMLConverter nsID extraState x x -modifyExtraState = modifyState.fmap - - --- | First sets the extra state to the new value. Then modifies the original --- extra state with a converter that uses the new state. Finally, the --- intermediate state is dropped and the extra state is lifted into the --- state as it was at the beginning of the function. --- As a result, exactly the extra state and nothing else is changed. --- The resulting converter even behaves like an identity converter on the --- value level. --- --- (The -ing form is meant to be mnemonic in a sequence of arrows as in --- convertingExtraState () converter >>> doOtherStuff) --- -convertingExtraState :: extraState' - -> FallibleXMLConverter nsID extraState' extraState extraState - -> FallibleXMLConverter nsID extraState x x -convertingExtraState v a = withSubStateF setVAsExtraState modifyWithA - where - setVAsExtraState = liftAsSuccess $ extractFromState id >>^ replaceExtraState v - modifyWithA = keepingTheValue (moreState ^>> a) - >>^ spreadChoice >>?% flip replaceExtraState - --- | First sets the extra state to the new value. Then produces a new --- extra state with a converter that uses the new state. Finally, the --- intermediate state is dropped and the extra state is lifted into the --- state as it was at the beginning of the function. --- As a result, exactly the extra state and nothing else is changed. --- The resulting converter even behaves like an identity converter on the --- value level. --- --- Equivalent to --- --- > \v x a -> convertingExtraState v (returnV x >>> a) --- --- (The -ing form is meant to be mnemonic in a sequence of arrows as in --- producingExtraState () () producer >>> doOtherStuff) --- -producingExtraState :: extraState' - -> a - -> FallibleXMLConverter nsID extraState' a extraState - -> FallibleXMLConverter nsID extraState x x -producingExtraState v x a = convertingExtraState v (returnV x >>> a) - - --------------------------------------------------------------------------------- --- Work in namespaces --------------------------------------------------------------------------------- - --- | Arrow version of 'getIRI' -lookupNSiri :: (NameSpaceID nsID) - => nsID - -> XMLConverter nsID extraState x (Maybe NameSpaceIRI) -lookupNSiri nsID = extractFromState - $ \state -> getIRI nsID $ namespaceIRIs state - --- -lookupNSprefix :: (NameSpaceID nsID) - => nsID - -> XMLConverter nsID extraState x (Maybe NameSpacePrefix) -lookupNSprefix nsID = extractFromState - $ \state -> M.lookup nsID $ namespacePrefixes state - --- | Extracts namespace attributes from the current element and tries to --- update the current mapping accordingly -readNSattributes :: (NameSpaceID nsID) - => FallibleXMLConverter nsID extraState x () -readNSattributes = fromState $ \state -> maybe (state, failEmpty ) - ( , succeedWith ()) - (extractNSAttrs state ) - where - extractNSAttrs :: (NameSpaceID nsID) - => XMLConverterState nsID extraState - -> Maybe (XMLConverterState nsID extraState) - extractNSAttrs startState - = foldl' (\state d -> state >>= addNS d) - (Just startState) - nsAttribs - where nsAttribs = mapMaybe readNSattr (XML.elAttribs element) - element = currentElement startState - readNSattr (XML.Attr (XML.QName name _ (Just "xmlns")) iri) - = Just (name, iri) - readNSattr _ = Nothing - addNS (prefix, iri) state = fmap updateState - $ getNamespaceID iri - $ namespaceIRIs state - where updateState (iris,nsID) - = state { namespaceIRIs = iris - , namespacePrefixes = M.insert nsID prefix - $ namespacePrefixes state - } - --------------------------------------------------------------------------------- --- Common namespace accessors --------------------------------------------------------------------------------- - --- | Given a namespace id and an element name, creates a 'XML.QName' for --- internal use -qualifyName :: (NameSpaceID nsID) - => nsID -> ElementName - -> XMLConverter nsID extraState x XML.QName -qualifyName nsID name = lookupNSiri nsID - &&& lookupNSprefix nsID - >>% XML.QName name - --- | Checks if a given element matches both a specified namespace id --- and a predicate -elemNameMatches :: (NameSpaceID nsID) - => nsID -> (ElementName -> Bool) - -> XMLConverter nsID extraState XML.Element Bool -elemNameMatches nsID f = keepingTheValue (lookupNSiri nsID) >>% hasMatchingName - where hasMatchingName e iri = let name = XML.elName e - in f (XML.qName name) - && XML.qURI name == iri - --- | Checks if a given element matches both a specified namespace id --- and a specified element name -elemNameIs :: (NameSpaceID nsID) - => nsID -> ElementName - -> XMLConverter nsID extraState XML.Element Bool -elemNameIs nsID name = elemNameMatches nsID (== name) - --------------------------------------------------------------------------------- --- General content --------------------------------------------------------------------------------- - -elName :: XML.Element -> ElementName -elName = XML.qName . XML.elName - --- -elContent :: XMLConverter nsID extraState x [XML.Content] -elContent = getCurrentElement - >>^ XML.elContent - --------------------------------------------------------------------------------- --- Children --------------------------------------------------------------------------------- - --- --- -findChildren :: (NameSpaceID nsID) - => nsID -> ElementName - -> XMLConverter nsID extraState x [XML.Element] -findChildren nsID name = qualifyName nsID name - &&& getCurrentElement - >>% XML.findChildren - --- -findChild' :: (NameSpaceID nsID) - => nsID - -> ElementName - -> XMLConverter nsID extraState x (Maybe XML.Element) -findChild' nsID name = qualifyName nsID name - &&& getCurrentElement - >>% XML.findChild - --- -findChild :: (NameSpaceID nsID) - => nsID -> ElementName - -> FallibleXMLConverter nsID extraState x XML.Element -findChild nsID name = findChild' nsID name - >>> maybeToChoice - -filterChildrenName' :: (NameSpaceID nsID) - => nsID - -> (ElementName -> Bool) - -> XMLConverter nsID extraState x [XML.Element] -filterChildrenName' nsID f = getCurrentElement - >>> arr XML.elChildren - >>> iterateS (keepingTheValue (elemNameMatches nsID f)) - >>> arr (map fst . filter snd) - --------------------------------------------------------------------------------- --- Attributes --------------------------------------------------------------------------------- - --- -isSet' :: (NameSpaceID nsID) - => nsID -> AttributeName - -> XMLConverter nsID extraState x (Maybe Bool) -isSet' nsID attrName = findAttr' nsID attrName - >>^ (>>= stringToBool') - -isSetWithDefault :: (NameSpaceID nsID) - => nsID -> AttributeName - -> Bool - -> XMLConverter nsID extraState x Bool -isSetWithDefault nsID attrName def' - = isSet' nsID attrName - >>^ fromMaybe def' - --- | Lookup value in a dictionary, fail if no attribute found or value --- not in dictionary -searchAttrIn :: (NameSpaceID nsID) - => nsID -> AttributeName - -> [(AttributeValue,a)] - -> FallibleXMLConverter nsID extraState x a -searchAttrIn nsID attrName dict - = findAttr nsID attrName - >>?^? maybeToChoice.(`lookup` dict ) - --- | Lookup value in a dictionary. If attribute or value not found, --- return default value -searchAttr :: (NameSpaceID nsID) - => nsID -> AttributeName - -> a - -> [(AttributeValue,a)] - -> XMLConverter nsID extraState x a -searchAttr nsID attrName defV dict - = searchAttrIn nsID attrName dict - >>> const defV ^|||^ id - --- | Read a 'Lookupable' attribute. Fail if no match. -lookupAttr :: (NameSpaceID nsID, Lookupable a) - => nsID -> AttributeName - -> FallibleXMLConverter nsID extraState x a -lookupAttr nsID attrName = lookupAttr' nsID attrName - >>^ maybeToChoice - - --- | Read a 'Lookupable' attribute. Return the result as a 'Maybe'. -lookupAttr' :: (NameSpaceID nsID, Lookupable a) - => nsID -> AttributeName - -> XMLConverter nsID extraState x (Maybe a) -lookupAttr' nsID attrName - = findAttr' nsID attrName - >>^ (>>= readLookupable) - --- | Read a 'Lookupable' attribute with explicit default -lookupAttrWithDefault :: (NameSpaceID nsID, Lookupable a) - => nsID -> AttributeName - -> a - -> XMLConverter nsID extraState x a -lookupAttrWithDefault nsID attrName deflt - = lookupAttr' nsID attrName - >>^ fromMaybe deflt - --- | Read a 'Lookupable' attribute with implicit default -lookupDefaultingAttr :: (NameSpaceID nsID, Lookupable a, Default a) - => nsID -> AttributeName - -> XMLConverter nsID extraState x a -lookupDefaultingAttr nsID attrName - = lookupAttrWithDefault nsID attrName def - --- | Return value as a (Maybe Text) -findAttr' :: (NameSpaceID nsID) - => nsID -> AttributeName - -> XMLConverter nsID extraState x (Maybe AttributeValue) -findAttr' nsID attrName = qualifyName nsID attrName - &&& getCurrentElement - >>% XML.findAttr - --- | Return value as a (Maybe Text) -findAttrText' :: (NameSpaceID nsID) - => nsID -> AttributeName - -> XMLConverter nsID extraState x (Maybe TextAttributeValue) -findAttrText' nsID attrName - = qualifyName nsID attrName - &&& getCurrentElement - >>% XML.findAttr - --- | Return value as string or fail -findAttr :: (NameSpaceID nsID) - => nsID -> AttributeName - -> FallibleXMLConverter nsID extraState x AttributeValue -findAttr nsID attrName = findAttr' nsID attrName - >>> maybeToChoice - --- | Return value as text or fail -findAttrText :: (NameSpaceID nsID) - => nsID -> AttributeName - -> FallibleXMLConverter nsID extraState x TextAttributeValue -findAttrText nsID attrName - = findAttr' nsID attrName - >>> maybeToChoice - --- | Return value as string or return provided default value -findAttrWithDefault :: (NameSpaceID nsID) - => nsID -> AttributeName - -> AttributeValue - -> XMLConverter nsID extraState x AttributeValue -findAttrWithDefault nsID attrName deflt - = findAttr' nsID attrName - >>^ fromMaybe deflt - --- | Return value as string or return provided default value -findAttrTextWithDefault :: (NameSpaceID nsID) - => nsID -> AttributeName - -> TextAttributeValue - -> XMLConverter nsID extraState x TextAttributeValue -findAttrTextWithDefault nsID attrName deflt - = findAttr' nsID attrName - >>^ fromMaybe deflt - --- | Read and return value or fail -readAttr :: (NameSpaceID nsID, Read attrValue) - => nsID -> AttributeName - -> FallibleXMLConverter nsID extraState x attrValue -readAttr nsID attrName = readAttr' nsID attrName - >>> maybeToChoice - --- | Read and return value or return Nothing -readAttr' :: (NameSpaceID nsID, Read attrValue) - => nsID -> AttributeName - -> XMLConverter nsID extraState x (Maybe attrValue) -readAttr' nsID attrName = findAttr' nsID attrName - >>^ (>>= tryToRead) - --- | Read and return value or return provided default value -readAttrWithDefault :: (NameSpaceID nsID, Read attrValue) - => nsID -> AttributeName - -> attrValue - -> XMLConverter nsID extraState x attrValue -readAttrWithDefault nsID attrName deflt - = findAttr' nsID attrName - >>^ (>>= tryToRead) - >>^ fromMaybe deflt - --- | Read and return value or return default value from 'Default' instance -getAttr :: (NameSpaceID nsID, Read attrValue, Default attrValue) - => nsID -> AttributeName - -> XMLConverter nsID extraState x attrValue -getAttr nsID attrName = readAttrWithDefault nsID attrName def - --------------------------------------------------------------------------------- --- Movements --------------------------------------------------------------------------------- - --- -jumpThere :: XMLConverter nsID extraState XML.Element XML.Element -jumpThere = withState (\state element - -> ( pushElement element state , element ) - ) - --- -swapStack :: XMLConverter nsID extraState [XML.Element] [XML.Element] -swapStack = withState swapStack' - --- -jumpBack :: FallibleXMLConverter nsID extraState _x _x -jumpBack = tryModifyState (popElement >>> maybeToChoice) - --- | Support function for "procedural" converters: jump to an element, execute --- a converter, jump back. --- This version is safer than 'executeThere', because it does not rely on the --- internal stack. As a result, the converter can not move around in arbitrary --- ways. The downside is of course that some of the environment is not --- accessible to the converter. -switchingTheStack :: XMLConverter nsID moreState a b - -> XMLConverter nsID moreState (a, XML.Element) b -switchingTheStack a = second ( (:[]) ^>> swapStack ) - >>> first a - >>> second swapStack - >>^ fst - --- | Support function for "procedural" converters: jumps to an element, executes --- a converter, jumps back. --- Make sure that the converter is well-behaved; that is it should --- return to the exact position it started from in /every possible path/ of --- execution, even if it "fails". If it does not, you may encounter --- strange bugs. If you are not sure about the behaviour or want to use --- shortcuts, you can often use 'switchingTheStack' instead. -executeThere :: FallibleXMLConverter nsID moreState a b - -> FallibleXMLConverter nsID moreState (a, XML.Element) b -executeThere a = second jumpThere - >>> fst - ^>> a - >>> jumpBack -- >>? jumpBack would not ensure the jump. - >>^ collapseEither - - --- | Do something in a specific element, then come back -executeIn :: XMLConverter nsID extraState XML.Element s - -> XMLConverter nsID extraState XML.Element s -executeIn a = duplicate >>> switchingTheStack a - --- | Do something in a sub-element, then come back -executeInSub :: (NameSpaceID nsID) - => nsID -> ElementName - -> FallibleXMLConverter nsID extraState f s - -> FallibleXMLConverter nsID extraState f s -executeInSub nsID name a = keepingTheValue - (findChild nsID name) - >>> ignoringState liftFailure - >>? switchingTheStack a - where liftFailure (_, Left f) = Left f - liftFailure (x, Right e) = Right (x, e) - --------------------------------------------------------------------------------- --- Iterating over children --------------------------------------------------------------------------------- - --- Helper converter to prepare different types of iterations. --- It lifts the children (of a certain type) of the current element --- into the value level and pairs each one with the current input value. -prepareIteration :: (NameSpaceID nsID) - => nsID -> ElementName - -> XMLConverter nsID extraState b [(b, XML.Element)] -prepareIteration nsID name = keepingTheValue - (findChildren nsID name) - >>% distributeValue - --- -withEveryL :: (NameSpaceID nsID) - => nsID -> ElementName - -> FallibleXMLConverter nsID extraState a b - -> FallibleXMLConverter nsID extraState a [b] -withEveryL = withEvery - --- | Applies a converter to every child element of a specific type. --- Collects results in a 'MonadPlus'. --- Fails completely if any conversion fails. -withEvery :: (NameSpaceID nsID, MonadPlus m) - => nsID -> ElementName - -> FallibleXMLConverter nsID extraState a b - -> FallibleXMLConverter nsID extraState a (m b) -withEvery nsID name a = prepareIteration nsID name - >>> iterateS' (switchingTheStack a) - --- | Applies a converter to every child element of a specific type. --- Collects all successful results in a list. -tryAll :: (NameSpaceID nsID) - => nsID -> ElementName - -> FallibleXMLConverter nsID extraState b a - -> XMLConverter nsID extraState b [a] -tryAll nsID name a = prepareIteration nsID name - >>> iterateS (switchingTheStack a) - >>^ rights - --------------------------------------------------------------------------------- --- Matching children --------------------------------------------------------------------------------- - -type IdXMLConverter nsID moreState x - = XMLConverter nsID moreState x x - -type MaybeCConverter nsID moreState x - = Maybe (IdXMLConverter nsID moreState (x, XML.Content)) - --- Chainable converter that helps deciding which converter to actually use. -type ContentMatchConverter nsID extraState x - = IdXMLConverter nsID - extraState - (MaybeCConverter nsID extraState x, XML.Content) - --- Helper function: The @c@ is actually a converter that is to be selected by --- matching XML content to the first two parameters. --- The fold used to match elements however is very simple, so to use it, --- this function wraps the converter in another converter that unifies --- the accumulator. Think of a lot of converters with the resulting type --- chained together. The accumulator not only transports the element --- unchanged to the next matcher, it also does the actual selecting by --- combining the intermediate results with '(<|>)'. -makeMatcherC :: (NameSpaceID nsID) - => nsID -> ElementName - -> FallibleXMLConverter nsID extraState a a - -> ContentMatchConverter nsID extraState a -makeMatcherC nsID name c = ( second ( contentToElem - >>> returnV Nothing - ||| ( elemNameIs nsID name - >>^ bool Nothing (Just cWithJump) - ) - ) - >>% (<|>) - ) &&&^ snd - where cWithJump = ( fst - ^&&& ( second contentToElem - >>> spreadChoice - ^>>? executeThere c - ) - >>% recover) - &&&^ snd - contentToElem :: FallibleXMLConverter nsID extraState XML.Content XML.Element - contentToElem = arr $ \case - XML.Elem e' -> succeedWith e' - _ -> failEmpty - --- Creates and chains a bunch of matchers -prepareMatchersC :: (NameSpaceID nsID) - => [(nsID, ElementName, FallibleXMLConverter nsID extraState x x)] - -> ContentMatchConverter nsID extraState x ---prepareMatchersC = foldSs . (map $ uncurry3 makeMatcherC) -prepareMatchersC = reverseComposition . map (uncurry3 makeMatcherC) - --- | Takes a list of element-data - converter groups and --- * Finds all content of the current element --- * Matches each group to each piece of content in order --- (at most one group per piece of content) --- * Filters non-matched content --- * Chains all found converters in content-order --- * Applies the chain to the input element -matchContent' :: (NameSpaceID nsID) - => [(nsID, ElementName, FallibleXMLConverter nsID extraState a a)] - -> XMLConverter nsID extraState a a -matchContent' lookups = matchContent lookups (arr fst) - --- | Takes a list of element-data - converter groups and --- * Finds all content of the current element --- * Matches each group to each piece of content in order --- (at most one group per piece of content) --- * Adds a default converter for all non-matched content --- * Chains all found converters in content-order --- * Applies the chain to the input element -matchContent :: (NameSpaceID nsID) - => [(nsID, ElementName, FallibleXMLConverter nsID extraState a a)] - -> XMLConverter nsID extraState (a,XML.Content) a - -> XMLConverter nsID extraState a a -matchContent lookups fallback - = let matcher = prepareMatchersC lookups - in keepingTheValue ( - elContent - >>> map (Nothing,) - ^>> iterateSL matcher - >>^ map swallowOrFallback - -- >>> foldSs - >>> reverseComposition - ) - >>> swap - ^>> app - where - -- let the converter swallow the content and drop the content - -- in the return value - swallowOrFallback (Just converter,content) = (,content) ^>> converter >>^ fst - swallowOrFallback (Nothing ,content) = (,content) ^>> fallback - --------------------------------------------------------------------------------- --- Internals --------------------------------------------------------------------------------- - -stringToBool' :: Text -> Maybe Bool -stringToBool' val | val `elem` trueValues = Just True - | val `elem` falseValues = Just False - | otherwise = Nothing - where trueValues = ["true" ,"on" ,"1"] - falseValues = ["false","off","0"] - - -distributeValue :: a -> [b] -> [(a,b)] -distributeValue = map.(,) - --------------------------------------------------------------------------------- - -{- -NOTES -It might be a good idea to refactor the namespace stuff. -E.g.: if a namespace constructor took a string as a parameter, things like -> a ?>/< (NsText,"body") -would be nicer. -Together with a rename and some trickery, something like -> |< NsText "body" >< NsText "p" ?> a | -might even be possible. - -Some day, XML.Light should be replaced by something better. -While doing that, it might be useful to replace String as the type of element -names with something else, too. (Of course with OverloadedStrings). -While doing that, maybe the types can be created in a way that something like -> NsText:"body" -could be used. Overloading (:) does not sounds like the best idea, but if the -element name type was a list, this might be possible. -Of course that would be a bit hackish, so the "right" way would probably be -something like -> InNS NsText "body" -but isn't that a bit boring? ;) --} diff --git a/src/Text/Pandoc/Readers/Odt/Namespaces.hs b/src/Text/Pandoc/Readers/Odt/Namespaces.hs deleted file mode 100644 --- a/src/Text/Pandoc/Readers/Odt/Namespaces.hs +++ /dev/null @@ -1,93 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{- | - Module : Text.Pandoc.Reader.Odt.Namespaces - Copyright : Copyright (C) 2015 Martin Linnemann - License : GNU GPL, version 2 or above - - Maintainer : Martin Linnemann - Stability : alpha - Portability : portable - -Namespaces used in odt files. --} - -module Text.Pandoc.Readers.Odt.Namespaces ( Namespace (..) - ) where - -import qualified Data.Map as M (empty, insert) -import Data.Maybe (fromMaybe, listToMaybe) -import Data.Text (Text) -import qualified Data.Text as T -import Text.Pandoc.Readers.Odt.Generic.Namespaces - - -instance NameSpaceID Namespace where - - getInitialIRImap = nsIDmap - - getNamespaceID "" m = Just(m, NsXML) - getNamespaceID iri m = asPair $ fromMaybe (NsOther iri) (findID iri) - where asPair nsID = Just (M.insert nsID iri m, nsID) - - -findID :: NameSpaceIRI -> Maybe Namespace -findID iri = listToMaybe [nsID | (iri',nsID) <- nsIDs, iri' `T.isPrefixOf` iri] - -nsIDmap :: NameSpaceIRIs Namespace -nsIDmap = foldr (uncurry $ flip M.insert) M.empty nsIDs - -data Namespace = -- Open Document core - NsOffice | NsStyle | NsText | NsTable | NsForm - | NsDraw | Ns3D | NsAnim | NsChart | NsConfig - | NsDB | NsMeta | NsNumber | NsScript | NsManifest - | NsPresentation - -- Metadata - | NsODF - -- Compatible elements - | NsXSL_FO | NsSVG | NsSmil - -- External standards - | NsMathML | NsXForms | NsXLink | NsXHtml | NsGRDDL - | NsDublinCore - -- Metadata manifest - | NsPKG - -- Others - | NsOpenFormula - -- Core XML (basically only for the 'id'-attribute) - | NsXML - -- Fallback - | NsOther Text - deriving ( Eq, Ord, Show ) - --- | Not the actual iri's, but large prefixes of them - this way there are --- less versioning problems and the like. -nsIDs :: [(Text, Namespace)] -nsIDs = [ - ("urn:oasis:names:tc:opendocument:xmlns:animation" , NsAnim ), - ("urn:oasis:names:tc:opendocument:xmlns:chart" , NsChart ), - ("urn:oasis:names:tc:opendocument:xmlns:config" , NsConfig ), - ("urn:oasis:names:tc:opendocument:xmlns:database" , NsDB ), - ("urn:oasis:names:tc:opendocument:xmlns:dr3d" , Ns3D ), - ("urn:oasis:names:tc:opendocument:xmlns:drawing" , NsDraw ), - ("urn:oasis:names:tc:opendocument:xmlns:form" , NsForm ), - ("urn:oasis:names:tc:opendocument:xmlns:manifest" , NsManifest ), - ("urn:oasis:names:tc:opendocument:xmlns:meta" , NsMeta ), - ("urn:oasis:names:tc:opendocument:xmlns:datastyle" , NsNumber ), - ("urn:oasis:names:tc:opendocument:xmlns:of" , NsOpenFormula ), - ("urn:oasis:names:tc:opendocument:xmlns:office:1.0" , NsOffice ), - ("urn:oasis:names:tc:opendocument:xmlns:presentation" , NsPresentation ), - ("urn:oasis:names:tc:opendocument:xmlns:script" , NsScript ), - ("urn:oasis:names:tc:opendocument:xmlns:style" , NsStyle ), - ("urn:oasis:names:tc:opendocument:xmlns:table" , NsTable ), - ("urn:oasis:names:tc:opendocument:xmlns:text" , NsText ), - ("urn:oasis:names:tc:opendocument:xmlns:xsl-fo-compatible", NsXSL_FO ), - ("urn:oasis:names:tc:opendocument:xmlns:smil-compatible" , NsSmil ), - ("urn:oasis:names:tc:opendocument:xmlns:svg-compatible" , NsSVG ), - ("http://docs.oasis-open.org/ns/office/1.2/meta/odf" , NsODF ), - ("http://docs.oasis-open.org/ns/office/1.2/meta/pkg" , NsPKG ), - ("http://purl.org/dc/elements" , NsDublinCore ), - ("http://www.w3.org/2003/g/data-view" , NsGRDDL ), - ("http://www.w3.org/1998/Math/MathML" , NsMathML ), - ("http://www.w3.org/1999/xhtml" , NsXHtml ), - ("http://www.w3.org/2002/xforms" , NsXForms ), - ("http://www.w3.org/1999/xlink" , NsXLink ) - ] diff --git a/src/Text/Pandoc/Readers/Odt/StyleReader.hs b/src/Text/Pandoc/Readers/Odt/StyleReader.hs deleted file mode 100644 --- a/src/Text/Pandoc/Readers/Odt/StyleReader.hs +++ /dev/null @@ -1,640 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE Arrows #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE OverloadedStrings #-} -{- | - Module : Text.Pandoc.Readers.Odt.StyleReader - Copyright : Copyright (C) 2015 Martin Linnemann - License : GNU GPL, version 2 or above - - Maintainer : Martin Linnemann - Stability : alpha - Portability : portable - -Reader for the style information in an odt document. --} - -module Text.Pandoc.Readers.Odt.StyleReader -( Style (..) -, StyleName -, StyleFamily (..) -, Styles (..) -, StyleProperties (..) -, TextProperties (..) -, ParaProperties (..) -, VerticalTextPosition (..) -, ListItemNumberFormat (..) -, ListLevel -, ListStyle (..) -, ListLevelStyle (..) -, ListLevelType (..) -, LengthOrPercent (..) -, lookupStyle -, getListLevelStyle -, getStyleFamily -, lookupDefaultStyle' -, lookupListStyleByName -, extendedStylePropertyChain -, readStylesAt -) where - -import Prelude hiding (Applicative(..)) -import Control.Applicative hiding (liftA, liftA2, liftA3) -import Control.Arrow - -import Data.Default -import qualified Data.Foldable as F -import Data.List (unfoldr, foldl') -import qualified Data.Map as M -import Data.Maybe -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Set as S - -import qualified Text.Pandoc.XML.Light as XML - -import Text.Pandoc.Shared (safeRead, tshow) - -import Text.Pandoc.Readers.Odt.Arrows.Utils - -import Text.Pandoc.Readers.Odt.Generic.Fallible -import qualified Text.Pandoc.Readers.Odt.Generic.SetMap as SM -import Text.Pandoc.Readers.Odt.Generic.Utils -import Text.Pandoc.Readers.Odt.Generic.XMLConverter - -import Text.Pandoc.Readers.Odt.Base -import Text.Pandoc.Readers.Odt.Namespaces - -readStylesAt :: XML.Element -> Fallible Styles -readStylesAt e = runConverter' readAllStyles mempty e - --------------------------------------------------------------------------------- --- Reader for font declarations and font pitches --------------------------------------------------------------------------------- - --- Pandoc has no support for different font pitches. Yet knowing them can be --- very helpful in cases where Pandoc has more semantics than OpenDocument. --- In these cases, the pitch can help deciding as what to define a block of --- text. So let's start with a type for font pitches: - -data FontPitch = PitchVariable | PitchFixed - deriving ( Eq, Show ) - -instance Lookupable FontPitch where - lookupTable = [ ("variable" , PitchVariable) - , ("fixed" , PitchFixed ) - ] - -instance Default FontPitch where - def = PitchVariable - --- The font pitch can be specified in a style directly. Normally, however, --- it is defined in the font. That is also the specs' recommendation. --- --- Thus, we want - -type FontFaceName = Text - -type FontPitches = M.Map FontFaceName FontPitch - --- To get there, the fonts have to be read and the pitches extracted. --- But the resulting map are only needed at one later place, so it should not be --- transported on the value level, especially as we already use a state arrow. --- So instead, the resulting map is lifted into the state of the reader. --- (An alternative might be ImplicitParams, but again, we already have a state.) --- --- So the main style readers will have the types -type StyleReader a b = XMLReader FontPitches a b --- and -type StyleReaderSafe a b = XMLReaderSafe FontPitches a b --- respectively. --- --- But before we can work with these, we need to define the reader that reads --- the fonts: - --- | A reader for font pitches -fontPitchReader :: XMLReader _s _x FontPitches -fontPitchReader = executeInSub NsOffice "font-face-decls" ( - withEveryL NsStyle "font-face" (liftAsSuccess ( - findAttr' NsStyle "name" - &&& - lookupDefaultingAttr NsStyle "font-pitch" - )) - >>?^ ( M.fromList . foldl' accumLegalPitches [] ) - ) `ifFailedDo` returnV (Right M.empty) - where accumLegalPitches ls (Nothing,_) = ls - accumLegalPitches ls (Just n,p) = (n,p):ls - - --- | A wrapper around the font pitch reader that lifts the result into the --- state. -readFontPitches :: StyleReader x x -readFontPitches = producingExtraState () () fontPitchReader - - --- | Looking up a pitch in the state of the arrow. --- --- The function does the following: --- * Look for the font pitch in an attribute. --- * If that fails, look for the font name, look up the font in the state --- and use the pitch from there. --- * Return the result in a Maybe --- -findPitch :: XMLReaderSafe FontPitches _x (Maybe FontPitch) -findPitch = ( lookupAttr NsStyle "font-pitch" - `ifFailedDo` findAttr NsStyle "font-name" - >>? ( keepingTheValue getExtraState - >>% M.lookup - >>^ maybeToChoice - ) - ) - >>> choiceToMaybe - --------------------------------------------------------------------------------- --- Definitions of main data --------------------------------------------------------------------------------- - -type StyleName = Text - --- | There are two types of styles: named styles with a style family and an --- optional style parent, and default styles for each style family, --- defining default style properties -data Styles = Styles - { stylesByName :: M.Map StyleName Style - , listStylesByName :: M.Map StyleName ListStyle - , defaultStyleMap :: M.Map StyleFamily StyleProperties - } - deriving ( Show ) - --- Styles from a monoid under union -instance Semigroup Styles where - (Styles sBn1 dSm1 lsBn1) <> (Styles sBn2 dSm2 lsBn2) - = Styles (M.union sBn1 sBn2) - (M.union dSm1 dSm2) - (M.union lsBn1 lsBn2) -instance Monoid Styles where - mempty = Styles M.empty M.empty M.empty - mappend = (<>) - --- Not all families from the specifications are implemented, only those we need. --- But there are none that are not mentioned here. -data StyleFamily = FaText | FaParagraph --- | FaTable | FaTableCell | FaTableColumn | FaTableRow --- | FaGraphic | FaDrawing | FaChart --- | FaPresentation --- | FaRuby - deriving ( Eq, Ord, Show ) - -instance Lookupable StyleFamily where - lookupTable = [ ( "text" , FaText ) - , ( "paragraph" , FaParagraph ) --- , ( "table" , FaTable ) --- , ( "table-cell" , FaTableCell ) --- , ( "table-column" , FaTableColumn ) --- , ( "table-row" , FaTableRow ) --- , ( "graphic" , FaGraphic ) --- , ( "drawing-page" , FaDrawing ) --- , ( "chart" , FaChart ) --- , ( "presentation" , FaPresentation ) --- , ( "ruby" , FaRuby ) - ] - --- | A named style -data Style = Style { styleFamily :: Maybe StyleFamily - , styleParentName :: Maybe StyleName - , listStyle :: Maybe StyleName - , styleProperties :: StyleProperties - } - deriving ( Eq, Show ) - -data StyleProperties = SProps { textProperties :: Maybe TextProperties - , paraProperties :: Maybe ParaProperties --- , tableColProperties :: Maybe TColProperties --- , tableRowProperties :: Maybe TRowProperties --- , tableCellProperties :: Maybe TCellProperties --- , tableProperties :: Maybe TableProperties --- , graphicProperties :: Maybe GraphProperties - } - deriving ( Eq, Show ) - -instance Default StyleProperties where - def = SProps { textProperties = Just def - , paraProperties = Just def - } - -data TextProperties = PropT { isEmphasised :: Bool - , isStrong :: Bool - , pitch :: Maybe FontPitch - , verticalPosition :: VerticalTextPosition - , underline :: Maybe UnderlineMode - , strikethrough :: Maybe UnderlineMode - } - deriving ( Eq, Show ) - -instance Default TextProperties where - def = PropT { isEmphasised = False - , isStrong = False - , pitch = Just def - , verticalPosition = def - , underline = Nothing - , strikethrough = Nothing - } - -data ParaProperties = PropP { paraNumbering :: ParaNumbering - , indentation :: LengthOrPercent - , margin_left :: LengthOrPercent - } - deriving ( Eq, Show ) - -instance Default ParaProperties where - def = PropP { paraNumbering = NumberingNone - , indentation = def - , margin_left = def - } - ----- --- All the little data types that make up the properties ----- - -data VerticalTextPosition = VPosNormal | VPosSuper | VPosSub - deriving ( Eq, Show ) - -instance Default VerticalTextPosition where - def = VPosNormal - -instance Read VerticalTextPosition where - readsPrec _ s = [ (VPosSub , s') | ("sub" , s') <- lexS ] - ++ [ (VPosSuper , s') | ("super" , s') <- lexS ] - ++ [ (signumToVPos n , s') | ( n , s') <- readPercent s ] - where - lexS = lex s - signumToVPos n | n < 0 = VPosSub - | n > 0 = VPosSuper - | otherwise = VPosNormal - -data UnderlineMode = UnderlineModeNormal | UnderlineModeSkipWhitespace - deriving ( Eq, Show ) - -instance Lookupable UnderlineMode where - lookupTable = [ ( "continuous" , UnderlineModeNormal ) - , ( "skip-white-space" , UnderlineModeSkipWhitespace ) - ] - - -data ParaNumbering = NumberingNone | NumberingKeep | NumberingRestart Int - deriving ( Eq, Show ) - -data LengthOrPercent = LengthValueMM Int | PercentValue Int - deriving ( Eq, Show ) - -instance Default LengthOrPercent where - def = LengthValueMM 0 - -instance Read LengthOrPercent where - readsPrec _ s = - [ (PercentValue percent , s' ) | (percent , s' ) <- readPercent s] - ++ [ (LengthValueMM lengthMM , s'') | (length' , s' ) <- reads s - , (unit , s'') <- reads s' - , let lengthMM = estimateInMillimeter - length' unit - ] - -data XslUnit = XslUnitMM | XslUnitCM - | XslUnitInch - | XslUnitPoints | XslUnitPica - | XslUnitPixel - | XslUnitEM - -instance Show XslUnit where - show XslUnitMM = "mm" - show XslUnitCM = "cm" - show XslUnitInch = "in" - show XslUnitPoints = "pt" - show XslUnitPica = "pc" - show XslUnitPixel = "px" - show XslUnitEM = "em" - -instance Read XslUnit where - readsPrec _ "mm" = [(XslUnitMM , "")] - readsPrec _ "cm" = [(XslUnitCM , "")] - readsPrec _ "in" = [(XslUnitInch , "")] - readsPrec _ "pt" = [(XslUnitPoints , "")] - readsPrec _ "pc" = [(XslUnitPica , "")] - readsPrec _ "px" = [(XslUnitPixel , "")] - readsPrec _ "em" = [(XslUnitEM , "")] - readsPrec _ _ = [] - --- | Rough conversion of measures into millimetres. --- Pixels and em's are actually implementation dependent/relative measures, --- so I could not really easily calculate anything exact here even if I wanted. --- But I do not care about exactness right now, as I only use measures --- to determine if a paragraph is "indented" or not. -estimateInMillimeter :: Int -> XslUnit -> Int -estimateInMillimeter n XslUnitMM = n -estimateInMillimeter n XslUnitCM = n * 10 -estimateInMillimeter n XslUnitInch = n * 25 -- \* 25.4 -estimateInMillimeter n XslUnitPoints = n `div` 3 -- \* 1/72 * 25.4 -estimateInMillimeter n XslUnitPica = n * 4 -- \* 12 * 1/72 * 25.4 -estimateInMillimeter n XslUnitPixel = n `div`3 -- \* 1/72 * 25.4 -estimateInMillimeter n XslUnitEM = n * 7 -- \* 16 * 1/72 * 25.4 - - ----- --- List styles ----- - -type ListLevel = Int - -newtype ListStyle = ListStyle { levelStyles :: M.Map ListLevel ListLevelStyle - } - deriving ( Eq, Show ) - --- -getListLevelStyle :: ListLevel -> ListStyle -> Maybe ListLevelStyle -getListLevelStyle level ListStyle{..} = - let (lower , exactHit , _) = M.splitLookup level levelStyles - in exactHit <|> fmap fst (M.maxView lower) - -- findBy (`M.lookup` levelStyles) [level, (level-1) .. 1] - -- \^ simpler, but in general less efficient - -data ListLevelStyle = ListLevelStyle { listLevelType :: ListLevelType - , listItemPrefix :: Maybe Text - , listItemSuffix :: Maybe Text - , listItemFormat :: ListItemNumberFormat - , listItemStart :: Int - } - deriving ( Eq, Ord ) - -instance Show ListLevelStyle where - show ListLevelStyle{..} = " listItemPrefix) - ++ show listItemFormat - ++ maybeToString (T.unpack <$> listItemSuffix) - ++ ">" - where maybeToString = fromMaybe "" - -data ListLevelType = LltBullet | LltImage | LltNumbered - deriving ( Eq, Ord, Show ) - -data ListItemNumberFormat = LinfNone - | LinfNumber - | LinfRomanLC | LinfRomanUC - | LinfAlphaLC | LinfAlphaUC - | LinfString String - deriving ( Eq, Ord ) - -instance Show ListItemNumberFormat where - show LinfNone = "" - show LinfNumber = "1" - show LinfRomanLC = "i" - show LinfRomanUC = "I" - show LinfAlphaLC = "a" - show LinfAlphaUC = "A" - show (LinfString s) = s - -instance Default ListItemNumberFormat where - def = LinfNone - -instance Read ListItemNumberFormat where - readsPrec _ "" = [(LinfNone , "")] - readsPrec _ "1" = [(LinfNumber , "")] - readsPrec _ "i" = [(LinfRomanLC , "")] - readsPrec _ "I" = [(LinfRomanUC , "")] - readsPrec _ "a" = [(LinfAlphaLC , "")] - readsPrec _ "A" = [(LinfAlphaUC , "")] - readsPrec _ s = [(LinfString s , "")] - --------------------------------------------------------------------------------- --- Readers --- --- ...it seems like a whole lot of this should be automatically derivable --- or at least moveable into a class. Most of this is data concealed in --- code. --------------------------------------------------------------------------------- - --- -readAllStyles :: StyleReader _x Styles -readAllStyles = ( readFontPitches - >>?! ( readAutomaticStyles - &&& readStyles )) - >>?%? chooseMax - -- all top elements are always on the same hierarchy level - --- -readStyles :: StyleReader _x Styles -readStyles = executeInSub NsOffice "styles" $ liftAsSuccess - $ liftA3 Styles - ( tryAll NsStyle "style" readStyle >>^ M.fromList ) - ( tryAll NsText "list-style" readListStyle >>^ M.fromList ) - ( tryAll NsStyle "default-style" readDefaultStyle >>^ M.fromList ) - --- -readAutomaticStyles :: StyleReader _x Styles -readAutomaticStyles = executeInSub NsOffice "automatic-styles" $ liftAsSuccess - $ liftA3 Styles - ( tryAll NsStyle "style" readStyle >>^ M.fromList ) - ( tryAll NsText "list-style" readListStyle >>^ M.fromList ) - ( returnV M.empty ) - --- -readDefaultStyle :: StyleReader _x (StyleFamily, StyleProperties) -readDefaultStyle = lookupAttr NsStyle "family" - >>?! keepingTheValue readStyleProperties - --- -readStyle :: StyleReader _x (StyleName,Style) -readStyle = findAttr NsStyle "name" - >>?! keepingTheValue - ( liftA4 Style - ( lookupAttr' NsStyle "family" ) - ( findAttr' NsStyle "parent-style-name" ) - ( findAttr' NsStyle "list-style-name" ) - readStyleProperties - ) - --- -readStyleProperties :: StyleReaderSafe _x StyleProperties -readStyleProperties = liftA2 SProps - ( readTextProperties >>> choiceToMaybe ) - ( readParaProperties >>> choiceToMaybe ) - --- -readTextProperties :: StyleReader _x TextProperties -readTextProperties = - executeInSub NsStyle "text-properties" $ liftAsSuccess - ( liftA6 PropT - ( searchAttr NsXSL_FO "font-style" False isFontEmphasised ) - ( searchAttr NsXSL_FO "font-weight" False isFontBold ) - findPitch - ( getAttr NsStyle "text-position" ) - readUnderlineMode - readStrikeThroughMode - ) - where isFontEmphasised = [("normal",False),("italic",True),("oblique",True)] - isFontBold = ("normal",False):("bold",True) - :map ((,True) . tshow) ([100,200..900]::[Int]) - -readUnderlineMode :: StyleReaderSafe _x (Maybe UnderlineMode) -readUnderlineMode = readLineMode "text-underline-mode" - "text-underline-style" - -readStrikeThroughMode :: StyleReaderSafe _x (Maybe UnderlineMode) -readStrikeThroughMode = readLineMode "text-line-through-mode" - "text-line-through-style" - -readLineMode :: Text -> Text -> StyleReaderSafe _x (Maybe UnderlineMode) -readLineMode modeAttr styleAttr = proc x -> do - isUL <- searchAttr NsStyle styleAttr False isLinePresent -< x - mode <- lookupAttr' NsStyle modeAttr -< x - if isUL - then case mode of - Just m -> returnA -< Just m - Nothing -> returnA -< Just UnderlineModeNormal - else returnA -< Nothing - where - isLinePresent = ("none",False) : map (,True) - [ "dash" , "dot-dash" , "dot-dot-dash" , "dotted" - , "long-dash" , "solid" , "wave" - ] - --- -readParaProperties :: StyleReader _x ParaProperties -readParaProperties = - executeInSub NsStyle "paragraph-properties" $ liftAsSuccess - ( liftA3 PropP - ( liftA2 readNumbering - ( isSet' NsText "number-lines" ) - ( readAttr' NsText "line-number" ) - ) - ( liftA2 readIndentation - ( isSetWithDefault NsStyle "auto-text-indent" False ) - ( getAttr NsXSL_FO "text-indent" ) - ) - ( getAttr NsXSL_FO "margin-left" ) - ) - where readNumbering (Just True) (Just n) = NumberingRestart n - readNumbering (Just True) _ = NumberingKeep - readNumbering _ _ = NumberingNone - - readIndentation False indent = indent - readIndentation True _ = def - ----- --- List styles ----- - --- -readListStyle :: StyleReader _x (StyleName, ListStyle) -readListStyle = - findAttr NsStyle "name" - >>?! keepingTheValue - ( liftA ListStyle - $ 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 :: Namespace -> ElementName - -> ListLevelType - -> StyleReaderSafe _x (SM.SetMap Int ListLevelStyle) -readListLevelStyles namespace elementName levelType = - tryAll namespace elementName (readListLevelStyle levelType) - >>^ SM.fromList - --- -readListLevelStyle :: ListLevelType -> StyleReader _x (Int, ListLevelStyle) -readListLevelStyle levelType = readAttr NsText "level" - >>?! keepingTheValue - ( liftA5 toListLevelStyle - ( returnV levelType ) - ( findAttr' NsStyle "num-prefix" ) - ( findAttr' NsStyle "num-suffix" ) - ( getAttr NsStyle "num-format" ) - ( findAttrText' NsText "start-value" ) - ) - where - toListLevelStyle _ p s LinfNone b = ListLevelStyle LltBullet p s LinfNone (startValue b) - toListLevelStyle _ p s f@(LinfString _) b = ListLevelStyle LltBullet p s f (startValue b) - toListLevelStyle t p s f b = ListLevelStyle t p s f (startValue b) - startValue mbx = fromMaybe 1 (mbx >>= safeRead) - --- -chooseMostSpecificListLevelStyle :: S.Set ListLevelStyle -> Maybe ListLevelStyle -chooseMostSpecificListLevelStyle ls = F.foldr select Nothing ls - where - select l Nothing = Just l - select ( ListLevelStyle t1 p1 s1 f1 b1 ) - ( Just ( ListLevelStyle t2 p2 s2 f2 _ )) - = Just $ ListLevelStyle (select' t1 t2) (p1 <|> p2) (s1 <|> s2) - (selectLinf f1 f2) b1 - select' LltNumbered _ = LltNumbered - select' _ LltNumbered = LltNumbered - select' _ _ = LltBullet - selectLinf LinfNone f2 = f2 - selectLinf f1 LinfNone = f1 - selectLinf (LinfString _) f2 = f2 - selectLinf f1 (LinfString _) = f1 - selectLinf f1 _ = f1 - - --------------------------------------------------------------------------------- --- Tools to access style data --------------------------------------------------------------------------------- - --- -lookupStyle :: StyleName -> Styles -> Maybe Style -lookupStyle name Styles{..} = M.lookup name stylesByName - --- -lookupDefaultStyle' :: Styles -> StyleFamily -> StyleProperties -lookupDefaultStyle' Styles{..} family = fromMaybe def - (M.lookup family defaultStyleMap) - --- -lookupListStyleByName :: StyleName -> Styles -> Maybe ListStyle -lookupListStyleByName name Styles{..} = M.lookup name listStylesByName - - --- | Returns a chain of parent of the current style. The direct parent will --- be the first element of the list, followed by its parent and so on. --- The current style is not in the list. -parents :: Style -> Styles -> [Style] -parents style styles = unfoldr findNextParent style -- Ha! - where findNextParent Style{..} - = fmap duplicate $ (`lookupStyle` styles) =<< styleParentName - --- | Looks up the style family of the current style. Normally, every style --- should have one. But if not, all parents are searched. -getStyleFamily :: Style -> Styles -> Maybe StyleFamily -getStyleFamily style@Style{..} styles - = styleFamily - <|> 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 --- parent style. This function makes this chain of inheritance --- concrete and easily accessible by encapsulating the necessary lookups. --- The resulting list contains the direct properties of the style as the first --- element, the ones of the direct parent element as the next one, and so on. --- --- Note: There should also be default properties for each style family. These --- are @not@ contained in this list because properties inherited from --- parent elements take precedence over default styles. --- --- This function is primarily meant to be used through convenience wrappers. --- -stylePropertyChain :: Style -> Styles -> [StyleProperties] -stylePropertyChain style styles - = map styleProperties (style : parents 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 diff --git a/src/Text/Pandoc/Readers/Org.hs b/src/Text/Pandoc/Readers/Org.hs --- a/src/Text/Pandoc/Readers/Org.hs +++ b/src/Text/Pandoc/Readers/Org.hs @@ -1,7 +1,6 @@ -{-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Readers.Org - Copyright : Copyright (C) 2014-2022 Albert Krewinkel + Copyright : Copyright (C) 2014-2023 Albert Krewinkel License : GNU GPL, version 2 or above Maintainer : Albert Krewinkel diff --git a/src/Text/Pandoc/Readers/Org/BlockStarts.hs b/src/Text/Pandoc/Readers/Org/BlockStarts.hs --- a/src/Text/Pandoc/Readers/Org/BlockStarts.hs +++ b/src/Text/Pandoc/Readers/Org/BlockStarts.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Readers.Org.BlockStarts - Copyright : Copyright (C) 2014-2022 Albert Krewinkel + Copyright : Copyright (C) 2014-2023 Albert Krewinkel License : GNU GPL, version 2 or above Maintainer : Albert Krewinkel diff --git a/src/Text/Pandoc/Readers/Org/Blocks.hs b/src/Text/Pandoc/Readers/Org/Blocks.hs --- a/src/Text/Pandoc/Readers/Org/Blocks.hs +++ b/src/Text/Pandoc/Readers/Org/Blocks.hs @@ -4,7 +4,7 @@ {-# LANGUAGE RecordWildCards #-} {- | Module : Text.Pandoc.Readers.Org.Blocks - Copyright : Copyright (C) 2014-2022 Albert Krewinkel + Copyright : Copyright (C) 2014-2023 Albert Krewinkel License : GNU GPL, version 2 or above Maintainer : Albert Krewinkel @@ -489,15 +489,10 @@ figKeyVals = blockAttrKeyValues figAttrs attr = (figLabel, mempty, figKeyVals) in if isFigure - then (\c -> - B.simpleFigureWith - attr c imgSrc (unstackFig figName)) <$> figCaption + then (\c -> B.figureWith attr (B.simpleCaption (B.plain c)) + (B.plain $ B.image imgSrc figName mempty)) + <$> figCaption else B.para . B.imageWith attr imgSrc figName <$> figCaption - unstackFig :: Text -> Text - unstackFig figName = - if "fig:" `T.isPrefixOf` figName - then T.drop 4 figName - else figName -- | Succeeds if looking at the end of the current paragraph endOfParagraph :: Monad m => OrgParser m () diff --git a/src/Text/Pandoc/Readers/Org/DocumentTree.hs b/src/Text/Pandoc/Readers/Org/DocumentTree.hs --- a/src/Text/Pandoc/Readers/Org/DocumentTree.hs +++ b/src/Text/Pandoc/Readers/Org/DocumentTree.hs @@ -3,7 +3,7 @@ {-# LANGUAGE TupleSections #-} {- | Module : Text.Pandoc.Readers.Org.DocumentTree - Copyright : Copyright (C) 2014-2022 Albert Krewinkel + Copyright : Copyright (C) 2014-2023 Albert Krewinkel License : GNU GPL, version 2 or above Maintainer : Albert Krewinkel diff --git a/src/Text/Pandoc/Readers/Org/ExportSettings.hs b/src/Text/Pandoc/Readers/Org/ExportSettings.hs --- a/src/Text/Pandoc/Readers/Org/ExportSettings.hs +++ b/src/Text/Pandoc/Readers/Org/ExportSettings.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Readers.Org.ExportSettings - Copyright : © 2016-2022 Albert Krewinkel + Copyright : © 2016-2023 Albert Krewinkel License : GNU GPL, version 2 or above Maintainer : Albert Krewinkel diff --git a/src/Text/Pandoc/Readers/Org/Inlines.hs b/src/Text/Pandoc/Readers/Org/Inlines.hs --- a/src/Text/Pandoc/Readers/Org/Inlines.hs +++ b/src/Text/Pandoc/Readers/Org/Inlines.hs @@ -2,7 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Readers.Org.Inlines - Copyright : Copyright (C) 2014-2022 Albert Krewinkel + Copyright : Copyright (C) 2014-2023 Albert Krewinkel License : GNU GPL, version 2 or above Maintainer : Albert Krewinkel @@ -126,8 +126,12 @@ linebreak = try $ pure B.linebreak <$ string "\\\\" <* skipSpaces <* newline str :: PandocMonad m => OrgParser m (F Inlines) -str = return . B.str <$> many1Char (noneOf $ specialChars ++ "\n\r ") +str = return . B.str <$> + ( many1Char (noneOf $ specialChars ++ "\n\r ") >>= updatePositions' ) <* updateLastStrPos + where + updatePositions' str' = str' <$ + maybe mzero (updatePositions . snd) (T.unsnoc str') -- | An endline character that can be treated as a space, not a structural -- break. This should reflect the values of the Emacs variable @@ -380,8 +384,9 @@ endOfCitation = try $ do many $ satisfy isCiteKeySpecialChar satisfy $ not . isCiteKeyChar - in try $ satisfy isCiteKeyChar `many1TillChar` lookAhead endOfCitation - + in try $ do + optional (char '&') -- this is used in org-ref v3 + satisfy isCiteKeyChar `many1TillChar` lookAhead endOfCitation -- | Supported citation types. Only a small subset of org-ref types is -- supported for now. TODO: rewrite this, use LaTeX reader as template. @@ -679,7 +684,6 @@ emphasisStart :: PandocMonad m => Char -> OrgParser m Char emphasisStart c = try $ do guard =<< afterEmphasisPreChar - guard =<< notAfterString char c lookAhead (noneOf emphasisForbiddenBorderChars) pushToInlineCharStack c @@ -792,8 +796,8 @@ subOrSuperExpr :: PandocMonad m => OrgParser m (F Inlines) subOrSuperExpr = try $ simpleSubOrSuperText <|> - (choice [ charsInBalanced '{' '}' (noneOf "\n\r") - , enclosing ('(', ')') <$> charsInBalanced '(' ')' (noneOf "\n\r") + (choice [ charsInBalanced '{' '}' (T.singleton <$> noneOf "\n\r") + , enclosing ('(', ')') <$> charsInBalanced '(' ')' (T.singleton <$> noneOf "\n\r") ] >>= parseFromString (mconcat <$> many inline)) where enclosing (left, right) s = T.cons left $ T.snoc s right diff --git a/src/Text/Pandoc/Readers/Org/Meta.hs b/src/Text/Pandoc/Readers/Org/Meta.hs --- a/src/Text/Pandoc/Readers/Org/Meta.hs +++ b/src/Text/Pandoc/Readers/Org/Meta.hs @@ -3,7 +3,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Readers.Org.Meta - Copyright : Copyright (C) 2014-2022 Albert Krewinkel + Copyright : Copyright (C) 2014-2023 Albert Krewinkel License : GNU GPL, version 2 or above Maintainer : Albert Krewinkel @@ -27,7 +27,7 @@ import Text.Pandoc.Class.PandocMonad (PandocMonad) import Text.Pandoc.Definition import Text.Pandoc.Shared (blocksToInlines, safeRead) -import Text.Pandoc.Network.HTTP (urlEncode) +import Text.Pandoc.URI (urlEncode) import Control.Monad (mzero, void) import Data.List (intercalate, intersperse) diff --git a/src/Text/Pandoc/Readers/Org/ParserState.hs b/src/Text/Pandoc/Readers/Org/ParserState.hs --- a/src/Text/Pandoc/Readers/Org/ParserState.hs +++ b/src/Text/Pandoc/Readers/Org/ParserState.hs @@ -3,7 +3,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Readers.Org.ParserState - Copyright : Copyright (C) 2014-2022 Albert Krewinkel + Copyright : Copyright (C) 2014-2023 Albert Krewinkel License : GNU GPL, version 2 or above Maintainer : Albert Krewinkel @@ -56,7 +56,7 @@ HasQuoteContext (..), HasReaderOptions (..), ParserContext (..), QuoteContext (..), SourcePos, askF, asksF, returnF, runF, trimInlinesF) -import Text.Pandoc.Readers.LaTeX.Types (Macro) +import Text.Pandoc.TeX (Macro) -- | This is used to delay evaluation until all relevant information has been -- parsed and made available in the parser state. diff --git a/src/Text/Pandoc/Readers/Org/Parsing.hs b/src/Text/Pandoc/Readers/Org/Parsing.hs --- a/src/Text/Pandoc/Readers/Org/Parsing.hs +++ b/src/Text/Pandoc/Readers/Org/Parsing.hs @@ -1,6 +1,6 @@ {- | Module : Text.Pandoc.Readers.Org.Parsing - Copyright : Copyright (C) 2014-2022 Albert Krewinkel + Copyright : Copyright (C) 2014-2023 Albert Krewinkel License : GNU GPL, version 2 or above Maintainer : Albert Krewinkel @@ -114,7 +114,7 @@ import Control.Monad.Reader (ReaderT) -- | The parser used to read org files. -type OrgParser m = ParserT Sources OrgParserState (ReaderT OrgParserLocal m) +type OrgParser m = ParsecT Sources OrgParserState (ReaderT OrgParserLocal m) -- -- Adaptions and specializations of parsing utilities @@ -163,7 +163,7 @@ -- | Parse in different context withContext :: Monad m => ParserContext -- ^ New parser context - -> OrgParser m a -- ^ Parser to run in that context + -> OrgParser m a -- ^ Parsec to run in that context -> OrgParser m a withContext context parser = do oldContext <- orgStateParserContext <$> getState @@ -173,7 +173,7 @@ return result -- --- Parser state functions +-- Parsec state functions -- -- | Get an export setting. diff --git a/src/Text/Pandoc/Readers/Org/Shared.hs b/src/Text/Pandoc/Readers/Org/Shared.hs --- a/src/Text/Pandoc/Readers/Org/Shared.hs +++ b/src/Text/Pandoc/Readers/Org/Shared.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Readers.Org.Shared - Copyright : Copyright (C) 2014-2022 Albert Krewinkel + Copyright : Copyright (C) 2014-2023 Albert Krewinkel License : GNU GPL, version 2 or above Maintainer : Albert Krewinkel @@ -23,7 +23,6 @@ import System.FilePath (isValid, takeExtension) import qualified System.FilePath.Posix as Posix import qualified System.FilePath.Windows as Windows -import Text.Pandoc.Shared (elemText) -- | Check whether the given string looks like the path to of URL of an image. isImageFilename :: Text -> Bool @@ -58,7 +57,7 @@ isUrl :: Text -> Bool isUrl cs = let (scheme, path) = T.break (== ':') cs - in T.all (\c -> isAlphaNum c || c `elemText` ".-") scheme + in T.all (\c -> isAlphaNum c || T.any (== c) ".-") scheme && not (T.null path) -- | Creates an key-value pair marking the original language name specified for diff --git a/src/Text/Pandoc/Readers/RIS.hs b/src/Text/Pandoc/Readers/RIS.hs --- a/src/Text/Pandoc/Readers/RIS.hs +++ b/src/Text/Pandoc/Readers/RIS.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Readers.RIS - Copyright : Copyright (C) 2022 John MacFarlane + Copyright : Copyright (C) 2022-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane @@ -29,7 +29,7 @@ import Text.Pandoc.Builder as B import Text.Pandoc.Class (PandocMonad) import Text.Pandoc.Citeproc.MetaValue (referenceToMetaValue) -import Text.Pandoc.Citeproc.BibTeX (toName) +import Text.Pandoc.Citeproc.Name (toName, NameOpts(..)) import Control.Monad.Except (throwError) import qualified Data.Text as T import Data.Text (Text) @@ -59,7 +59,7 @@ B.doc mempty Left e -> throwError e -type RISParser m = ParserT Sources () m +type RISParser m = ParsecT Sources () m risLine :: PandocMonad m => RISParser m (Text, Text) risLine = do @@ -140,7 +140,9 @@ M.insert (toVariable k) (FancyVal v) (referenceVariables r) } addName k v r = - let new = toName [] . B.toList . B.text $ v + let new = toName NameOpts{ nameOptsPrefixIsNonDroppingParticle = False + , nameOptsUseJuniorComma = False } + . B.toList . B.text $ v f Nothing = Just (NamesVal new) f (Just (NamesVal ns)) = Just (NamesVal (new ++ ns)) f (Just x) = Just x diff --git a/src/Text/Pandoc/Readers/RST.hs b/src/Text/Pandoc/Readers/RST.hs --- a/src/Text/Pandoc/Readers/RST.hs +++ b/src/Text/Pandoc/Readers/RST.hs @@ -4,7 +4,7 @@ {-# LANGUAGE ViewPatterns #-} {- | Module : Text.Pandoc.Readers.RST - Copyright : Copyright (C) 2006-2022 John MacFarlane + Copyright : Copyright (C) 2006-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane @@ -19,7 +19,7 @@ import Control.Monad.Except (throwError) import Control.Monad.Identity (Identity (..)) import Data.Char (isHexDigit, isSpace, toUpper, isAlphaNum) -import Data.List (deleteFirstsBy, elemIndex, nub, sort, transpose) +import Data.List (deleteFirstsBy, elemIndex, nub, partition, sort, transpose) import qualified Data.Map as M import Data.Maybe (fromMaybe, maybeToList, isJust) import Data.Sequence (ViewR (..), viewr) @@ -36,6 +36,7 @@ import Text.Pandoc.Options import Text.Pandoc.Parsing import Text.Pandoc.Shared +import Text.Pandoc.URI import qualified Text.Pandoc.UTF8 as UTF8 import Data.Time.Format import System.FilePath (takeDirectory) @@ -55,7 +56,7 @@ Right result -> return result Left e -> throwError e -type RSTParser m = ParserT Sources ParserState m +type RSTParser m = ParsecT Sources ParserState m -- -- Constants and data structure definitions @@ -355,7 +356,7 @@ -- hrule block -- -hrule :: Monad m => ParserT Sources st m Blocks +hrule :: Monad m => ParsecT Sources st m Blocks hrule = try $ do chr <- oneOf underlineChars count 3 (char chr) @@ -370,7 +371,7 @@ -- read a line indented by a given string indentedLine :: (HasReaderOptions st, Monad m) - => Int -> ParserT Sources st m Text + => Int -> ParsecT Sources st m Text indentedLine indents = try $ do lookAhead spaceChar gobbleAtMostSpaces indents @@ -379,7 +380,7 @@ -- one or more indented lines, possibly separated by blank lines. -- any amount of indentation will work. indentedBlock :: (HasReaderOptions st, Monad m) - => ParserT Sources st m Text + => ParsecT Sources st m Text indentedBlock = try $ do indents <- length <$> lookAhead (many1 spaceChar) lns <- many1 $ try $ do b <- option "" blanklines @@ -388,20 +389,20 @@ optional blanklines return $ T.unlines lns -quotedBlock :: Monad m => ParserT Sources st m Text +quotedBlock :: Monad m => ParsecT Sources st m Text quotedBlock = try $ do quote <- lookAhead $ oneOf "!\"#$%&'()*+,-./:;<=>?@[\\]^_`{|}~" lns <- many1 $ lookAhead (char quote) >> anyLine optional blanklines return $ T.unlines lns -codeBlockStart :: Monad m => ParserT Sources st m Char +codeBlockStart :: Monad m => ParsecT Sources st m Char codeBlockStart = string "::" >> blankline >> blankline -codeBlock :: Monad m => ParserT Sources ParserState m Blocks +codeBlock :: Monad m => ParsecT Sources ParserState m Blocks codeBlock = try $ codeBlockStart >> codeBlockBody -codeBlockBody :: Monad m => ParserT Sources ParserState m Blocks +codeBlockBody :: Monad m => ParsecT Sources ParserState m Blocks codeBlockBody = do lang <- stateRstHighlight <$> getState try $ B.codeBlockWith ("", maybeToList lang, []) . stripTrailingNewlines <$> @@ -417,14 +418,14 @@ return $ B.codeBlockWith ("", ["haskell","literate"], []) $ T.intercalate "\n" lns -latexCodeBlock :: Monad m => ParserT Sources st m [Text] +latexCodeBlock :: Monad m => ParsecT Sources st m [Text] latexCodeBlock = try $ do try (latexBlockLine "\\begin{code}") many1Till anyLine (try $ latexBlockLine "\\end{code}") where latexBlockLine s = skipMany spaceChar >> string s >> blankline -birdCodeBlock :: Monad m => ParserT Sources st m [Text] +birdCodeBlock :: Monad m => ParsecT Sources st m [Text] birdCodeBlock = filterSpace <$> many1 birdTrackLine where filterSpace lns = -- if (as is normal) there is always a space after >, drop it @@ -432,7 +433,7 @@ then map (T.drop 1) lns else lns -birdTrackLine :: Monad m => ParserT Sources st m Text +birdTrackLine :: Monad m => ParsecT Sources st m Text birdTrackLine = char '>' >> anyLine -- @@ -509,7 +510,7 @@ definitionList = B.definitionList <$> many1 definitionListItem -- parses bullet list start and returns its length (inc. following whitespace) -bulletListStart :: Monad m => ParserT Sources st m Int +bulletListStart :: Monad m => ParsecT Sources st m Int bulletListStart = try $ do notFollowedBy' hrule -- because hrules start out just like lists marker <- oneOf bulletListMarkers @@ -729,8 +730,12 @@ "figure" -> do (caption, legend) <- parseFromString' extractCaption body' let src = escapeURI $ trim top - return $ B.simpleFigureWith - (imgAttr "figclass") caption src "" <> legend + let (ident, cls, kvs) = imgAttr "class" + let (figclasskv, kvs') = partition ((== "figclass") . fst) kvs + let figattr = ("", concatMap (T.words . snd) figclasskv, []) + let capt = B.caption Nothing (B.plain caption <> legend) + return $ B.figureWith figattr capt $ + B.plain (B.imageWith (ident, cls, kvs') src "" (B.text src)) "image" -> do let src = escapeURI $ trim top let alt = B.str $ maybe "image" trim $ lookup "alt" fields @@ -871,7 +876,7 @@ let res = parseCSV opts rawcsv' case (<>) <$> header' <*> res of Left e -> - throwError $ PandocParsecError "csv table" e + throwError $ fromParsecError (toSources rawcsv') e Right rawrows -> do let singleParaToPlain bs = case B.toList bs of @@ -1106,7 +1111,7 @@ -- plus isolated (no two adjacent) internal hyphens, underscores, -- periods, colons and plus signs; no whitespace or other characters -- are allowed. -simpleReferenceName :: Monad m => ParserT Sources st m Text +simpleReferenceName :: Monad m => ParsecT Sources st m Text simpleReferenceName = do x <- alphaNum xs <- many $ alphaNum @@ -1125,7 +1130,7 @@ -- return enough blanks to replace key return $ T.replicate (sourceLine endPos - sourceLine startPos) "\n" -targetURI :: Monad m => ParserT Sources st m Text +targetURI :: Monad m => ParsecT Sources st m Text targetURI = do skipSpaces optional $ try $ newline >> notFollowedBy blankline @@ -1253,13 +1258,13 @@ -- - ensure that rightmost column span does not need to reach end -- - require at least 2 columns -dashedLine :: Monad m => Char -> ParserT Sources st m (Int, Int) +dashedLine :: Monad m => Char -> ParsecT Sources st m (Int, Int) dashedLine ch = do dashes <- many1 (char ch) sp <- many (char ' ') return (length dashes, length $ dashes ++ sp) -simpleDashedLines :: Monad m => Char -> ParserT Sources st m [(Int,Int)] +simpleDashedLines :: Monad m => Char -> ParsecT Sources st m [(Int,Int)] simpleDashedLines ch = try $ many1 (dashedLine ch) -- Parse a table row separator @@ -1383,7 +1388,7 @@ -- don't want to treat endline after hyphen or dash as a space return $ B.str result -escapedChar :: Monad m => ParserT Sources st m Inlines +escapedChar :: Monad m => ParsecT Sources st m Inlines escapedChar = do c <- escaped anyChar return $ if c == ' ' || c == '\n' || c == '\r' -- '\ ' is null in RST @@ -1439,6 +1444,7 @@ "superscript" -> return $ B.superscript $ treatAsText contents "sub" -> return $ B.subscript $ treatAsText contents "subscript" -> return $ B.subscript $ treatAsText contents + "mark" -> return $ B.spanWith ("",["mark"],[]) $ treatAsText contents "emphasis" -> return $ B.emph $ treatAsText contents "strong" -> return $ B.strong $ treatAsText contents "rfc-reference" -> return $ rfcLink contents diff --git a/src/Text/Pandoc/Readers/RTF.hs b/src/Text/Pandoc/Readers/RTF.hs --- a/src/Text/Pandoc/Readers/RTF.hs +++ b/src/Text/Pandoc/Readers/RTF.hs @@ -3,7 +3,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Readers.RTF - Copyright : Copyright (C) 2021-2022 John MacFarlane + Copyright : Copyright (C) 2021-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane () @@ -184,7 +184,7 @@ , gInTable = False } -type RTFParser m = ParserT Sources RTFState m +type RTFParser m = ParsecT Sources RTFState m data ListType = Bullet | Ordered ListAttributes deriving (Show, Eq) @@ -251,7 +251,7 @@ hyph <- option False $ True <$ char '-' rest <- many digit if null rest - then return $! Nothing + then return Nothing else do let pstr = T.pack rest case TR.decimal pstr of @@ -259,7 +259,7 @@ return $! Just $! if hyph then (-1) * i else i - _ -> return $! Nothing + _ -> return Nothing hexVal = do char '\'' x <- hexDigit diff --git a/src/Text/Pandoc/Readers/Roff.hs b/src/Text/Pandoc/Readers/Roff.hs --- a/src/Text/Pandoc/Readers/Roff.hs +++ b/src/Text/Pandoc/Readers/Roff.hs @@ -121,16 +121,16 @@ , afterConditional = False } -type RoffLexer m = ParserT Sources RoffState m +type RoffLexer m = ParsecT Sources RoffState m -- -- Lexer: T.Text -> RoffToken -- -eofline :: (Stream s m Char, UpdateSourcePos s Char) => ParserT s u m () +eofline :: (Stream s m Char, UpdateSourcePos s Char) => ParsecT s u m () eofline = void newline <|> eof <|> () <$ lookAhead (string "\\}") -spacetab :: (Stream s m Char, UpdateSourcePos s Char) => ParserT s u m Char +spacetab :: (Stream s m Char, UpdateSourcePos s Char) => ParsecT s u m Char spacetab = char ' ' <|> char '\t' characterCodeMap :: M.Map T.Text Char @@ -503,7 +503,7 @@ expression :: PandocMonad m => RoffLexer m (Maybe Bool) expression = do - raw <- charsInBalanced '(' ')' (satisfy (/= '\n')) + raw <- charsInBalanced '(' ')' (T.singleton <$> (satisfy (/= '\n'))) <|> many1Char nonspaceChar returnValue $ case raw of diff --git a/src/Text/Pandoc/Readers/TWiki.hs b/src/Text/Pandoc/Readers/TWiki.hs --- a/src/Text/Pandoc/Readers/TWiki.hs +++ b/src/Text/Pandoc/Readers/TWiki.hs @@ -26,7 +26,7 @@ import Text.Pandoc.Class.PandocMonad (PandocMonad (..)) import Text.Pandoc.Definition import Text.Pandoc.Options -import Text.Pandoc.Parsing hiding (enclosed, nested) +import Text.Pandoc.Parsing hiding (enclosed) import Text.Pandoc.Readers.HTML (htmlTag, isCommentTag) import Text.Pandoc.Shared (tshow) import Text.Pandoc.XML (fromEntities) @@ -43,7 +43,7 @@ Left e -> throwError e Right d -> return d -type TWParser = ParserT Sources ParserState +type TWParser = ParsecT Sources ParserState -- -- utility functions @@ -52,15 +52,6 @@ tryMsg :: Text -> TWParser m a -> TWParser m a tryMsg msg p = try p T.unpack msg -nested :: PandocMonad m => TWParser m a -> TWParser m a -nested p = do - nestlevel <- stateMaxNestingLevel <$> getState - guard $ nestlevel > 0 - updateState $ \st -> st{ stateMaxNestingLevel = stateMaxNestingLevel st - 1 } - res <- p - updateState $ \st -> st{ stateMaxNestingLevel = nestlevel } - return res - htmlElement :: PandocMonad m => Text -> TWParser m (Attr, Text) htmlElement tag = tryMsg tag $ do (TagOpen _ attr, _) <- htmlTag (~== TagOpen tag []) @@ -85,7 +76,7 @@ parsedContent <- try $ parseContent content return (attr, parsedContent) where - parseContent = parseFromString' $ nested $ manyTill parser endOfContent + parseContent = parseFromString' $ manyTill parser endOfContent endOfContent = try $ skipMany blankline >> skipSpaces >> eof parseCharHtmlContentWithAttrs :: PandocMonad m @@ -402,7 +393,7 @@ nestedInlines end = innerSpace <|> nestedInline where innerSpace = try $ whitespace <* notFollowedBy end - nestedInline = notFollowedBy whitespace >> nested inline + nestedInline = notFollowedBy whitespace >> inline strong :: PandocMonad m => TWParser m B.Inlines strong = try $ B.strong <$> enclosed (char '*') nestedInlines @@ -456,7 +447,7 @@ | otherwise = isAlphaNum c str :: PandocMonad m => TWParser m B.Inlines -str = B.str <$> (many1Char alphaNum <|> countChar 1 characterReference) +str = B.str <$> (many1Char alphaNum <|> characterReference) nop :: PandocMonad m => TWParser m B.Inlines nop = try $ (void exclamation <|> void nopTag) >> followContent diff --git a/src/Text/Pandoc/Readers/Textile.hs b/src/Text/Pandoc/Readers/Textile.hs --- a/src/Text/Pandoc/Readers/Textile.hs +++ b/src/Text/Pandoc/Readers/Textile.hs @@ -3,7 +3,7 @@ {- | Module : Text.Pandoc.Readers.Textile Copyright : Copyright (C) 2010-2012 Paul Rivier - 2010-2022 John MacFarlane + 2010-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : Paul Rivier @@ -54,6 +54,7 @@ import Text.Pandoc.Readers.HTML (htmlTag, isBlockTag, isInlineTag) import Text.Pandoc.Readers.LaTeX (rawLaTeXBlock, rawLaTeXInline) import Text.Pandoc.Shared (trim, tshow) +import Text.Read (readMaybe) -- | Parse a Textile text and return a Pandoc document. readTextile :: (PandocMonad m, ToSources a) @@ -67,7 +68,7 @@ Right result -> return result Left e -> throwError e -type TextileParser = ParserT Sources ParserState +type TextileParser = ParsecT Sources ParserState -- | Generate a Pandoc ADT from a textile document parseTextile :: PandocMonad m => TextileParser m Pandoc @@ -120,7 +121,8 @@ , rawHtmlBlock , rawLaTeXBlock' , table - , maybeExplicitBlock "p" para + , explicitBlock "p" (para <|> pure (B.para mempty)) + , para , mempty <$ blanklines ] @@ -147,7 +149,7 @@ char ' ' let starts = ["p", "table", "bq", "bc", "pre", "h1", "h2", "h3", "h4", "h5", "h6", "pre", "###", "notextile"] - let ender = choice $ map explicitBlockStart starts + let ender = () <$ choice (map explicitBlockStart starts) contents <- if extended then do f <- anyLine @@ -229,30 +231,59 @@ -- | Bullet List Item of given depth, depth being the number of -- leading '*' bulletListItemAtDepth :: PandocMonad m => Int -> TextileParser m Blocks -bulletListItemAtDepth = genericListItemAtDepth '*' +bulletListItemAtDepth depth = try $ do + bulletListStartAtDepth depth + genericListItemContentsAtDepth depth -- | Ordered List of given depth, depth being the number of -- leading '#' +-- The first Ordered List Item may have a start attribute orderedListAtDepth :: PandocMonad m => Int -> TextileParser m Blocks orderedListAtDepth depth = try $ do - items <- many1 (orderedListItemAtDepth depth) - return $ B.orderedList items + (startNum, firstItem) <- firstOrderedListItemAtDepth depth + moreItems <- many (orderedListItemAtDepth depth) + let listItems = firstItem : moreItems + return $ B.orderedListWith (startNum, DefaultStyle, DefaultDelim) listItems +-- | The first Ordered List Item, which could have a start attribute +firstOrderedListItemAtDepth :: PandocMonad m => Int + -> TextileParser m (Int, Blocks) +firstOrderedListItemAtDepth depth = try $ do + startNum <- orderedListStartAtDepth depth + contents <- genericListItemContentsAtDepth depth + return (startNum, contents) + -- | Ordered List Item of given depth, depth being the number of -- leading '#' orderedListItemAtDepth :: PandocMonad m => Int -> TextileParser m Blocks -orderedListItemAtDepth = genericListItemAtDepth '#' +orderedListItemAtDepth depth = try $ do + orderedListStartAtDepth depth + genericListItemContentsAtDepth depth --- | Common implementation of list items -genericListItemAtDepth :: PandocMonad m => Char -> Int -> TextileParser m Blocks -genericListItemAtDepth c depth = try $ do - count depth (char c) >> attributes >> whitespace +-- | Lists always start with a number of leading characters '#' or '*' +-- Ordered list start characters '#' can be followed by the start attribute +-- number, but bullet list characters '*' can not +orderedListStartAtDepth :: PandocMonad m => Int -> TextileParser m Int +orderedListStartAtDepth depth = count depth (char '#') >> + try orderedListStartAttr <* (attributes >> whitespace) + +bulletListStartAtDepth :: PandocMonad m => Int -> TextileParser m () +bulletListStartAtDepth depth = () <$ (count depth (char '*') >> + attributes >> whitespace) + +-- | The leading characters and start attributes differ between ordered and +-- unordered lists, but their contents have the same structure and can +-- share a Parser +genericListItemContentsAtDepth :: PandocMonad m => Int + -> TextileParser m Blocks +genericListItemContentsAtDepth depth = do contents <- mconcat <$> many ((B.plain . mconcat <$> many1 inline) <|> try (newline >> codeBlockHtml)) newline sublist <- option mempty (anyListAtDepth (depth + 1)) return $ contents <> sublist + -- | A definition list is a set of consecutive definition items definitionList :: PandocMonad m => TextileParser m Blocks definitionList = try $ B.definitionList <$> many1 definitionListItem @@ -260,12 +291,17 @@ -- | List start character. listStart :: PandocMonad m => TextileParser m () listStart = genericListStart '*' - <|> () <$ genericListStart '#' + <|> () <$ orderedListStart <|> () <$ definitionListStart genericListStart :: PandocMonad m => Char -> TextileParser m () genericListStart c = () <$ try (many1 (char c) >> whitespace) +orderedListStart :: PandocMonad m => TextileParser m () +orderedListStart = () <$ try (many1 (char '#') >> + try orderedListStartAttr >> + whitespace) + basicDLStart :: PandocMonad m => TextileParser m () basicDLStart = do char '-' @@ -401,25 +437,27 @@ _ <- anyLine return () -explicitBlockStart :: PandocMonad m => Text -> TextileParser m () +explicitBlockStart :: PandocMonad m => Text -> TextileParser m Attr explicitBlockStart name = try $ do string (T.unpack name) - attributes + attr <- attributes char '.' optional whitespace optional endline + return attr -- | Blocks like 'p' and 'table' do not need explicit block tag. -- However, they can be used to set HTML/CSS attributes when needed. -maybeExplicitBlock :: PandocMonad m - => Text -- ^ block tag name - -> TextileParser m Blocks -- ^ implicit block - -> TextileParser m Blocks -maybeExplicitBlock name blk = try $ do - optional $ explicitBlockStart name - blk - - +explicitBlock :: PandocMonad m + => Text -- ^ block tag name + -> TextileParser m Blocks -- ^ implicit block + -> TextileParser m Blocks +explicitBlock name blk = try $ do + attr <- explicitBlockStart name + contents <- blk + return $ if attr == nullAttr + then contents + else B.divWith attr contents ---------- -- Inlines @@ -445,7 +483,7 @@ , link , image , mark - , B.str . T.singleton <$> characterReference + , B.str <$> characterReference , smartPunctuation inline , symbol ] @@ -569,17 +607,21 @@ attr <- attributes name <- trimInlines . mconcat <$> withQuoteContext InDoubleQuote (many1Till inline (char '"')) + url <- linkUrl bracketed + let name' = if B.toList name == [Str "$"] then B.str url else name + return $ if attr == nullAttr + then B.link url "" name' + else B.spanWith attr $ B.link url "" name' + +linkUrl :: PandocMonad m => Bool -> TextileParser m Text +linkUrl bracketed = do char ':' let stop = if bracketed then char ']' else lookAhead $ space <|> eof' <|> - try (oneOf "!.,;:" *> + try (oneOf "!.,;:*" *> (space <|> newline <|> eof')) - url <- T.pack <$> many1Till nonspaceChar stop - let name' = if B.toList name == [Str "$"] then B.str url else name - return $ if attr == nullAttr - then B.link url "" name' - else B.spanWith attr $ B.link url "" name' + T.pack <$> many1Till nonspaceChar stop -- | image embedding image :: PandocMonad m => TextileParser m Inlines @@ -592,7 +634,11 @@ src <- T.pack <$> many1 (noneOf " \t\n\r!(") alt <- fmap T.pack $ option "" $ try $ char '(' *> manyTill anyChar (char ')') char '!' - return $ B.imageWith attr src alt (B.str alt) + let img = B.imageWith attr src alt (B.str alt) + try (do -- image link + url <- linkUrl False + return (B.link url "" img)) + <|> return img escapedInline :: PandocMonad m => TextileParser m Inlines escapedInline = escapedEqs <|> escapedTag @@ -631,6 +677,13 @@ htmlTag (tagOpen (=="tt") null) B.code . T.pack <$> manyTill anyChar' (try $ htmlTag $ tagClose (=="tt")) +orderedListStartAttr :: PandocMonad m => TextileParser m Int +orderedListStartAttr = do + digits <- many digit + case readMaybe digits :: Maybe Int of + Nothing -> return 1 + Just n -> return n + -- | Html / CSS attributes attributes :: PandocMonad m => TextileParser m Attr attributes = foldl' (flip ($)) ("",[],[]) <$> @@ -681,9 +734,9 @@ -- | Parses material surrounded by a parser. surrounded :: (PandocMonad m, Show t) - => ParserT Sources st m t -- ^ surrounding parser - -> ParserT Sources st m a -- ^ content parser (to be used repeatedly) - -> ParserT Sources st m [a] + => ParsecT Sources st m t -- ^ surrounding parser + -> ParsecT Sources st m a -- ^ content parser (to be used repeatedly) + -> ParsecT Sources st m [a] surrounded border = enclosed (border *> notFollowedBy (oneOf " \t\n\r")) (try border) @@ -713,5 +766,5 @@ char ']' return $ sp1 <> result <> sp2 -eof' :: Monad m => ParserT Sources s m Char +eof' :: Monad m => ParsecT Sources s m Char eof' = '\n' <$ eof diff --git a/src/Text/Pandoc/Readers/TikiWiki.hs b/src/Text/Pandoc/Readers/TikiWiki.hs --- a/src/Text/Pandoc/Readers/TikiWiki.hs +++ b/src/Text/Pandoc/Readers/TikiWiki.hs @@ -29,7 +29,7 @@ import Text.Pandoc.Definition import Text.Pandoc.Logging (Verbosity (..)) import Text.Pandoc.Options -import Text.Pandoc.Parsing hiding (enclosed, nested) +import Text.Pandoc.Parsing hiding (enclosed) import Text.Pandoc.Shared (safeRead) import Text.Pandoc.XML (fromEntities) import Text.Printf (printf) @@ -46,7 +46,7 @@ Left e -> throwError e Right d -> return d -type TikiWikiParser = ParserT Sources ParserState +type TikiWikiParser = ParsecT Sources ParserState -- -- utility functions @@ -58,15 +58,6 @@ skip :: TikiWikiParser m a -> TikiWikiParser m () skip parser = Control.Monad.void parser -nested :: PandocMonad m => TikiWikiParser m a -> TikiWikiParser m a -nested p = do - nestlevel <- stateMaxNestingLevel <$> getState - guard $ nestlevel > 0 - updateState $ \st -> st{ stateMaxNestingLevel = stateMaxNestingLevel st - 1 } - res <- p - updateState $ \st -> st{ stateMaxNestingLevel = nestlevel } - return res - -- -- main parser -- @@ -450,7 +441,7 @@ nestedInlines end = innerSpace <|> nestedInline where innerSpace = try $ whitespace <* notFollowedBy end - nestedInline = notFollowedBy whitespace >> nested inline + nestedInline = notFollowedBy whitespace >> inline -- {img attId="39" imalign="right" link="http://info.tikiwiki.org" alt="Panama Hat"} -- @@ -594,7 +585,7 @@ return $ B.str $ T.pack body str :: PandocMonad m => TikiWikiParser m B.Inlines -str = fmap B.str (T.pack <$> many1 alphaNum <|> countChar 1 characterReference) +str = fmap B.str (T.pack <$> many1 alphaNum <|> characterReference) symbol :: PandocMonad m => TikiWikiParser m B.Inlines symbol = fmap B.str (countChar 1 nonspaceChar) diff --git a/src/Text/Pandoc/Readers/Txt2Tags.hs b/src/Text/Pandoc/Readers/Txt2Tags.hs --- a/src/Text/Pandoc/Readers/Txt2Tags.hs +++ b/src/Text/Pandoc/Readers/Txt2Tags.hs @@ -33,9 +33,10 @@ import Text.Pandoc.Definition import Text.Pandoc.Options import Text.Pandoc.Parsing hiding (space, spaces, uri) -import Text.Pandoc.Shared (compactify, compactifyDL, escapeURI) +import Text.Pandoc.Shared (compactify, compactifyDL) +import Text.Pandoc.URI (escapeURI) -type T2T = ParserT Sources ParserState (Reader T2TMeta) +type T2T = ParsecT Sources ParserState (Reader T2TMeta) -- | An object for the T2T macros meta information -- the contents of each field is simply substituted verbatim into the file @@ -402,7 +403,7 @@ target <- getTarget inlineMarkup (T.singleton <$> anyChar) (B.rawInline target) '\'' id --- Parser for markup indicated by a double character. +-- Parsec for markup indicated by a double character. -- Inline markup is greedy and glued -- Greedy meaning ***a*** = Bold [Str "*a*"] -- Glued meaning that markup must be tight to content diff --git a/src/Text/Pandoc/Readers/Vimwiki.hs b/src/Text/Pandoc/Readers/Vimwiki.hs --- a/src/Text/Pandoc/Readers/Vimwiki.hs +++ b/src/Text/Pandoc/Readers/Vimwiki.hs @@ -70,19 +70,19 @@ ListNumberStyle (..), Pandoc (..), nullMeta) import Text.Pandoc.Options (ReaderOptions) -import Text.Pandoc.Parsing (ParserState, ParserT, blanklines, emailAddress, +import Text.Pandoc.Parsing (ParserState, ParsecT, blanklines, emailAddress, many1Till, orderedListMarker, readWithM, registerHeader, spaceChar, stateMeta, stateOptions, uri, manyTillChar, manyChar, textStr, many1Char, countChar, many1TillChar, alphaNum, anyChar, char, newline, noneOf, oneOf, - space, spaces, string) + space, spaces, string, choice, eof, lookAhead, + many1, many, manyTill, notFollowedBy, + skipMany1, try, option, + updateState, getState, (<|>)) import Text.Pandoc.Sources (ToSources(..), Sources) -import Text.Pandoc.Shared (splitTextBy, stringify, stripFirstAndLast, - isURI, tshow) -import Text.Parsec.Combinator (between, choice, eof, lookAhead, many1, - manyTill, notFollowedBy, option, skipMany1) -import Text.Parsec.Prim (getState, many, try, updateState, (<|>)) +import Text.Pandoc.Shared (splitTextBy, stringify, stripFirstAndLast, tshow) +import Text.Pandoc.URI (isURI) readVimwiki :: (PandocMonad m, ToSources a) => ReaderOptions @@ -95,7 +95,7 @@ Left e -> throwError e Right result -> return result -type VwParser = ParserT Sources ParserState +type VwParser = ParsecT Sources ParserState -- constants @@ -345,8 +345,9 @@ listTodoMarker :: PandocMonad m => VwParser m Inlines listTodoMarker = try $ do - x <- between (many spaceChar >> char '[') (char ']' >> spaceChar) - (oneOf " .oOX") + x <- (many spaceChar >> char '[') + *> oneOf " .oOX" + <* (char ']' >> spaceChar) return $ makeListMarkerSpan x makeListMarkerSpan :: Char -> Inlines @@ -506,7 +507,7 @@ strong :: PandocMonad m => VwParser m Inlines strong = try $ do - s <- lookAhead $ between (char '*') (char '*') (many1 $ noneOf "*") + s <- lookAhead $ char '*' *> many1 (noneOf "*") <* char '*' guard $ (head s `notElem` spaceChars) && (last s `notElem` spaceChars) char '*' @@ -520,7 +521,7 @@ emph :: PandocMonad m => VwParser m Inlines emph = try $ do - s <- lookAhead $ between (char '_') (char '_') (many1 $ noneOf "_") + s <- lookAhead $ char '_' *> many1 (noneOf "_") <* char '_' guard $ (head s `notElem` spaceChars) && (last s `notElem` spaceChars) char '_' diff --git a/src/Text/Pandoc/RoffChar.hs b/src/Text/Pandoc/RoffChar.hs --- a/src/Text/Pandoc/RoffChar.hs +++ b/src/Text/Pandoc/RoffChar.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.RoffChar - Copyright : Copyright (C) 2007-2022 John MacFarlane + Copyright : Copyright (C) 2007-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane diff --git a/src/Text/Pandoc/Scripting.hs b/src/Text/Pandoc/Scripting.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/Scripting.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ImpredicativeTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{- | +Module : Text.Pandoc.Scripting +Copyright : © 2022-2023 Albert Krewinkel +License : GPL-2.0-or-later +Maintainer : Albert Krewinkel + +Central data structure for scripting engines. +-} +module Text.Pandoc.Scripting + ( ScriptingEngine (..) + , CustomComponents(..) + , noEngine + ) +where + +import Control.Monad.Except (throwError) +import Control.Monad.IO.Class (MonadIO) +import Data.Text (Text) +import Text.Pandoc.Class.PandocMonad (PandocMonad) +import Text.Pandoc.Definition (Pandoc) +import Text.Pandoc.Error (PandocError (PandocNoScriptingEngine)) +import Text.Pandoc.Filter.Environment (Environment) +import Text.Pandoc.Format (ExtensionsConfig) +import Text.Pandoc.Readers (Reader) +import Text.Pandoc.Writers (Writer) + +-- | A component of a custom reader/writer: a custom reader, +-- a custom writer, a template for a custom writer, or a specification +-- of the extensions used by a script and their default values. +-- Note that a single script can contain all of these. +data CustomComponents m = + CustomComponents + { customReader :: Maybe (Reader m) + , customWriter :: Maybe (Writer m) + , customTemplate :: Maybe Text + , customExtensions :: Maybe ExtensionsConfig + } + +-- | Structure to define a scripting engine. +data ScriptingEngine = ScriptingEngine + { engineName :: Text -- ^ Name of the engine. + + , engineApplyFilter :: forall m. (PandocMonad m, MonadIO m) + => Environment -> [String] -> FilePath + -> Pandoc -> m Pandoc + -- ^ Use the scripting engine to run a filter. + + , engineLoadCustom :: forall m. (PandocMonad m, MonadIO m) + => FilePath -> m (CustomComponents m) + -- ^ Function to load a custom reader/writer from a script. + } + +noEngine :: ScriptingEngine +noEngine = ScriptingEngine + { engineName = "none" + , engineApplyFilter = \_env _args _fp _doc -> + throwError PandocNoScriptingEngine + , engineLoadCustom = \_fp -> + throwError PandocNoScriptingEngine + } diff --git a/src/Text/Pandoc/SelfContained.hs b/src/Text/Pandoc/SelfContained.hs --- a/src/Text/Pandoc/SelfContained.hs +++ b/src/Text/Pandoc/SelfContained.hs @@ -3,7 +3,7 @@ {-# LANGUAGE TupleSections #-} {- | Module : Text.Pandoc.SelfContained - Copyright : Copyright (C) 2011-2022 John MacFarlane + Copyright : Copyright (C) 2011-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane @@ -32,11 +32,12 @@ import Text.Pandoc.Logging import Text.Pandoc.Error (PandocError(..)) import Text.Pandoc.MIME (MimeType) -import Text.Pandoc.Shared (isURI, renderTags', trim, tshow) +import Text.Pandoc.Shared (renderTags', trim, tshow) +import Text.Pandoc.URI (isURI) import Text.Pandoc.UTF8 (toString, toText, fromText) -import Text.Parsec (ParsecT, runParserT) +import Text.Pandoc.Parsing (ParsecT, runParserT) +import qualified Text.Pandoc.Parsing as P import Control.Monad.Except (throwError, catchError) -import qualified Text.Parsec as P isOk :: Char -> Bool isOk c = isAscii c && isAlphaNum c diff --git a/src/Text/Pandoc/Server.hs b/src/Text/Pandoc/Server.hs deleted file mode 100644 --- a/src/Text/Pandoc/Server.hs +++ /dev/null @@ -1,355 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -module Text.Pandoc.Server - ( app - , ServerOpts(..) - , Params(..) - , Blob(..) - , parseServerOpts - ) where - -import Data.Aeson -import Network.Wai -import Servant -import Text.DocTemplates as DocTemplates -import Text.Pandoc -import Text.Pandoc.Citeproc (processCitations) -import Text.Pandoc.Highlighting (lookupHighlightingStyle) -import qualified Text.Pandoc.UTF8 as UTF8 -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Encoding as TLE -import Data.Maybe (fromMaybe) -import Data.Char (isAlphaNum) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as BL -import Data.ByteString.Base64 (decodeBase64, encodeBase64) -import Data.Default -import Control.Monad (when, foldM) -import qualified Data.Set as Set -import Skylighting (defaultSyntaxMap) -import qualified Data.Map as M -import System.Console.GetOpt -import System.Environment (getArgs, getProgName) -import qualified Control.Exception as E -import Text.Pandoc.Shared (safeStrRead, headerShift, filterIpynbOutput, - eastAsianLineBreakFilter, stripEmptyParagraphs) -import Text.Pandoc.App.Opt ( IpynbOutput (..), Opt(..), defaultOpts ) -import Text.Pandoc.Builder (setMeta) -import Text.Pandoc.SelfContained (makeSelfContained) -import System.Exit - -data ServerOpts = - ServerOpts - { serverPort :: Int - , serverTimeout :: Int } - deriving (Show) - -defaultServerOpts :: ServerOpts -defaultServerOpts = ServerOpts { serverPort = 3030, serverTimeout = 2 } - -cliOptions :: [OptDescr (ServerOpts -> IO ServerOpts)] -cliOptions = - [ Option ['p'] ["port"] - (ReqArg (\s opts -> case safeStrRead s of - Just i -> return opts{ serverPort = i } - Nothing -> - E.throwIO $ PandocOptionError $ T.pack - s <> " is not a number") "NUMBER") - "port number" - , Option ['t'] ["timeout"] - (ReqArg (\s opts -> case safeStrRead s of - Just i -> return opts{ serverTimeout = i } - Nothing -> - E.throwIO $ PandocOptionError $ T.pack - s <> " is not a number") "NUMBER") - "timeout (seconds)" - - , Option ['h'] ["help"] - (NoArg (\_ -> do - prg <- getProgName - let header = "Usage: " <> prg <> " [OPTION...]" - putStrLn $ usageInfo header cliOptions - exitWith ExitSuccess)) - "help message" - - , Option ['v'] ["version"] - (NoArg (\_ -> do - prg <- getProgName - putStrLn $ prg <> " " <> T.unpack pandocVersion - exitWith ExitSuccess)) - "version info" - - ] - -parseServerOpts :: IO ServerOpts -parseServerOpts = do - args <- getArgs - let handleUnknownOpt x = "Unknown option: " <> x - case getOpt' Permute cliOptions args of - (os, ns, unrecognizedOpts, es) -> do - when (not (null es) || not (null unrecognizedOpts)) $ - E.throwIO $ PandocOptionError $ T.pack $ - concat es ++ unlines (map handleUnknownOpt unrecognizedOpts) ++ - ("Try --help for more information.") - when (not (null ns)) $ - E.throwIO $ PandocOptionError $ T.pack $ - "Unknown arguments: " <> unwords ns - foldM (flip ($)) defaultServerOpts os - -newtype Blob = Blob BL.ByteString - deriving (Show, Eq) - -instance ToJSON Blob where - toJSON (Blob bs) = toJSON (encodeBase64 $ BL.toStrict bs) - -instance FromJSON Blob where - parseJSON = withText "Blob" $ \t -> do - let inp = UTF8.fromText t - case decodeBase64 inp of - Right bs -> return $ Blob $ BL.fromStrict bs - Left _ -> -- treat as regular text - return $ Blob $ BL.fromStrict inp - --- This is the data to be supplied by the JSON payload --- of requests. Maybe values may be omitted and will be --- given default values. -data Params = Params - { options :: Opt - , text :: Text - , files :: Maybe (M.Map FilePath Blob) - , citeproc :: Maybe Bool - } deriving (Show) - -instance Default Params where - def = Params - { options = defaultOpts - , text = mempty - , files = Nothing - , citeproc = Nothing - } - --- Automatically derive code to convert to/from JSON. -instance FromJSON Params where - parseJSON = withObject "Params" $ \o -> - Params - <$> parseJSON (Object o) - <*> o .: "text" - <*> o .:? "files" - <*> o .:? "citeproc" - - --- This is the API. The "/convert" endpoint takes a request body --- consisting of a JSON-encoded Params structure and responds to --- Get requests with either plain text or JSON, depending on the --- Accept header. -type API = - ReqBody '[JSON] Params :> Post '[PlainText, JSON] Text - :<|> - ReqBody '[JSON] Params :> Post '[OctetStream] BS.ByteString - :<|> - "batch" :> ReqBody '[JSON] [Params] :> Post '[JSON] [Text] - :<|> - "babelmark" :> QueryParam' '[Required] "text" Text :> QueryParam "from" Text :> QueryParam "to" Text :> QueryFlag "standalone" :> Get '[JSON] Value - :<|> - "version" :> Get '[PlainText, JSON] Text - -app :: Application -app = serve api server - -api :: Proxy API -api = Proxy - -server :: Server API -server = convert - :<|> convertBytes - :<|> mapM convert - :<|> babelmark -- for babelmark which expects {"html": "", "version": ""} - :<|> pure pandocVersion - where - babelmark text' from' to' standalone' = do - res <- convert def{ text = text', - options = defaultOpts{ - optFrom = from', - optTo = to', - optStandalone = standalone' } - } - return $ toJSON $ object [ "html" .= res, "version" .= pandocVersion ] - - -- We use runPure for the pandoc conversions, which ensures that - -- they will do no IO. This makes the server safe to use. However, - -- it will mean that features requiring IO, like RST includes, will not work. - -- Changing this to - -- handleErr =<< liftIO (runIO (convert' params)) - -- will allow the IO operations. - convert params = handleErr $ - runPure (convert' id (encodeBase64 . BL.toStrict) params) - - convertBytes params = handleErr $ - runPure (convert' UTF8.fromText BL.toStrict params) - - convert' :: (Text -> a) -> (BL.ByteString -> a) -> Params -> PandocPure a - convert' textHandler bsHandler params = do - curtime <- getCurrentTime - -- put files params in ersatz file system - let addFile :: FilePath -> Blob -> FileTree -> FileTree - addFile fp (Blob lbs) = - insertInFileTree fp FileInfo{ infoFileMTime = curtime - , infoFileContents = BL.toStrict lbs } - case files params of - Nothing -> return () - Just fs -> do - let filetree = M.foldrWithKey addFile mempty fs - modifyPureState $ \st -> st{ stFiles = filetree } - - let opts = options params - let readerFormat = fromMaybe "markdown" $ optFrom opts - let writerFormat = fromMaybe "html" $ optTo opts - (readerSpec, readerExts) <- getReader readerFormat - (writerSpec, writerExts) <- getWriter writerFormat - - let isStandalone = optStandalone opts - let toformat = T.toLower $ T.takeWhile isAlphaNum $ writerFormat - hlStyle <- traverse (lookupHighlightingStyle . T.unpack) - $ optHighlightStyle opts - - mbTemplate <- if isStandalone - then case optTemplate opts of - Nothing -> Just <$> - compileDefaultTemplate toformat - Just t -> Just <$> - compileCustomTemplate toformat t - else return Nothing - - abbrevs <- Set.fromList . filter (not . T.null) . T.lines . UTF8.toText <$> - case optAbbreviations opts of - Nothing -> readDataFile "abbreviations" - Just f -> readFileStrict f - - let readeropts = def{ readerExtensions = readerExts - , readerStandalone = isStandalone - , readerTabStop = optTabStop opts - , readerIndentedCodeClasses = - optIndentedCodeClasses opts - , readerAbbreviations = abbrevs - , readerDefaultImageExtension = - optDefaultImageExtension opts - , readerTrackChanges = optTrackChanges opts - , readerStripComments = optStripComments opts - } - let writeropts = - def{ writerExtensions = writerExts - , writerTabStop = optTabStop opts - , writerWrapText = optWrap opts - , writerColumns = optColumns opts - , writerTemplate = mbTemplate - , writerSyntaxMap = defaultSyntaxMap - , writerVariables = optVariables opts - , writerTableOfContents = optTableOfContents opts - , writerIncremental = optIncremental opts - , writerHTMLMathMethod = optHTMLMathMethod opts - , writerNumberSections = optNumberSections opts - , writerNumberOffset = optNumberOffset opts - , writerSectionDivs = optSectionDivs opts - , writerReferenceLinks = optReferenceLinks opts - , writerDpi = optDpi opts - , writerEmailObfuscation = optEmailObfuscation opts - , writerIdentifierPrefix = optIdentifierPrefix opts - , writerCiteMethod = optCiteMethod opts - , writerHtmlQTags = optHtmlQTags opts - , writerSlideLevel = optSlideLevel opts - , writerTopLevelDivision = optTopLevelDivision opts - , writerListings = optListings opts - , writerHighlightStyle = hlStyle - , writerSetextHeaders = optSetextHeaders opts - , writerEpubSubdirectory = T.pack $ optEpubSubdirectory opts - , writerEpubMetadata = T.pack <$> optEpubMetadata opts - , writerEpubFonts = optEpubFonts opts - , writerEpubChapterLevel = optEpubChapterLevel opts - , writerTOCDepth = optTOCDepth opts - , writerReferenceDoc = optReferenceDoc opts - , writerReferenceLocation = optReferenceLocation opts - , writerPreferAscii = optAscii opts - } - let reader = case readerSpec of - TextReader r -> r readeropts - ByteStringReader r -> \t -> do - let eitherbs = decodeBase64 $ UTF8.fromText t - case eitherbs of - Left errt -> throwError $ PandocSomeError errt - Right bs -> r readeropts $ BL.fromStrict bs - let writer = case writerSpec of - TextWriter w -> - fmap textHandler . - (\d -> w writeropts d >>= - if optEmbedResources opts && htmlFormat (optTo opts) - then makeSelfContained - else return) - ByteStringWriter w -> fmap bsHandler . w writeropts - - let transforms :: Pandoc -> Pandoc - transforms = (case optShiftHeadingLevelBy opts of - 0 -> id - x -> headerShift x) . - (case optStripEmptyParagraphs opts of - True -> stripEmptyParagraphs - False -> id) . - (if extensionEnabled Ext_east_asian_line_breaks - readerExts && - not (extensionEnabled Ext_east_asian_line_breaks - writerExts && - optWrap opts == WrapPreserve) - then eastAsianLineBreakFilter - else id) . - (case optIpynbOutput opts of - IpynbOutputAll -> id - IpynbOutputNone -> filterIpynbOutput Nothing - IpynbOutputBest -> filterIpynbOutput (Just $ - case optTo opts of - Just "latex" -> Format "latex" - Just "beamer" -> Format "latex" - Nothing -> Format "html" - Just f - | htmlFormat (optTo opts) -> Format "html" - | otherwise -> Format f)) - - let meta = (case optBibliography opts of - [] -> id - fs -> setMeta "bibliography" (MetaList - (map (MetaString . T.pack) fs))) . - maybe id (setMeta "csl" . MetaString . T.pack) - (optCSL opts) . - maybe id (setMeta "citation-abbreviations" . MetaString . - T.pack) - (optCitationAbbreviations opts) $ - optMetadata opts - - let addMetadata m' (Pandoc m bs) = Pandoc (m <> m') bs - - reader (text params) >>= - return . transforms . addMetadata meta >>= - (case citeproc params of - Just True -> processCitations - _ -> return) >>= - writer - - htmlFormat :: Maybe Text -> Bool - htmlFormat Nothing = True - htmlFormat (Just f) = - any (`T.isPrefixOf` f) - ["html","html4","html5","s5","slidy", "slideous","dzslides","revealjs"] - - handleErr (Right t) = return t - handleErr (Left err) = throwError $ - err500 { errBody = TLE.encodeUtf8 $ TL.fromStrict $ renderError err } - - compileCustomTemplate toformat t = do - res <- runWithPartials $ compileTemplate ("custom." <> T.unpack toformat) - (T.pack t) - case res of - Left e -> throwError $ PandocTemplateError (T.pack e) - Right tpl -> return tpl - diff --git a/src/Text/Pandoc/Shared.hs b/src/Text/Pandoc/Shared.hs --- a/src/Text/Pandoc/Shared.hs +++ b/src/Text/Pandoc/Shared.hs @@ -8,7 +8,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Shared - Copyright : Copyright (C) 2006-2022 John MacFarlane + Copyright : Copyright (C) 2006-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane @@ -22,13 +22,9 @@ splitBy, splitTextBy, splitTextByIndices, - ordNub, - findM, -- * Text processing inquotes, tshow, - elemText, - notElemText, stripTrailingNewlines, trim, triml, @@ -38,9 +34,7 @@ camelCaseToHyphenated, camelCaseStrToHyphenated, toRomanNumeral, - escapeURI, tabFilter, - crFilter, -- * Date/time normalizeDate, -- * Pandoc block and inline list processing @@ -48,15 +42,16 @@ extractSpaces, removeFormatting, deNote, - deLink, stringify, capitalize, compactify, compactifyDL, linesToPara, + figureDiv, makeSections, uniqueIdent, inlineListToIdentifier, + textToIdentifier, isHeaderBlock, headerShift, stripEmptyParagraphs, @@ -66,7 +61,6 @@ taskListItemToAscii, handleTaskListItem, addMetaField, - makeMeta, eastAsianLineBreakFilter, htmlSpanLikeElements, filterIpynbOutput, @@ -75,14 +69,9 @@ renderTags', -- * File handling inDirectory, + makeCanonical, collapseFilePath, - uriPathToPath, filteredFilesFromArchive, - -- * URI handling - schemes, - isURI, - -- * Error handling - mapLeft, -- * for squashing blocks blocksToInlines, blocksToInlines', @@ -90,11 +79,7 @@ defaultBlocksSeparator, -- * Safe read safeRead, - safeStrRead, - -- * User data directory - defaultUserDataDir, - -- * Version - pandocVersion + safeStrRead ) where import Codec.Archive.Zip @@ -102,21 +87,18 @@ import Control.Monad (MonadPlus (..), msum, unless) import qualified Control.Monad.State.Strict as S import qualified Data.ByteString.Lazy as BL -import qualified Data.Bifunctor as Bifunctor +import Data.Containers.ListUtils (nubOrd) import Data.Char (isAlpha, isLower, isSpace, isUpper, toLower, isAlphaNum, generalCategory, GeneralCategory(NonSpacingMark, SpacingCombiningMark, EnclosingMark, ConnectorPunctuation)) -import Data.Containers.ListUtils (nubOrd) -import Data.List (find, intercalate, intersperse, sortOn, foldl', groupBy) +import Data.List (find, foldl', groupBy, intercalate, intersperse, + union, sortOn) import qualified Data.Map as M import Data.Maybe (mapMaybe, fromMaybe) import Data.Monoid (Any (..)) import Data.Sequence (ViewL (..), ViewR (..), viewl, viewr) import qualified Data.Set as Set import qualified Data.Text as T -import Data.Version (showVersion) -import Network.URI (URI (uriScheme), escapeURIString, parseURI) -import Paths_pandoc (version) import System.Directory import System.FilePath (isPathSeparator, splitDirectories) import qualified System.FilePath.Posix as Posix @@ -132,10 +114,6 @@ import Text.DocLayout (charWidth) import Text.Pandoc.Walk --- | Version number of pandoc library. -pandocVersion :: T.Text -pandocVersion = T.pack $ showVersion version - -- -- List processing -- @@ -176,23 +154,6 @@ splitAt' n (x:xs) = (x:ys,zs) where (ys,zs) = splitAt' (n - charWidth x) xs --- | Remove duplicates from a list. -ordNub :: (Ord a) => [a] -> [a] -ordNub = nubOrd -{-# INLINE ordNub #-} - --- | Returns the first element in a foldable structure for that the --- monadic predicate holds true, and @Nothing@ if no such element --- exists. -findM :: forall m t a. (Monad m, Foldable t) - => (a -> m Bool) -> t a -> m (Maybe a) -findM p = foldr go (pure Nothing) - where - go :: a -> m (Maybe a) -> m (Maybe a) - go x acc = do - b <- p x - if b then pure (Just x) else acc - -- -- Text processing -- @@ -205,14 +166,6 @@ tshow :: Show a => a -> T.Text tshow = T.pack . show --- | @True@ exactly when the @Char@ appears in the @Text@. -elemText :: Char -> T.Text -> Bool -elemText c = T.any (== c) - --- | @True@ exactly when the @Char@ does not appear in the @Text@. -notElemText :: Char -> T.Text -> Bool -notElemText c = T.all (/= c) - -- | Strip trailing newlines from string. stripTrailingNewlines :: T.Text -> T.Text stripTrailingNewlines = T.dropWhileEnd (== '\n') @@ -295,12 +248,6 @@ | x >= 1 = "I" <> toRomanNumeral (x - 1) | otherwise = "" --- | Escape whitespace and some punctuation characters in URI. -escapeURI :: T.Text -> T.Text -escapeURI = T.pack . escapeURIString (not . needsEscaping) . T.unpack - where needsEscaping c = isSpace c || c `elemText` "<>|\"{}[]^`" - - -- | Convert tabs to spaces. Tabs will be preserved if tab stop is set to 0. tabFilter :: Int -- ^ Tab stop -> T.Text -- ^ Input @@ -315,11 +262,6 @@ (tabStop - (T.length s1 `mod` tabStop)) (T.pack " ") <> go (T.drop 1 s2) -{-# DEPRECATED crFilter "readers filter crs automatically" #-} --- | Strip out DOS line endings. -crFilter :: T.Text -> T.Text -crFilter = T.filter (/= '\r') - -- -- Date/time -- @@ -401,12 +343,6 @@ deNote (Note _) = Str "" deNote x = x --- {- DEPRECATED deLink "deLink will be removed in a future version" -} --- | Turns links into spans, keeping just the link text. -deLink :: Inline -> Inline -deLink (Link _ ils _) = Span nullAttr ils -deLink x = x - -- | Convert pandoc structure to a string with formatting removed. -- Footnotes are skipped (since we don't want their contents in link -- labels). @@ -493,16 +429,31 @@ linesToPara :: [[Inline]] -> Block linesToPara = Para . combineLines +-- | Creates a Div block from figure components. The intended use is in +-- writers of formats that do not have markup support for figures. +-- +-- The resulting div is given the class @figure@ and contains the figure +-- body and the figure caption. The latter is wrapped in a 'Div' of +-- class @caption@, with the stringified @short-caption@ as attribute. +figureDiv :: Attr -> Caption -> [Block] -> Block +figureDiv (ident, classes, kv) (Caption shortcapt longcapt) body = + let divattr = ( ident + , ["figure"] `union` classes + , kv + ) + captkv = maybe mempty (\s -> [("short-caption", stringify s)]) shortcapt + capt = [Div ("", ["caption"], captkv) longcapt | not (null longcapt)] + in Div divattr (body ++ capt) + +-- | Returns 'True' iff the given element is a 'Para'. isPara :: Block -> Bool isPara (Para _) = True isPara _ = False --- | Convert Pandoc inline list to plain text identifier. HTML --- identifiers must start with a letter, and may contain only --- letters, digits, and the characters _-. +-- | Convert Pandoc inline list to plain text identifier. inlineListToIdentifier :: Extensions -> [Inline] -> T.Text inlineListToIdentifier exts = - dropNonLetter . filterAscii . toIdent . stringify . walk unEmojify + textToIdentifier exts . stringify . walk unEmojify where unEmojify :: [Inline] -> [Inline] unEmojify @@ -511,6 +462,12 @@ | otherwise = id unEmoji (Span ("",["emoji"],[("data-emoji",ename)]) _) = Str ename unEmoji x = x + +-- | Convert string to plain text identifier. +textToIdentifier :: Extensions -> T.Text -> T.Text +textToIdentifier exts = + dropNonLetter . filterAscii . toIdent + where dropNonLetter | extensionEnabled Ext_gfm_auto_identifiers exts = id | otherwise = T.dropWhile (not . isAlpha) @@ -590,14 +547,13 @@ xs' <- go xs rest' <- go rest return $ Div attr xs' : rest' - go (Null:xs) = go xs go (x:xs) = (x :) <$> go xs go [] = return [] combineAttr :: Attr -> Attr -> Attr combineAttr (id1, classes1, kvs1) (id2, classes2, kvs2) = (if T.null id1 then id2 else id1, - ordNub (classes1 ++ classes2), + nubOrd (classes1 ++ classes2), foldr (\(k,v) kvs -> case lookup k kvs of Nothing -> (k,v):kvs Just _ -> kvs) mempty (kvs1 ++ kvs2)) @@ -715,14 +671,6 @@ tolist (MetaList ys) = ys tolist y = [y] --- | Create 'Meta' from old-style title, authors, date. This is --- provided to ease the transition from the old API. -makeMeta :: [Inline] -> [[Inline]] -> [Inline] -> Meta -makeMeta title authors date = - addMetaField "title" (B.fromList title) - $ addMetaField "author" (map B.fromList authors) - $ addMetaField "date" (B.fromList date) nullMeta - -- | Remove soft breaks between East Asian characters. eastAsianLineBreakFilter :: Pandoc -> Pandoc eastAsianLineBreakFilter = bottomUp go @@ -825,12 +773,14 @@ setCurrentDirectory (const $ setCurrentDirectory path >> action) --- --- Error reporting --- - -mapLeft :: (a -> b) -> Either a c -> Either b c -mapLeft = Bifunctor.first +-- | Canonicalizes a file path by removing redundant @.@ and @..@. +makeCanonical :: FilePath -> FilePath +makeCanonical = Posix.joinPath . transformPathParts . splitDirectories + where transformPathParts = reverse . foldl' go [] + go as "." = as + go ("..":as) ".." = ["..", ".."] <> as + go (_:as) ".." = as + go as x = x : as -- | Remove intermediate "." and ".." directories from a path. -- @@ -856,19 +806,6 @@ isSingleton _ = Nothing checkPathSeperator = fmap isPathSeparator . isSingleton --- | Converts the path part of a file: URI to a regular path. --- On windows, @/c:/foo@ should be @c:/foo@. --- On linux, @/foo@ should be @/foo@. -uriPathToPath :: T.Text -> FilePath -uriPathToPath (T.unpack -> path) = -#ifdef _WINDOWS - case path of - '/':ps -> ps - ps -> ps -#else - path -#endif - -- -- File selection from the archive -- @@ -879,70 +816,6 @@ fileAndBinary :: Archive -> FilePath -> Maybe (FilePath, BL.ByteString) fileAndBinary a fp = findEntryByPath fp a >>= \e -> Just (fp, fromEntry e) --- --- IANA URIs --- - --- | Schemes from http://www.iana.org/assignments/uri-schemes.html plus --- the unofficial schemes doi, javascript, isbn, pmid. -schemes :: Set.Set T.Text -schemes = Set.fromList - -- Official IANA schemes - [ "aaa", "aaas", "about", "acap", "acct", "acr", "adiumxtra", "afp", "afs" - , "aim", "appdata", "apt", "attachment", "aw", "barion", "beshare", "bitcoin" - , "blob", "bolo", "browserext", "callto", "cap", "chrome", "chrome-extension" - , "cid", "coap", "coaps", "com-eventbrite-attendee", "content", "crid", "cvs" - , "data", "dav", "dict", "dis", "dlna-playcontainer", "dlna-playsingle" - , "dns", "dntp", "dtn", "dvb", "ed2k", "example", "facetime", "fax", "feed" - , "feedready", "file", "filesystem", "finger", "fish", "ftp", "geo", "gg" - , "git", "gizmoproject", "go", "gopher", "graph", "gtalk", "h323", "ham" - , "hcp", "http", "https", "hxxp", "hxxps", "hydrazone", "iax", "icap", "icon" - , "im", "imap", "info", "iotdisco", "ipn", "ipp", "ipps", "irc", "irc6" - , "ircs", "iris", "iris.beep", "iris.lwz", "iris.xpc", "iris.xpcs" - , "isostore", "itms", "jabber", "jar", "jms", "keyparc", "lastfm", "ldap" - , "ldaps", "lvlt", "magnet", "mailserver", "mailto", "maps", "market" - , "message", "mid", "mms", "modem", "mongodb", "moz", "ms-access" - , "ms-browser-extension", "ms-drive-to", "ms-enrollment", "ms-excel" - , "ms-gamebarservices", "ms-getoffice", "ms-help", "ms-infopath" - , "ms-media-stream-id", "ms-officeapp", "ms-project", "ms-powerpoint" - , "ms-publisher", "ms-search-repair", "ms-secondary-screen-controller" - , "ms-secondary-screen-setup", "ms-settings", "ms-settings-airplanemode" - , "ms-settings-bluetooth", "ms-settings-camera", "ms-settings-cellular" - , "ms-settings-cloudstorage", "ms-settings-connectabledevices" - , "ms-settings-displays-topology", "ms-settings-emailandaccounts" - , "ms-settings-language", "ms-settings-location", "ms-settings-lock" - , "ms-settings-nfctransactions", "ms-settings-notifications" - , "ms-settings-power", "ms-settings-privacy", "ms-settings-proximity" - , "ms-settings-screenrotation", "ms-settings-wifi", "ms-settings-workplace" - , "ms-spd", "ms-sttoverlay", "ms-transit-to", "ms-virtualtouchpad" - , "ms-visio", "ms-walk-to", "ms-whiteboard", "ms-whiteboard-cmd", "ms-word" - , "msnim", "msrp", "msrps", "mtqp", "mumble", "mupdate", "mvn", "news", "nfs" - , "ni", "nih", "nntp", "notes", "ocf", "oid", "onenote", "onenote-cmd" - , "opaquelocktoken", "pack", "palm", "paparazzi", "pkcs11", "platform", "pop" - , "pres", "prospero", "proxy", "pwid", "psyc", "qb", "query", "redis" - , "rediss", "reload", "res", "resource", "rmi", "rsync", "rtmfp", "rtmp" - , "rtsp", "rtsps", "rtspu", "secondlife", "service", "session", "sftp", "sgn" - , "shttp", "sieve", "sip", "sips", "skype", "smb", "sms", "smtp", "snews" - , "snmp", "soap.beep", "soap.beeps", "soldat", "spotify", "ssh", "steam" - , "stun", "stuns", "submit", "svn", "tag", "teamspeak", "tel", "teliaeid" - , "telnet", "tftp", "things", "thismessage", "tip", "tn3270", "tool", "turn" - , "turns", "tv", "udp", "unreal", "urn", "ut2004", "v-event", "vemmi" - , "ventrilo", "videotex", "vnc", "view-source", "wais", "webcal", "wpid" - , "ws", "wss", "wtai", "wyciwyg", "xcon", "xcon-userid", "xfire" - , "xmlrpc.beep", "xmlrpc.beeps", "xmpp", "xri", "ymsgr", "z39.50", "z39.50r" - , "z39.50s" - -- Unofficial schemes - , "doi", "isbn", "javascript", "pmid" - ] - --- | Check if the string is a valid URL with a IANA or frequently used but --- unofficial scheme (see @schemes@). -isURI :: T.Text -> Bool -isURI = maybe False hasKnownScheme . parseURI . T.unpack - where - hasKnownScheme = (`Set.member` schemes) . T.toLower . - T.filter (/= ':') . T.pack . uriScheme - --- --- Squash blocks into inlines --- @@ -974,7 +847,7 @@ unTableBody (TableBody _ _ hd bd) = hd <> bd unTableBodies = concatMap unTableBody blockToInlines (Div _ blks) = blocksToInlines' blks -blockToInlines Null = mempty +blockToInlines (Figure _ _ body) = blocksToInlines' body blocksToInlinesWithSep :: Inlines -> [Block] -> Inlines blocksToInlinesWithSep sep = @@ -992,7 +865,7 @@ defaultBlocksSeparator = -- This is used in the pandoc.utils.blocks_to_inlines function. Docs -- there should be updated if this is changed. - B.space <> B.str "¶" <> B.space + B.linebreak -- -- Safe read @@ -1006,24 +879,3 @@ (d,x):_ | all isSpace x -> return d _ -> mzero --- --- User data directory --- - --- | Return appropriate user data directory for platform. We use --- XDG_DATA_HOME (or its default value), but for backwards compatibility, --- we fall back to the legacy user data directory ($HOME/.pandoc on *nix) --- if the XDG_DATA_HOME is missing and this exists. If neither directory --- is present, we return the XDG data directory. If the XDG data directory --- is not defined (e.g. because we are in an environment where $HOME is --- not defined), we return the empty string. -defaultUserDataDir :: IO FilePath -defaultUserDataDir = do - xdgDir <- E.catch (getXdgDirectory XdgData "pandoc") - (\(_ :: E.SomeException) -> return mempty) - legacyDir <- getAppUserDataDirectory "pandoc" - xdgExists <- doesDirectoryExist xdgDir - legacyDirExists <- doesDirectoryExist legacyDir - if not xdgExists && legacyDirExists - then return legacyDir - else return xdgDir diff --git a/src/Text/Pandoc/Slides.hs b/src/Text/Pandoc/Slides.hs --- a/src/Text/Pandoc/Slides.hs +++ b/src/Text/Pandoc/Slides.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Slides - Copyright : Copyright (C) 2012-2022 John MacFarlane + Copyright : Copyright (C) 2012-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane @@ -30,7 +30,7 @@ -- | Prepare a block list to be passed to makeSections. prepSlides :: Int -> [Block] -> [Block] -prepSlides slideLevel = ensureStartWithH . splitHrule . extractRefsHeader . filter (/= Null) +prepSlides slideLevel = ensureStartWithH . splitHrule . extractRefsHeader where splitHrule (HorizontalRule : Header n attr xs : ys) | n == slideLevel = Header slideLevel attr xs : splitHrule ys splitHrule (HorizontalRule : xs) = Header slideLevel nullAttr [Str "\0"] : diff --git a/src/Text/Pandoc/Sources.hs b/src/Text/Pandoc/Sources.hs --- a/src/Text/Pandoc/Sources.hs +++ b/src/Text/Pandoc/Sources.hs @@ -6,7 +6,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Sources - Copyright : Copyright (C) 2021-2022 John MacFarlane + Copyright : Copyright (C) 2021-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane @@ -46,6 +46,8 @@ import Text.Parsec.Pos as P import Data.Text (Text) import qualified Data.Text as T +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BL import Data.Char (isSpace, isLetter, isAlphaNum, isDigit, isHexDigit) import Data.String (IsString(..)) import qualified Data.List.NonEmpty as NonEmpty @@ -110,6 +112,15 @@ updateSourcePos :: SourcePos -> c -> s -> SourcePos instance UpdateSourcePos Text Char where + updateSourcePos pos c _ = updatePosChar pos c + +instance UpdateSourcePos [Char] Char where + updateSourcePos pos c _ = updatePosChar pos c + +instance UpdateSourcePos BS.ByteString Char where + updateSourcePos pos c _ = updatePosChar pos c + +instance UpdateSourcePos BL.ByteString Char where updateSourcePos pos c _ = updatePosChar pos c instance UpdateSourcePos Sources Char where diff --git a/src/Text/Pandoc/TeX.hs b/src/Text/Pandoc/TeX.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/TeX.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE FlexibleInstances #-} +{- | + Module : Text.Pandoc.TeX + Copyright : Copyright (C) 2017-2023 John MacFarlane + License : GNU GPL, version 2 or above + + Maintainer : John MacFarlane + Stability : alpha + Portability : portable + +Types for TeX tokens and macros. +-} +module Text.Pandoc.TeX ( Tok(..) + , TokType(..) + , Macro(..) + , ArgSpec(..) + , ExpansionPoint(..) + , MacroScope(..) + , SourcePos + ) +where +import Data.Text (Text) +import Text.Parsec (SourcePos, sourceName) +import Text.Pandoc.Sources +import Data.List (groupBy) + +data TokType = CtrlSeq Text | Spaces | Newline | Symbol | Word | Comment | + Esc1 | Esc2 | Arg Int | DeferredArg Int + deriving (Eq, Ord, Show) + +data Tok = Tok SourcePos TokType Text + deriving (Eq, Ord, Show) + +instance ToSources [Tok] where + toSources = Sources + . map (\ts -> case ts of + Tok p _ _ : _ -> (p, mconcat $ map tokToText ts) + _ -> error "toSources [Tok] encountered empty group") + . groupBy (\(Tok p1 _ _) (Tok p2 _ _) -> sourceName p1 == sourceName p2) + +tokToText :: Tok -> Text +tokToText (Tok _ _ t) = t + +data ExpansionPoint = ExpandWhenDefined | ExpandWhenUsed + deriving (Eq, Ord, Show) + +data MacroScope = GlobalScope | GroupScope + deriving (Eq, Ord, Show) + +data Macro = Macro MacroScope ExpansionPoint [ArgSpec] (Maybe [Tok]) [Tok] + deriving Show + +data ArgSpec = ArgNum Int | Pattern [Tok] + deriving Show diff --git a/src/Text/Pandoc/Templates.hs b/src/Text/Pandoc/Templates.hs --- a/src/Text/Pandoc/Templates.hs +++ b/src/Text/Pandoc/Templates.hs @@ -4,7 +4,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Templates - Copyright : Copyright (C) 2009-2022 John MacFarlane + Copyright : Copyright (C) 2009-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane @@ -12,6 +12,22 @@ Portability : portable Utility functions for working with pandoc templates. + +'WithDefaultPartials' and 'WithPartials' are Monad wrappers. Wrapping +these around an instance of 'PandocMonad' gives different instances of +'TemplateMonad', with different search behaviors when retrieving +partials. + +To compile a template and limit partial search to pandoc’s data files, +use @runWithDefaultPartials (compileTemplate ...)@. + +To compile a template and allow partials to be found locally (either on +the file system or via HTTP, in the event that the main template has an +absolute URL), ue @runWithPartials (compileTemplate ...)@. + +'getTemplate' seeks a template locally, or via HTTP if the template has +an absolute URL, falling back to the data files if not found. + -} module Text.Pandoc.Templates ( Template @@ -27,8 +43,9 @@ import System.FilePath ((<.>), (), takeFileName) import Text.DocTemplates (Template, TemplateMonad(..), compileTemplate, renderTemplate) import Text.Pandoc.Class.CommonState (CommonState(..)) -import Text.Pandoc.Class.PandocMonad (PandocMonad, readDataFile, fetchItem, +import Text.Pandoc.Class.PandocMonad (PandocMonad, fetchItem, getCommonState, modifyCommonState) +import Text.Pandoc.Data (readDataFile) import qualified Text.Pandoc.UTF8 as UTF8 import Control.Monad.Except (catchError, throwError) import Data.Text (Text) @@ -80,8 +97,7 @@ getDefaultTemplate :: PandocMonad m => Text -- ^ Name of writer -> m Text -getDefaultTemplate writer = do - let format = T.takeWhile (`notElem` ("+-" :: String)) writer -- strip off extensions +getDefaultTemplate format = do case format of "native" -> return "" "csljson" -> return "" diff --git a/src/Text/Pandoc/Translations.hs b/src/Text/Pandoc/Translations.hs --- a/src/Text/Pandoc/Translations.hs +++ b/src/Text/Pandoc/Translations.hs @@ -1,98 +1,96 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Translations - Copyright : Copyright (C) 2017-2022 John MacFarlane + Copyright : Copyright (C) 2017-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane Stability : alpha Portability : portable -Data types for localization. - -Translations are stored in @data/translations/langname.trans@, -where langname can be the full BCP47 language specifier, or -just the language part. File format is: - -> # A comment, ignored -> Figure: Figura -> Index: Indeksi - +Functions for getting localized translations of terms. -} module Text.Pandoc.Translations ( - Term(..) - , Translations - , lookupTerm + module Text.Pandoc.Translations.Types , readTranslations + , getTranslations + , setTranslations + , translateTerm ) where -import Data.Aeson.Types (Value(..), FromJSON(..)) -import qualified Data.Aeson.Types as Aeson -import qualified Data.Map as M +import Text.Pandoc.Translations.Types +import Text.Pandoc.Class (PandocMonad(..), CommonState(..), report) +import Text.Pandoc.Data (readDataFile) +import Text.Pandoc.Error (PandocError(..)) +import Text.Pandoc.Logging (LogMessage(..)) +import Control.Monad.Except (catchError) import qualified Data.Text as T import qualified Data.Yaml as Yaml -import GHC.Generics (Generic) -import Text.Pandoc.Shared (safeRead) import qualified Text.Pandoc.UTF8 as UTF8 import Data.Yaml (prettyPrintParseException) - -data Term = - Abstract - | Appendix - | Bibliography - | Cc - | Chapter - | Contents - | Encl - | Figure - | Glossary - | Index - | Listing - | ListOfFigures - | ListOfTables - | Page - | Part - | Preface - | Proof - | References - | See - | SeeAlso - | Table - | To - deriving (Show, Eq, Ord, Generic, Enum, Read) - -newtype Translations = Translations (M.Map Term T.Text) - deriving (Show, Generic, Semigroup, Monoid) - -instance FromJSON Term where - parseJSON (String t) = case safeRead t of - Just t' -> pure t' - Nothing -> Prelude.fail $ "Invalid Term name " ++ - show t - parseJSON invalid = Aeson.typeMismatch "Term" invalid - -instance FromJSON Translations where - parseJSON o@(Object{}) = do - xs <- parseJSON o >>= mapM addItem . M.toList - return $ Translations (M.fromList xs) - where addItem (k,v) = - case safeRead k of - Nothing -> Prelude.fail $ "Invalid Term name " ++ show k - Just t -> - case v of - (String s) -> return (t, T.strip s) - inv -> Aeson.typeMismatch "String" inv - parseJSON invalid = Aeson.typeMismatch "Translations" invalid - -lookupTerm :: Term -> Translations -> Maybe T.Text -lookupTerm t (Translations tm) = M.lookup t tm +import Text.Collate.Lang (Lang(..), renderLang) +-- | Parse YAML translations. readTranslations :: T.Text -> Either T.Text Translations readTranslations s = case Yaml.decodeAllEither' $ UTF8.fromText s of Left err' -> Left $ T.pack $ prettyPrintParseException err' Right (t:_) -> Right t Right [] -> Left "empty YAML document" + +-- | Select the language to use with 'translateTerm'. +-- Note that this does not read a translation file; +-- that is only done the first time 'translateTerm' is +-- used. +setTranslations :: PandocMonad m => Lang -> m () +setTranslations lang = + modifyCommonState $ \st -> st{ stTranslations = Just (lang, Nothing) } + +-- | Load term map. +getTranslations :: PandocMonad m => m Translations +getTranslations = do + mbtrans <- getsCommonState stTranslations + case mbtrans of + Nothing -> return mempty -- no language defined + Just (_, Just t) -> return t + Just (lang, Nothing) -> do -- read from file + let translationFile = "translations/" <> renderLang lang <> ".yaml" + let fallbackFile = "translations/" <> langLanguage lang <> ".yaml" + let getTrans fp = do + bs <- readDataFile fp + case readTranslations (UTF8.toText bs) of + Left e -> do + report $ CouldNotLoadTranslations (renderLang lang) + (T.pack fp <> ": " <> e) + -- make sure we don't try again... + modifyCommonState $ \st -> + st{ stTranslations = Nothing } + return mempty + Right t -> do + modifyCommonState $ \st -> + st{ stTranslations = Just (lang, Just t) } + return t + catchError (getTrans $ T.unpack translationFile) + (\_ -> + catchError (getTrans $ T.unpack fallbackFile) + (\e -> do + report $ CouldNotLoadTranslations (renderLang lang) + $ case e of + PandocCouldNotFindDataFileError _ -> + "data file " <> fallbackFile <> " not found" + _ -> "" + -- make sure we don't try again... + modifyCommonState $ \st -> st{ stTranslations = Nothing } + return mempty)) + +-- | Get a translation from the current term map. +-- Issue a warning if the term is not defined. +translateTerm :: PandocMonad m => Term -> m T.Text +translateTerm term = do + translations <- getTranslations + case lookupTerm term translations of + Just s -> return s + Nothing -> do + report $ NoTranslation $ T.pack $ show term + return "" diff --git a/src/Text/Pandoc/Translations/Types.hs b/src/Text/Pandoc/Translations/Types.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/Translations/Types.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{- | + Module : Text.Pandoc.Translations.Types + Copyright : Copyright (C) 2017-2023 John MacFarlane + License : GNU GPL, version 2 or above + + Maintainer : John MacFarlane + Stability : alpha + Portability : portable + +Data types for localization. + +Translations are stored in @data/translations/langname.trans@, +where langname can be the full BCP47 language specifier, or +just the language part. File format is: + +> # A comment, ignored +> Figure: Figura +> Index: Indeksi + +-} +module Text.Pandoc.Translations.Types ( + Term(..) + , Translations + , lookupTerm + ) +where +import Data.Aeson.Types (Value(..), FromJSON(..)) +import qualified Data.Aeson.Types as Aeson +import qualified Data.Map as M +import qualified Data.Text as T +import GHC.Generics (Generic) +import Text.Pandoc.Shared (safeRead) + +data Term = + Abstract + | Appendix + | Bibliography + | Cc + | Chapter + | Contents + | Encl + | Figure + | Glossary + | Index + | Listing + | ListOfFigures + | ListOfTables + | Page + | Part + | Preface + | Proof + | References + | See + | SeeAlso + | Table + | To + deriving (Show, Eq, Ord, Generic, Enum, Read) + +newtype Translations = Translations (M.Map Term T.Text) + deriving (Show, Generic, Semigroup, Monoid) + +instance FromJSON Term where + parseJSON (String t) = case safeRead t of + Just t' -> pure t' + Nothing -> Prelude.fail $ "Invalid Term name " ++ + show t + parseJSON invalid = Aeson.typeMismatch "Term" invalid + +instance FromJSON Translations where + parseJSON o@(Object{}) = do + xs <- parseJSON o >>= mapM addItem . M.toList + return $ Translations (M.fromList xs) + where addItem (k,v) = + case safeRead k of + Nothing -> Prelude.fail $ "Invalid Term name " ++ show k + Just t -> + case v of + (String s) -> return (t, T.strip s) + inv -> Aeson.typeMismatch "String" inv + parseJSON invalid = Aeson.typeMismatch "Translations" invalid + +-- | Lookup a term in a 'Translations'. +lookupTerm :: Term -> Translations -> Maybe T.Text +lookupTerm t (Translations tm) = M.lookup t tm diff --git a/src/Text/Pandoc/URI.hs b/src/Text/Pandoc/URI.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/URI.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} +{- | + Module : Text.Pandoc.URI + Copyright : Copyright (C) 2006-2023 John MacFarlane + License : GNU GPL, version 2 or above + + Maintainer : John MacFarlane + Stability : alpha + Portability : portable +-} +module Text.Pandoc.URI ( urlEncode + , escapeURI + , isURI + , schemes + , uriPathToPath + ) where +import qualified Network.HTTP.Types as HTTP +import qualified Text.Pandoc.UTF8 as UTF8 +import qualified Data.Text as T +import qualified Data.Set as Set +import Data.Char (isSpace, isAscii) +import Network.URI (URI (uriScheme), parseURI, escapeURIString) + +urlEncode :: T.Text -> T.Text +urlEncode = UTF8.toText . HTTP.urlEncode True . UTF8.fromText + +-- | Escape whitespace and some punctuation characters in URI. +escapeURI :: T.Text -> T.Text +escapeURI = T.pack . escapeURIString (not . needsEscaping) . T.unpack + where needsEscaping c = isSpace c || T.any (== c) "<>|\"{}[]^`" + +-- +-- IANA URIs +-- + +-- | Schemes from http://www.iana.org/assignments/uri-schemes.html plus +-- the unofficial schemes doi, javascript, isbn, pmid. +schemes :: Set.Set T.Text +schemes = Set.fromList + -- Official IANA schemes + [ "aaa", "aaas", "about", "acap", "acct", "acr", "adiumxtra", "afp", "afs" + , "aim", "appdata", "apt", "attachment", "aw", "barion", "beshare", "bitcoin" + , "blob", "bolo", "browserext", "callto", "cap", "chrome", "chrome-extension" + , "cid", "coap", "coaps", "com-eventbrite-attendee", "content", "crid", "cvs" + , "data", "dav", "dict", "dis", "dlna-playcontainer", "dlna-playsingle" + , "dns", "dntp", "dtn", "dvb", "ed2k", "example", "facetime", "fax", "feed" + , "feedready", "file", "filesystem", "finger", "fish", "ftp", "geo", "gg" + , "git", "gizmoproject", "go", "gopher", "graph", "gtalk", "h323", "ham" + , "hcp", "http", "https", "hxxp", "hxxps", "hydrazone", "iax", "icap", "icon" + , "im", "imap", "info", "iotdisco", "ipn", "ipp", "ipps", "irc", "irc6" + , "ircs", "iris", "iris.beep", "iris.lwz", "iris.xpc", "iris.xpcs" + , "isostore", "itms", "jabber", "jar", "jms", "keyparc", "lastfm", "ldap" + , "ldaps", "lvlt", "magnet", "mailserver", "mailto", "maps", "market" + , "message", "mid", "mms", "modem", "mongodb", "moz", "ms-access" + , "ms-browser-extension", "ms-drive-to", "ms-enrollment", "ms-excel" + , "ms-gamebarservices", "ms-getoffice", "ms-help", "ms-infopath" + , "ms-media-stream-id", "ms-officeapp", "ms-project", "ms-powerpoint" + , "ms-publisher", "ms-search-repair", "ms-secondary-screen-controller" + , "ms-secondary-screen-setup", "ms-settings", "ms-settings-airplanemode" + , "ms-settings-bluetooth", "ms-settings-camera", "ms-settings-cellular" + , "ms-settings-cloudstorage", "ms-settings-connectabledevices" + , "ms-settings-displays-topology", "ms-settings-emailandaccounts" + , "ms-settings-language", "ms-settings-location", "ms-settings-lock" + , "ms-settings-nfctransactions", "ms-settings-notifications" + , "ms-settings-power", "ms-settings-privacy", "ms-settings-proximity" + , "ms-settings-screenrotation", "ms-settings-wifi", "ms-settings-workplace" + , "ms-spd", "ms-sttoverlay", "ms-transit-to", "ms-virtualtouchpad" + , "ms-visio", "ms-walk-to", "ms-whiteboard", "ms-whiteboard-cmd", "ms-word" + , "msnim", "msrp", "msrps", "mtqp", "mumble", "mupdate", "mvn", "news", "nfs" + , "ni", "nih", "nntp", "notes", "ocf", "oid", "onenote", "onenote-cmd" + , "opaquelocktoken", "pack", "palm", "paparazzi", "pkcs11", "platform", "pop" + , "pres", "prospero", "proxy", "pwid", "psyc", "qb", "query", "redis" + , "rediss", "reload", "res", "resource", "rmi", "rsync", "rtmfp", "rtmp" + , "rtsp", "rtsps", "rtspu", "secondlife", "service", "session", "sftp", "sgn" + , "shttp", "sieve", "sip", "sips", "skype", "smb", "sms", "smtp", "snews" + , "snmp", "soap.beep", "soap.beeps", "soldat", "spotify", "ssh", "steam" + , "stun", "stuns", "submit", "svn", "tag", "teamspeak", "tel", "teliaeid" + , "telnet", "tftp", "things", "thismessage", "tip", "tn3270", "tool", "turn" + , "turns", "tv", "udp", "unreal", "urn", "ut2004", "v-event", "vemmi" + , "ventrilo", "videotex", "vnc", "view-source", "wais", "webcal", "wpid" + , "ws", "wss", "wtai", "wyciwyg", "xcon", "xcon-userid", "xfire" + , "xmlrpc.beep", "xmlrpc.beeps", "xmpp", "xri", "ymsgr", "z39.50", "z39.50r" + , "z39.50s" + -- Unofficial schemes + , "doi", "isbn", "javascript", "pmid" + ] + +-- | Check if the string is a valid URL with a IANA or frequently used but +-- unofficial scheme (see @schemes@). +isURI :: T.Text -> Bool +isURI = + -- we URI-escape non-ASCII characters because otherwise parseURI will choke: + maybe False hasKnownScheme . parseURI . escapeURIString isAscii . T.unpack + where + hasKnownScheme = (`Set.member` schemes) . T.toLower . + T.filter (/= ':') . T.pack . uriScheme + +-- | Converts the path part of a file: URI to a regular path. +-- On windows, @/c:/foo@ should be @c:/foo@. +-- On linux, @/foo@ should be @/foo@. +uriPathToPath :: T.Text -> FilePath +uriPathToPath (T.unpack -> path) = +#ifdef _WINDOWS + case path of + '/':ps -> ps + ps -> ps +#else + path +#endif diff --git a/src/Text/Pandoc/UTF8.hs b/src/Text/Pandoc/UTF8.hs --- a/src/Text/Pandoc/UTF8.hs +++ b/src/Text/Pandoc/UTF8.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.UTF8 - Copyright : Copyright (C) 2010-2022 John MacFarlane + Copyright : Copyright (C) 2010-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane diff --git a/src/Text/Pandoc/UUID.hs b/src/Text/Pandoc/UUID.hs --- a/src/Text/Pandoc/UUID.hs +++ b/src/Text/Pandoc/UUID.hs @@ -1,6 +1,6 @@ {- | Module : Text.Pandoc.UUID - Copyright : Copyright (C) 2010-2022 John MacFarlane + Copyright : Copyright (C) 2010-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane diff --git a/src/Text/Pandoc/Version.hs b/src/Text/Pandoc/Version.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/Version.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE CPP #-} +{- | + Module : Text.Pandoc.Version + Copyright : Copyright (C) 2022-2023 John MacFarlane + License : GNU GPL, version 2 or above + + Maintainer : John MacFarlane + Stability : alpha + Portability : portable + +Version information. +-} +module Text.Pandoc.Version ( + pandocVersion, + pandocVersionText + ) where + +import Data.Version (Version, showVersion) +import Paths_pandoc (version) +import qualified Data.Text as T + +-- | Version number of pandoc library. +pandocVersion :: Version +pandocVersion = version + +-- | Text representation of the library's version number. +pandocVersionText :: T.Text +pandocVersionText = T.pack $ showVersion version diff --git a/src/Text/Pandoc/Writers.hs b/src/Text/Pandoc/Writers.hs --- a/src/Text/Pandoc/Writers.hs +++ b/src/Text/Pandoc/Writers.hs @@ -1,10 +1,11 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} {- | Module : Text.Pandoc - Copyright : Copyright (C) 2006-2022 John MacFarlane + Copyright : Copyright (C) 2006-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane @@ -23,12 +24,13 @@ , writeBeamer , writeBibTeX , writeBibLaTeX + , writeChunkedHTML , writeCommonMark , writeConTeXt , writeCslJson , writeDZSlides - , writeDocbook4 - , writeDocbook5 + , writeDocBook4 + , writeDocBook5 , writeDocx , writeDokuWiki , writeEPUB2 @@ -76,23 +78,22 @@ ) where import Control.Monad.Except (throwError) -import Control.Monad (unless) import Data.Aeson import qualified Data.ByteString.Lazy as BL import Data.Text (Text) -import qualified Data.Text as T -import Text.Pandoc.Shared (tshow) import Text.Pandoc.Class import Text.Pandoc.Definition +import qualified Text.Pandoc.Format as Format import Text.Pandoc.Options import qualified Text.Pandoc.UTF8 as UTF8 import Text.Pandoc.Error import Text.Pandoc.Writers.AsciiDoc import Text.Pandoc.Writers.BibTeX +import Text.Pandoc.Writers.ChunkedHTML import Text.Pandoc.Writers.CommonMark import Text.Pandoc.Writers.ConTeXt import Text.Pandoc.Writers.CslJson -import Text.Pandoc.Writers.Docbook +import Text.Pandoc.Writers.DocBook import Text.Pandoc.Writers.Docx import Text.Pandoc.Writers.DokuWiki import Text.Pandoc.Writers.EPUB @@ -148,9 +149,9 @@ ,("slideous" , TextWriter writeSlideous) ,("dzslides" , TextWriter writeDZSlides) ,("revealjs" , TextWriter writeRevealJs) - ,("docbook" , TextWriter writeDocbook5) - ,("docbook4" , TextWriter writeDocbook4) - ,("docbook5" , TextWriter writeDocbook5) + ,("docbook" , TextWriter writeDocBook5) + ,("docbook4" , TextWriter writeDocBook4) + ,("docbook5" , TextWriter writeDocBook5) ,("jats" , TextWriter writeJatsArchiving) ,("jats_articleauthoring", TextWriter writeJatsArticleAuthoring) ,("jats_publishing" , TextWriter writeJatsPublishing) @@ -190,32 +191,17 @@ ,("bibtex" , TextWriter writeBibTeX) ,("biblatex" , TextWriter writeBibLaTeX) ,("markua" , TextWriter writeMarkua) + ,("chunkedhtml" , ByteStringWriter writeChunkedHTML) ] -- | Retrieve writer, extensions based on formatSpec (format+extensions). -getWriter :: PandocMonad m => Text -> m (Writer m, Extensions) -getWriter s = - case parseFormatSpec s of - Left e -> throwError $ PandocAppError $ - "Error parsing writer format " <> tshow s <> ": " <> tshow e - Right (writerName, extsToEnable, extsToDisable) -> - case lookup writerName writers of - Nothing -> throwError $ - PandocUnknownWriterError writerName - Just w -> do - let allExts = getAllExtensions writerName - let exts = foldr disableExtension - (foldr enableExtension - (getDefaultExtensions writerName) - extsToEnable) extsToDisable - mapM_ (\ext -> - unless (extensionEnabled ext allExts) $ - throwError $ - PandocUnsupportedExtensionError - (T.drop 4 $ T.pack $ show ext) writerName) - (extsToEnable ++ extsToDisable) - return (w, exts) - +getWriter :: PandocMonad m => Format.FlavoredFormat -> m (Writer m, Extensions) +getWriter flvrd = do + let writerName = Format.formatName flvrd + case lookup writerName writers of + Nothing -> throwError $ PandocUnknownWriterError writerName + Just w -> (w,) <$> + Format.applyExtensionsDiff (Format.getExtensionsConfig writerName) flvrd writeJSON :: PandocMonad m => WriterOptions -> Pandoc -> m Text writeJSON _ = return . UTF8.toText . BL.toStrict . encode diff --git a/src/Text/Pandoc/Writers/AnnotatedTable.hs b/src/Text/Pandoc/Writers/AnnotatedTable.hs --- a/src/Text/Pandoc/Writers/AnnotatedTable.hs +++ b/src/Text/Pandoc/Writers/AnnotatedTable.hs @@ -42,7 +42,6 @@ where import Control.Monad.RWS.Strict - hiding ( (<>) ) import Data.Generics ( Data , Typeable ) diff --git a/src/Text/Pandoc/Writers/AsciiDoc.hs b/src/Text/Pandoc/Writers/AsciiDoc.hs --- a/src/Text/Pandoc/Writers/AsciiDoc.hs +++ b/src/Text/Pandoc/Writers/AsciiDoc.hs @@ -1,7 +1,8 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Writers.AsciiDoc - Copyright : Copyright (C) 2006-2022 John MacFarlane + Copyright : Copyright (C) 2006-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane @@ -19,7 +20,9 @@ AsciiDoc: -} module Text.Pandoc.Writers.AsciiDoc (writeAsciiDoc, writeAsciiDoctor) where +import Control.Monad (foldM) import Control.Monad.State.Strict + ( StateT, MonadState(get), gets, modify, evalStateT ) import Data.Char (isPunctuation, isSpace) import Data.List (delete, intercalate, intersperse) import Data.List.NonEmpty (NonEmpty(..)) @@ -27,6 +30,7 @@ import qualified Data.Set as Set import qualified Data.Text as T import Data.Text (Text) +import System.FilePath (dropExtension) import Text.Pandoc.Class.PandocMonad (PandocMonad, report) import Text.Pandoc.Definition import Text.Pandoc.ImageSize @@ -35,9 +39,10 @@ import Text.Pandoc.Parsing hiding (blankline, space) import Text.DocLayout import Text.Pandoc.Shared +import Text.Pandoc.URI import Text.Pandoc.Templates (renderTemplate) import Text.Pandoc.Writers.Shared - +import Text.Pandoc.Walk (walk) data WriterState = WriterState { defListMarker :: Text , orderedListLevel :: Int @@ -112,7 +117,7 @@ escChar c = T.singleton c -- | Ordered list start parser for use in Para below. -olMarker :: Parser Text ParserState Char +olMarker :: Parsec Text ParserState Char olMarker = do (start, style', delim) <- anyOrderedListMarker if delim == Period && (style' == UpperAlpha || (style' == UpperRoman && @@ -140,7 +145,6 @@ => WriterOptions -- ^ Options -> Block -- ^ Block element -> ADW m (Doc Text) -blockToAsciiDoc _ Null = return empty blockToAsciiDoc opts (Div (id',"section":_,_) (Header level (_,cls,kvs) ils : xs)) = do hdr <- blockToAsciiDoc opts (Header level (id',cls,kvs) ils) @@ -149,10 +153,6 @@ blockToAsciiDoc opts (Plain inlines) = do contents <- inlineListToAsciiDoc opts inlines return $ contents <> blankline -blockToAsciiDoc opts (SimpleFigure attr alternate (src, tit)) - -- image::images/logo.png[Company logo, title="blah"] - = (\args -> "image::" <> args <> blankline) <$> - imageArguments opts attr alternate src tit blockToAsciiDoc opts (Para inlines) = do contents <- inlineListToAsciiDoc opts inlines -- escape if para starts with ordered list marker @@ -186,7 +186,23 @@ return $ identifier $$ nowrap (text (replicate (level + 1) '=') <> space <> contents) <> blankline - +blockToAsciiDoc opts (Figure attr (Caption _ longcapt) body) = do + -- Images in figures all get rendered as individual block-level images + -- with the given caption. Non-image elements are rendered unchanged. + capt <- inlineListToAsciiDoc opts (blocksToInlines longcapt) + let renderFigElement = \case + Plain [Image imgAttr alternate (src, tit)] -> do + args <- imageArguments opts imgAttr alternate src tit + let figAttributes = case attr of + ("", _, _) -> empty + (ident, _, _) -> literal $ "[#" <> ident <> "]" + -- .Figure caption + -- image::images/logo.png[Company logo, title="blah"] + return $ "." <> nowrap capt $$ + figAttributes $$ + "image::" <> args <> blankline + blk -> blockToAsciiDoc opts blk + vcat <$> mapM renderFigElement body blockToAsciiDoc _ (CodeBlock (_,classes,_) str) = return $ flush ( if null classes then "...." $$ literal str $$ "...." @@ -560,8 +576,12 @@ -- relative: link:downloads/foo.zip[download foo.zip] -- abs: http://google.cod[Google] -- or my@email.com[email john] - let fixCommas = T.replace "," "," -- see #8070 - linktext <- fmap fixCommas <$> inlineListToAsciiDoc opts txt + let fixCommas (Str t) = + intersperse (RawInline (Format "asciidoc") ",") + $ map Str $ T.splitOn "," t -- see #8070 + fixCommas x = [x] + + linktext <- inlineListToAsciiDoc opts $ walk (concatMap fixCommas) txt let isRelative = T.all (/= ':') src let needsPassthrough = "--" `T.isInfixOf` src let prefix = if isRelative @@ -608,7 +628,7 @@ ADW m (Doc Text) imageArguments opts attr altText src title = do let txt = if null altText || (altText == [Str ""]) - then [Str "image"] + then [Str . T.pack . dropExtension $ T.unpack src] else altText linktext <- inlineListToAsciiDoc opts txt let linktitle = if T.null title diff --git a/src/Text/Pandoc/Writers/BibTeX.hs b/src/Text/Pandoc/Writers/BibTeX.hs --- a/src/Text/Pandoc/Writers/BibTeX.hs +++ b/src/Text/Pandoc/Writers/BibTeX.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Writers.BibTeX - Copyright : Copyright (C) 2021-2022 John MacFarlane + Copyright : Copyright (C) 2021-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane @@ -57,5 +57,3 @@ case writerTemplate opts of Nothing -> main Just tpl -> renderTemplate tpl context - - diff --git a/src/Text/Pandoc/Writers/Blaze.hs b/src/Text/Pandoc/Writers/Blaze.hs --- a/src/Text/Pandoc/Writers/Blaze.hs +++ b/src/Text/Pandoc/Writers/Blaze.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Writers.Blaze - Copyright : Copyright (C) 2021-2022 John MacFarlane + Copyright : Copyright (C) 2021-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane diff --git a/src/Text/Pandoc/Writers/ChunkedHTML.hs b/src/Text/Pandoc/Writers/ChunkedHTML.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/Writers/ChunkedHTML.hs @@ -0,0 +1,165 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} +{- | + Module : Text.Pandoc.Writers.ChunkedHTML + Copyright : Copyright (C) 2023 John MacFarlane + License : GNU GPL, version 2 or above + + Maintainer : John MacFarlane + Stability : alpha + Portability : portable + +Conversion of 'Pandoc' documents to "chunked" HTML (a folder of +linked HTML documents, split by sections. +-} +module Text.Pandoc.Writers.ChunkedHTML ( + writeChunkedHTML + ) where +import Text.Pandoc.Definition +import Text.Pandoc.Options (WriterOptions(..)) +import Text.Pandoc.Shared (stringify, tshow) +import Text.Pandoc.Class (PandocMonad, getPOSIXTime, runPure, + fetchItem, insertMedia, getMediaBag) +import Text.Pandoc.MediaBag (mediaItems) +import qualified Data.ByteString.Lazy as BL +import Text.Pandoc.Chunks (splitIntoChunks, Chunk(..), ChunkedDoc(..), + SecInfo(..), tocToList) +import Data.Text (Text) +import Data.Tree +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import Text.Pandoc.Writers.HTML (writeHtml5String) +import Codec.Archive.Zip (Entry, addEntryToArchive, emptyArchive, toEntry, + fromArchive) +import qualified Data.Map as M +import Text.DocTemplates (Context(..), Val(..)) +import Text.DocLayout (literal) +import Text.Pandoc.Writers.Shared (defField) +import Data.Aeson (toJSON, encode) +import System.FilePath (isRelative, normalise) +import Data.List (isInfixOf) +import Text.Pandoc.Walk (walkM) + +-- | Splits document into HTML chunks, dividing them by section, +-- and returns a zip archive of a folder of files. +writeChunkedHTML :: PandocMonad m + => WriterOptions -> Pandoc -> m BL.ByteString +writeChunkedHTML opts (Pandoc meta blocks) = do + walkM addMedia (Pandoc meta blocks) + epochtime <- floor <$> getPOSIXTime + let toMediaEntry (fp, _mt, bs) = toEntry fp epochtime bs + mediaEntries <- map toMediaEntry . mediaItems <$> getMediaBag + let chunkedDoc = splitIntoChunks "%s-%i.html" + True + (Just 1) + (writerSplitLevel opts) + (Pandoc meta blocks) + let topChunk = + Chunk + { chunkHeading = docTitle meta + , chunkId = "top" + , chunkLevel = 0 + , chunkNumber = 0 + , chunkSectionNumber = Nothing + , chunkPath = "index.html" + , chunkUp = Nothing + , chunkPrev = Nothing + , chunkNext = case chunkedChunks chunkedDoc of + [] -> Nothing + (x:_) -> Just x + , chunkUnlisted = True + , chunkContents = mempty + } + + let chunks = map (\x -> case chunkUp x of + Nothing -> x{ chunkUp = Just topChunk } + _ -> x) + $ case chunkedChunks chunkedDoc of + [] -> [] + (x:xs) -> x{ chunkPrev = Just topChunk } : xs + + let Node secinfo secs = chunkedTOC chunkedDoc + let tocTree = Node secinfo{ secTitle = docTitle meta, + secPath = "index.html" } secs + renderedTOC <- writeHtml5String opts{ writerTemplate = Nothing } + (Pandoc nullMeta [buildTOC opts tocTree]) + let opts' = opts{ writerVariables = + defField "table-of-contents" renderedTOC + $ writerVariables opts } + entries <- mapM (chunkToEntry opts' meta topChunk) (topChunk : chunks) + let sitemap = toEntry "sitemap.json" epochtime + (encode $ toJSON $ tocTreeToContext tocTree) + let archive = foldr addEntryToArchive emptyArchive + (sitemap : entries ++ mediaEntries) + return $ fromArchive archive + + +addMedia :: PandocMonad m => Inline -> m Inline +addMedia il@(Image _ _ (src,_)) + | fp <- normalise (T.unpack src) + , isRelative fp + , not (".." `isInfixOf` fp) = do + (bs, mbMime) <- fetchItem (T.pack fp) + insertMedia fp mbMime (BL.fromStrict bs) + return il +addMedia il = return il + +buildTOC :: WriterOptions -> Tree SecInfo -> Block +buildTOC opts = tocToList (writerNumberSections opts) (writerTOCDepth opts) + +chunkToEntry :: PandocMonad m + => WriterOptions -> Meta -> Chunk -> Chunk -> m Entry +chunkToEntry opts meta topChunk chunk = do + html <- writeHtml5String opts' (Pandoc meta' blocks) + epochtime <- floor <$> getPOSIXTime + let htmlLBS = BL.fromStrict $ TE.encodeUtf8 html + return $ toEntry (chunkPath chunk) epochtime htmlLBS + where + opts' = opts{ writerVariables = + addContextVars opts' topChunk chunk $ writerVariables opts } + meta' = if chunk == topChunk + then meta + else Meta $ M.fromList [("pagetitle", MetaString + (stringify $ chunkHeading chunk))] + blocks = chunkContents chunk + +tocTreeToContext :: Tree SecInfo -> Context Text +tocTreeToContext (Node secinfo subs) = + Context $ M.fromList + [ ("section", MapVal $ secInfoToContext secinfo) + , ("subsections", ListVal $ map (MapVal . tocTreeToContext) subs) + ] + +secInfoToContext :: SecInfo -> Context Text +secInfoToContext sec = + Context $ M.fromList + [ ("title", SimpleVal $ literal $ stringify $ secTitle sec) + , ("number", maybe NullVal (SimpleVal . literal) (secNumber sec)) + , ("id", SimpleVal $ literal $ secId sec) + , ("path", SimpleVal $ literal $ secPath sec) + , ("level", SimpleVal $ literal $ tshow $ secLevel sec) + ] + +addContextVars + :: WriterOptions -> Chunk -> Chunk -> Context Text -> Context Text +addContextVars opts topChunk chunk context = + maybe id (defField "next" . navlinks) (chunkNext chunk) + . maybe id (defField "previous" . navlinks) (chunkPrev chunk) + . maybe id (defField "up" . navlinks) (chunkUp chunk) + . maybe id (defField "top" . navlinks) (if chunk == topChunk + then Nothing + else Just topChunk) + . defField "toc" (chunk == topChunk && writerTableOfContents opts) + $ context + where + navlinks ch = toMapVal [("url", formatPath ch), ("title", formatHeading ch)] + toMapVal = MapVal . Context . M.fromList + formatPath = SimpleVal . literal . T.pack . chunkPath + formatHeading ch = SimpleVal . literal . either (const "") id . runPure $ + writeHtml5String opts{ writerTemplate = Nothing } + (Pandoc nullMeta [Plain $ chunkHeading ch]) diff --git a/src/Text/Pandoc/Writers/CommonMark.hs b/src/Text/Pandoc/Writers/CommonMark.hs --- a/src/Text/Pandoc/Writers/CommonMark.hs +++ b/src/Text/Pandoc/Writers/CommonMark.hs @@ -1,6 +1,6 @@ {- | Module : Text.Pandoc.Writers.CommonMark - Copyright : Copyright (C) 2015-2022 John MacFarlane + Copyright : Copyright (C) 2015-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane @@ -14,4 +14,3 @@ module Text.Pandoc.Writers.CommonMark (writeCommonMark) where import Text.Pandoc.Writers.Markdown (writeCommonMark) - diff --git a/src/Text/Pandoc/Writers/ConTeXt.hs b/src/Text/Pandoc/Writers/ConTeXt.hs --- a/src/Text/Pandoc/Writers/ConTeXt.hs +++ b/src/Text/Pandoc/Writers/ConTeXt.hs @@ -4,7 +4,7 @@ {-# LANGUAGE ViewPatterns #-} {- | Module : Text.Pandoc.Writers.ConTeXt - Copyright : Copyright (C) 2007-2022 John MacFarlane + Copyright : Copyright (C) 2007-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane @@ -14,37 +14,47 @@ Conversion of 'Pandoc' format into ConTeXt. -} module Text.Pandoc.Writers.ConTeXt ( writeConTeXt ) where +import Control.Monad (liftM, unless) import Control.Monad.State.Strict + ( StateT, MonadState(put, get), gets, modify, evalStateT ) import Data.Char (ord, isDigit) import Data.List (intersperse) import Data.List.NonEmpty (NonEmpty ((:|))) -import Data.Maybe (mapMaybe, catMaybes) +import Data.Maybe (isNothing, mapMaybe, catMaybes) +import Data.Monoid (Any (Any, getAny)) import Data.Text (Text) import qualified Data.Text as T import Network.URI (unEscapeString) import Text.Collate.Lang (Lang(..)) import Text.Pandoc.Class.PandocMonad (PandocMonad, report, toLang) import Text.Pandoc.Definition +import Text.Pandoc.Highlighting + (formatConTeXtBlock, formatConTeXtInline, highlight, styleToConTeXt) import Text.Pandoc.ImageSize import Text.Pandoc.Logging import Text.Pandoc.Options import Text.DocLayout import Text.Pandoc.Shared +import Text.Pandoc.URI (isURI) import Text.Pandoc.Templates (renderTemplate) import Text.Pandoc.Walk (query) import Text.Pandoc.Writers.Shared import Text.Printf (printf) import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Map.Strict as Map import qualified Text.Pandoc.Writers.AnnotatedTable as Ann data WriterState = - WriterState { stNextRef :: Int -- number of next URL reference - , stOrderedListLevel :: Int -- level of ordered list - , stOptions :: WriterOptions -- writer options - , stHasCslRefs :: Bool -- has CSL citations - , stCslHangingIndent :: Bool -- CSL hanging indent - } + WriterState + { stCslHangingIndent :: Bool -- CSL hanging indent + , stHasCslRefs :: Bool -- has CSL citations + , stHighlighting :: Bool -- has syntax-highlighted code blocks + , stNextRef :: Int -- number of next URL reference + , stOptions :: WriterOptions -- writer options + , stOrderedListLevel :: Int -- level of ordered list + , stEmphasisCommands :: Map.Map Text (Doc Text) + } -- | Table type data Tabl = Xtb -- ^ Extreme tables @@ -60,12 +70,15 @@ -- | Convert Pandoc to ConTeXt. writeConTeXt :: PandocMonad m => WriterOptions -> Pandoc -> m Text writeConTeXt options document = - let defaultWriterState = WriterState { stNextRef = 1 - , stOrderedListLevel = 0 - , stOptions = options - , stHasCslRefs = False - , stCslHangingIndent = False - } + let defaultWriterState = WriterState + { stCslHangingIndent = False + , stHasCslRefs = False + , stHighlighting = False + , stNextRef = 1 + , stOptions = options + , stOrderedListLevel = 0 + , stEmphasisCommands = mempty + } in evalStateT (pandocToConTeXt options document) defaultWriterState type WM = StateT WriterState @@ -113,6 +126,12 @@ | all isDigit (d:ds) -> resetField "papersize" (T.pack ('A':d:ds)) _ -> id) + $ defField "emphasis-commands" + (mconcat $ Map.elems (stEmphasisCommands st)) + $ (case writerHighlightStyle options of + Just sty | stHighlighting st -> + defField "highlighting-commands" (styleToConTeXt sty) + _ -> id) $ (case T.toLower $ lookupMetaString "pdfa" meta of "true" -> resetField "pdfa" (T.pack "1b:2005") _ -> id) metadata @@ -165,25 +184,26 @@ -- | Convert Pandoc block element to ConTeXt. blockToConTeXt :: PandocMonad m => Block -> WM m (Doc Text) -blockToConTeXt Null = return empty blockToConTeXt (Div attr@(_,"section":_,_) (Header level _ title' : xs)) = do header' <- sectionHeader attr level title' SectionHeading footer' <- sectionFooter attr level innerContents <- blockListToConTeXt xs return $ header' $$ innerContents $$ footer' -blockToConTeXt (Plain lst) = inlineListToConTeXt lst -blockToConTeXt (SimpleFigure attr txt (src, _)) = do - capt <- inlineListToConTeXt txt - img <- inlineToConTeXt (Image attr txt (src, "")) - let (ident, _, _) = attr - label = if T.null ident - then empty - else "[]" <> brackets (literal $ toLabel ident) - return $ blankline $$ "\\placefigure" <> label <> braces capt <> img <> blankline +blockToConTeXt (Plain lst) = do + opts <- gets stOptions + contents <- inlineListToConTeXt lst + return $ + if isEnabled Ext_tagging opts + then "\\bpar{}" <> contents <> "\\epar{}" + else contents blockToConTeXt (Para lst) = do + opts <- gets stOptions contents <- inlineListToConTeXt lst - return $ contents <> blankline + return $ + if isEnabled Ext_tagging opts + then "\\bpar" $$ contents $$ "\\epar" <> blankline + else contents <> blankline blockToConTeXt (LineBlock lns) = do let emptyToBlankline doc = if isEmpty doc then blankline @@ -194,9 +214,25 @@ blockToConTeXt (BlockQuote lst) = do contents <- blockListToConTeXt lst return $ "\\startblockquote" $$ nest 0 contents $$ "\\stopblockquote" <> blankline -blockToConTeXt (CodeBlock _ str) = - return $ flush ("\\starttyping" <> cr <> literal str <> cr <> "\\stoptyping") $$ blankline +blockToConTeXt (CodeBlock (_ident, classes, kv) str) = do + opts <- gets stOptions + let syntaxMap = writerSyntaxMap opts + let attr' = ("", classes, kv) + let unhighlighted = vcat ["\\starttyping", literal str, "\\stoptyping"] + let highlighted = + case highlight syntaxMap formatConTeXtBlock attr' str of + Left msg -> do + unless (T.null msg) $ + report (CouldNotHighlight msg) + return unhighlighted + Right h -> do + modify (\s -> s{ stHighlighting = True }) + return (literal h) -- blankline because \stoptyping can't have anything after it, inc. '}' + ($$ blankline) . flush <$> + if null classes || isNothing (writerHighlightStyle opts) + then pure unhighlighted + else highlighted blockToConTeXt b@(RawBlock f str) | f == Format "context" || f == Format "tex" = return $ literal str <> blankline | otherwise = empty <$ report (BlockNotRendered b) @@ -264,7 +300,25 @@ sectionHeader attr level lst NonSectionHeading blockToConTeXt (Table attr caption colspecs thead tbody tfoot) = tableToConTeXt (Ann.toTable attr caption colspecs thead tbody tfoot) +blockToConTeXt (Figure (ident, _, _) (Caption cshort clong) body) = do + title <- inlineListToConTeXt (blocksToInlines clong) + list <- maybe (pure empty) inlineListToConTeXt cshort + content <- blockListToConTeXt body + let options = + ["reference=" <> literal (toLabel ident) | not (T.null ident)] + ++ ["title=" <> braces title | not (isEmpty title)] + ++ ["list=" <> braces list | not (isEmpty list)] + let hasSubfigures = getAny $ + query (Any . \case {Figure {} -> True; _ -> False}) body + return + $ "\\startplacefigure" <> brackets (mconcat $ intersperse "," options) + $$ (if hasSubfigures then "\\startfloatcombination" else empty) + $$ content + $$ (if hasSubfigures then "\\stopfloatcombination" else empty) + $$ "\\stopplacefigure" + $$ blankline + tableToConTeXt :: PandocMonad m => Ann.Table -> WM m (Doc Text) tableToConTeXt (Ann.Table attr caption colspecs thead tbodies tfoot) = do opts <- gets stOptions @@ -309,9 +363,9 @@ ] setupCols :: [ColSpec] -> Doc Text -setupCols = vcat . map toColSetup . zip [1::Int ..] +setupCols = vcat . zipWith toColSetup [1::Int ..] where - toColSetup (i, (align, width)) = + toColSetup i (align, width) = let opts = filter (not . isEmpty) [ case align of AlignLeft -> "align=right" @@ -512,19 +566,31 @@ isSpacey (Str (T.uncons -> Just ('\160',_))) = True isSpacey _ = False +highlightInlines :: PandocMonad m + => Text -> (Doc Text) -> [Inline] + -> WM m (Doc Text) +highlightInlines name style inlines = do + opts <- gets stOptions + contents <- inlineListToConTeXt inlines + if not (isEnabled Ext_tagging opts) + then return $ braces (style <> space <> contents) + else do + let cmd = "\\definehighlight " <> brackets (literal name) <> + brackets ("style=" <> braces style) + modify (\st -> st{ stEmphasisCommands = + Map.insert name cmd (stEmphasisCommands st) }) + return $ "\\" <> literal name <> braces contents + -- | Convert inline element to ConTeXt inlineToConTeXt :: PandocMonad m => Inline -- ^ Inline to convert -> WM m (Doc Text) -inlineToConTeXt (Emph lst) = do - contents <- inlineListToConTeXt lst - return $ braces $ "\\em " <> contents +inlineToConTeXt (Emph lst) = highlightInlines "emph" "\\em" lst +inlineToConTeXt (Strong lst) = highlightInlines "strong" "\\bf" lst +inlineToConTeXt (SmallCaps lst) = highlightInlines "smallcaps" "\\sc" lst inlineToConTeXt (Underline lst) = do contents <- inlineListToConTeXt lst return $ "\\underbar" <> braces contents -inlineToConTeXt (Strong lst) = do - contents <- inlineListToConTeXt lst - return $ braces $ "\\bf " <> contents inlineToConTeXt (Strikeout lst) = do contents <- inlineListToConTeXt lst return $ "\\overstrikes" <> braces contents @@ -534,14 +600,31 @@ inlineToConTeXt (Subscript lst) = do contents <- inlineListToConTeXt lst return $ "\\low" <> braces contents -inlineToConTeXt (SmallCaps lst) = do - contents <- inlineListToConTeXt lst - return $ braces $ "\\sc " <> contents -inlineToConTeXt (Code _ str) | not ('{' `elemText` str || '}' `elemText` str) = - return $ "\\type" <> braces (literal str) -inlineToConTeXt (Code _ str) = do +inlineToConTeXt (Code (_ident, classes, _kv) str) = do + let rawCode = + pure . literal $ + case typeDelim str of + Just (open, close) -> + "\\type" <> (open `T.cons` str) `T.snoc` close + Nothing -> + "\\type[escape=yes]{" <> + (T.replace "{" "/BTEX\\letteropenbrace /ETEX" . + T.replace "}" "/BTEX\\letterclosebrace /ETEX" $ + str) `T.snoc` '}' opts <- gets stOptions - return $ "\\mono" <> braces (literal $ stringToConTeXt opts str) + let syntaxMap = writerSyntaxMap opts + let attr' = ("", classes, []) + let highlightCode = + case highlight syntaxMap formatConTeXtInline attr' str of + Left msg -> do + unless (T.null msg) $ report (CouldNotHighlight msg) + rawCode + Right h -> do + modify (\st -> st{ stHighlighting = True }) + return (text (T.unpack h)) + if isNothing (writerHighlightStyle opts) || null classes + then rawCode + else highlightCode inlineToConTeXt (Quoted SingleQuote lst) = do contents <- inlineListToConTeXt lst return $ "\\quote" <> braces contents @@ -661,20 +744,18 @@ opts <- gets stOptions contents <- inlineListToConTeXt lst levelText <- sectionLevelToText opts (ident,classes,kvs) hdrLevel secenv - let ident' = if T.null ident - then empty - else "reference=" <> braces (literal (toLabel ident)) - let contents' = if isEmpty contents - then empty - else "title=" <> braces contents - let options = if isEmpty keys || isEmpty levelText - then empty - else brackets keys - where keys = hcat $ intersperse "," $ - filter (not . isEmpty) [contents', ident'] + let optsList = mconcat . filter (not . null) $ + [ ["title=" <> braces contents | not (isEmpty contents)] + , ["reference=" <> braces (literal (toLabel ident)) | not (T.null ident)] + , ["number=no" | "unnumbered" `elem` classes] + , ["incrementnumber=no" | "unnumbered" `elem` classes] + ] let starter = case secenv of SectionHeading -> "\\start" NonSectionHeading -> "\\" + let options = if null optsList || isEmpty levelText + then empty + else brackets $ hcat (intersperse "," optsList) return $ starter <> levelText <> options <> blankline -- | Craft the section footer @@ -689,8 +770,9 @@ => WriterOptions -> Attr -> Int -> HeadingType -> WM m (Doc Text) sectionLevelToText opts (_,classes,_) hdrLevel headingType = do + let unlisted = "unlisted" `elem` classes let semanticSection shift = do - let (section, chapter) = if "unnumbered" `elem` classes + let (section, chapter) = if unlisted then (literal "subject", literal "title") else (literal "section", literal "chapter") return $ case hdrLevel + shift of @@ -704,10 +786,23 @@ TopLevelPart -> semanticSection (-2) TopLevelChapter -> semanticSection (-1) TopLevelSection -> semanticSection 0 - TopLevelDefault -> return . literal $ - case headingType of - SectionHeading -> "sectionlevel" - NonSectionHeading -> "" + TopLevelDefault -> if unlisted + then semanticSection 0 + else return . literal $ + case headingType of + SectionHeading -> "sectionlevel" + NonSectionHeading -> "" + +-- | Finds a pair of symbols that can be used as delimiters. +typeDelim :: Text -> Maybe (Char, Char) +typeDelim t = + let delimChars = "{\"'`()-+=%,.:;" + go delims '}' = go delims '{' + go delims c = T.filter (/= c) delims + in case fmap fst . T.uncons $ T.foldl' go delimChars t of + Just '{' -> Just ('{', '}') + Just c -> Just (c, c) + Nothing -> Nothing fromBCP47 :: PandocMonad m => Maybe Text -> WM m (Maybe Text) fromBCP47 mbs = fromBCP47' <$> toLang mbs diff --git a/src/Text/Pandoc/Writers/CslJson.hs b/src/Text/Pandoc/Writers/CslJson.hs --- a/src/Text/Pandoc/Writers/CslJson.hs +++ b/src/Text/Pandoc/Writers/CslJson.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Writers.CslJson - Copyright : Copyright (C) 2020-2022 John MacFarlane + Copyright : Copyright (C) 2020-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane diff --git a/src/Text/Pandoc/Writers/Custom.hs b/src/Text/Pandoc/Writers/Custom.hs deleted file mode 100644 --- a/src/Text/Pandoc/Writers/Custom.hs +++ /dev/null @@ -1,58 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{- | - Module : Text.Pandoc.Writers.Custom - Copyright : 2012-2022 John MacFarlane, - License : GNU GPL, version 2 or above - Maintainer : John MacFarlane - -Conversion of 'Pandoc' documents to custom markup using -a Lua writer. --} -module Text.Pandoc.Writers.Custom ( writeCustom ) where -import Control.Exception -import Control.Monad ((<=<)) -import Data.Maybe (fromMaybe) -import Data.Text (Text) -import HsLua -import Control.Monad.IO.Class (MonadIO) -import Text.Pandoc.Class (PandocMonad, findFileWithDataFallback) -import Text.Pandoc.Definition (Pandoc (..)) -import Text.Pandoc.Lua (Global (..), runLua, setGlobals) -import Text.Pandoc.Options (WriterOptions) - -import qualified Text.Pandoc.Lua.Writer.Classic as Classic - --- | Convert Pandoc to custom markup. -writeCustom :: (PandocMonad m, MonadIO m) - => FilePath -> WriterOptions -> Pandoc -> m Text -writeCustom luaFile opts doc = do - luaFile' <- fromMaybe luaFile <$> findFileWithDataFallback "writers" luaFile - either throw pure <=< runLua $ do - setGlobals [ PANDOC_DOCUMENT doc - , PANDOC_SCRIPT_FILE luaFile' - , PANDOC_WRITER_OPTIONS opts - ] - dofileTrace luaFile' >>= \case - OK -> pure () - _ -> throwErrorAsException - -- Most classic writers contain code that throws an error if a global - -- is not present. This would break our check for the existence of a - -- "Writer" function. We resort to raw access for that reason, but - -- could also catch the error instead. - let rawgetglobal x = do - pushglobaltable - pushName x - rawget (nth 2) <* remove (nth 2) -- remove global table - - rawgetglobal "Writer" >>= \case - TypeNil -> do - pop 1 -- remove nil - Classic.runCustom opts doc - _ -> do - -- Writer on top of the stack. Call it with document and writer - -- options as arguments. - push doc - push opts - callTrace 2 1 - forcePeek $ peekText top diff --git a/src/Text/Pandoc/Writers/DocBook.hs b/src/Text/Pandoc/Writers/DocBook.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/Writers/DocBook.hs @@ -0,0 +1,542 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} +{- | + Module : Text.Pandoc.Writers.DocBook + Copyright : Copyright (C) 2006-2023 John MacFarlane + License : GNU GPL, version 2 or above + + Maintainer : John MacFarlane + Stability : alpha + Portability : portable + +Conversion of 'Pandoc' documents to DocBook XML. +-} +module Text.Pandoc.Writers.DocBook ( writeDocBook4, writeDocBook5 ) where +import Control.Monad.Reader +import Data.Generics (everywhere, mkT) +import Data.List (nub, partition) +import Data.Maybe (isNothing) +import Data.Monoid (All (..), Any (..)) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Text.Pandoc.Builder as B +import Text.Pandoc.Class.PandocMonad (PandocMonad, report) +import Text.Pandoc.Definition +import Text.Pandoc.Highlighting (languages, languagesByExtension) +import Text.Pandoc.ImageSize +import Text.Pandoc.Logging +import Text.Pandoc.Options +import Text.DocLayout +import Text.Pandoc.Shared +import Text.Pandoc.URI +import Text.Pandoc.Templates (renderTemplate) +import Text.Pandoc.Writers.Shared +import Text.Pandoc.Walk +import Text.Pandoc.Writers.Math +import Text.Pandoc.XML +import Text.TeXMath +import qualified Text.XML.Light as Xml + +data DocBookVersion = DocBook4 | DocBook5 + deriving (Eq, Show) + +type DB = ReaderT DocBookVersion + +-- | Get level of the top-level headers based on the configured top-level division. +-- The header level can then be used to determine appropriate DocBook element +-- for each subdivision associated with a header. +-- The numbering here follows LaTeX's internal numbering +getStartLvl :: WriterOptions -> Int +getStartLvl opts = + case writerTopLevelDivision opts of + TopLevelPart -> -1 + TopLevelChapter -> 0 + TopLevelSection -> 1 + TopLevelDefault -> 1 + +-- | Get correct name for the id attribute based on DocBook version. +-- DocBook 4 used custom id attribute but DocBook 5 adopted the xml:id specification. +-- https://www.w3.org/TR/xml-id/ +idName :: DocBookVersion -> Text +idName DocBook5 = "xml:id" +idName DocBook4 = "id" + +-- | Convert list of authors to a docbook section +authorToDocBook :: PandocMonad m => WriterOptions -> [Inline] -> DB m B.Inlines +authorToDocBook opts name' = do + name <- render Nothing <$> inlinesToDocBook opts name' + let colwidth = if writerWrapText opts == WrapAuto + then Just $ writerColumns opts + else Nothing + return $ B.rawInline "docbook" $ + render colwidth $ inTags True "personname" [] $ + if T.any (== ',') name + then -- last name first + let (lastname, rest) = T.break (==',') name + firstname = triml rest in + inTagsSimple "firstname" (literal $ escapeStringForXML firstname) <> + inTagsSimple "surname" (literal $ escapeStringForXML lastname) + else -- last name last + let namewords = T.words name + lengthname = length namewords + (firstname, lastname) = case lengthname of + 0 -> ("","") + 1 -> ("", name) + n -> (T.unwords (take (n-1) namewords), last namewords) + in inTagsSimple "firstname" (literal $ escapeStringForXML firstname) $$ + inTagsSimple "surname" (literal $ escapeStringForXML lastname) + +writeDocBook4 :: PandocMonad m => WriterOptions -> Pandoc -> m Text +writeDocBook4 opts d = + runReaderT (writeDocBook opts d) DocBook4 + +writeDocBook5 :: PandocMonad m => WriterOptions -> Pandoc -> m Text +writeDocBook5 opts d = + runReaderT (writeDocBook opts d) DocBook5 + +-- | Convert Pandoc document to string in DocBook format. +writeDocBook :: PandocMonad m => WriterOptions -> Pandoc -> DB m Text +writeDocBook opts doc = do + let Pandoc meta blocks = ensureValidXmlIdentifiers doc + let colwidth = if writerWrapText opts == WrapAuto + then Just $ writerColumns opts + else Nothing + let startLvl = getStartLvl opts + let fromBlocks = blocksToDocBook opts . + makeSections False (Just startLvl) + auths' <- mapM (authorToDocBook opts) $ docAuthors meta + let meta' = B.setMeta "author" auths' meta + metadata <- metaToContext opts + fromBlocks + (inlinesToDocBook opts) + meta' + main <- fromBlocks blocks + let context = defField "body" main + $ defField "mathml" (case writerHTMLMathMethod opts of + MathML -> True + _ -> False) metadata + return $ render colwidth $ + (if writerPreferAscii opts then fmap toEntities else id) $ + case writerTemplate opts of + Nothing -> main + Just tpl -> renderTemplate tpl context + +-- | Convert a list of Pandoc blocks to DocBook. +blocksToDocBook :: PandocMonad m => WriterOptions -> [Block] -> DB m (Doc Text) +blocksToDocBook opts = fmap vcat . mapM (blockToDocBook opts) + +-- | Auxiliary function to convert Plain block to Para. +plainToPara :: Block -> Block +plainToPara (Plain x) = Para x +plainToPara x = x + +-- | Convert a list of pairs of terms and definitions into a list of +-- DocBook varlistentrys. +deflistItemsToDocBook :: PandocMonad m + => WriterOptions -> [([Inline],[[Block]])] + -> DB m (Doc Text) +deflistItemsToDocBook opts items = + vcat <$> mapM (uncurry (deflistItemToDocBook opts)) items + +-- | Convert a term and a list of blocks into a DocBook varlistentry. +deflistItemToDocBook :: PandocMonad m + => WriterOptions -> [Inline] -> [[Block]] + -> DB m (Doc Text) +deflistItemToDocBook opts term defs = do + term' <- inlinesToDocBook opts term + def' <- blocksToDocBook opts $ concatMap (map plainToPara) defs + return $ inTagsIndented "varlistentry" $ + inTagsIndented "term" term' $$ + inTagsIndented "listitem" def' + +-- | Convert a list of lists of blocks to a list of DocBook list items. +listItemsToDocBook :: PandocMonad m + => WriterOptions -> [[Block]] -> DB m (Doc Text) +listItemsToDocBook opts items = vcat <$> mapM (listItemToDocBook opts) items + +-- | Convert a list of blocks into a DocBook list item. +listItemToDocBook :: PandocMonad m + => WriterOptions -> [Block] -> DB m (Doc Text) +listItemToDocBook opts item = + inTagsIndented "listitem" <$> blocksToDocBook opts (map plainToPara item) + +imageToDocBook :: WriterOptions -> Attr -> Text -> Doc Text +imageToDocBook _ attr src = selfClosingTag "imagedata" $ + ("fileref", src) : idAndRole attr <> dims + where + dims = go Width "width" <> go Height "depth" + go dir dstr = case dimension dir attr of + Just a -> [(dstr, tshow a)] + Nothing -> [] + +-- | Convert a Pandoc block element to DocBook. +blockToDocBook :: PandocMonad m => WriterOptions -> Block -> DB m (Doc Text) +-- Add ids to paragraphs in divs with ids - this is needed for +-- pandoc-citeproc to get link anchors in bibliographies: +blockToDocBook opts (Div (id',"section":_,_) (Header lvl (_,classes,attrs) ils : xs)) = do + version <- ask + -- DocBook doesn't allow sections with no content, so insert some if needed + let bs = if null xs + then [Para []] + else xs + tag = case lvl of + -1 -> "part" + 0 -> "chapter" + n | n >= 1 && n <= 5 -> if version == DocBook5 + then "section" + else "sect" <> tshow n + _ -> "simplesect" + idAttr = [(idName version, writerIdentifierPrefix opts <> id') | not (T.null id')] + -- We want to add namespaces to the root (top-level) element. + nsAttr = if version == DocBook5 && lvl == getStartLvl opts && isNothing (writerTemplate opts) + -- Though, DocBook 4 does not support namespaces and + -- standalone documents will include them in the template. + then [("xmlns", "http://docbook.org/ns/docbook") + ,("xmlns:xlink", "http://www.w3.org/1999/xlink")] + else [] + + -- Populate miscAttr with Header.Attr.attributes, filtering out non-valid DocBook section attributes, id, and xml:id + -- Also enrich the role attribute with certain class tokens + miscAttr = enrichRole (filter (isSectionAttr version) attrs) classes + attribs = nsAttr <> idAttr <> miscAttr + title' <- inlinesToDocBook opts ils + contents <- blocksToDocBook opts bs + return $ inTags True tag attribs $ inTagsSimple "title" title' $$ contents +blockToDocBook opts (Div (ident,classes,_) bs) = do + version <- ask + let identAttribs = [(idName version, ident) | not (T.null ident)] + admonitions = ["caution","danger","important","note","tip","warning"] + case classes of + (l:_) | l `elem` admonitions -> do + let (mTitleBs, bodyBs) = + case bs of + -- Matches AST produced by the DocBook reader → Markdown writer → Markdown reader chain. + (Div (_,["title"],_) [Para ts] : rest) -> (Just (inlinesToDocBook opts ts), rest) + -- Matches AST produced by the DocBook reader. + (Div (_,["title"],_) ts : rest) -> (Just (blocksToDocBook opts ts), rest) + _ -> (Nothing, bs) + admonitionTitle <- case mTitleBs of + Nothing -> return mempty + -- id will be attached to the admonition so let’s pass empty identAttrs. + Just titleBs -> inTagsSimple "title" <$> titleBs + admonitionBody <- handleDivBody [] bodyBs + return (inTags True l identAttribs (admonitionTitle $$ admonitionBody)) + _ -> handleDivBody identAttribs bs + where + handleDivBody identAttribs [Para lst] = + if hasLineBreaks lst + then flush . nowrap . inTags False "literallayout" identAttribs + <$> inlinesToDocBook opts lst + else inTags True "para" identAttribs <$> inlinesToDocBook opts lst + handleDivBody identAttribs bodyBs = do + contents <- blocksToDocBook opts (map plainToPara bodyBs) + return $ + (if null identAttribs + then mempty + else selfClosingTag "anchor" identAttribs) $$ contents +blockToDocBook _ h@Header{} = do + -- should be handled by Div section above, except inside lists/blockquotes + report $ BlockNotRendered h + return empty +blockToDocBook opts (Plain lst) = inlinesToDocBook opts lst +blockToDocBook opts (Para lst) + | hasLineBreaks lst = flush . nowrap . inTagsSimple "literallayout" + <$> inlinesToDocBook opts lst + | otherwise = inTagsIndented "para" <$> inlinesToDocBook opts lst +blockToDocBook opts (LineBlock lns) = + blockToDocBook opts $ linesToPara lns +blockToDocBook opts (BlockQuote blocks) = + inTagsIndented "blockquote" <$> blocksToDocBook opts blocks +blockToDocBook opts (CodeBlock (_,classes,_) str) = return $ + literal (" lang <> ">") <> cr <> + flush (literal (escapeStringForXML str) <> cr <> literal "") + where lang = if null langs + then "" + else " language=\"" <> escapeStringForXML (head langs) <> + "\"" + syntaxMap = writerSyntaxMap opts + isLang l = T.toLower l `elem` map T.toLower (languages syntaxMap) + langsFrom s = if isLang s + then [s] + else (languagesByExtension syntaxMap) . T.toLower $ s + langs = concatMap langsFrom classes +blockToDocBook opts (BulletList lst) = do + let attribs = [("spacing", "compact") | isTightList lst] + inTags True "itemizedlist" attribs <$> listItemsToDocBook opts lst +blockToDocBook _ (OrderedList _ []) = return empty +blockToDocBook opts (OrderedList (start, numstyle, _) (first:rest)) = do + let numeration = case numstyle of + DefaultStyle -> [] + Decimal -> [("numeration", "arabic")] + Example -> [("numeration", "arabic")] + UpperAlpha -> [("numeration", "upperalpha")] + LowerAlpha -> [("numeration", "loweralpha")] + UpperRoman -> [("numeration", "upperroman")] + LowerRoman -> [("numeration", "lowerroman")] + spacing = [("spacing", "compact") | isTightList (first:rest)] + attribs = numeration <> spacing + items <- if start == 1 + then listItemsToDocBook opts (first:rest) + else do + first' <- blocksToDocBook opts (map plainToPara first) + rest' <- listItemsToDocBook opts rest + return $ + inTags True "listitem" [("override",tshow start)] first' $$ + rest' + return $ inTags True "orderedlist" attribs items +blockToDocBook opts (DefinitionList lst) = do + let attribs = [("spacing", "compact") | isTightList $ concatMap snd lst] + inTags True "variablelist" attribs <$> deflistItemsToDocBook opts lst +blockToDocBook _ b@(RawBlock f str) + | f == "docbook" = return $ literal str -- raw XML block + | f == "html" = do + version <- ask + if version == DocBook5 + then return empty -- No html in DocBook5 + else return $ literal str -- allow html for backwards + -- compatibility + | otherwise = do + report $ BlockNotRendered b + return empty +blockToDocBook _ HorizontalRule = return empty -- not semantic +blockToDocBook opts (Table _ blkCapt specs thead tbody tfoot) = do + let (caption, aligns, widths, headers, rows) = + toLegacyTable blkCapt specs thead tbody tfoot + captionDoc <- if null caption + then return empty + else inTagsSimple "title" <$> + inlinesToDocBook opts caption + let tableType = if isEmpty captionDoc then "informaltable" else "table" + percent w = tshow (truncate (100*w) :: Integer) <> "*" + coltags = vcat $ zipWith (\w al -> selfClosingTag "colspec" + ([("colwidth", percent w) | w > 0] <> + [("align", alignmentToString al)])) widths aligns + head' <- if all null headers + then return empty + else inTagsIndented "thead" <$> tableRowToDocBook opts headers + body' <- inTagsIndented "tbody" . vcat <$> + mapM (tableRowToDocBook opts) rows + return $ inTagsIndented tableType $ captionDoc $$ + inTags True "tgroup" [("cols", tshow (length aligns))] ( + coltags $$ head' $$ body') +blockToDocBook opts (Figure attr capt@(Caption _ caption) body) = do + -- TODO: probably better to handle nested figures as mediaobject + let isAcceptable = \case + Table {} -> All False + Figure {} -> All False + _ -> All True + if not . getAll $ query isAcceptable body + -- Fallback to a div if the content cannot be included in a figure + then blockToDocBook opts $ figureDiv attr capt body + else do + title <- inlinesToDocBook opts (blocksToInlines caption) + let toMediaobject = \case + Plain [Image imgAttr inlns (src, _)] -> do + alt <- inlinesToDocBook opts inlns + pure $ inTagsIndented "mediaobject" ( + inTagsIndented "imageobject" + (imageToDocBook opts imgAttr src) $$ + if isEmpty alt + then empty + else inTagsSimple "textobject" (inTagsSimple "phrase" alt)) + _ -> ask >>= \case + DocBook4 -> pure mempty -- docbook4 requires media + DocBook5 -> blocksToDocBook opts body + mediaobjects <- mapM toMediaobject body + return $ + if isEmpty $ mconcat mediaobjects + then mempty -- figures must have at least some content + else inTagsIndented "figure" $ + inTagsSimple "title" title $$ + mconcat mediaobjects + +hasLineBreaks :: [Inline] -> Bool +hasLineBreaks = getAny . query isLineBreak . walk removeNote + where + removeNote :: Inline -> Inline + removeNote (Note _) = Str "" + removeNote x = x + isLineBreak :: Inline -> Any + isLineBreak LineBreak = Any True + isLineBreak _ = Any False + +alignmentToString :: Alignment -> Text +alignmentToString alignment = case alignment of + AlignLeft -> "left" + AlignRight -> "right" + AlignCenter -> "center" + AlignDefault -> "left" + +tableRowToDocBook :: PandocMonad m + => WriterOptions + -> [[Block]] + -> DB m (Doc Text) +tableRowToDocBook opts cols = + inTagsIndented "row" . vcat <$> mapM (tableItemToDocBook opts) cols + +tableItemToDocBook :: PandocMonad m + => WriterOptions + -> [Block] + -> DB m (Doc Text) +tableItemToDocBook opts item = + inTags True "entry" [] . vcat <$> mapM (blockToDocBook opts) item + +-- | Convert a list of inline elements to DocBook. +inlinesToDocBook :: PandocMonad m => WriterOptions -> [Inline] -> DB m (Doc Text) +inlinesToDocBook opts lst = hcat <$> mapM (inlineToDocBook opts) lst + +-- | Convert an inline element to DocBook. +inlineToDocBook :: PandocMonad m => WriterOptions -> Inline -> DB m (Doc Text) +inlineToDocBook _ (Str str) = return $ literal $ escapeStringForXML str +inlineToDocBook opts (Emph lst) = + inTagsSimple "emphasis" <$> inlinesToDocBook opts lst +inlineToDocBook opts (Underline lst) = + inTags False "emphasis" [("role", "underline")] <$> inlinesToDocBook opts lst +inlineToDocBook opts (Strong lst) = + inTags False "emphasis" [("role", "strong")] <$> inlinesToDocBook opts lst +inlineToDocBook opts (Strikeout lst) = + inTags False "emphasis" [("role", "strikethrough")] <$> + inlinesToDocBook opts lst +inlineToDocBook opts (Superscript lst) = + inTagsSimple "superscript" <$> inlinesToDocBook opts lst +inlineToDocBook opts (Subscript lst) = + inTagsSimple "subscript" <$> inlinesToDocBook opts lst +inlineToDocBook opts (SmallCaps lst) = + inTags False "emphasis" [("role", "smallcaps")] <$> + inlinesToDocBook opts lst +inlineToDocBook opts (Quoted _ lst) = + inTagsSimple "quote" <$> inlinesToDocBook opts lst +inlineToDocBook opts (Cite _ lst) = + inlinesToDocBook opts lst +inlineToDocBook opts (Span (ident,_,_) ils) = do + version <- ask + ((if T.null ident + then mempty + else selfClosingTag "anchor" [(idName version, ident)]) <>) <$> + inlinesToDocBook opts ils +inlineToDocBook _ (Code _ str) = + return $ inTagsSimple "literal" $ literal (escapeStringForXML str) +inlineToDocBook opts (Math t str) + | isMathML (writerHTMLMathMethod opts) = do + res <- convertMath writeMathML t str + case res of + Right r -> return $ inTagsSimple tagtype + $ literal $ T.pack $ Xml.ppcElement conf + $ fixNS + $ removeAttr r + Left il -> inlineToDocBook opts il + | otherwise = + texMathToInlines t str >>= inlinesToDocBook opts + where tagtype = case t of + InlineMath -> "inlineequation" + DisplayMath -> "informalequation" + conf = Xml.useShortEmptyTags (const False) Xml.defaultConfigPP + removeAttr e = e{ Xml.elAttribs = [] } + fixNS' qname = qname{ Xml.qPrefix = Just "mml" } + fixNS = everywhere (mkT fixNS') +inlineToDocBook _ il@(RawInline f x) + | f == "html" || f == "docbook" = return $ literal x + | otherwise = do + report $ InlineNotRendered il + return empty +inlineToDocBook _ LineBreak = return $ literal "\n" +-- currently ignore, would require the option to add custom +-- styles to the document +inlineToDocBook _ Space = return space +-- because we use \n for LineBreak, we can't do soft breaks: +inlineToDocBook _ SoftBreak = return space +inlineToDocBook opts (Link attr txt (src, _)) + | Just email <- T.stripPrefix "mailto:" src = + let emailLink = inTagsSimple "email" $ literal $ + escapeStringForXML email + in case txt of + [Str s] | escapeURI s == email -> return emailLink + _ -> do contents <- inlinesToDocBook opts txt + return $ contents <+> + char '(' <> emailLink <> char ')' + | otherwise = do + version <- ask + (if "#" `T.isPrefixOf` src + then let tag = if null txt then "xref" else "link" + in inTags False tag $ + ("linkend", writerIdentifierPrefix opts <> T.drop 1 src) : + idAndRole attr + else if version == DocBook5 + then inTags False "link" $ ("xlink:href", src) : idAndRole attr + else inTags False "ulink" $ ("url", src) : idAndRole attr ) + <$> inlinesToDocBook opts txt +inlineToDocBook opts (Image attr ils (src, tit)) = return $ + let titleDoc = if T.null tit + then empty + else inTagsIndented "objectinfo" $ + inTagsSimple "title" (literal $ escapeStringForXML tit) + alt = if null ils + then mempty + else inTagsIndented "textobject" $ + inTagsSimple "phrase" $ literal (stringify ils) + in inTagsIndented "inlinemediaobject" $ + inTagsIndented "imageobject" + (titleDoc $$ imageToDocBook opts attr src) + $$ alt +inlineToDocBook opts (Note contents) = + inTagsIndented "footnote" <$> blocksToDocBook opts contents + +isMathML :: HTMLMathMethod -> Bool +isMathML MathML = True +isMathML _ = False + +idAndRole :: Attr -> [(Text, Text)] +idAndRole (id',cls,_) = ident <> role + where + ident = [("id", id') | not (T.null id')] + role = [("role", T.unwords cls) | not (null cls)] + +-- Used in blockToDocBook for Header (section) to create or extend +-- the role attribute with candidate class tokens +enrichRole :: [(Text, Text)] -> [Text] -> [(Text, Text)] +enrichRole mattrs cls = [("role", T.unwords roles) | roles /= []] <> nonRole + where + (roleAttr, nonRole) = partition (\(key, _v) -> key == "role") mattrs + roles = nub $ filter (`elem` cand) cls <> map snd roleAttr + cand = ["unnumbered"] + +isSectionAttr :: DocBookVersion -> (Text, Text) -> Bool +isSectionAttr _ ("label",_) = True +isSectionAttr _ ("status",_) = True +isSectionAttr DocBook5 ("annotations",_) = True +isSectionAttr DocBook5 ("dir","ltr") = True +isSectionAttr DocBook5 ("dir","rtl") = True +isSectionAttr DocBook5 ("dir","lro") = True +isSectionAttr DocBook5 ("dir","rlo") = True +isSectionAttr _ ("remap",_) = True +isSectionAttr _ ("revisionflag","changed") = True +isSectionAttr _ ("revisionflag","added") = True +isSectionAttr _ ("revisionflag","deleted") = True +isSectionAttr _ ("revisionflag","off") = True +isSectionAttr _ ("role",_) = True +isSectionAttr DocBook5 ("version",_) = True +isSectionAttr DocBook5 ("xml:base",_) = True +isSectionAttr DocBook5 ("xml:lang",_) = True +isSectionAttr _ ("xreflabel",_) = True +isSectionAttr DocBook5 ("linkend",_) = True +isSectionAttr DocBook5 ("linkends",_) = True +isSectionAttr DocBook5 ("xlink:actuate",_) = True +isSectionAttr DocBook5 ("xlink:arcrole",_) = True +isSectionAttr DocBook5 ("xlink:from",_) = True +isSectionAttr DocBook5 ("xlink:href",_) = True +isSectionAttr DocBook5 ("xlink:label",_) = True +isSectionAttr DocBook5 ("xlink:role",_) = True +isSectionAttr DocBook5 ("xlink:show",_) = True +isSectionAttr DocBook5 ("xlink:title",_) = True +isSectionAttr DocBook5 ("xlink:to",_) = True +isSectionAttr DocBook5 ("xlink:type",_) = True +isSectionAttr DocBook4 ("arch",_) = True +isSectionAttr DocBook4 ("condition",_) = True +isSectionAttr DocBook4 ("conformance",_) = True +isSectionAttr DocBook4 ("lang",_) = True +isSectionAttr DocBook4 ("os",_) = True +isSectionAttr DocBook4 ("revision",_) = True +isSectionAttr DocBook4 ("security",_) = True +isSectionAttr DocBook4 ("vendor",_) = True +isSectionAttr _ (_,_) = False diff --git a/src/Text/Pandoc/Writers/Docbook.hs b/src/Text/Pandoc/Writers/Docbook.hs deleted file mode 100644 --- a/src/Text/Pandoc/Writers/Docbook.hs +++ /dev/null @@ -1,498 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternGuards #-} -{- | - Module : Text.Pandoc.Writers.Docbook - Copyright : Copyright (C) 2006-2022 John MacFarlane - License : GNU GPL, version 2 or above - - Maintainer : John MacFarlane - Stability : alpha - Portability : portable - -Conversion of 'Pandoc' documents to Docbook XML. --} -module Text.Pandoc.Writers.Docbook ( writeDocbook4, writeDocbook5 ) where -import Control.Monad.Reader -import Data.Generics (everywhere, mkT) -import Data.Maybe (isNothing) -import Data.Monoid (Any (..)) -import Data.Text (Text) -import qualified Data.Text as T -import qualified Text.Pandoc.Builder as B -import Text.Pandoc.Class.PandocMonad (PandocMonad, report) -import Text.Pandoc.Definition -import Text.Pandoc.Highlighting (languages, languagesByExtension) -import Text.Pandoc.ImageSize -import Text.Pandoc.Logging -import Text.Pandoc.Options -import Text.DocLayout -import Text.Pandoc.Shared -import Text.Pandoc.Templates (renderTemplate) -import Text.Pandoc.Writers.Shared -import Text.Pandoc.Walk -import Text.Pandoc.Writers.Math -import Text.Pandoc.XML -import Text.TeXMath -import qualified Text.XML.Light as Xml - -data DocBookVersion = DocBook4 | DocBook5 - deriving (Eq, Show) - -type DB = ReaderT DocBookVersion - --- | Get level of the top-level headers based on the configured top-level division. --- The header level can then be used to determine appropriate DocBook element --- for each subdivision associated with a header. --- The numbering here follows LaTeX's internal numbering -getStartLvl :: WriterOptions -> Int -getStartLvl opts = - case writerTopLevelDivision opts of - TopLevelPart -> -1 - TopLevelChapter -> 0 - TopLevelSection -> 1 - TopLevelDefault -> 1 - --- | Get correct name for the id attribute based on DocBook version. --- DocBook 4 used custom id attribute but DocBook 5 adopted the xml:id specification. --- https://www.w3.org/TR/xml-id/ -idName :: DocBookVersion -> Text -idName DocBook5 = "xml:id" -idName DocBook4 = "id" - --- | Convert list of authors to a docbook section -authorToDocbook :: PandocMonad m => WriterOptions -> [Inline] -> DB m B.Inlines -authorToDocbook opts name' = do - name <- render Nothing <$> inlinesToDocbook opts name' - let colwidth = if writerWrapText opts == WrapAuto - then Just $ writerColumns opts - else Nothing - return $ B.rawInline "docbook" $ - render colwidth $ inTags True "personname" [] $ - if T.any (== ',') name - then -- last name first - let (lastname, rest) = T.break (==',') name - firstname = triml rest in - inTagsSimple "firstname" (literal $ escapeStringForXML firstname) <> - inTagsSimple "surname" (literal $ escapeStringForXML lastname) - else -- last name last - let namewords = T.words name - lengthname = length namewords - (firstname, lastname) = case lengthname of - 0 -> ("","") - 1 -> ("", name) - n -> (T.unwords (take (n-1) namewords), last namewords) - in inTagsSimple "firstname" (literal $ escapeStringForXML firstname) $$ - inTagsSimple "surname" (literal $ escapeStringForXML lastname) - -writeDocbook4 :: PandocMonad m => WriterOptions -> Pandoc -> m Text -writeDocbook4 opts d = - runReaderT (writeDocbook opts d) DocBook4 - -writeDocbook5 :: PandocMonad m => WriterOptions -> Pandoc -> m Text -writeDocbook5 opts d = - runReaderT (writeDocbook opts d) DocBook5 - --- | Convert Pandoc document to string in Docbook format. -writeDocbook :: PandocMonad m => WriterOptions -> Pandoc -> DB m Text -writeDocbook opts doc = do - let Pandoc meta blocks = ensureValidXmlIdentifiers doc - let colwidth = if writerWrapText opts == WrapAuto - then Just $ writerColumns opts - else Nothing - let startLvl = getStartLvl opts - let fromBlocks = blocksToDocbook opts . - makeSections False (Just startLvl) - auths' <- mapM (authorToDocbook opts) $ docAuthors meta - let meta' = B.setMeta "author" auths' meta - metadata <- metaToContext opts - fromBlocks - (inlinesToDocbook opts) - meta' - main <- fromBlocks blocks - let context = defField "body" main - $ defField "mathml" (case writerHTMLMathMethod opts of - MathML -> True - _ -> False) metadata - return $ render colwidth $ - (if writerPreferAscii opts then fmap toEntities else id) $ - case writerTemplate opts of - Nothing -> main - Just tpl -> renderTemplate tpl context - --- | Convert a list of Pandoc blocks to Docbook. -blocksToDocbook :: PandocMonad m => WriterOptions -> [Block] -> DB m (Doc Text) -blocksToDocbook opts = fmap vcat . mapM (blockToDocbook opts) - --- | Auxiliary function to convert Plain block to Para. -plainToPara :: Block -> Block -plainToPara (Plain x) = Para x -plainToPara x = x - --- | Convert a list of pairs of terms and definitions into a list of --- Docbook varlistentrys. -deflistItemsToDocbook :: PandocMonad m - => WriterOptions -> [([Inline],[[Block]])] -> DB m (Doc Text) -deflistItemsToDocbook opts items = - vcat <$> mapM (uncurry (deflistItemToDocbook opts)) items - --- | Convert a term and a list of blocks into a Docbook varlistentry. -deflistItemToDocbook :: PandocMonad m - => WriterOptions -> [Inline] -> [[Block]] -> DB m (Doc Text) -deflistItemToDocbook opts term defs = do - term' <- inlinesToDocbook opts term - def' <- blocksToDocbook opts $ concatMap (map plainToPara) defs - return $ inTagsIndented "varlistentry" $ - inTagsIndented "term" term' $$ - inTagsIndented "listitem" def' - --- | Convert a list of lists of blocks to a list of Docbook list items. -listItemsToDocbook :: PandocMonad m => WriterOptions -> [[Block]] -> DB m (Doc Text) -listItemsToDocbook opts items = vcat <$> mapM (listItemToDocbook opts) items - --- | Convert a list of blocks into a Docbook list item. -listItemToDocbook :: PandocMonad m => WriterOptions -> [Block] -> DB m (Doc Text) -listItemToDocbook opts item = - inTagsIndented "listitem" <$> blocksToDocbook opts (map plainToPara item) - -imageToDocbook :: WriterOptions -> Attr -> Text -> Doc Text -imageToDocbook _ attr src = selfClosingTag "imagedata" $ - ("fileref", src) : idAndRole attr <> dims - where - dims = go Width "width" <> go Height "depth" - go dir dstr = case dimension dir attr of - Just a -> [(dstr, tshow a)] - Nothing -> [] - --- | Convert a Pandoc block element to Docbook. -blockToDocbook :: PandocMonad m => WriterOptions -> Block -> DB m (Doc Text) -blockToDocbook _ Null = return empty --- Add ids to paragraphs in divs with ids - this is needed for --- pandoc-citeproc to get link anchors in bibliographies: -blockToDocbook opts (Div (id',"section":_,_) (Header lvl (_,_,attrs) ils : xs)) = do - version <- ask - -- Docbook doesn't allow sections with no content, so insert some if needed - let bs = if null xs - then [Para []] - else xs - tag = case lvl of - -1 -> "part" - 0 -> "chapter" - n | n >= 1 && n <= 5 -> if version == DocBook5 - then "section" - else "sect" <> tshow n - _ -> "simplesect" - idAttr = [(idName version, writerIdentifierPrefix opts <> id') | not (T.null id')] - -- We want to add namespaces to the root (top-level) element. - nsAttr = if version == DocBook5 && lvl == getStartLvl opts && isNothing (writerTemplate opts) - -- Though, DocBook 4 does not support namespaces and - -- standalone documents will include them in the template. - then [("xmlns", "http://docbook.org/ns/docbook"),("xmlns:xlink", "http://www.w3.org/1999/xlink")] - else [] - - -- Populate miscAttr with Header.Attr.attributes, filtering out non-valid DocBook section attributes, id, and xml:id - miscAttr = filter (isSectionAttr version) attrs - attribs = nsAttr <> idAttr <> miscAttr - title' <- inlinesToDocbook opts ils - contents <- blocksToDocbook opts bs - return $ inTags True tag attribs $ inTagsSimple "title" title' $$ contents -blockToDocbook opts (Div (ident,classes,_) bs) = do - version <- ask - let identAttribs = [(idName version, ident) | not (T.null ident)] - admonitions = ["caution","danger","important","note","tip","warning"] - case classes of - (l:_) | l `elem` admonitions -> do - let (mTitleBs, bodyBs) = - case bs of - -- Matches AST produced by the DocBook reader → Markdown writer → Markdown reader chain. - (Div (_,["title"],_) [Para ts] : rest) -> (Just (inlinesToDocbook opts ts), rest) - -- Matches AST produced by the Docbook reader. - (Div (_,["title"],_) ts : rest) -> (Just (blocksToDocbook opts ts), rest) - _ -> (Nothing, bs) - admonitionTitle <- case mTitleBs of - Nothing -> return mempty - -- id will be attached to the admonition so let’s pass empty identAttrs. - Just titleBs -> inTags False "title" [] <$> titleBs - admonitionBody <- handleDivBody [] bodyBs - return (inTags True l identAttribs (admonitionTitle $$ admonitionBody)) - _ -> handleDivBody identAttribs bs - where - handleDivBody identAttribs [Para lst] = - if hasLineBreaks lst - then flush . nowrap . inTags False "literallayout" identAttribs - <$> inlinesToDocbook opts lst - else inTags True "para" identAttribs <$> inlinesToDocbook opts lst - handleDivBody identAttribs bodyBs = do - contents <- blocksToDocbook opts (map plainToPara bodyBs) - return $ - (if null identAttribs - then mempty - else selfClosingTag "anchor" identAttribs) $$ contents -blockToDocbook _ h@Header{} = do - -- should be handled by Div section above, except inside lists/blockquotes - report $ BlockNotRendered h - return empty -blockToDocbook opts (Plain lst) = inlinesToDocbook opts lst --- title beginning with fig: indicates that the image is a figure -blockToDocbook opts (SimpleFigure attr txt (src, _)) = do - alt <- inlinesToDocbook opts txt - let capt = if null txt - then empty - else inTagsSimple "title" alt - return $ inTagsIndented "figure" $ - capt $$ - inTagsIndented "mediaobject" ( - inTagsIndented "imageobject" - (imageToDocbook opts attr src) $$ - inTagsSimple "textobject" (inTagsSimple "phrase" alt)) -blockToDocbook opts (Para lst) - | hasLineBreaks lst = flush . nowrap . inTagsSimple "literallayout" - <$> inlinesToDocbook opts lst - | otherwise = inTagsIndented "para" <$> inlinesToDocbook opts lst -blockToDocbook opts (LineBlock lns) = - blockToDocbook opts $ linesToPara lns -blockToDocbook opts (BlockQuote blocks) = - inTagsIndented "blockquote" <$> blocksToDocbook opts blocks -blockToDocbook opts (CodeBlock (_,classes,_) str) = return $ - literal (" lang <> ">") <> cr <> - flush (literal (escapeStringForXML str) <> cr <> literal "") - where lang = if null langs - then "" - else " language=\"" <> escapeStringForXML (head langs) <> - "\"" - syntaxMap = writerSyntaxMap opts - isLang l = T.toLower l `elem` map T.toLower (languages syntaxMap) - langsFrom s = if isLang s - then [s] - else (languagesByExtension syntaxMap) . T.toLower $ s - langs = concatMap langsFrom classes -blockToDocbook opts (BulletList lst) = do - let attribs = [("spacing", "compact") | isTightList lst] - inTags True "itemizedlist" attribs <$> listItemsToDocbook opts lst -blockToDocbook _ (OrderedList _ []) = return empty -blockToDocbook opts (OrderedList (start, numstyle, _) (first:rest)) = do - let numeration = case numstyle of - DefaultStyle -> [] - Decimal -> [("numeration", "arabic")] - Example -> [("numeration", "arabic")] - UpperAlpha -> [("numeration", "upperalpha")] - LowerAlpha -> [("numeration", "loweralpha")] - UpperRoman -> [("numeration", "upperroman")] - LowerRoman -> [("numeration", "lowerroman")] - spacing = [("spacing", "compact") | isTightList (first:rest)] - attribs = numeration <> spacing - items <- if start == 1 - then listItemsToDocbook opts (first:rest) - else do - first' <- blocksToDocbook opts (map plainToPara first) - rest' <- listItemsToDocbook opts rest - return $ - inTags True "listitem" [("override",tshow start)] first' $$ - rest' - return $ inTags True "orderedlist" attribs items -blockToDocbook opts (DefinitionList lst) = do - let attribs = [("spacing", "compact") | isTightList $ concatMap snd lst] - inTags True "variablelist" attribs <$> deflistItemsToDocbook opts lst -blockToDocbook _ b@(RawBlock f str) - | f == "docbook" = return $ literal str -- raw XML block - | f == "html" = do - version <- ask - if version == DocBook5 - then return empty -- No html in Docbook5 - else return $ literal str -- allow html for backwards compatibility - | otherwise = do - report $ BlockNotRendered b - return empty -blockToDocbook _ HorizontalRule = return empty -- not semantic -blockToDocbook opts (Table _ blkCapt specs thead tbody tfoot) = do - let (caption, aligns, widths, headers, rows) = toLegacyTable blkCapt specs thead tbody tfoot - captionDoc <- if null caption - then return empty - else inTagsIndented "title" <$> - inlinesToDocbook opts caption - let tableType = if isEmpty captionDoc then "informaltable" else "table" - percent w = tshow (truncate (100*w) :: Integer) <> "*" - coltags = vcat $ zipWith (\w al -> selfClosingTag "colspec" - ([("colwidth", percent w) | w > 0] <> - [("align", alignmentToString al)])) widths aligns - head' <- if all null headers - then return empty - else inTagsIndented "thead" <$> tableRowToDocbook opts headers - body' <- inTagsIndented "tbody" . vcat <$> - mapM (tableRowToDocbook opts) rows - return $ inTagsIndented tableType $ captionDoc $$ - inTags True "tgroup" [("cols", tshow (length aligns))] ( - coltags $$ head' $$ body') - -hasLineBreaks :: [Inline] -> Bool -hasLineBreaks = getAny . query isLineBreak . walk removeNote - where - removeNote :: Inline -> Inline - removeNote (Note _) = Str "" - removeNote x = x - isLineBreak :: Inline -> Any - isLineBreak LineBreak = Any True - isLineBreak _ = Any False - -alignmentToString :: Alignment -> Text -alignmentToString alignment = case alignment of - AlignLeft -> "left" - AlignRight -> "right" - AlignCenter -> "center" - AlignDefault -> "left" - -tableRowToDocbook :: PandocMonad m - => WriterOptions - -> [[Block]] - -> DB m (Doc Text) -tableRowToDocbook opts cols = - inTagsIndented "row" . vcat <$> mapM (tableItemToDocbook opts) cols - -tableItemToDocbook :: PandocMonad m - => WriterOptions - -> [Block] - -> DB m (Doc Text) -tableItemToDocbook opts item = - inTags True "entry" [] . vcat <$> mapM (blockToDocbook opts) item - --- | Convert a list of inline elements to Docbook. -inlinesToDocbook :: PandocMonad m => WriterOptions -> [Inline] -> DB m (Doc Text) -inlinesToDocbook opts lst = hcat <$> mapM (inlineToDocbook opts) lst - --- | Convert an inline element to Docbook. -inlineToDocbook :: PandocMonad m => WriterOptions -> Inline -> DB m (Doc Text) -inlineToDocbook _ (Str str) = return $ literal $ escapeStringForXML str -inlineToDocbook opts (Emph lst) = - inTagsSimple "emphasis" <$> inlinesToDocbook opts lst -inlineToDocbook opts (Underline lst) = - inTags False "emphasis" [("role", "underline")] <$> inlinesToDocbook opts lst -inlineToDocbook opts (Strong lst) = - inTags False "emphasis" [("role", "strong")] <$> inlinesToDocbook opts lst -inlineToDocbook opts (Strikeout lst) = - inTags False "emphasis" [("role", "strikethrough")] <$> - inlinesToDocbook opts lst -inlineToDocbook opts (Superscript lst) = - inTagsSimple "superscript" <$> inlinesToDocbook opts lst -inlineToDocbook opts (Subscript lst) = - inTagsSimple "subscript" <$> inlinesToDocbook opts lst -inlineToDocbook opts (SmallCaps lst) = - inTags False "emphasis" [("role", "smallcaps")] <$> - inlinesToDocbook opts lst -inlineToDocbook opts (Quoted _ lst) = - inTagsSimple "quote" <$> inlinesToDocbook opts lst -inlineToDocbook opts (Cite _ lst) = - inlinesToDocbook opts lst -inlineToDocbook opts (Span (ident,_,_) ils) = do - version <- ask - ((if T.null ident - then mempty - else selfClosingTag "anchor" [(idName version, ident)]) <>) <$> - inlinesToDocbook opts ils -inlineToDocbook _ (Code _ str) = - return $ inTagsSimple "literal" $ literal (escapeStringForXML str) -inlineToDocbook opts (Math t str) - | isMathML (writerHTMLMathMethod opts) = do - res <- convertMath writeMathML t str - case res of - Right r -> return $ inTagsSimple tagtype - $ literal $ T.pack $ Xml.ppcElement conf - $ fixNS - $ removeAttr r - Left il -> inlineToDocbook opts il - | otherwise = - texMathToInlines t str >>= inlinesToDocbook opts - where tagtype = case t of - InlineMath -> "inlineequation" - DisplayMath -> "informalequation" - conf = Xml.useShortEmptyTags (const False) Xml.defaultConfigPP - removeAttr e = e{ Xml.elAttribs = [] } - fixNS' qname = qname{ Xml.qPrefix = Just "mml" } - fixNS = everywhere (mkT fixNS') -inlineToDocbook _ il@(RawInline f x) - | f == "html" || f == "docbook" = return $ literal x - | otherwise = do - report $ InlineNotRendered il - return empty -inlineToDocbook _ LineBreak = return $ literal "\n" --- currently ignore, would require the option to add custom --- styles to the document -inlineToDocbook _ Space = return space --- because we use \n for LineBreak, we can't do soft breaks: -inlineToDocbook _ SoftBreak = return space -inlineToDocbook opts (Link attr txt (src, _)) - | Just email <- T.stripPrefix "mailto:" src = - let emailLink = inTagsSimple "email" $ literal $ - escapeStringForXML email - in case txt of - [Str s] | escapeURI s == email -> return emailLink - _ -> do contents <- inlinesToDocbook opts txt - return $ contents <+> - char '(' <> emailLink <> char ')' - | otherwise = do - version <- ask - (if "#" `T.isPrefixOf` src - then let tag = if null txt then "xref" else "link" - in inTags False tag $ - ("linkend", writerIdentifierPrefix opts <> T.drop 1 src) : idAndRole attr - else if version == DocBook5 - then inTags False "link" $ ("xlink:href", src) : idAndRole attr - else inTags False "ulink" $ ("url", src) : idAndRole attr ) - <$> inlinesToDocbook opts txt -inlineToDocbook opts (Image attr _ (src, tit)) = return $ - let titleDoc = if T.null tit - then empty - else inTagsIndented "objectinfo" $ - inTagsIndented "title" (literal $ escapeStringForXML tit) - in inTagsIndented "inlinemediaobject" $ inTagsIndented "imageobject" $ - titleDoc $$ imageToDocbook opts attr src -inlineToDocbook opts (Note contents) = - inTagsIndented "footnote" <$> blocksToDocbook opts contents - -isMathML :: HTMLMathMethod -> Bool -isMathML MathML = True -isMathML _ = False - -idAndRole :: Attr -> [(Text, Text)] -idAndRole (id',cls,_) = ident <> role - where - ident = [("id", id') | not (T.null id')] - role = [("role", T.unwords cls) | not (null cls)] - -isSectionAttr :: DocBookVersion -> (Text, Text) -> Bool -isSectionAttr _ ("label",_) = True -isSectionAttr _ ("status",_) = True -isSectionAttr DocBook5 ("annotations",_) = True -isSectionAttr DocBook5 ("dir","ltr") = True -isSectionAttr DocBook5 ("dir","rtl") = True -isSectionAttr DocBook5 ("dir","lro") = True -isSectionAttr DocBook5 ("dir","rlo") = True -isSectionAttr _ ("remap",_) = True -isSectionAttr _ ("revisionflag","changed") = True -isSectionAttr _ ("revisionflag","added") = True -isSectionAttr _ ("revisionflag","deleted") = True -isSectionAttr _ ("revisionflag","off") = True -isSectionAttr _ ("role",_) = True -isSectionAttr DocBook5 ("version",_) = True -isSectionAttr DocBook5 ("xml:base",_) = True -isSectionAttr DocBook5 ("xml:lang",_) = True -isSectionAttr _ ("xreflabel",_) = True -isSectionAttr DocBook5 ("linkend",_) = True -isSectionAttr DocBook5 ("linkends",_) = True -isSectionAttr DocBook5 ("xlink:actuate",_) = True -isSectionAttr DocBook5 ("xlink:arcrole",_) = True -isSectionAttr DocBook5 ("xlink:from",_) = True -isSectionAttr DocBook5 ("xlink:href",_) = True -isSectionAttr DocBook5 ("xlink:label",_) = True -isSectionAttr DocBook5 ("xlink:role",_) = True -isSectionAttr DocBook5 ("xlink:show",_) = True -isSectionAttr DocBook5 ("xlink:title",_) = True -isSectionAttr DocBook5 ("xlink:to",_) = True -isSectionAttr DocBook5 ("xlink:type",_) = True -isSectionAttr DocBook4 ("arch",_) = True -isSectionAttr DocBook4 ("condition",_) = True -isSectionAttr DocBook4 ("conformance",_) = True -isSectionAttr DocBook4 ("lang",_) = True -isSectionAttr DocBook4 ("os",_) = True -isSectionAttr DocBook4 ("revision",_) = True -isSectionAttr DocBook4 ("security",_) = True -isSectionAttr DocBook4 ("vendor",_) = True -isSectionAttr _ (_,_) = False diff --git a/src/Text/Pandoc/Writers/Docx.hs b/src/Text/Pandoc/Writers/Docx.hs --- a/src/Text/Pandoc/Writers/Docx.hs +++ b/src/Text/Pandoc/Writers/Docx.hs @@ -5,9 +5,10 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} {- | Module : Text.Pandoc.Writers.Docx - Copyright : Copyright (C) 2012-2022 John MacFarlane + Copyright : Copyright (C) 2012-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane @@ -18,11 +19,22 @@ -} module Text.Pandoc.Writers.Docx ( writeDocx ) where import Codec.Archive.Zip + ( Archive(zEntries), + addEntryToArchive, + emptyArchive, + findEntryByPath, + fromArchive, + toArchive, + toEntry, + Entry(eRelativePath) ) import Control.Applicative ((<|>)) +import Control.Monad (MonadPlus(mplus), unless, when) import Control.Monad.Except (catchError, throwError) import Control.Monad.Reader -import Control.Monad.State.Strict + ( asks, MonadReader(local), MonadTrans(lift), ReaderT(runReaderT) ) +import Control.Monad.State.Strict ( StateT(runStateT), gets, modify ) import qualified Data.ByteString.Lazy as BL +import Data.Containers.ListUtils (nubOrd) import Data.Char (isSpace, isLetter) import Data.List (intercalate, isPrefixOf, isSuffixOf) import Data.String (fromString) @@ -35,12 +47,12 @@ import Data.Time.Clock.POSIX import Data.Digest.Pure.SHA (sha1, showDigest) import Skylighting -import Text.Collate.Lang (renderLang) -import Text.Pandoc.Class (PandocMonad, report, toLang, translateTerm, - getMediaBag) +import Text.Pandoc.Class (PandocMonad, report, toLang, getMediaBag) +import Text.Pandoc.Translations (translateTerm) import Text.Pandoc.MediaBag (lookupMedia, MediaItem(..)) import qualified Text.Pandoc.Translations as Term import qualified Text.Pandoc.Class.PandocMonad as P +import Text.Pandoc.Data (readDataFile, readDefaultDataFile) import Data.Time import Text.Pandoc.UTF8 (fromTextLazy) import Text.Pandoc.Definition @@ -52,7 +64,7 @@ import Text.Pandoc.MIME (extensionFromMimeType, getMimeType, getMimeTypeDef) import Text.Pandoc.Options import Text.Pandoc.Writers.Docx.StyleMap -import Text.Pandoc.Writers.Docx.Table +import Text.Pandoc.Writers.Docx.Table as Table import Text.Pandoc.Writers.Docx.Types import Text.Pandoc.Shared import Text.Pandoc.Walk @@ -63,6 +75,7 @@ import Text.Pandoc.Writers.OOXML import Text.Pandoc.XML.Light as XML import Data.Generics (mkT, everywhere) +import Text.Collate.Lang (renderLang, Lang(..)) squashProps :: EnvProps -> [Element] squashProps (EnvProps Nothing es) = es @@ -118,13 +131,14 @@ utctime <- P.getTimestamp oldUserDataDir <- P.getUserDataDir P.setUserDataDir Nothing - res <- P.readDefaultDataFile "reference.docx" + res <- readDefaultDataFile "reference.docx" P.setUserDataDir oldUserDataDir let distArchive = toArchive $ BL.fromStrict res refArchive <- case writerReferenceDoc opts of - Just f -> toArchive <$> P.readFileLazy f + Just f -> toArchive . BL.fromStrict . fst + <$> P.fetchItem (T.pack f) Nothing -> toArchive . BL.fromStrict <$> - P.readDataFile "reference.docx" + readDataFile "reference.docx" parsedDoc <- parseXml refArchive distArchive "word/document.xml" let wname f qn = qPrefix qn == Just "w" && f (qName qn) @@ -153,17 +167,34 @@ let addLang :: Element -> Element addLang = case mblang of Nothing -> id - Just l -> everywhere (mkT (go (renderLang l))) + Just l -> everywhere (mkT (go l)) where - go :: Text -> Element -> Element - go l e' - | qName (elName e') == "lang" - = e'{ elAttribs = map (setvalattr l) $ elAttribs e' } - | otherwise = e' + go :: Lang -> Element -> Element + go lang e' + | qName (elName e') == "lang" + = if isEastAsianLang lang + then e'{ elAttribs = + map (setattr "eastAsia" (renderLang lang)) $ + elAttribs e' } + else + if isBidiLang lang + then e'{ elAttribs = + map (setattr "bidi" (renderLang lang)) $ + elAttribs e' } + else e'{ elAttribs = + map (setattr "val" (renderLang lang)) $ + elAttribs e' } + | otherwise = e' - setvalattr l (XML.Attr qn@(QName "val" _ _) _) = XML.Attr qn l - setvalattr _ x = x + setattr attrname l (XML.Attr qn@(QName s _ _) _) + | s == attrname = XML.Attr qn l + setattr _ _ x = x + isEastAsianLang Lang{ langLanguage = lang } = + lang == "zh" || lang == "jp" || lang == "ko" + isBidiLang Lang{ langLanguage = lang } = + lang == "he" || lang == "ar" + let stylepath = "word/styles.xml" styledoc <- addLang <$> parseXml refArchive distArchive stylepath @@ -615,7 +646,7 @@ mkNumbering :: [ListMarker] -> [Element] mkNumbering lists = elts ++ zipWith mkNum lists [baseListId..(baseListId + length lists - 1)] - where elts = map mkAbstractNum (ordNub lists) + where elts = map mkAbstractNum (nubOrd lists) maxListLevel :: Int maxListLevel = 8 @@ -804,7 +835,6 @@ blockToOpenXML opts blk = withDirection $ blockToOpenXML' opts blk blockToOpenXML' :: (PandocMonad m) => WriterOptions -> Block -> WS m [Content] -blockToOpenXML' _ Null = return [] blockToOpenXML' opts (Div (ident,_classes,kvs) bs) = do stylemod <- case lookup dynamicStyleKey kvs of Just (fromString . T.unpack -> sty) -> do @@ -860,38 +890,6 @@ if isInTable || isInList then withParaProp prop block else block --- title beginning with fig: indicates that the image is a figure -blockToOpenXML' opts (SimpleFigure attr@(imgident, _, _) alt (src, tit)) = do - setFirstPara - fignum <- gets stNextFigureNum - unless (null alt) $ modify $ \st -> st{ stNextFigureNum = fignum + 1 } - let refid = if T.null imgident - then "ref_fig" <> tshow fignum - else "ref_" <> imgident - figname <- translateTerm Term.Figure - prop <- pStyleM $ - if null alt - then "Figure" - else "Captioned Figure" - paraProps <- local (\env -> env { envParaProperties = EnvProps (Just prop) [] <> envParaProperties env }) (getParaProps False) - contents <- inlinesToOpenXML opts [Image attr alt (src,tit)] - captionNode <- if null alt - then return [] - else withParaPropM (pStyleM "Image Caption") - $ blockToOpenXML opts - $ Para - $ if isEnabled Ext_native_numbering opts - then Span (refid,[],[]) - [Str (figname <> "\160"), - RawInline (Format "openxml") - (" " \\* ARABIC \">" - <> tshow fignum - <> "")] : Str ": " : alt - else alt - return $ - Elem (mknode "w:p" [] (map Elem paraProps ++ contents)) - : captionNode blockToOpenXML' opts (Para lst) | null lst && not (isEnabled Ext_empty_paragraphs opts) = return [] | otherwise = do @@ -934,8 +932,11 @@ ("o:hralign","center"), ("o:hrstd","t"),("o:hr","t")] () ] blockToOpenXML' opts (Table attr caption colspecs thead tbodies tfoot) = do + -- Remove extra paragraph indentation due to list items (#5947). + -- This means that tables in lists will not be indented, but it + -- avoids unwanted indentation in each cell. content <- tableToOpenXML opts - (blocksToOpenXML opts) + (local (\env -> env{ envListLevel = -1 }) . blocksToOpenXML opts) (Grid.toTable attr caption colspecs thead tbodies tfoot) let (tableId, _, _) = attr wrapBookmark tableId content @@ -957,7 +958,100 @@ l <- concat `fmap` mapM (definitionListItemToOpenXML opts) items setFirstPara return l +blockToOpenXML' opts (Figure (ident, _, _) (Caption _ longcapt) body) = do + setFirstPara + fignum <- gets stNextFigureNum + unless (null longcapt) $ modify $ \st -> st{ stNextFigureNum = fignum + 1 } + let refid = if T.null ident + then "ref_fig" <> tshow fignum + else "ref_" <> ident + figname <- translateTerm Term.Figure + prop <- pStyleM $ + if null longcapt + then "Figure" + else "Captioned Figure" + paraProps <- local + (\env -> env { envParaProperties = EnvProps (Just prop) [] <> + envParaProperties env }) + (getParaProps False) + -- Figure contents + let simpleImage x = do + imgXML <- inlineToOpenXML opts x + pure $ Elem (mknode "w:p" [] (map Elem paraProps ++ imgXML)) + contentsNode <- case body of + [Plain [img@Image {}]] -> simpleImage img + [Para [img@Image {}]] -> simpleImage img + _ -> toFigureTable opts body + -- Caption + let imageCaption = withParaPropM (pStyleM "Image Caption") + . blocksToOpenXML opts + let fstCaptionPara inlns = Para $ + if not $ isEnabled Ext_native_numbering opts + then inlns + else let rawfld = RawInline (Format "openxml") $ mconcat + [ "" + , tshow fignum + , "" + ] + in Span (refid,[],[]) [Str (figname <> "\160") , rawfld] + : Str ": " : inlns + captionNode <- case longcapt of + [] -> return [] + (Para xs : bs) -> imageCaption (fstCaptionPara xs : bs) + (Plain xs : bs) -> imageCaption (fstCaptionPara xs : bs) + _ -> imageCaption longcapt + return $ contentsNode : captionNode + +toFigureTable :: PandocMonad m + => WriterOptions -> [Block] -> WS m Content +toFigureTable opts blks = do + modify $ \s -> s { stInTable = True } + let ncols = length blks + let textwidth = 7920 -- 5.5 in in twips (1 twip == 1/20 pt) + let cellfrac = 1 / fromIntegral ncols + let colwidth = tshow @Integer $ floor (textwidth * cellfrac) -- twips + let gridCols = replicate ncols $ mknode "w:gridCol" [("w:w", colwidth)] () + let scaleImage = \case + Image attr@(ident, classes, attribs) alt tgt -> + let dimWidth = case dimension Width attr of + Nothing -> Percent (cellfrac * 100) + Just d -> scaleDimension cellfrac d + dimHeight = scaleDimension cellfrac <$> dimension Height attr + attribs' = (tshow Width, tshow dimWidth) : + (case dimHeight of + Nothing -> id + Just h -> ((tshow Height, tshow h) :)) + [ (k, v) | (k, v) <- attribs + , k `notElem` ["width", "height"] + ] + in Image (ident, classes, attribs') alt tgt + x -> x + let blockToCell = Table.OOXMLCell nullAttr AlignCenter 1 1 . (:[]) + . walk scaleImage + tblBody <- Table.rowToOpenXML (blocksToOpenXML opts) . + Table.OOXMLRow Table.BodyRow nullAttr $ + map blockToCell blks + let tbl = mknode "w:tbl" [] + ( mknode "w:tblPr" [] + ( mknode "w:tblStyle" [("w:val","FigureTable")] () : + mknode "w:tblW" [ ("w:type", "auto"), ("w:w", "0") ] () : + mknode "w:tblLook" [ ("w:firstRow", "0") + , ("w:lastRow", "0") + , ("w:firstColumn", "0") + , ("w:lastColumn", "0") + ] () : + mknode "w:jc" [("w:val","center")] () : + [] + ) + : mknode "w:tblGrid" [] gridCols + : [tblBody] + ) + modify $ \s -> s { stInTable = False } + return $ Elem tbl + + definitionListItemToOpenXML :: (PandocMonad m) => WriterOptions -> ([Inline],[[Block]]) -> WS m [Content] @@ -1082,6 +1176,9 @@ map Elem <$> formattedString str inlineToOpenXML' opts Space = inlineToOpenXML opts (Str " ") inlineToOpenXML' opts SoftBreak = inlineToOpenXML opts (Str " ") +inlineToOpenXML' opts (Span ("",["mark"],[]) ils) = + withTextProp (mknode "w:highlight" [("w:val","yellow")] ()) $ + inlinesToOpenXML opts ils inlineToOpenXML' opts (Span ("",["csl-block"],[]) ils) = inlinesToOpenXML opts ils inlineToOpenXML' opts (Span ("",["csl-left-margin"],[]) ils) = @@ -1310,8 +1407,10 @@ (xpt,ypt) = desiredSizeInPoints opts attr (either (const def) id (imageSize opts img)) -- 12700 emu = 1 pt - (xemu,yemu) = fitToPage (xpt * 12700, ypt * 12700) - (pageWidth * 12700) + pageWidthPt = case dimension Width attr of + Just (Percent a) -> pageWidth * (floor $ a * 127) + _ -> pageWidth * 12700 + (xemu,yemu) = fitToPage (xpt * 12700, ypt * 12700) pageWidthPt cNvPicPr = mknode "pic:cNvPicPr" [] $ mknode "a:picLocks" [("noChangeArrowheads","1") ,("noChangeAspect","1")] () diff --git a/src/Text/Pandoc/Writers/Docx/StyleMap.hs b/src/Text/Pandoc/Writers/Docx/StyleMap.hs --- a/src/Text/Pandoc/Writers/Docx/StyleMap.hs +++ b/src/Text/Pandoc/Writers/Docx/StyleMap.hs @@ -2,7 +2,7 @@ {- | Module : Text.Pandoc.Writers.Docx.StyleMap Copyright : © 2014-2020 Jesse Rosenthal , - 2014-2022 John MacFarlane , + 2014-2023 John MacFarlane , 2015-2019 Nikolay Yakimov License : GNU GPL, version 2 or above diff --git a/src/Text/Pandoc/Writers/Docx/Table.hs b/src/Text/Pandoc/Writers/Docx/Table.hs --- a/src/Text/Pandoc/Writers/Docx/Table.hs +++ b/src/Text/Pandoc/Writers/Docx/Table.hs @@ -3,7 +3,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {- | Module : Text.Pandoc.Writers.Docx.Table -Copyright : Copyright (C) 2012-2022 John MacFarlane +Copyright : Copyright (C) 2012-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane @@ -11,9 +11,15 @@ -} module Text.Pandoc.Writers.Docx.Table ( tableToOpenXML + , rowToOpenXML + , OOXMLRow (..) + , OOXMLCell (..) + , RowType (..) ) where -import Control.Monad.State.Strict ( modify, gets, unless ) +import Control.Monad.State.Strict ( modify, gets ) +import Control.Monad ( unless , zipWithM ) +import Control.Monad.Except ( throwError ) import Data.Array ( elems, (!), assocs, indices ) import Data.Text (Text) import Text.Pandoc.Definition @@ -27,17 +33,21 @@ RowSpan(..), ColSpan(..), ColWidth(ColWidth) ) -import Text.Pandoc.Class.PandocMonad (PandocMonad, translateTerm) +import Text.Pandoc.Class.PandocMonad (PandocMonad) +import Text.Pandoc.Translations (translateTerm) import Text.Pandoc.Writers.Docx.Types ( WS, WriterState(stNextTableNum, stInTable), + WriterEnv(..), setFirstPara, pStyleM, withParaProp, withParaPropM ) +import Control.Monad.Reader (asks) import Text.Pandoc.Shared ( tshow, stringify ) import Text.Pandoc.Options (WriterOptions, isEnabled) import Text.Pandoc.Extensions (Extension(Ext_native_numbering)) +import Text.Pandoc.Error (PandocError(PandocSomeError)) import Text.Printf (printf) import Text.Pandoc.Writers.GridTable ( rowArray, @@ -97,6 +107,8 @@ -- 0×0400 Do not apply column banding conditional formattin let tblLookVal = if hasHeader then (0x20 :: Int) else 0 let (gridCols, tblWattr) = tableLayout (elems colspecs) + listLevel <- asks envListLevel + let indent = (listLevel + 1) * 720 let tbl = mknode "w:tbl" [] ( mknode "w:tblPr" [] ( mknode "w:tblStyle" [("w:val","Table")] () : @@ -109,6 +121,9 @@ ,("w:noVBand","0") ,("w:val", T.pack $ printf "%04x" tblLookVal) ] () : + mknode "w:jc" [("w:val","start")] () + : [ mknode "w:tblInd" [("w:w", tshow indent),("w:type","dxa")] () + | indent > 0 ] ++ [ mknode "w:tblCaption" [("w:val", captionStr)] () | not (T.null captionStr) ] ) @@ -171,8 +186,8 @@ cellGridToOpenXML blocksToOpenXML rowType aligns part@(Part _ cellArray _) = if null (elems cellArray) then return mempty - else mapM (rowToOpenXML blocksToOpenXML) $ - partToRows rowType aligns part + else partToRows rowType aligns part >>= + mapM (rowToOpenXML blocksToOpenXML) data OOXMLCell = OOXMLCell Attr Alignment RowSpan ColSpan [Block] @@ -180,32 +195,33 @@ data OOXMLRow = OOXMLRow RowType Attr [OOXMLCell] -partToRows :: RowType -> [Alignment] -> Part -> [OOXMLRow] -partToRows rowType aligns part = - let - toOOXMLCell :: Alignment -> RowIndex -> ColIndex -> GridCell -> [OOXMLCell] - toOOXMLCell columnAlign ridx cidx = \case - ContentCell attr align rowspan colspan blocks -> - -- Respect non-default, cell specific alignment. - let align' = case align of - AlignDefault -> columnAlign - _ -> align - in [OOXMLCell attr align' rowspan colspan blocks] - ContinuationCell idx'@(ridx',cidx') | ridx /= ridx', cidx == cidx' -> - case (partCellArray part)!idx' of - (ContentCell _ _ _ colspan _) -> [OOXMLCellMerge colspan] - x -> error $ "Content cell expected, got, " ++ show x ++ - " at index " ++ show idx' - _ -> mempty - mkRow :: (RowIndex, Attr) -> OOXMLRow - mkRow (ridx, attr) = OOXMLRow rowType attr - . mconcat - . zipWith (\align -> uncurry $ toOOXMLCell align ridx) - aligns - . assocs - . rowArray ridx - $ partCellArray part - in map mkRow $ assocs (partRowAttrs part) +partToRows :: PandocMonad m + => RowType -> [Alignment] -> Part -> WS m [OOXMLRow] +partToRows rowType aligns part = do + let toOOXMLCell :: PandocMonad m => + Alignment -> RowIndex -> ColIndex -> GridCell -> WS m [OOXMLCell] + toOOXMLCell columnAlign ridx cidx = \case + UnassignedCell -> + throwError $ PandocSomeError "Encountered unassigned table cell" + ContentCell attr align rowspan colspan blocks -> do + -- Respect non-default, cell specific alignment. + let align' = case align of + AlignDefault -> columnAlign + _ -> align + return [OOXMLCell attr align' rowspan colspan blocks] + ContinuationCell idx'@(ridx',cidx') | ridx /= ridx', cidx == cidx' -> do + case (partCellArray part)!idx' of + (ContentCell _ _ _ colspan _) -> return [OOXMLCellMerge colspan] + x -> error $ "Content cell expected, got, " ++ show x ++ + " at index " ++ show idx' + _ -> return mempty + let mkRow :: PandocMonad m => (RowIndex, Attr) -> WS m OOXMLRow + mkRow (ridx, attr) = do + cs <- zipWithM (\align -> uncurry $ toOOXMLCell align ridx) + aligns + (assocs . rowArray ridx $ partCellArray part) + return $ OOXMLRow rowType attr . mconcat $ cs + mapM mkRow $ assocs (partRowAttrs part) rowToOpenXML :: PandocMonad m => ([Block] -> WS m [Content]) diff --git a/src/Text/Pandoc/Writers/Docx/Types.hs b/src/Text/Pandoc/Writers/Docx/Types.hs --- a/src/Text/Pandoc/Writers/Docx/Types.hs +++ b/src/Text/Pandoc/Writers/Docx/Types.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Writers.Docx -Copyright : Copyright (C) 2012-2022 John MacFarlane +Copyright : Copyright (C) 2012-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane diff --git a/src/Text/Pandoc/Writers/DokuWiki.hs b/src/Text/Pandoc/Writers/DokuWiki.hs --- a/src/Text/Pandoc/Writers/DokuWiki.hs +++ b/src/Text/Pandoc/Writers/DokuWiki.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Writers.DokuWiki - Copyright : Copyright (C) 2008-2022 John MacFarlane + Copyright : Copyright (C) 2008-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : Clare Macrae @@ -34,9 +34,11 @@ import Text.Pandoc.Definition import Text.Pandoc.ImageSize import Text.Pandoc.Logging -import Text.Pandoc.Options (WrapOption (..), WriterOptions (writerTableOfContents, writerTemplate, writerWrapText)) -import Text.Pandoc.Shared (camelCaseToHyphenated, escapeURI, isURI, linesToPara, +import Text.Pandoc.Options (WrapOption (..), WriterOptions (writerTableOfContents, + writerTemplate, writerWrapText)) +import Text.Pandoc.Shared (camelCaseToHyphenated, figureDiv, linesToPara, removeFormatting, trimr, tshow) +import Text.Pandoc.URI (escapeURI, isURI) import Text.Pandoc.Templates (renderTemplate) import Text.DocLayout (render, literal) import Text.Pandoc.Writers.Shared (defField, metaToContext, toLegacyTable) @@ -98,8 +100,6 @@ -> Block -- ^ Block element -> DokuWiki m Text -blockToDokuWiki _ Null = return "" - blockToDokuWiki opts (Div _attrs bs) = do contents <- blockListToDokuWiki opts bs return $ contents <> "\n" @@ -107,17 +107,6 @@ blockToDokuWiki opts (Plain inlines) = inlineListToDokuWiki opts inlines --- title beginning with fig: indicates that the image is a figure --- dokuwiki doesn't support captions - so combine together alt and caption into alt -blockToDokuWiki opts (SimpleFigure attr txt (src, tit)) = do - capt <- if null txt - then return "" - else (" " <>) `fmap` inlineListToDokuWiki opts txt - let opt = if null txt - then "" - else "|" <> if T.null tit then capt else tit <> capt - return $ "{{" <> src <> imageDims opts attr <> opt <> "}}\n" - blockToDokuWiki opts (Para inlines) = do indent <- asks stIndent useTags <- asks stUseTags @@ -220,6 +209,9 @@ , stBackSlashLB = backSlash}) (mapM (orderedListItemToDokuWiki opts) items) return $ vcat contents <> if T.null indent then "\n" else "" + +blockToDokuWiki opts (Figure attr capt body) = + blockToDokuWiki opts $ figureDiv attr capt body -- TODO Need to decide how to make definition lists work on dokuwiki - I don't think there -- is a specific representation of them. diff --git a/src/Text/Pandoc/Writers/EPUB.hs b/src/Text/Pandoc/Writers/EPUB.hs --- a/src/Text/Pandoc/Writers/EPUB.hs +++ b/src/Text/Pandoc/Writers/EPUB.hs @@ -5,7 +5,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {- | Module : Text.Pandoc.Writers.EPUB - Copyright : Copyright (C) 2010-2022 John MacFarlane + Copyright : Copyright (C) 2010-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane @@ -20,14 +20,14 @@ import Control.Applicative ( (<|>) ) import Control.Monad (mplus, unless, when, zipWithM) import Control.Monad.Except (catchError, throwError) -import Control.Monad.State.Strict (StateT, evalState, evalStateT, get, +import Control.Monad.State.Strict (State, StateT, evalState, evalStateT, get, gets, lift, modify) import qualified Data.ByteString.Lazy as B import qualified Data.ByteString.Lazy.Char8 as B8 import Data.Char (isAlphaNum, isAscii, isDigit) import Data.List (isInfixOf, isPrefixOf) import qualified Data.Map as M -import Data.Maybe (fromMaybe, isNothing, mapMaybe, isJust) +import Data.Maybe (fromMaybe, isNothing, mapMaybe, isJust, catMaybes) import qualified Data.Set as Set import qualified Data.Text as T import Data.Text (Text) @@ -36,8 +36,10 @@ import Text.HTML.TagSoup (Tag (TagOpen), fromAttrib, parseTags) import Text.Pandoc.Builder (fromList, setMeta) import Text.Pandoc.Writers.Shared (ensureValidXmlIdentifiers) +import Data.Tree (Tree(..)) import Text.Pandoc.Class (PandocMonad, report) import qualified Text.Pandoc.Class.PandocPure as P +import Text.Pandoc.Data (readDataFile) import qualified Text.Pandoc.Class.PandocMonad as P import Data.Time import Text.Pandoc.Definition @@ -45,21 +47,23 @@ import Text.Pandoc.ImageSize import Text.Pandoc.Logging import Text.Pandoc.MIME (MimeType, extensionFromMimeType, getMimeType) -import Text.Pandoc.Network.HTTP (urlEncode) +import Text.Pandoc.URI (urlEncode) import Text.Pandoc.Options (EPUBVersion (..), HTMLMathMethod (..), ObfuscationMethod (NoObfuscation), WrapOption (..), WriterOptions (..)) -import Text.Pandoc.Shared (makeSections, normalizeDate, renderTags', +import Text.Pandoc.Shared (normalizeDate, renderTags', stringify, uniqueIdent, tshow) import qualified Text.Pandoc.UTF8 as UTF8 import Text.Pandoc.UUID (getRandomUUID) -import Text.Pandoc.Walk (query, walk, walkM) +import Text.Pandoc.Walk (walk, walkM) import Text.Pandoc.Writers.HTML (writeHtmlStringForEPUB) import Text.Printf (printf) import Text.Pandoc.XML.Light import Text.Pandoc.XML (escapeStringForXML) import Text.DocTemplates (FromContext(lookupContext), Context(..), ToContext(toVal), Val(..)) +import Text.Pandoc.Chunks (splitIntoChunks, Chunk(..), ChunkedDoc(..), + SecInfo(..)) -- A Chapter includes a list of blocks. newtype Chapter = Chapter [Block] @@ -460,7 +464,7 @@ -- stylesheet stylesheets <- case epubStylesheets metadata of [] -> (\x -> [B.fromChunks [x]]) <$> - P.readDataFile "epub.css" + readDataFile "epub.css" fs -> mapM P.readFileLazy fs stylesheetEntries <- zipWithM (\bs n -> mkEntry ("styles/stylesheet" ++ show n ++ ".css") bs) @@ -525,22 +529,27 @@ -- body pages -- add level 1 header to beginning if none there - let secs = makeSections True Nothing - $ addIdentifiers opts - $ case blocks of - (Div _ - (Header{}:_) : _) -> blocks - (Header 1 _ _ : _) -> blocks - _ -> Header 1 ("",["unnumbered"],[]) - (docTitle' meta) : blocks + let blocks' = addIdentifiers opts + $ case blocks of + (Div _ + (Header{}:_) : _) -> blocks + (Header 1 _ _ : _) -> blocks + _ -> Header 1 ("",["unnumbered"],[]) + (docTitle' meta) : blocks - -- create the chapters and their reftable from the original options and the sections - let (chapters, reftable) = createChaptersAndReftable opts secs + -- create the chapters + let chunkedDoc = splitIntoChunks "ch%n.xhtml" + (writerNumberSections opts) + Nothing + (writerSplitLevel opts) + (Pandoc meta blocks') + -- Create the chapter entries from the chapters. -- Also requires access to the extended writer options and context -- as well as the css Context and html writer - chapterEntries <- createChapterEntries opts' vars cssvars writeHtml chapters + chapterEntries <- createChapterEntries opts' vars cssvars writeHtml + (chunkedChunks chunkedDoc) @@ -624,7 +633,9 @@ (n :: Int, fp) <- zip [1..] (map (makeRelative epubSubdir . eRelativePath) stylesheetEntries) ] ++ - map chapterNode (cpgEntry ++ (tpEntry : chapterEntries)) ++ + map chapterNode (cpgEntry ++ + [tpEntry | writerEpubTitlePage opts] ++ + chapterEntries) ++ (case cpicEntry of [] -> [] (x:_) -> [add_attrs @@ -638,11 +649,12 @@ Nothing -> [] Just _ -> [ unode "itemref" ! [("idref", "cover_xhtml")] $ () ] - ++ ((unode "itemref" ! [("idref", "title_page_xhtml") + ++ ([unode "itemref" ! [("idref", "title_page_xhtml") ,("linear", case lookupMeta "title" meta of Just _ -> "yes" - Nothing -> "no")] $ ()) : + Nothing -> "no")] $ () + | writerEpubTitlePage opts] ++ [unode "itemref" ! [("idref", "nav")] $ () | writerTableOfContents opts ] ++ map chapterRefNode chapterEntries) @@ -662,40 +674,14 @@ contentsEntry <- mkEntry "content.opf" contentsData -- toc.ncx - let tocLevel = writerTOCDepth opts - - -- Helper function for both the toc and anv Entries - let navPointNode :: PandocMonad m - => (Int -> [Inline] -> T.Text -> [Element] -> Element) - -> Block -> StateT Int m [Element] - navPointNode formatter (Div (ident,_,_) - (Header lvl (_,_,kvs) ils : children)) = - if lvl > tocLevel - then return [] - else do - n <- get - modify (+1) - let num = fromMaybe "" $ lookup "number" kvs - let tit = if writerNumberSections opts && not (T.null num) - then Span ("", ["section-header-number"], []) - [Str num] : Space : ils - else ils - src <- case lookup ident reftable of - Just x -> return x - Nothing -> throwError $ PandocSomeError $ - ident <> " not found in reftable" - subs <- concat <$> mapM (navPointNode formatter) children - return [formatter n tit src subs] - navPointNode formatter (Div _ bs) = - concat <$> mapM (navPointNode formatter) bs - navPointNode _ _ = return [] - -- Create the tocEntry from the metadata together with the sections and title. - tocEntry <- createTocEntry meta metadata plainTitle secs navPointNode + tocEntry <- createTocEntry opts' meta metadata plainTitle + (chunkedTOC chunkedDoc) -- Create the navEntry using the metadata, all of the various writer options, -- the CSS and HTML helpers, the document and toc title as well as the epub version and all of the sections - navEntry <- createNavEntry meta metadata opts opts' vars cssvars writeHtml plainTitle tocTitle version secs navPointNode + navEntry <- createNavEntry opts' meta metadata vars cssvars + writeHtml tocTitle version (chunkedTOC chunkedDoc) -- mimetype mimetypeEntry <- mkEntry "mimetype" $ @@ -723,7 +709,8 @@ -- construct archive let archive = foldr addEntryToArchive emptyArchive $ [mimetypeEntry, containerEntry, appleEntry, - contentsEntry, tocEntry, navEntry, tpEntry] ++ + contentsEntry, tocEntry, navEntry] ++ + [tpEntry | writerEpubTitlePage opts] ++ stylesheetEntries ++ picEntries ++ cpicEntry ++ cpgEntry ++ chapterEntries ++ fontEntries return $ fromArchive archive @@ -740,7 +727,7 @@ -> (WriterOptions -> Pandoc -> m B8.ByteString) -> Text -> StateT EPUBState m ([Entry], [Entry]) -createCoverPage meta metadata opts' vars cssvars writeHtml plainTitle = +createCoverPage meta metadata opts' vars cssvars writeHtml plainTitle = case epubCoverImage metadata of Nothing -> return ([],[]) Just img -> do @@ -787,13 +774,13 @@ -> Context Text -> (Bool -> Context Text) -> (WriterOptions -> Pandoc -> StateT EPUBState m B8.ByteString) - -> [Chapter] + -> [Chunk] -> StateT EPUBState m [Entry] createChapterEntries opts' vars cssvars writeHtml chapters = do -- Create an entry from the chapter with the provided number. -- chapToEntry :: Int -> Chapter -> StateT EPUBState m Entry - let chapToEntry num (Chapter bs) = - mkEntry ("text/" ++ T.unpack (showChapter num)) =<< + let chapToEntry num chunk = + mkEntry ("text/" ++ chunkPath chunk) =<< -- Combine all provided options writeHtml opts'{ writerVariables = Context (M.fromList @@ -801,13 +788,16 @@ ("pagetitle", toVal' $ showChapter num)]) <> cssvars True <> vars } pdoc - where (pdoc, bodyType) = + where bs = chunkContents chunk + meta' = setMeta "title" (fromList + (walk removeNote + (chunkHeading chunk))) nullMeta + (pdoc, bodyType) = case bs of - (Div (_,"section":_,kvs) (Header _ _ xs : _) : _) -> + (Div (_,"section":_,kvs) _ : _) -> -- remove notes or we get doubled footnotes - (Pandoc (setMeta "title" - (walk removeNote $ fromList xs) nullMeta) bs, - -- Check if the chapters belongs to the frontmatter, + (Pandoc meta' bs, + -- Check if the chapters belongs to the frontmatter, -- backmatter of bodymatter defaulting to the body case lookup "epub:type" kvs of Nothing -> "bodymatter" @@ -815,7 +805,7 @@ | x `elem` frontMatterTypes -> "frontmatter" | x `elem` backMatterTypes -> "backmatter" | otherwise -> "bodymatter") - _ -> (Pandoc nullMeta bs, "bodymatter") + _ -> (Pandoc meta' bs, "bodymatter") frontMatterTypes = ["prologue", "abstract", "acknowledgments", "copyright-page", "dedication", "credits", "keywords", "imprint", @@ -829,118 +819,39 @@ zipWithM chapToEntry [1..] chapters --- | Splits the blocks into chapters and creates a corresponding reftable -createChaptersAndReftable :: WriterOptions -> [Block] -> ([Chapter], [(Text, Text)]) -createChaptersAndReftable opts secs = (chapters, reftable) - where - chapterHeaderLevel = writerEpubChapterLevel opts - - isChapterHeader :: Block -> Bool - isChapterHeader (Div _ (Header n _ _:_)) = n <= chapterHeaderLevel - isChapterHeader _ = False - - secsToChapters :: [Block] -> [Chapter] - secsToChapters [] = [] - secsToChapters (d@(Div attr (h@(Header lvl _ _) : bs)) : rest) - -- If the header is of the same level as chapters, create a chapter - | chapterHeaderLevel == lvl = - Chapter [d] : secsToChapters rest - -- If the header is a level higher than chapters, - -- create a chapter of everything until the next chapter header. - | chapterHeaderLevel > lvl = - Chapter [Div attr (h:xs)] : - secsToChapters ys ++ secsToChapters rest - where (xs, ys) = break isChapterHeader bs - secsToChapters bs = - -- If this is the last block, keep it as is, - -- otherwise create a chapter for everything until the next chapter header. - (if null xs then id else (Chapter xs :)) $ secsToChapters ys - where (xs, ys) = break isChapterHeader bs - - -- Convert the sections to initial chapters - chapters' = secsToChapters secs - - -- Extract references for the reftable from Inline elements - extractLinkURL' :: Int -> Inline -> [(T.Text, T.Text)] - extractLinkURL' num (Span (ident, _, _) _) - | not (T.null ident) = [(ident, showChapter num <> "#" <> ident)] - extractLinkURL' num (Link (ident, _, _) _ _) - | not (T.null ident) = [(ident, showChapter num <> "#" <> ident)] - extractLinkURL' num (Image (ident, _, _) _ _) - | not (T.null ident) = [(ident, showChapter num <> "#" <> ident)] - extractLinkURL' num (RawInline fmt raw) - | isHtmlFormat fmt - = foldr (\tag -> - case tag of - TagOpen{} -> - case fromAttrib "id" tag of - "" -> id - x -> ((x, showChapter num <> "#" <> x):) - _ -> id) - [] (parseTags raw) - extractLinkURL' _ _ = [] - - -- Extract references for the reftable from Block elements - extractLinkURL :: Int -> Block -> [(T.Text, T.Text)] - extractLinkURL num (Div (ident, _, _) _) - | not (T.null ident) = [(ident, showChapter num <> "#" <> ident)] - extractLinkURL num (Header _ (ident, _, _) _) - | not (T.null ident) = [(ident, showChapter num <> "#" <> ident)] - extractLinkURL num (Table (ident,_,_) _ _ _ _ _) - | not (T.null ident) = [(ident, showChapter num <> "#" <> ident)] - extractLinkURL num (RawBlock fmt raw) - | isHtmlFormat fmt - = foldr (\tag -> - case tag of - TagOpen{} -> - case fromAttrib "id" tag of - "" -> id - x -> ((x, showChapter num <> "#" <> x):) - _ -> id) - [] (parseTags raw) - extractLinkURL num b = query (extractLinkURL' num) b - - -- Create a reference table for the chapters with appropriate numbering - reftable = concat $ zipWith (\(Chapter bs) num -> - query (extractLinkURL num) bs) - chapters' [1..] - - fixInternalReferences :: Inline -> Inline - fixInternalReferences (Link attr lab (src, tit)) - | Just ('#', xs) <- T.uncons src = case lookup xs reftable of - Just ys -> Link attr lab (ys, tit) - Nothing -> Link attr lab (src, tit) - fixInternalReferences x = x - - -- internal reference IDs change when we chunk the file, - -- so that '#my-header-1' might turn into 'chap004.xhtml#my-header'. - -- this fixes that: - chapters = map (\(Chapter bs) -> - Chapter $ walk fixInternalReferences bs) - chapters' - createTocEntry :: PandocMonad m => - Meta - -> EPUBMetadata - -> Text - -> [Block] - -> ((Int -> [Inline] -> T.Text -> [Element] -> Element) -> Block -> StateT Int m [Element]) - -> StateT EPUBState m Entry -createTocEntry meta metadata plainTitle secs navPointNode = do - let navMapFormatter :: Int -> [Inline] -> T.Text -> [Element] -> Element - navMapFormatter n tit src subs = unode "navPoint" ! - [("id", "navPoint-" <> tshow n)] $ - [ unode "navLabel" $ unode "text" $ stringify tit - , unode "content" ! [("src", "text/" <> src)] $ () - ] ++ subs + WriterOptions + -> Meta + -> EPUBMetadata + -> Text + -> Tree SecInfo + -> StateT EPUBState m Entry +createTocEntry opts meta metadata plainTitle (Node _ secs) = do + let mkNavPoint :: Tree SecInfo -> State Int (Maybe Element) + mkNavPoint (Node secinfo subsecs) + | secLevel secinfo > writerTOCDepth opts = return Nothing + | otherwise = do + n <- get + modify (+ 1) + subs <- catMaybes <$> mapM mkNavPoint subsecs + let secnum' = case secNumber secinfo of + Just t -> t <> " " + Nothing -> "" + let title' = secnum' <> stringify (secTitle secinfo) + return $ Just $ unode "navPoint" ! + [("id", "navPoint-" <> tshow n)] $ + [ unode "navLabel" $ unode "text" title' + , unode "content" ! + [("src", "text/" <> secPath secinfo)] $ () + ] ++ subs let tpNode = unode "navPoint" ! [("id", "navPoint-0")] $ - [ unode "navLabel" $ unode "text" (stringify $ docTitle' meta) + [ unode "navLabel" $ unode "text" + (stringify $ docTitle' meta) , unode "content" ! [("src", "text/title_page.xhtml")] $ () ] - navMap <- lift $ evalStateT - (concat <$> mapM (navPointNode navMapFormatter) secs) 1 + let navMap = evalState (catMaybes <$> mapM mkNavPoint secs) 1 uuid <- case epubIdentifier metadata of (x:_) -> return $ identifierText x -- use first identifier as UUID @@ -962,58 +873,61 @@ Just img -> [unode "meta" ! [("name","cover"), ("content", toId img)] $ ()] , unode "docTitle" $ unode "text" plainTitle - , unode "navMap" $ - tpNode : navMap + , unode "navMap" $ [tpNode | writerEpubTitlePage opts] ++ navMap ] mkEntry "toc.ncx" tocData -createNavEntry :: PandocMonad m => - Meta - -> EPUBMetadata - -> WriterOptions - -> WriterOptions - -> Context Text - -> (Bool -> Context Text) - -> (WriterOptions -> Pandoc -> m B8.ByteString) - -> Text - -> Text - -> EPUBVersion - -> [Block] - -> ((Int -> [Inline] -> T.Text -> [Element] -> Element) -> Block -> StateT Int m [Element]) - -> StateT EPUBState m Entry -createNavEntry meta metadata opts opts' vars cssvars writeHtml plainTitle tocTitle version secs navPointNode = do - let navXhtmlFormatter :: Int -> [Inline] -> T.Text -> [Element] -> Element - navXhtmlFormatter n tit src subs = unode "li" ! - [("id", "toc-li-" <> tshow n)] $ - (unode "a" ! - [("href", "text/" <> src)] - $ titElements) - : case subs of - [] -> [] - (_:_) -> [unode "ol" ! [("class","toc")] $ subs] - where titElements = either (const []) id $ - parseXMLContents (TL.fromStrict titRendered) - titRendered = case P.runPure - (writeHtmlStringForEPUB version - opts{ writerTemplate = Nothing - , writerVariables = - Context (M.fromList - [("pagetitle", toVal $ - escapeStringForXML plainTitle)]) - <> writerVariables opts} - (Pandoc nullMeta - [Plain $ walk clean tit])) of - Left _ -> stringify tit - Right x -> x - -- can't have elements inside generated links... - clean (Link _ ils _) = Span ("", [], []) ils - clean (Note _) = Str "" - clean x = x +createNavEntry :: PandocMonad m + => WriterOptions + -> Meta + -> EPUBMetadata + -> Context Text + -> (Bool -> Context Text) + -> (WriterOptions -> Pandoc -> m B8.ByteString) + -> Text + -> EPUBVersion + -> Tree SecInfo + -> StateT EPUBState m Entry +createNavEntry opts meta metadata + vars cssvars writeHtml tocTitle version (Node _ secs) = do + let mkItem :: Tree SecInfo -> State Int (Maybe Element) + mkItem (Node secinfo subsecs) + | secLevel secinfo > writerTOCDepth opts = return Nothing + | otherwise = do + n <- get + modify (+ 1) + subs <- catMaybes <$> mapM mkItem subsecs + let secnum' = case secNumber secinfo of + Just num -> [Span ("", ["section-header-number"], []) + [Str num] , Space] + Nothing -> [] + let title' = secnum' <> secTitle secinfo + -- can't have elements inside generated links... + let clean (Link _ ils _) = Span ("", [], []) ils + clean (Note _) = Str "" + clean x = x + let titRendered = case P.runPure + (writeHtmlStringForEPUB version + opts{ writerTemplate = Nothing } + (Pandoc nullMeta + [Plain $ walk clean title'])) of + Left _ -> stringify title' + Right x -> x + let titElements = either (const []) id $ + parseXMLContents (TL.fromStrict titRendered) + return $ Just $ unode "li" ! + [("id", "toc-li-" <> tshow n)] $ + (unode "a" ! + [("href", "text/" <> secPath secinfo)] + $ titElements) + : case subs of + [] -> [] + (_:_) -> [unode "ol" ! [("class","toc")] $ subs] + let navtag = if version == EPUB3 then "nav" else "div" - tocBlocks <- lift $ evalStateT - (concat <$> mapM (navPointNode navXhtmlFormatter) secs) 1 + let tocBlocks = evalState (catMaybes <$> mapM mkItem secs) 1 let navBlocks = [RawBlock (Format "html") $ showElement $ -- prettyprinting introduces bad spaces unode navtag ! ([("epub:type","toc") | version == EPUB3] ++ @@ -1021,11 +935,12 @@ [ unode "h1" ! [("id","toc-title")] $ tocTitle , unode "ol" ! [("class","toc")] $ tocBlocks ]] let landmarkItems = if version == EPUB3 - then unode "li" + then [ unode "li" [ unode "a" ! [("href", "text/title_page.xhtml") ,("epub:type", "titlepage")] $ - ("Title Page" :: Text) ] : + ("Title Page" :: Text) ] | + writerEpubTitlePage opts ] ++ [ unode "li" [ unode "a" ! [("href", "text/cover.xhtml") ,("epub:type", "cover")] $ @@ -1045,7 +960,7 @@ ,("hidden","hidden")] $ [ unode "ol" landmarkItems ] | not (null landmarkItems)] - navData <- lift $ writeHtml opts'{ writerVariables = + navData <- lift $ writeHtml opts{ writerVariables = Context (M.fromList [("navpage", toVal' "true") ,("body-type", toVal' "frontmatter") ]) @@ -1220,8 +1135,10 @@ Just (n,_) -> return $ T.pack n Nothing -> catchError (do (img, mbMime) <- P.fetchItem $ T.pack oldsrc - let ext = maybe (takeExtension (takeWhile (/='?') oldsrc)) T.unpack - (("." <>) <$> (mbMime >>= extensionFromMimeType)) + let ext = maybe + (takeExtension (takeWhile (/='?') oldsrc)) + (T.unpack . ("." <>)) + (mbMime >>= extensionFromMimeType) newName <- getMediaNextNewName ext let newPath = "media/" ++ newName entry <- mkEntry newPath (B.fromChunks . (:[]) $ img) diff --git a/src/Text/Pandoc/Writers/FB2.hs b/src/Text/Pandoc/Writers/FB2.hs --- a/src/Text/Pandoc/Writers/FB2.hs +++ b/src/Text/Pandoc/Writers/FB2.hs @@ -3,7 +3,7 @@ {- | Module : Text.Pandoc.Writers.FB2 Copyright : Copyright (C) 2011-2012 Sergey Astanin - 2012-2022 John MacFarlane + 2012-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane @@ -18,9 +18,9 @@ -} module Text.Pandoc.Writers.FB2 (writeFB2) where -import Control.Monad (zipWithM) +import Control.Monad (zipWithM, liftM) import Control.Monad.Except (catchError, throwError) -import Control.Monad.State.Strict (StateT, evalStateT, get, gets, lift, liftM, modify) +import Control.Monad.State.Strict (StateT, evalStateT, get, gets, lift, modify) import Data.ByteString.Base64 (encodeBase64) import Data.Char (isAscii, isControl, isSpace) import Data.Either (lefts, rights) @@ -28,7 +28,7 @@ import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Lazy as TL -import Text.Pandoc.Network.HTTP (urlEncode) +import Text.Pandoc.URI (urlEncode, isURI) import Text.Pandoc.XML.Light as X import Text.Pandoc.Class.PandocMonad (PandocMonad, report) @@ -37,8 +37,9 @@ import Text.Pandoc.Error (PandocError(..)) import Text.Pandoc.Logging import Text.Pandoc.Options (HTMLMathMethod (..), WriterOptions (..), def) -import Text.Pandoc.Shared (capitalize, isURI, orderedListMarkers, +import Text.Pandoc.Shared (blocksToInlines, capitalize, orderedListMarkers, makeSections, tshow, stringify) +import Text.Pandoc.Walk (walk) import Text.Pandoc.Writers.Shared (lookupMetaString, toLegacyTable, ensureValidXmlIdentifiers) import Data.Generics (everywhere, mkT) @@ -299,11 +300,11 @@ -- | Convert a block-level Pandoc's element to FictionBook XML representation. blockToXml :: PandocMonad m => Block -> FBM m [Content] +blockToXml (Plain [img@Image {}]) = insertImage NormalImage img blockToXml (Plain ss) = cMapM toXml ss -- FIXME: can lead to malformed FB2 +-- Special handling for singular images and display math elements blockToXml (Para [Math DisplayMath formula]) = insertMath NormalImage formula --- title beginning with fig: indicates that the image is a figure -blockToXml (SimpleFigure atr alt (src, tit)) = - insertImage NormalImage (Image atr alt (src,tit)) +blockToXml (Para [img@(Image {})]) = insertImage NormalImage img blockToXml (Para ss) = list . el "p" <$> cMapM toXml ss blockToXml (CodeBlock _ s) = return . spaceBeforeAfter . map (el "p" . el "code") . T.lines $ s @@ -360,7 +361,11 @@ align_str AlignCenter = "center" align_str AlignRight = "right" align_str AlignDefault = "left" -blockToXml Null = return [] +blockToXml (Figure _attr (Caption _ longcapt) body) = + let alt = blocksToInlines longcapt + addAlt (Image imgattr [] tgt) = Image imgattr alt tgt + addAlt inln = inln + in cMapM blockToXml (walk addAlt body) -- Replace plain text with paragraphs and add line break after paragraphs. -- It is used to convert plain text from tight list items to paragraphs. diff --git a/src/Text/Pandoc/Writers/GridTable.hs b/src/Text/Pandoc/Writers/GridTable.hs --- a/src/Text/Pandoc/Writers/GridTable.hs +++ b/src/Text/Pandoc/Writers/GridTable.hs @@ -5,7 +5,7 @@ {- | Module : Text.Pandoc.Writers.GridTable -Copyright : © 2020-2022 Albert Krewinkel +Copyright : © 2020-2023 Albert Krewinkel License : GNU GPL, version 2 or above Maintainer : Albert Krewinkel @@ -45,6 +45,7 @@ data GridCell = ContentCell Attr Alignment RowSpan ColSpan [Block] | ContinuationCell CellIndex + | UnassignedCell deriving (Show) -- | Row index in a table part. @@ -103,7 +104,7 @@ fromBuilderCell :: BuilderCell -> GridCell fromBuilderCell = \case FilledCell c -> c - FreeCell -> error "Found an unassigned cell. Please report this as a bug!" + FreeCell -> UnassignedCell rowsToPart :: Attr -> [B.Row] -> Part rowsToPart attr = \case diff --git a/src/Text/Pandoc/Writers/HTML.hs b/src/Text/Pandoc/Writers/HTML.hs --- a/src/Text/Pandoc/Writers/HTML.hs +++ b/src/Text/Pandoc/Writers/HTML.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} @@ -6,7 +8,7 @@ {-# LANGUAGE ViewPatterns #-} {- | Module : Text.Pandoc.Writers.HTML - Copyright : Copyright (C) 2006-2022 John MacFarlane + Copyright : Copyright (C) 2006-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane @@ -29,9 +31,13 @@ tagWithAttributes ) where import Control.Monad.State.Strict + ( StateT, MonadState(get), gets, modify, evalStateT ) +import Control.Monad ( liftM, when, foldM, unless ) +import Control.Monad.Trans ( MonadTrans(lift) ) import Data.Char (ord) import Data.List (intercalate, intersperse, partition, delete, (\\), foldl') import Data.List.NonEmpty (NonEmpty((:|))) +import Data.Containers.ListUtils (nubOrd) import Data.Maybe (fromMaybe, isJust, isNothing) import qualified Data.Set as Set import Data.Text (Text) @@ -43,11 +49,9 @@ import Text.Blaze.Internal (MarkupM (Empty), customLeaf, customParent) import Text.DocTemplates (FromContext (lookupContext), Context (..)) import Text.Blaze.Html hiding (contents) -import Text.Pandoc.Translations (Term(Abstract)) -import Text.Pandoc.CSS (cssAttributes) import Text.Pandoc.Definition -import Text.Pandoc.Highlighting (formatHtmlBlock, formatHtmlInline, highlight, - styleToCss) +import Text.Pandoc.Highlighting (formatHtmlBlock, formatHtml4Block, + formatHtmlInline, highlight, styleToCss) import Text.Pandoc.ImageSize import Text.Pandoc.Options import Text.Pandoc.Shared @@ -57,7 +61,7 @@ import Text.Pandoc.Writers.Math import Text.Pandoc.Writers.Shared import qualified Text.Pandoc.Writers.AnnotatedTable as Ann -import Text.Pandoc.Network.HTTP (urlEncode) +import Text.Pandoc.URI (urlEncode) import Text.Pandoc.XML (escapeStringForXML, fromEntities, toEntities, html5Attributes, html4Attributes, rdfaAttributes) import qualified Text.Blaze.XHtml5 as H5 @@ -67,8 +71,8 @@ import Text.Blaze.Html.Renderer.Text (renderHtml) import qualified Text.Blaze.XHtml1.Transitional as H import qualified Text.Blaze.XHtml1.Transitional.Attributes as A -import Text.Pandoc.Class.PandocMonad (PandocMonad, report, - translateTerm) +import Text.Pandoc.Class.PandocMonad (PandocMonad, report) +import Text.Pandoc.Translations (Term(Abstract), translateTerm) import Text.Pandoc.Class.PandocPure (runPure) import Text.Pandoc.Error import Text.Pandoc.Logging @@ -114,21 +118,20 @@ strToHtml :: Text -> Html strToHtml t - | T.any isSpecial t = strToHtml' $ T.unpack t + | T.any isSpecial t = + let !x = foldl' go mempty $ T.groupBy samegroup t + in x | otherwise = toHtml t where - strToHtml' ('\'':xs) = preEscapedString "\'" `mappend` strToHtml' xs - strToHtml' ('"' :xs) = preEscapedString "\"" `mappend` strToHtml' xs - strToHtml' (x:xs) | needsVariationSelector x - = preEscapedString [x, '\xFE0E'] `mappend` - case xs of - ('\xFE0E':ys) -> strToHtml' ys - _ -> strToHtml' xs - strToHtml' xs@(_:_) = case break isSpecial xs of - (_ ,[]) -> toHtml xs - (ys,zs) -> toHtml ys `mappend` strToHtml' zs - strToHtml' [] = "" - isSpecial c = c == '\'' || c == '"' || needsVariationSelector c + samegroup c d = d == '\xFE0E' || not (isSpecial c || isSpecial d) + isSpecial '\'' = True + isSpecial '"' = True + isSpecial c = needsVariationSelector c + go h "\'" = h <> preEscapedString "\'" + go h "\"" = h <> preEscapedString "\"" + go h txt | T.length txt == 1 && T.all needsVariationSelector txt + = h <> preEscapedString (T.unpack txt <> "\xFE0E") + go h txt = h <> toHtml txt -- See #5469: this prevents iOS from substituting emojis. needsVariationSelector :: Char -> Bool @@ -339,15 +342,7 @@ H.link ! A.rel "stylesheet" ! A.href (toValue $ url <> "katex.min.css") - _ -> case lookupContext "mathml-script" - (writerVariables opts) of - Just s | not (stHtml5 st) -> - H.script ! A.type_ "text/javascript" - $ preEscapedString - ("/* T.unpack s <> - "/*]]>*/\n") - | otherwise -> mempty - Nothing -> mempty + _ -> mempty let mCss :: Maybe [Text] = lookupContext "css" metadata let context :: Context Text context = (if stHighlighting st @@ -545,9 +540,9 @@ = H5.section ! A.id "footnotes" ! A.class_ className ! customAttribute "epub:type" "footnotes" $ x - | html5 = H5.section ! A.id "footnotes" - ! A.class_ className - ! customAttribute "role" "doc-endnotes" + | html5 = H5.section ! A5.id "footnotes" + ! A5.class_ className + ! A5.role "doc-endnotes" $ x | slideVariant /= NoSlides = H.div ! A.class_ "footnotes slide" $ x | otherwise = H.div ! A.class_ className $ x @@ -679,9 +674,10 @@ => WriterOptions -> Attr -> StateT WriterState m [Attribute] attrsToHtml opts (id',classes',keyvals) = do attrs <- toAttrs keyvals + let classes'' = filter (not . T.null) classes' return $ [prefixedId opts id' | not (T.null id')] ++ - [A.class_ (toValue $ T.unwords classes') | not (null classes')] ++ attrs + [A.class_ (toValue $ T.unwords classes'') | not (null classes'')] ++ attrs imgAttrsToHtml :: PandocMonad m => WriterOptions -> Attr -> StateT WriterState m [Attribute] @@ -709,34 +705,6 @@ (Just x) -> [("style", tshow dir <> ":" <> tshow x)] Nothing -> [] -figure :: PandocMonad m - => WriterOptions -> Attr -> [Inline] -> (Text, Text) - -> StateT WriterState m Html -figure opts attr@(_, _, attrList) txt (s,tit) = do - html5 <- gets stHtml5 - -- Screen-readers will normally read the @alt@ text and the figure; we - -- want to avoid them reading the same text twice. With HTML5 we can - -- use aria-hidden for the caption; with HTML4, we use an empty - -- alt-text instead. - -- When the alt text differs from the caption both should be read. - let alt = if html5 then txt else [Str ""] - let tocapt = if html5 - then (H5.figcaption !) $ - if isJust (lookup "alt" attrList) - then mempty - else H5.customAttribute (textTag "aria-hidden") - (toValue @Text "true") - else H.p ! A.class_ "caption" - img <- inlineToHtml opts (Image attr alt (s,tit)) - capt <- if null txt - then return mempty - else (nl <>) . tocapt <$> inlineListToHtml opts txt - let inner = mconcat [nl, img, capt, nl] - return $ if html5 - then H5.figure inner - else H.div ! A.class_ "figure" $ inner - - adjustNumbers :: WriterOptions -> [Block] -> [Block] adjustNumbers opts doc = if all (==0) (writerNumberOffset opts) @@ -757,25 +725,20 @@ showSecNum = T.intercalate "." . map tshow blockToHtmlInner :: PandocMonad m => WriterOptions -> Block -> StateT WriterState m Html -blockToHtmlInner _ Null = return mempty blockToHtmlInner opts (Plain lst) = inlineListToHtml opts lst -blockToHtmlInner opts (Para [Image attr@(_,classes,_) txt (src,tit)]) - | "r-stretch" `elem` classes = do - slideVariant <- gets stSlideVariant - case slideVariant of - RevealJsSlides -> - -- a "stretched" image in reveal.js must be a direct child - -- of the slide container - inlineToHtml opts (Image attr txt (src, tit)) - _ -> figure opts attr txt (src, tit) --- title beginning with fig: indicates that the image is a figure -blockToHtmlInner opts (SimpleFigure attr caption (src, title)) = - figure opts attr caption (src, title) blockToHtmlInner opts (Para lst) = do - contents <- inlineListToHtml opts lst - case contents of - Empty _ | not (isEnabled Ext_empty_paragraphs opts) -> return mempty - _ -> return $ H.p contents + slideVariant <- gets stSlideVariant + case (slideVariant, lst) of + (RevealJsSlides, [Image attr@(_,classes,_) txt (src,tit)]) + | "r-stretch" `elem` classes -> do + -- a "stretched" image in reveal.js must be a direct child + -- of the slide container + inlineToHtml opts (Image attr txt (src, tit)) + _ -> do + contents <- inlineListToHtml opts lst + case contents of + Empty _ | not (isEnabled Ext_empty_paragraphs opts) -> return mempty + _ -> return $ H.p contents blockToHtmlInner opts (LineBlock lns) = if writerWrapText opts == WrapNone then blockToHtml opts $ linesToPara lns @@ -808,9 +771,11 @@ let inDiv' zs = RawBlock (Format "html") ("
fragmentClass <> "\">") : (zs ++ [RawBlock (Format "html") "
"]) - let breakOnPauses zs = case splitBy isPause zs of + let breakOnPauses zs + | slide = case splitBy isPause zs of [] -> [] y:ys -> y ++ concatMap inDiv' ys + | otherwise = zs let (titleBlocks, innerSecs) = if titleSlide -- title slides have no content of their own @@ -827,7 +792,7 @@ res <- blockListToHtml opts innerSecs modify $ \st -> st{ stInSection = inSection } return res - let classes' = ordNub $ + let classes' = nubOrd $ ["title-slide" | titleSlide] ++ ["slide" | slide] ++ ["section" | (slide || writerSectionDivs opts) && not html5 ] ++ @@ -878,8 +843,8 @@ , k /= "width" || "column" `notElem` classes] ++ [("style", "width:" <> w <> ";") | "column" `elem` classes , ("width", w) <- kvs'] ++ - [("role", "doc-bibliography") | isCslBibBody && html5] ++ - [("role", "doc-biblioentry") | isCslBibEntry && html5] + [("role", "list") | isCslBibBody && html5] ++ + [("role", "listitem") | isCslBibEntry && html5] let speakerNotes = "notes" `elem` classes -- we don't want incremental output inside speaker notes, see #1394 let opts' = if | speakerNotes -> opts{ writerIncremental = False } @@ -913,7 +878,7 @@ DZSlides -> do t <- addAttrs opts' attr $ H5.div contents' - return $ t ! H5.customAttribute "role" "note" + return $ t ! A5.role "note" NoSlides -> addAttrs opts' attr $ H.div contents' _ -> return mempty @@ -926,7 +891,9 @@ else if (f == Format "latex" || f == Format "tex") && allowsMathEnvironments (writerHTMLMathMethod opts) && isMathEnvironment str - then blockToHtml opts $ Plain [Math DisplayMath str] + then do + modify (\st -> st {stMath = True}) + blockToHtml opts $ Plain [Math DisplayMath str] else do report $ BlockNotRendered (RawBlock f str) return mempty @@ -934,6 +901,7 @@ html5 <- gets stHtml5 return $ if html5 then H5.hr else H.hr blockToHtmlInner opts (CodeBlock (id',classes,keyvals) rawCode) = do + html5 <- gets stHtml5 id'' <- if T.null id' then do modify $ \st -> st{ stCodeBlockNum = stCodeBlockNum st + 1 } @@ -952,7 +920,8 @@ then T.unlines . map ("> " <>) . T.lines $ rawCode else rawCode hlCode = if isJust (writerHighlightStyle opts) - then highlight (writerSyntaxMap opts) formatHtmlBlock + then highlight (writerSyntaxMap opts) + (if html5 then formatHtmlBlock else formatHtml4Block) (id'',classes',keyvals) adjCode else Left "" case hlCode of @@ -1001,7 +970,8 @@ else [ (k, v) | (k, v) <- kvs , k `elem` (["lang", "dir", "title", "style" , "align"] ++ intrinsicEventsHTML4)] - addAttrs opts (ident,classes,kvs') + let classes' = if level > 6 then "heading":classes else classes + addAttrs opts (ident,classes',kvs') $ case level of 1 -> H.h1 contents' 2 -> H.h2 contents' @@ -1009,7 +979,7 @@ 4 -> H.h4 contents' 5 -> H.h5 contents' 6 -> H.h6 contents' - _ -> H.p ! A.class_ "heading" $ contents' + _ -> H.p contents' blockToHtmlInner opts (BulletList lst) = do contents <- mapM (listItemToHtml opts) lst let isTaskList = not (null lst) && all isTaskListItem lst @@ -1048,7 +1018,35 @@ defList opts contents blockToHtmlInner opts (Table attr caption colspecs thead tbody tfoot) = tableToHtml opts (Ann.toTable attr caption colspecs thead tbody tfoot) +blockToHtmlInner opts (Figure attrs (Caption _ captBody) body) = do + html5 <- gets stHtml5 + figAttrs <- attrsToHtml opts attrs + contents <- blockListToHtml opts body + figCaption <- if null captBody + then return mempty + else do + captCont <- blockListToHtml opts captBody + return . mconcat $ + if html5 + then let fcattr = if captionIsAlt captBody body + then H5.customAttribute + (textTag "aria-hidden") + (toValue @Text "true") + else mempty + in [ H5.figcaption ! fcattr $ captCont, nl ] + else [ (H.div ! A.class_ "figcaption") captCont, nl ] + return $ + if html5 + then foldl (!) H5.figure figAttrs $ mconcat [nl, contents, nl, figCaption] + else foldl (!) H.div (A.class_ "float" : figAttrs) $ mconcat + [nl, contents, nl, figCaption] + where + captionIsAlt capt [Plain [Image (_, _, kv) desc _]] = + let alt = fromMaybe (stringify desc) $ lookup "alt" kv + in stringify capt == alt + captionIsAlt _ _ = False + -- | Convert Pandoc block element to HTML. All the legwork is done by -- 'blockToHtmlInner', this just takes care of emitting the notes after -- the block if necessary. @@ -1259,13 +1257,6 @@ rowHtml nl -alignmentToString :: Alignment -> Maybe Text -alignmentToString = \case - AlignLeft -> Just "left" - AlignRight -> Just "right" - AlignCenter -> Just "center" - AlignDefault -> Nothing - colspanAttrib :: ColSpan -> Attribute colspanAttrib = \case ColSpan 1 -> mempty @@ -1301,12 +1292,12 @@ let align' = case align of AlignDefault -> colAlign _ -> align - let kvs' = case alignmentToString align' of + let kvs' = case htmlAlignmentToString align' of Nothing -> kvs Just alignStr -> if html5 - then addStyle ("text-align", alignStr) kvs + then htmlAddStyle ("text-align", alignStr) kvs else case break ((== "align") . fst) kvs of (_, []) -> ("align", alignStr) : kvs (xs, _:rest) -> xs ++ ("align", alignStr) : rest @@ -1319,23 +1310,6 @@ tag' ! attribs $ contents nl --- | Adds a key-value pair to the @style@ attribute. -addStyle :: (Text, Text) -> [(Text, Text)] -> [(Text, Text)] -addStyle (key, value) kvs = - let cssToStyle = T.intercalate " " . map (\(k, v) -> k <> ": " <> v <> ";") - in case break ((== "style") . fst) kvs of - (_, []) -> - -- no style attribute yet, add new one - ("style", cssToStyle [(key, value)]) : kvs - (xs, (_,cssStyles):rest) -> - -- modify the style attribute - xs ++ ("style", cssToStyle modifiedCssStyles) : rest - where - modifiedCssStyles = - case break ((== key) . fst) $ cssAttributes cssStyles of - (cssAttribs, []) -> (key, value) : cssAttribs - (pre, _:post) -> pre ++ (key, value) : post - toListItems :: [Html] -> [Html] toListItems items = map toListItem items ++ [nl] @@ -1536,16 +1510,20 @@ case istex of True | allowsMathEnvironments mm && isMathEnvironment str - -> inlineToHtml opts $ Math DisplayMath str + -> do + modify (\st -> st {stMath = True}) + inlineToHtml opts $ Math DisplayMath str | allowsRef mm && isRef str - -> inlineToHtml opts $ Math InlineMath str + -> do + modify (\st -> st {stMath = True}) + inlineToHtml opts $ Math InlineMath str _ -> do report $ InlineNotRendered inline return mempty (Link attr txt (s,_)) | "mailto:" `T.isPrefixOf` s -> do - linkText <- inlineListToHtml opts txt + linkText <- inlineListToHtml opts (removeLinks txt) obfuscateLink opts attr linkText s (Link (ident,classes,kvs) txt (s,tit)) -> do - linkText <- inlineListToHtml opts txt + linkText <- inlineListToHtml opts (removeLinks txt) slideVariant <- gets stSlideVariant let s' = case T.uncons s of Just ('#',xs) -> let prefix = if slideVariant == RevealJsSlides @@ -1610,10 +1588,12 @@ $ toHtml ref return $ case epubVersion of Just EPUB3 -> link ! customAttribute "epub:type" "noteref" - _ | html5 -> link ! H5.customAttribute - "role" "doc-noteref" + _ | html5 -> link ! A5.role "doc-noteref" _ -> link - (Cite cits il)-> do contents <- inlineListToHtml opts (walk addRoleToLink il) + (Cite cits il)-> do contents <- inlineListToHtml opts + (if html5 + then walk addRoleToLink il + else il) let citationIds = T.unwords $ map citationId cits let result = H.span ! A.class_ "citation" $ contents return $ if html5 @@ -1696,6 +1676,7 @@ , "multline" , "multline*" , "pmatrix" + , "prooftree" -- bussproofs , "smallmatrix" , "split" , "subarray" @@ -1724,3 +1705,11 @@ html5 <- gets stHtml5 return $ f == Format "html" || ((html5 && f == Format "html5") || f == Format "html4") + +-- We need to remove links from link text, because an element is +-- not allowed inside another element. +removeLinks :: [Inline] -> [Inline] +removeLinks = walk go + where + go (Link attr ils _) = Span attr ils + go x = x diff --git a/src/Text/Pandoc/Writers/Haddock.hs b/src/Text/Pandoc/Writers/Haddock.hs --- a/src/Text/Pandoc/Writers/Haddock.hs +++ b/src/Text/Pandoc/Writers/Haddock.hs @@ -14,7 +14,9 @@ Haddock: -} module Text.Pandoc.Writers.Haddock (writeHaddock) where +import Control.Monad (zipWithM) import Control.Monad.State.Strict + ( StateT, MonadState(get), modify, evalStateT ) import Data.Char (isAlphaNum) import Data.Default import Data.Text (Text) @@ -25,6 +27,7 @@ import Text.Pandoc.Options import Text.DocLayout import Text.Pandoc.Shared +import Text.Pandoc.URI import Text.Pandoc.Templates (renderTemplate) import Text.Pandoc.Writers.Shared @@ -90,16 +93,12 @@ => WriterOptions -- ^ Options -> Block -- ^ Block element -> StateT WriterState m (Doc Text) -blockToHaddock _ Null = return empty blockToHaddock opts (Div _ ils) = do contents <- blockListToHaddock opts ils return $ contents <> blankline blockToHaddock opts (Plain inlines) = do contents <- inlineListToHaddock opts inlines return $ contents <> cr --- title beginning with fig: indicates figure -blockToHaddock opts (SimpleFigure attr alt (src, tit)) - = blockToHaddock opts (Para [Image attr alt (src,tit)]) blockToHaddock opts (Para inlines) = -- TODO: if it contains linebreaks, we need to use a @...@ block (<> blankline) `fmap` blockToHaddock opts (Plain inlines) @@ -149,6 +148,9 @@ blockToHaddock opts (DefinitionList items) = do contents <- mapM (definitionListItemToHaddock opts) items return $ vcat contents <> blankline +blockToHaddock opts (Figure _ (Caption _ longcapt) body) = + -- Haddock has no concept of figures, floats, or captions. + fmap (<> blankline) (blockListToHaddock opts (body ++ longcapt)) -- | Convert bullet list item (list of blocks) to haddock bulletListItemToHaddock :: PandocMonad m diff --git a/src/Text/Pandoc/Writers/ICML.hs b/src/Text/Pandoc/Writers/ICML.hs --- a/src/Text/Pandoc/Writers/ICML.hs +++ b/src/Text/Pandoc/Writers/ICML.hs @@ -17,7 +17,9 @@ -} module Text.Pandoc.Writers.ICML (writeICML) where import Control.Monad.Except (catchError) +import Control.Monad (liftM2) import Control.Monad.State.Strict + ( MonadTrans(lift), StateT(runStateT), MonadState(state, get, put) ) import Data.List (intersperse) import Data.Maybe (fromMaybe, maybeToList) import qualified Data.Set as Set @@ -30,6 +32,7 @@ import Text.Pandoc.Options import Text.DocLayout import Text.Pandoc.Shared +import Text.Pandoc.URI (isURI) import Text.Pandoc.Templates (renderTemplate) import Text.Pandoc.Writers.Math (texMathToInlines) import Text.Pandoc.Writers.Shared @@ -309,10 +312,6 @@ -- | Convert a Pandoc block element to ICML. blockToICML :: PandocMonad m => WriterOptions -> Style -> Block -> WS m (Doc Text) blockToICML opts style (Plain lst) = parStyle opts style "" lst -blockToICML opts style (SimpleFigure attr txt (src, tit)) = do - figure <- parStyle opts (figureName:style) "" [Image attr txt (src, tit)] - caption <- parStyle opts (imgCaptionName:style) "" txt - return $ intersperseBrs [figure, caption] blockToICML opts style (Para lst) = parStyle opts (paragraphName:style) "" lst blockToICML opts style (LineBlock lns) = blockToICML opts style $ linesToPara lns @@ -383,8 +382,17 @@ blockToICML opts style (Div (_ident, _, kvs) lst) = let dynamicStyle = maybeToList $ lookup dynamicStyleKey kvs in blocksToICML opts (dynamicStyle <> style) lst -blockToICML _ _ Null = return empty +blockToICML opts style (Figure attr capt@(Caption _ longcapt) body) = + case body of + [Plain [img@(Image {})]] -> do + figure <- parStyle opts (figureName:style) "" [img] + caption <- parStyle opts (imgCaptionName:style) "" $ + blocksToInlines longcapt + return $ intersperseBrs [figure, caption] + _ -> -- fallback to rendering the figure as a Div + blockToICML opts style $ figureDiv attr capt body + -- | Convert a list of lists of blocks to ICML list items. listItemsToICML :: PandocMonad m => WriterOptions -> Text -> Style -> Maybe ListAttributes -> [[Block]] -> WS m (Doc Text) listItemsToICML _ _ _ _ [] = return empty @@ -486,7 +494,7 @@ in inlinesToICML opts (dynamicStyle <> style) ident lst -- ident will be the id of the span, that we need to use down in the hyperlink setter -- if T.null ident --- then +-- then -- else do -- | Convert a list of block elements to an ICML footnote. @@ -559,7 +567,7 @@ -- | Create the markup for the content (incl. named destinations) -- | NOTE: since we have no easy way to get actual named dests, we just create them for any short content blocks makeContent :: Text -> Doc Text -> Doc Text -makeContent ident cont +makeContent ident cont | isEmpty cont = empty | not (Text.null ident) = makeLinkDest ident cont | otherwise = inTagsSimple "Content" $ flush cont @@ -620,6 +628,13 @@ , selfClosingTag "PathPointType" [("Anchor", hw<>" -"<>hh), ("LeftDirection", hw<>" -"<>hh), ("RightDirection", hw<>" -"<>hh)] ] + img = if "data:" `Text.isPrefixOf` src' && "base64," `Text.isInfixOf` src' + then -- see #8398 + inTags True "Contents" [] $ + literal (" + Text.drop 1 (Text.dropWhile (/=',') src') <> "]]>") + else selfClosingTag "Link" [("Self", "ueb"), ("LinkResourceURI", src')] + image = inTags True "Image" [("Self","ue6"), ("ItemTransform", scale<>" -"<>hw<>" -"<>hh)] $ vcat [ @@ -629,7 +644,7 @@ , ("Right", showFl $ ow*ow / imgWidth) , ("Bottom", showFl $ oh*oh / imgHeight)] ] - , selfClosingTag "Link" [("Self", "ueb"), ("LinkResourceURI", src')] + , img ] doc = inTags True "CharacterStyleRange" attrs $ inTags True "Rectangle" [("Self","uec"), ("StrokeWeight", "0"), diff --git a/src/Text/Pandoc/Writers/Ipynb.hs b/src/Text/Pandoc/Writers/Ipynb.hs --- a/src/Text/Pandoc/Writers/Ipynb.hs +++ b/src/Text/Pandoc/Writers/Ipynb.hs @@ -2,7 +2,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {- | Module : Text.Pandoc.Writers.Ipynb - Copyright : Copyright (C) 2019-2022 John MacFarlane + Copyright : Copyright (C) 2019-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane @@ -14,7 +14,8 @@ -} module Text.Pandoc.Writers.Ipynb ( writeIpynb ) where -import Control.Monad.State +import Control.Monad (foldM) +import Control.Monad.State ( StateT(runStateT), modify ) import qualified Data.Map as M import Data.Maybe (catMaybes, fromMaybe) import Text.Pandoc.Options @@ -29,7 +30,8 @@ import qualified Data.Text.Lazy as TL import Data.Aeson as Aeson import qualified Text.Pandoc.UTF8 as UTF8 -import Text.Pandoc.Shared (safeRead, isURI) +import Text.Pandoc.Shared (safeRead) +import Text.Pandoc.URI (isURI) import Text.Pandoc.Writers.Shared (metaToContext') import Text.Pandoc.Writers.Markdown (writePlain, writeMarkdown) import qualified Data.Text.Encoding as TE diff --git a/src/Text/Pandoc/Writers/JATS.hs b/src/Text/Pandoc/Writers/JATS.hs --- a/src/Text/Pandoc/Writers/JATS.hs +++ b/src/Text/Pandoc/Writers/JATS.hs @@ -4,7 +4,7 @@ {-# LANGUAGE ViewPatterns #-} {- | Module : Text.Pandoc.Writers.JATS - Copyright : 2017-2022 John MacFarlane + Copyright : 2017-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane @@ -22,6 +22,7 @@ , writeJatsArticleAuthoring ) where import Control.Applicative ((<|>)) +import Control.Monad import Control.Monad.Reader import Control.Monad.State import Data.Generics (everywhere, mkT) @@ -41,6 +42,7 @@ import Text.Pandoc.Options import Text.DocLayout import Text.Pandoc.Shared +import Text.Pandoc.URI import Text.Pandoc.Templates (renderTemplate) import Text.DocTemplates (Context(..), Val(..)) import Text.Pandoc.Writers.JATS.References (referencesToJATS) @@ -70,6 +72,7 @@ -- | Alias for @'writeJatsArchiving'@. This function exists for backwards -- compatibility, but will be deprecated in the future. Use -- @'writeJatsArchiving'@ instead. +{-# DEPRECATED writeJATS "Use writeJatsArchiving instead" #-} writeJATS :: PandocMonad m => WriterOptions -> Pandoc -> m Text writeJATS = writeJatsArchiving @@ -135,8 +138,11 @@ formatTime defaultTimeLocale "%F" day) ] Just x -> x + title' <- inlinesToJATS opts $ map fixLineBreak + (lookupMetaInlines "title" meta) let context = defField "body" main $ defField "back" back + $ resetField "title" title' $ resetField "date" date $ defField "mathml" (case writerHTMLMathMethod opts of MathML -> True @@ -214,17 +220,6 @@ maybe empty (inTagsSimple "label" . text . T.unpack) mbmarker $$ contents -imageMimeType :: Text -> [(Text, Text)] -> (Text, Text) -imageMimeType src kvs = - let mbMT = getMimeType (T.unpack src) - maintype = fromMaybe "image" $ - lookup "mimetype" kvs `mplus` - (T.takeWhile (/='/') <$> mbMT) - subtype = fromMaybe "" $ - lookup "mime-subtype" kvs `mplus` - (T.drop 1 . T.dropWhile (/='/') <$> mbMT) - in (maintype, subtype) - languageFor :: WriterOptions -> [Text] -> Text languageFor opts classes = case langs of @@ -249,15 +244,20 @@ "platforms", "position", "specific-use"]] lang = languageFor opts classes +-- is only allowed as a direct child of or or +-- <article-title> +fixLineBreak :: Inline -> Inline +fixLineBreak LineBreak = RawInline (Format "jats") "<break/>" +fixLineBreak x = x + -- | Convert a Pandoc block element to JATS. blockToJATS :: PandocMonad m => WriterOptions -> Block -> JATS m (Doc Text) -blockToJATS _ Null = return empty blockToJATS opts (Div (id',"section":_,kvs) (Header _lvl _ ils : xs)) = do let idAttr = [ ("id", writerIdentifierPrefix opts <> escapeNCName id') | not (T.null id')] let otherAttrs = ["sec-type", "specific-use"] let attribs = idAttr ++ [(k,v) | (k,v) <- kvs, k `elem` otherAttrs] - title' <- inlinesToJATS opts ils + title' <- inlinesToJATS opts (map fixLineBreak ils) contents <- blocksToJATS opts xs return $ inTags True "sec" attribs $ inTagsSimple "title" title' $$ contents @@ -287,37 +287,15 @@ "content-type", "orientation", "position"]] return $ inTags True "boxed-text" attr contents blockToJATS opts (Header _ _ title) = do - title' <- inlinesToJATS opts title + title' <- inlinesToJATS opts (map fixLineBreak title) return $ inTagsSimple "title" title' +-- Special cases for bare images, which are rendered as graphics +blockToJATS _opts (Plain [Image attr alt tgt]) = + return $ graphic attr alt tgt +blockToJATS _opts (Para [Image attr alt tgt]) = + return $ graphic attr alt tgt -- No Plain, everything needs to be in a block-level tag blockToJATS opts (Plain lst) = blockToJATS opts (Para lst) -blockToJATS opts (SimpleFigure (ident, _, kvs) txt (src, tit)) = do - alt <- inlinesToJATS opts txt - let (maintype, subtype) = imageMimeType src kvs - let capt = if null txt - then empty - else inTagsSimple "caption" $ inTagsSimple "p" alt - let attr = [("id", escapeNCName ident) | not (T.null ident)] ++ - [(k,v) | (k,v) <- kvs, k `elem` ["fig-type", "orientation", - "position", "specific-use"]] - let graphicattr = [("mimetype",maintype), - ("mime-subtype",subtype), - ("xlink:href",src), -- do we need to URL escape this? - ("xlink:title",tit)] - return $ inTags True "fig" attr $ - capt $$ selfClosingTag "graphic" graphicattr -blockToJATS _ (Para [Image (ident,_,kvs) _ (src, tit)]) = do - let (maintype, subtype) = imageMimeType src kvs - let attr = [("id", escapeNCName ident) | not (T.null ident)] ++ - [("mimetype", maintype), - ("mime-subtype", subtype), - ("xlink:href", src)] ++ - [("xlink:title", tit) | not (T.null tit)] ++ - [(k,v) | (k,v) <- kvs, k `elem` ["baseline-shift", - "content-type", "specific-use", "xlink:actuate", - "xlink:href", "xlink:role", "xlink:show", - "xlink:type"]] - return $ selfClosingTag "graphic" attr blockToJATS opts (Para lst) = inTagsSimple "p" <$> inlinesToJATS opts lst blockToJATS opts (LineBlock lns) = @@ -373,6 +351,16 @@ blockToJATS _ HorizontalRule = return empty -- not semantic blockToJATS opts (Table attr caption colspecs thead tbody tfoot) = tableToJATS opts (Ann.toTable attr caption colspecs thead tbody tfoot) +blockToJATS opts (Figure (ident, _, kvs) caption body) = do + capt <- case caption of + Caption _ [] -> pure empty + Caption _ cpt -> inTagsSimple "caption" <$> blocksToJATS opts cpt + figbod <- blocksToJATS opts body + let figattr = [("id", escapeNCName ident) | not (T.null ident)] ++ + [(k,v) | (k,v) <- kvs + , k `elem` [ "fig-type", "orientation" + , "position", "specific-use"]] + return $ inTags True "fig" figattr $ capt $$ figbod -- | Convert a list of inline elements to JATS. inlinesToJATS :: PandocMonad m => WriterOptions -> [Inline] -> JATS m (Doc Text) @@ -531,27 +519,40 @@ "xlink:type"]] contents <- inlinesToJATS opts txt return $ inTags False "ext-link" attr contents -inlineToJATS _ (Image (ident,_,kvs) _ (src, tit)) = do +inlineToJATS _ (Image attr alt tgt) = do + return $ selfClosingTag "inline-graphic" (graphicAttr attr alt tgt) + +graphic :: Attr -> [Inline] -> Target -> (Doc Text) +graphic attr alt tgt = + selfClosingTag "graphic" (graphicAttr attr alt tgt) + +graphicAttr :: Attr -> [Inline] -> Target -> [(Text, Text)] +graphicAttr (ident, _, kvs) _alt (src, tit) = + let (maintype, subtype) = imageMimeType src kvs + in [("id", escapeNCName ident) | not (T.null ident)] ++ + [ ("mimetype", maintype) + , ("mime-subtype", subtype) + , ("xlink:href", src) + ] ++ + [("xlink:title", tit) | not (T.null tit)] ++ + [(k,v) | (k,v) <- kvs + , k `elem` [ "baseline-shift", "content-type", "specific-use" + , "xlink:actuate", "xlink:href", "xlink:role" + , "xlink:show", "xlink:type"] + ] + +imageMimeType :: Text -> [(Text, Text)] -> (Text, Text) +imageMimeType src kvs = let mbMT = getMimeType (T.unpack src) - let maintype = fromMaybe "image" $ + maintype = fromMaybe "image" $ lookup "mimetype" kvs `mplus` (T.takeWhile (/='/') <$> mbMT) - let subtype = fromMaybe "" $ + subtype = fromMaybe "" $ lookup "mime-subtype" kvs `mplus` (T.drop 1 . T.dropWhile (/='/') <$> mbMT) - let attr = [("id", escapeNCName ident) | not (T.null ident)] ++ - [("mimetype", maintype), - ("mime-subtype", subtype), - ("xlink:href", src)] ++ - [("xlink:title", tit) | not (T.null tit)] ++ - [(k,v) | (k,v) <- kvs, k `elem` ["baseline-shift", - "content-type", "specific-use", "xlink:actuate", - "xlink:href", "xlink:role", "xlink:show", - "xlink:type"]] - return $ selfClosingTag "inline-graphic" attr + in (maintype, subtype) isParaOrList :: Block -> Bool -isParaOrList SimpleFigure{} = False -- implicit figures are not paragraphs isParaOrList Para{} = True isParaOrList Plain{} = True isParaOrList BulletList{} = True diff --git a/src/Text/Pandoc/Writers/JATS/References.hs b/src/Text/Pandoc/Writers/JATS/References.hs --- a/src/Text/Pandoc/Writers/JATS/References.hs +++ b/src/Text/Pandoc/Writers/JATS/References.hs @@ -2,7 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Writers.JATS.References - Copyright : © 2021-2022 Albert Krewinkel + Copyright : © 2021-2023 Albert Krewinkel License : GNU GPL, version 2 or above Maintainer : Albert Krewinkel <tarleb@zeitkraut.de> @@ -147,13 +147,11 @@ fourDigits n = T.takeEnd 4 $ "000" <> tshow n toNameElements :: Name -> Doc Text -toNameElements name = - if not (isEmpty nameTags) - then inTags' "name" [] nameTags - else if nameLiteral name == Just "others" -- indicates an "et al." - then "<etal/>" - else nameLiteral name `inNameTag` "string-name" - where +toNameElements name + | not (isEmpty nameTags) = inTags' "name" [] nameTags + | nameLiteral name == Just "others" = "<etal/>" + | otherwise = nameLiteral name `inNameTag` "string-name" + where inNameTag mVal tag = case mVal of Nothing -> empty Just val -> inTags' tag [] . literal $ escapeStringForXML val diff --git a/src/Text/Pandoc/Writers/JATS/Table.hs b/src/Text/Pandoc/Writers/JATS/Table.hs --- a/src/Text/Pandoc/Writers/JATS/Table.hs +++ b/src/Text/Pandoc/Writers/JATS/Table.hs @@ -3,7 +3,7 @@ {-# LANGUAGE TupleSections #-} {- | Module : Text.Pandoc.Writers.JATS.Table - Copyright : © 2020-2022 Albert Krewinkel + Copyright : © 2020-2023 Albert Krewinkel License : GNU GPL, version 2 or above Maintainer : Albert Krewinkel <tarleb@zeitkraut.de> @@ -234,8 +234,13 @@ tableCellToJats opts ctype colAlign (Cell attr align rowspan colspan item) = do blockToJats <- asks jatsBlockWriter inlinesToJats <- asks jatsInlinesWriter + let fixBreak LineBreak = RawInline (Format "jats") "<break/>" + fixBreak x = x let cellContents = \case - [Plain inlines] -> inlinesToJats opts inlines + [Plain inlines] -> inlinesToJats opts + (map fixBreak inlines) + -- Note: <break/> is allowed only as a direct + -- child of <td>, so we don't use walk. blocks -> blockToJats needsWrapInCell opts blocks let tag' = case ctype of BodyCell -> "td" diff --git a/src/Text/Pandoc/Writers/JATS/Types.hs b/src/Text/Pandoc/Writers/JATS/Types.hs --- a/src/Text/Pandoc/Writers/JATS/Types.hs +++ b/src/Text/Pandoc/Writers/JATS/Types.hs @@ -1,6 +1,6 @@ {- | Module : Text.Pandoc.Writers.JATS.Types - Copyright : Copyright (C) 2017-2022 John MacFarlane + Copyright : Copyright (C) 2017-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> diff --git a/src/Text/Pandoc/Writers/Jira.hs b/src/Text/Pandoc/Writers/Jira.hs --- a/src/Text/Pandoc/Writers/Jira.hs +++ b/src/Text/Pandoc/Writers/Jira.hs @@ -3,7 +3,7 @@ {-# LANGUAGE PatternGuards #-} {- | Module : Text.Pandoc.Writers.Jira - Copyright : © 2010-2022 Albert Krewinkel, John MacFarlane + Copyright : © 2010-2023 Albert Krewinkel, John MacFarlane License : GNU GPL, version 2 or above Maintainer : Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> @@ -103,7 +103,6 @@ Para xs -> singleton . Jira.Para <$> toJiraInlines xs Plain xs -> singleton . Jira.Para <$> toJiraInlines xs RawBlock fmt cs -> rawBlockToJira fmt cs - Null -> return mempty Table _ blkCapt specs thead tbody tfoot -> singleton <$> do let (_, _, _, hd, body) = toLegacyTable blkCapt specs thead tbody tfoot headerRow <- if all null hd @@ -114,6 +113,7 @@ Just header -> header : bodyRows Nothing -> bodyRows return $ Jira.Table rows + Figure attr _ body -> toJiraPanel attr body jiraBlocks <- mapM convert blocks return $ mconcat jiraBlocks diff --git a/src/Text/Pandoc/Writers/LaTeX.hs b/src/Text/Pandoc/Writers/LaTeX.hs --- a/src/Text/Pandoc/Writers/LaTeX.hs +++ b/src/Text/Pandoc/Writers/LaTeX.hs @@ -3,10 +3,11 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} {- | Module : Text.Pandoc.Writers.LaTeX - Copyright : Copyright (C) 2006-2022 John MacFarlane + Copyright : Copyright (C) 2006-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> @@ -20,9 +21,20 @@ , writeBeamer ) where import Control.Monad.State.Strict + ( MonadState(get, put), + gets, + modify, + evalStateT ) +import Control.Monad + ( MonadPlus(mplus), + liftM, + when, + unless ) +import Data.Containers.ListUtils (nubOrd) import Data.Char (isDigit) import Data.List (intersperse, (\\)) import Data.Maybe (catMaybes, fromMaybe, isJust, mapMaybe, isNothing) +import Data.Monoid (Any (..)) import Data.Text (Text) import qualified Data.Text as T import Network.URI (unEscapeString) @@ -37,6 +49,7 @@ import Text.Pandoc.Options import Text.DocLayout import Text.Pandoc.Shared +import Text.Pandoc.URI import Text.Pandoc.Slides import Text.Pandoc.Walk (query, walk, walkM) import Text.Pandoc.Writers.LaTeX.Caption (getCaption) @@ -67,12 +80,12 @@ pandocToLaTeX :: PandocMonad m => WriterOptions -> Pandoc -> LW m Text pandocToLaTeX options (Pandoc meta blocks) = do - -- Strip off final 'references' header if --natbib or --biblatex + -- Strip off 'references' header if --natbib or --biblatex let method = writerCiteMethod options + let isRefsDiv (Div ("refs",_,_) _) = True + isRefsDiv _ = False let blocks' = if method == Biblatex || method == Natbib - then case reverse blocks of - Div ("refs",_,_) _:xs -> reverse xs - _ -> blocks + then filter (not . isRefsDiv) blocks else blocks -- see if there are internal links let isInternalLink (Link _ _ (s,_)) @@ -123,7 +136,7 @@ titleMeta <- stringToLaTeX TextString $ stringify $ docTitle meta authorsMeta <- mapM (stringToLaTeX TextString . stringify) $ docAuthors meta docLangs <- catMaybes <$> - mapM (toLang . Just) (ordNub (query (extract "lang") blocks)) + mapM (toLang . Just) (nubOrd (query (extract "lang") blocks)) let hasStringValue x = isJust (getField x metadata :: Maybe (Doc Text)) let geometryFromMargins = mconcat $ intersperse ("," :: Doc Text) $ mapMaybe (\(x,y) -> @@ -165,6 +178,8 @@ defField "numbersections" (writerNumberSections options) $ defField "lhs" (stLHS st) $ defField "graphics" (stGraphics st) $ + defField "subfigure" (stSubfigure st) $ + defField "svg" (stSVG st) $ defField "has-chapters" (stHasChapters st) $ defField "has-frontmatter" (documentClass `elem` frontmatterClasses) $ defField "listings" (writerListings options || stLHS st) $ @@ -208,9 +223,9 @@ maybe id (\l -> defField "lang" (literal $ renderLang l)) mblang $ maybe id (\l -> defField "babel-lang" - (literal $ toBabel l)) mblang + (literal l)) (mblang >>= toBabel) $ defField "babel-otherlangs" - (map (literal . toBabel) docLangs) + (map literal $ mapMaybe toBabel docLangs) $ defField "latex-dir-rtl" ((render Nothing <$> getField "dir" context) == Just ("rtl" :: Text)) context @@ -259,7 +274,6 @@ blockToLaTeX :: PandocMonad m => Block -- ^ Block to convert -> LW m (Doc Text) -blockToLaTeX Null = return empty blockToLaTeX (Div attr@(identifier,"block":dclasses,_) (Header _ _ ils : bs)) = do let blockname @@ -282,8 +296,8 @@ hasCodeBlock _ = [] let hasCode (Code _ _) = [True] hasCode _ = [] - let classes = ordNub $ dclasses ++ hclasses - let kvs = ordNub $ dkvs ++ hkvs + let classes = nubOrd $ dclasses ++ hclasses + let kvs = nubOrd $ dkvs ++ hkvs let fragile = "fragile" `elem` classes || not (null $ query hasCodeBlock bs ++ query hasCode bs) let frameoptions = ["allowdisplaybreaks", "allowframebreaks", "fragile", @@ -354,21 +368,6 @@ wrapNotes <$> wrapDiv (identifier,classes,kvs) result blockToLaTeX (Plain lst) = inlineListToLaTeX lst -blockToLaTeX (SimpleFigure attr@(ident, _, _) txt (src, tit)) = do - (capt, captForLof, footnotes) <- getCaption inlineListToLaTeX True txt - lab <- labelFor ident - let caption = "\\caption" <> captForLof <> braces capt <> lab - img <- inlineToLaTeX (Image attr txt (src,tit)) - innards <- hypertarget True ident $ - "\\centering" $$ img $$ caption <> cr - let figure = cr <> "\\begin{figure}" $$ innards $$ "\\end{figure}" - st <- get - return $ (if stInMinipage st - -- can't have figures in notes or minipage (here, table cell) - -- http://www.tex.ac.uk/FAQ-ouparmd.html - then cr <> "\\begin{center}" $$ img $+$ capt $$ - "\\end{center}" - else figure) $$ footnotes -- . . . indicates pause in beamer slides blockToLaTeX (Para [Str ".",Space,Str ".",Space,Str "."]) = do beamer <- gets stBeamer @@ -564,7 +563,59 @@ blockToLaTeX (Table attr blkCapt specs thead tbodies tfoot) = tableToLaTeX inlineListToLaTeX blockListToLaTeX (Ann.toTable attr blkCapt specs thead tbodies tfoot) +blockToLaTeX (Figure (ident, _, _) (Caption _ longCapt) body) = do + (capt, captForLof, footnotes) <- getCaption inlineListToLaTeX True + (blocksToInlines longCapt) + lab <- labelFor ident + let caption = "\\caption" <> captForLof <> braces capt <> lab + isSubfigure <- gets stInFigure + modify $ \st -> st{ stInFigure = True } + contents <- case body of + [b] -> blockToLaTeX b + bs -> mconcat . intersperse (cr <> "\\hfill") <$> + mapM (toSubfigure (length bs)) bs + innards <- hypertarget True ident $ + "\\centering" $$ contents $$ caption <> cr + modify $ \st -> + st{ stInFigure = isSubfigure + , stSubfigure = stSubfigure st || isSubfigure + } + + let containsTable = getAny . (query $ \case + Table {} -> Any True + _ -> Any False) + st <- get + return $ (case () of + _ | containsTable body -> + -- placing a longtable in a figure or center environment does + -- not make sense. + cr <> contents + _ | stInMinipage st -> + -- can't have figures in notes or minipage (here, table cell) + -- http://www.tex.ac.uk/FAQ-ouparmd.html + cr <> "\\begin{center}" $$ contents $+$ capt $$ "\\end{center}" + _ | isSubfigure -> + innards + _ -> cr <> "\\begin{figure}" $$ innards $$ "\\end{figure}") + $$ footnotes + +toSubfigure :: PandocMonad m => Int -> Block -> LW m (Doc Text) +toSubfigure nsubfigs blk = do + contents <- blockToLaTeX blk + let linewidth = tshow @Double (0.9 / fromIntegral nsubfigs) <> "\\linewidth" + return $ cr <> case blk of + Figure {} -> vcat + [ "\\begin{subfigure}[t]" <> braces (literal linewidth) + , contents + , "\\end{subfigure}" + ] + _ -> vcat + [ "\\begin{minipage}[t]" <> braces (literal linewidth) + , contents + , "\\end{minipage}" + ] + blockListToLaTeX :: PandocMonad m => [Block] -> LW m (Doc Text) blockListToLaTeX lst = vsep `fmap` mapM (\b -> setEmptyLine True >> blockToLaTeX b) lst @@ -723,6 +774,9 @@ inlineToLaTeX :: PandocMonad m => Inline -- ^ Inline to convert -> LW m (Doc Text) +inlineToLaTeX (Span ("",["mark"],[]) lst) = do + modify $ \st -> st{ stStrikeout = True } -- this gives us the soul package + inCmd "hl" <$> inlineListToLaTeX lst inlineToLaTeX (Span (id',classes,kvs) ils) = do linkAnchor <- hypertarget False id' empty lang <- toLang $ lookup "lang" kvs @@ -738,10 +792,9 @@ kvToCmd ("dir","ltr") = Just "LR" kvToCmd _ = Nothing langCmds = - case lang of - Just lng -> let l = toBabel lng - in ["foreignlanguage{" <> l <> "}"] - Nothing -> [] + case lang >>= toBabel of + Just l -> ["foreignlanguage{" <> l <> "}"] + Nothing -> [] let cmds = mapMaybe classToCmd classes ++ mapMaybe kvToCmd kvs ++ langCmds contents <- inlineListToLaTeX ils return $ @@ -760,8 +813,8 @@ else foldr inCmd contents cmds) inlineToLaTeX (Emph lst) = inCmd "emph" <$> inlineListToLaTeX lst inlineToLaTeX (Underline lst) = do - modify $ \st -> st{ stStrikeout = True } -- this gives us the ulem package - inCmd "uline" <$> inlineListToLaTeX lst + modify $ \st -> st{ stStrikeout = True } -- this gives us the soul package + inCmd "ul" <$> inlineListToLaTeX lst inlineToLaTeX (Strong lst) = inCmd "textbf" <$> inlineListToLaTeX lst inlineToLaTeX (Strikeout lst) = do -- we need to protect VERB in an mbox or we get an error @@ -770,7 +823,7 @@ -- incorrect results if there is a space, see #5529 contents <- inlineListToLaTeX $ walk (concatMap protectCode) lst modify $ \s -> s{ stStrikeout = True } - return $ inCmd "sout" contents + return $ inCmd "st" contents inlineToLaTeX (Superscript lst) = inCmd "textsuperscript" <$> inlineListToLaTeX lst inlineToLaTeX (Subscript lst) = @@ -935,7 +988,9 @@ return empty inlineToLaTeX (Image attr@(_,_,kvs) _ (source, _)) = do setEmptyLine False - modify $ \s -> s{ stGraphics = True } + let isSVG = ".svg" `T.isSuffixOf` source || ".SVG" `T.isSuffixOf` source + modify $ \s -> s{ stGraphics = True + , stSVG = stSVG s || isSVG } opts <- gets stOptions let showDim dir = let d = text (show dir) <> "=" in case dimension dir attr of @@ -959,7 +1014,7 @@ optList = showDim Width <> showDim Height <> maybe [] (\x -> ["page=" <> literal x]) (lookup "page" kvs) <> maybe [] (\x -> ["trim=" <> literal x]) (lookup "trim" kvs) <> - maybe [] (\_ -> ["clip"]) (lookup "clip" kvs) + maybe [] (const ["clip"]) (lookup "clip" kvs) options = if null optList then empty else brackets $ mconcat (intersperse "," optList) @@ -969,7 +1024,8 @@ source'' <- stringToLaTeX URLString source' inHeading <- gets stInHeading return $ - (if inHeading then "\\protect\\includegraphics" else "\\includegraphics") <> + (if inHeading then "\\protect" else "") <> + (if isSVG then "\\includesvg" else "\\includegraphics") <> options <> braces (literal source'') inlineToLaTeX (Note contents) = do setEmptyLine False diff --git a/src/Text/Pandoc/Writers/LaTeX/Caption.hs b/src/Text/Pandoc/Writers/LaTeX/Caption.hs --- a/src/Text/Pandoc/Writers/LaTeX/Caption.hs +++ b/src/Text/Pandoc/Writers/LaTeX/Caption.hs @@ -1,6 +1,6 @@ {- | Module : Text.Pandoc.Writers.LaTeX.Caption - Copyright : Copyright (C) 2006-2022 John MacFarlane + Copyright : Copyright (C) 2006-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> diff --git a/src/Text/Pandoc/Writers/LaTeX/Citation.hs b/src/Text/Pandoc/Writers/LaTeX/Citation.hs --- a/src/Text/Pandoc/Writers/LaTeX/Citation.hs +++ b/src/Text/Pandoc/Writers/LaTeX/Citation.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Writers.LaTeX.Citation - Copyright : Copyright (C) 2006-2022 John MacFarlane + Copyright : Copyright (C) 2006-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> diff --git a/src/Text/Pandoc/Writers/LaTeX/Lang.hs b/src/Text/Pandoc/Writers/LaTeX/Lang.hs --- a/src/Text/Pandoc/Writers/LaTeX/Lang.hs +++ b/src/Text/Pandoc/Writers/LaTeX/Lang.hs @@ -2,7 +2,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {- | Module : Text.Pandoc.Writers.LaTeX.Lang - Copyright : Copyright (C) 2006-2022 John MacFarlane + Copyright : Copyright (C) 2006-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> @@ -21,125 +21,125 @@ -- http://mirrors.ctan.org/macros/latex/required/babel/base/babel.pdf -- List of supported languages (slightly outdated): -- http://tug.ctan.org/language/hyph-utf8/doc/generic/hyph-utf8/hyphenation.pdf -toBabel :: Lang -> Text +toBabel :: Lang -> Maybe Text toBabel (Lang "de" _ (Just "AT") vars _ _) - | "1901" `elem` vars = "austrian" - | otherwise = "naustrian" + | "1901" `elem` vars = Just "austrian" + | otherwise = Just "naustrian" toBabel (Lang "de" _ (Just "CH") vars _ _) - | "1901" `elem` vars = "swissgerman" - | otherwise = "nswissgerman" + | "1901" `elem` vars = Just "swissgerman" + | otherwise = Just "nswissgerman" toBabel (Lang "de" _ _ vars _ _) - | "1901" `elem` vars = "german" - | otherwise = "ngerman" -toBabel (Lang "dsb" _ _ _ _ _) = "lowersorbian" + | "1901" `elem` vars = Just "german" + | otherwise = Just "ngerman" +toBabel (Lang "dsb" _ _ _ _ _) = Just "lowersorbian" toBabel (Lang "el" _ _ vars _ _) - | "polyton" `elem` vars = "polutonikogreek" -toBabel (Lang "en" _ (Just "AU") _ _ _) = "australian" -toBabel (Lang "en" _ (Just "CA") _ _ _) = "canadian" -toBabel (Lang "en" _ (Just "GB") _ _ _) = "british" -toBabel (Lang "en" _ (Just "NZ") _ _ _) = "newzealand" -toBabel (Lang "en" _ (Just "UK") _ _ _) = "british" -toBabel (Lang "en" _ (Just "US") _ _ _) = "american" -toBabel (Lang "fr" _ (Just "CA") _ _ _) = "canadien" + | "polyton" `elem` vars = Just "polutonikogreek" +toBabel (Lang "en" _ (Just "AU") _ _ _) = Just "australian" +toBabel (Lang "en" _ (Just "CA") _ _ _) = Just "canadian" +toBabel (Lang "en" _ (Just "GB") _ _ _) = Just "british" +toBabel (Lang "en" _ (Just "NZ") _ _ _) = Just "newzealand" +toBabel (Lang "en" _ (Just "UK") _ _ _) = Just "british" +toBabel (Lang "en" _ (Just "US") _ _ _) = Just "american" +toBabel (Lang "fr" _ (Just "CA") _ _ _) = Just "canadien" toBabel (Lang "fra" _ _ vars _ _) - | "aca" `elem` vars = "acadian" -toBabel (Lang "grc" _ _ _ _ _) = "ancientgreek" -toBabel (Lang "hsb" _ _ _ _ _) = "uppersorbian" + | "aca" `elem` vars = Just "acadian" +toBabel (Lang "grc" _ _ _ _ _) = Just "ancientgreek" +toBabel (Lang "hsb" _ _ _ _ _) = Just "uppersorbian" toBabel (Lang "la" _ _ vars _ _) - | "x-classic" `elem` vars = "classiclatin" -toBabel (Lang "pt" _ (Just "BR") _ _ _) = "brazilian" -toBabel (Lang "sl" _ _ _ _ _) = "slovene" + | "x-classic" `elem` vars = Just "classiclatin" +toBabel (Lang "pt" _ (Just "BR") _ _ _) = Just "brazilian" +toBabel (Lang "sl" _ _ _ _ _) = Just "slovene" toBabel x = commonFromBcp47 x -- Takes a list of the constituents of a BCP47 language code -- and converts it to a string shared by Babel and Polyglossia. -- https://tools.ietf.org/html/bcp47#section-2.1 -commonFromBcp47 :: Lang -> Text -commonFromBcp47 (Lang "sr" (Just "Cyrl") _ _ _ _) = "serbianc" +commonFromBcp47 :: Lang -> Maybe Text +commonFromBcp47 (Lang "sr" (Just "Cyrl") _ _ _ _) = Just "serbianc" commonFromBcp47 (Lang "zh" (Just "Latn") _ vars _ _) - | "pinyin" `elem` vars = "pinyin" + | "pinyin" `elem` vars = Just "pinyin" commonFromBcp47 (Lang l _ _ _ _ _) = fromIso l where - fromIso "af" = "afrikaans" - fromIso "am" = "amharic" - fromIso "ar" = "arabic" - fromIso "as" = "assamese" - fromIso "ast" = "asturian" - fromIso "bg" = "bulgarian" - fromIso "bn" = "bengali" - fromIso "bo" = "tibetan" - fromIso "br" = "breton" - fromIso "ca" = "catalan" - fromIso "cy" = "welsh" - fromIso "cs" = "czech" - fromIso "cop" = "coptic" - fromIso "da" = "danish" - fromIso "dv" = "divehi" - fromIso "el" = "greek" - fromIso "en" = "english" - fromIso "eo" = "esperanto" - fromIso "es" = "spanish" - fromIso "et" = "estonian" - fromIso "eu" = "basque" - fromIso "fa" = "farsi" - fromIso "fi" = "finnish" - fromIso "fr" = "french" - fromIso "fur" = "friulan" - fromIso "ga" = "irish" - fromIso "gd" = "scottish" - fromIso "gez" = "ethiopic" - fromIso "gl" = "galician" - fromIso "gu" = "gujarati" - fromIso "he" = "hebrew" - fromIso "hi" = "hindi" - fromIso "hr" = "croatian" - fromIso "hu" = "magyar" - fromIso "hy" = "armenian" - fromIso "ia" = "interlingua" - fromIso "id" = "indonesian" - fromIso "ie" = "interlingua" - fromIso "is" = "icelandic" - fromIso "it" = "italian" - fromIso "ja" = "japanese" - fromIso "km" = "khmer" - fromIso "kmr" = "kurmanji" - fromIso "kn" = "kannada" - fromIso "ko" = "korean" - fromIso "la" = "latin" - fromIso "lo" = "lao" - fromIso "lt" = "lithuanian" - fromIso "lv" = "latvian" - fromIso "ml" = "malayalam" - fromIso "mn" = "mongolian" - fromIso "mr" = "marathi" - fromIso "nb" = "norsk" - fromIso "nl" = "dutch" - fromIso "nn" = "nynorsk" - fromIso "no" = "norsk" - fromIso "nqo" = "nko" - fromIso "oc" = "occitan" - fromIso "or" = "oriya" - fromIso "pa" = "punjabi" - fromIso "pl" = "polish" - fromIso "pms" = "piedmontese" - fromIso "pt" = "portuguese" - fromIso "rm" = "romansh" - fromIso "ro" = "romanian" - fromIso "ru" = "russian" - fromIso "sa" = "sanskrit" - fromIso "se" = "samin" - fromIso "sk" = "slovak" - fromIso "sq" = "albanian" - fromIso "sr" = "serbian" - fromIso "sv" = "swedish" - fromIso "syr" = "syriac" - fromIso "ta" = "tamil" - fromIso "te" = "telugu" - fromIso "th" = "thai" - fromIso "ti" = "ethiopic" - fromIso "tk" = "turkmen" - fromIso "tr" = "turkish" - fromIso "uk" = "ukrainian" - fromIso "ur" = "urdu" - fromIso "vi" = "vietnamese" - fromIso _ = "" + fromIso "af" = Just "afrikaans" + fromIso "am" = Just "amharic" + fromIso "ar" = Just "arabic" + fromIso "as" = Just "assamese" + fromIso "ast" = Just "asturian" + fromIso "bg" = Just "bulgarian" + fromIso "bn" = Just "bengali" + fromIso "bo" = Just "tibetan" + fromIso "br" = Just "breton" + fromIso "ca" = Just "catalan" + fromIso "cy" = Just "welsh" + fromIso "cs" = Just "czech" + fromIso "cop" = Just "coptic" + fromIso "da" = Just "danish" + fromIso "dv" = Just "divehi" + fromIso "el" = Just "greek" + fromIso "en" = Just "english" + fromIso "eo" = Just "esperanto" + fromIso "es" = Just "spanish" + fromIso "et" = Just "estonian" + fromIso "eu" = Just "basque" + fromIso "fa" = Just "farsi" + fromIso "fi" = Just "finnish" + fromIso "fr" = Just "french" + fromIso "fur" = Just "friulan" + fromIso "ga" = Just "irish" + fromIso "gd" = Just "scottish" + fromIso "gez" = Just "ethiopic" + fromIso "gl" = Just "galician" + fromIso "gu" = Just "gujarati" + fromIso "he" = Just "hebrew" + fromIso "hi" = Just "hindi" + fromIso "hr" = Just "croatian" + fromIso "hu" = Just "magyar" + fromIso "hy" = Just "armenian" + fromIso "ia" = Just "interlingua" + fromIso "id" = Just "indonesian" + fromIso "ie" = Just "interlingua" + fromIso "is" = Just "icelandic" + fromIso "it" = Just "italian" + fromIso "ja" = Just "japanese" + fromIso "km" = Just "khmer" + fromIso "kmr" = Just "kurmanji" + fromIso "kn" = Just "kannada" + fromIso "ko" = Just "korean" + fromIso "la" = Just "latin" + fromIso "lo" = Just "lao" + fromIso "lt" = Just "lithuanian" + fromIso "lv" = Just "latvian" + fromIso "ml" = Just "malayalam" + fromIso "mn" = Just "mongolian" + fromIso "mr" = Just "marathi" + fromIso "nb" = Just "norsk" + fromIso "nl" = Just "dutch" + fromIso "nn" = Just "nynorsk" + fromIso "no" = Just "norsk" + fromIso "nqo" = Just "nko" + fromIso "oc" = Just "occitan" + fromIso "or" = Just "oriya" + fromIso "pa" = Just "punjabi" + fromIso "pl" = Just "polish" + fromIso "pms" = Just "piedmontese" + fromIso "pt" = Just "portuguese" + fromIso "rm" = Just "romansh" + fromIso "ro" = Just "romanian" + fromIso "ru" = Just "russian" + fromIso "sa" = Just "sanskrit" + fromIso "se" = Just "samin" + fromIso "sk" = Just "slovak" + fromIso "sq" = Just "albanian" + fromIso "sr" = Just "serbian" + fromIso "sv" = Just "swedish" + fromIso "syr" = Just "syriac" + fromIso "ta" = Just "tamil" + fromIso "te" = Just "telugu" + fromIso "th" = Just "thai" + fromIso "ti" = Just "ethiopic" + fromIso "tk" = Just "turkmen" + fromIso "tr" = Just "turkish" + fromIso "uk" = Just "ukrainian" + fromIso "ur" = Just "urdu" + fromIso "vi" = Just "vietnamese" + fromIso _ = Nothing diff --git a/src/Text/Pandoc/Writers/LaTeX/Notes.hs b/src/Text/Pandoc/Writers/LaTeX/Notes.hs --- a/src/Text/Pandoc/Writers/LaTeX/Notes.hs +++ b/src/Text/Pandoc/Writers/LaTeX/Notes.hs @@ -2,7 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Writers.LaTeX.Notes - Copyright : Copyright (C) 2006-2022 John MacFarlane + Copyright : Copyright (C) 2006-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> diff --git a/src/Text/Pandoc/Writers/LaTeX/Table.hs b/src/Text/Pandoc/Writers/LaTeX/Table.hs --- a/src/Text/Pandoc/Writers/LaTeX/Table.hs +++ b/src/Text/Pandoc/Writers/LaTeX/Table.hs @@ -2,7 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Writers.LaTeX.Table - Copyright : Copyright (C) 2006-2022 John MacFarlane + Copyright : Copyright (C) 2006-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> @@ -14,7 +14,8 @@ module Text.Pandoc.Writers.LaTeX.Table ( tableToLaTeX ) where -import Control.Monad.State.Strict +import Control.Monad.State.Strict ( gets, modify ) +import Control.Monad (when) import Data.List (intersperse) import qualified Data.List.NonEmpty as NonEmpty import Data.List.NonEmpty (NonEmpty ((:|))) @@ -49,31 +50,42 @@ let removeNote (Note _) = Span ("", [], []) [] removeNote x = x let colCount = ColumnCount $ length specs - firsthead <- if isEmpty capt || isEmptyHead thead - then return empty - else ($$ text "\\endfirsthead") <$> - headToLaTeX blksToLaTeX colCount thead - head' <- if isEmptyHead thead - then return "\\toprule()" - -- avoid duplicate notes in head and firsthead: - else headToLaTeX blksToLaTeX colCount - (if isEmpty firsthead - then thead - else walk removeNote thead) + -- The first head is not repeated on the following pages. If we were to just + -- use a single head, without a separate first head, then the caption would be + -- repeated on all pages that contain a part of the table. We avoid this by + -- making the caption part of the first head. The downside is that we must + -- duplicate the header rows for this. + head' <- do + let mkHead = headToLaTeX blksToLaTeX colCount + case (not $ isEmpty capt, not $ isEmptyHead thead) of + (False, False) -> return "\\toprule\\noalign{}" + (False, True) -> mkHead thead + (True, False) -> return (capt $$ "\\toprule\\noalign{}" $$ "\\endfirsthead") + (True, True) -> do + -- avoid duplicate notes in head and firsthead: + firsthead <- mkHead thead + repeated <- mkHead (walk removeNote thead) + return $ capt $$ firsthead $$ "\\endfirsthead" $$ repeated rows' <- mapM (rowToLaTeX blksToLaTeX colCount BodyCell) $ - mconcat (map bodyRows tbodies) <> footRows tfoot + mconcat (map bodyRows tbodies) + foot' <- if isEmptyFoot tfoot + then pure empty + else do + lastfoot <- mapM (rowToLaTeX blksToLaTeX colCount BodyCell) $ + footRows tfoot + pure $ "\\midrule\\noalign{}" $$ vcat lastfoot modify $ \s -> s{ stTable = True } notes <- notesToLaTeX <$> gets stNotes return $ "\\begin{longtable}[]" <> braces ("@{}" <> colDescriptors tbl <> "@{}") -- the @{} removes extra space at beginning and end - $$ capt - $$ firsthead $$ head' $$ "\\endhead" + $$ foot' + $$ "\\bottomrule\\noalign{}" + $$ "\\endlastfoot" $$ vcat rows' - $$ "\\bottomrule()" $$ "\\end{longtable}" $$ captNotes $$ notes @@ -172,7 +184,7 @@ rowsContents <- mapM (rowToLaTeX blocksWriter colCount HeaderCell . headerRowCells) headerRows - return ("\\toprule()" $$ vcat rowsContents $$ "\\midrule()") + return ("\\toprule\\noalign{}" $$ vcat rowsContents $$ "\\midrule\\noalign{}") -- | Converts a row of table cells into a LaTeX row. rowToLaTeX :: PandocMonad m @@ -204,6 +216,10 @@ isEmptyHead :: Ann.TableHead -> Bool isEmptyHead (Ann.TableHead _attr []) = True isEmptyHead (Ann.TableHead _attr rows) = all (null . headerRowCells) rows + +isEmptyFoot :: Ann.TableFoot -> Bool +isEmptyFoot (Ann.TableFoot _attr []) = True +isEmptyFoot (Ann.TableFoot _attr rows) = all (null . headerRowCells) rows -- | Gets all cells in a header row. headerRowCells :: Ann.HeaderRow -> [Ann.Cell] diff --git a/src/Text/Pandoc/Writers/LaTeX/Types.hs b/src/Text/Pandoc/Writers/LaTeX/Types.hs --- a/src/Text/Pandoc/Writers/LaTeX/Types.hs +++ b/src/Text/Pandoc/Writers/LaTeX/Types.hs @@ -25,16 +25,19 @@ , stInMinipage :: Bool -- ^ true if in minipage , stInHeading :: Bool -- ^ true if in a section heading , stInItem :: Bool -- ^ true if in \item[..] + , stInFigure :: Bool -- ^ true if in figure environment , stNotes :: [Doc Text] -- ^ notes in a minipage , stOLLevel :: Int -- ^ level of ordered list nesting , stOptions :: WriterOptions -- ^ writer options, so they don't have to -- be parameter , stVerbInNote :: Bool -- ^ true if document has verbatim text in note , stTable :: Bool -- ^ true if document has a table + , stSubfigure :: Bool -- ^ true if document has subfigures , stMultiRow :: Bool -- ^ true if document has multirow cells , stStrikeout :: Bool -- ^ true if document has strikeout , stUrl :: Bool -- ^ true if document has visible URL link , stGraphics :: Bool -- ^ true if document contains images + , stSVG :: Bool -- ^ true if document contains SVGs , stLHS :: Bool -- ^ true if document has literate haskell code , stHasChapters :: Bool -- ^ true if document has chapters , stCsquotes :: Bool -- ^ true if document uses csquotes @@ -57,15 +60,18 @@ , stInHeading = False , stInMinipage = False , stInItem = False + , stInFigure = False , stNotes = [] , stOLLevel = 1 , stOptions = options , stVerbInNote = False , stTable = False + , stSubfigure = False , stMultiRow = False , stStrikeout = False , stUrl = False , stGraphics = False + , stSVG = False , stLHS = False , stHasChapters = case writerTopLevelDivision options of TopLevelPart -> True diff --git a/src/Text/Pandoc/Writers/LaTeX/Util.hs b/src/Text/Pandoc/Writers/LaTeX/Util.hs --- a/src/Text/Pandoc/Writers/LaTeX/Util.hs +++ b/src/Text/Pandoc/Writers/LaTeX/Util.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Writers.LaTeX.Util - Copyright : Copyright (C) 2006-2022 John MacFarlane + Copyright : Copyright (C) 2006-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> @@ -37,7 +37,7 @@ import Text.Pandoc.Extensions (Extension(Ext_smart)) import Data.Char (isLetter, isSpace, isDigit, isAscii, ord, isAlphaNum) import Text.Printf (printf) -import Text.Pandoc.Shared (safeRead, elemText) +import Text.Pandoc.Shared (safeRead) import qualified Data.Text.Normalize as Normalize import Data.List (uncons) @@ -50,7 +50,7 @@ stringToLaTeX :: PandocMonad m => StringContext -> Text -> LW m Text stringToLaTeX context zs = do opts <- gets stOptions - when ('\x200c' `elemText` zs) $ + when (T.any (== '\x200c') zs) $ modify (\s -> s { stZwnj = True }) return $ T.pack $ foldr (go opts context) mempty $ T.unpack $ @@ -182,7 +182,7 @@ where go = T.concatMap $ \x -> case x of _ | (isLetter x || isDigit x) && isAscii x -> T.singleton x - | x `elemText` "_-+=:;." -> T.singleton x + | T.any (== x) "_-+=:;." -> T.singleton x | otherwise -> T.pack $ "ux" <> printf "%x" (ord x) -- | Puts contents into LaTeX command. @@ -237,9 +237,8 @@ Just "rtl" -> align "RTL" Just "ltr" -> align "LTR" _ -> id - wrapLang txt = case lang of - Just lng -> let l = toBabel lng - in inCmd "begin" "otherlanguage" + wrapLang txt = case lang >>= toBabel of + Just l -> inCmd "begin" "otherlanguage" <> (braces (literal l)) $$ blankline <> txt <> blankline $$ inCmd "end" "otherlanguage" diff --git a/src/Text/Pandoc/Writers/Man.hs b/src/Text/Pandoc/Writers/Man.hs --- a/src/Text/Pandoc/Writers/Man.hs +++ b/src/Text/Pandoc/Writers/Man.hs @@ -3,7 +3,7 @@ {-# LANGUAGE ViewPatterns #-} {- | Module : Text.Pandoc.Writers.Man - Copyright : Copyright (C) 2007-2022 John MacFarlane + Copyright : Copyright (C) 2007-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> @@ -14,7 +14,9 @@ -} module Text.Pandoc.Writers.Man ( writeMan ) where -import Control.Monad.State.Strict +import Control.Monad ( liftM, zipWithM, forM ) +import Control.Monad.State.Strict ( StateT, gets, modify, evalStateT ) +import Control.Monad.Trans (MonadTrans(lift)) import Data.List (intersperse) import Data.List.NonEmpty (nonEmpty) import Data.Maybe (fromMaybe) @@ -27,6 +29,7 @@ import Text.Pandoc.Options import Text.DocLayout import Text.Pandoc.Shared +import Text.Pandoc.URI import Text.Pandoc.Templates (renderTemplate) import Text.Pandoc.Writers.Math import Text.Pandoc.Writers.Shared @@ -73,14 +76,16 @@ $ setFieldsFromTitle $ defField "has-tables" hasTables $ defField "hyphenate" True - $ defField "pandoc-version" pandocVersion metadata + metadata return $ render colwidth $ case writerTemplate opts of Nothing -> main Just tpl -> renderTemplate tpl context escString :: WriterOptions -> Text -> Text -escString _ = escapeString AsciiOnly -- for better portability +escString opts = escapeString (if writerPreferAscii opts + then AsciiOnly + else AllowUTF8) -- | Return man representation of notes. notesToMan :: PandocMonad m => WriterOptions -> [[Block]] -> StateT WriterState m (Doc Text) @@ -105,7 +110,6 @@ => WriterOptions -- ^ Options -> Block -- ^ Block element -> StateT WriterState m (Doc Text) -blockToMan _ Null = return empty blockToMan opts (Div _ bs) = blockListToMan opts bs blockToMan opts (Plain inlines) = splitSentences <$> inlineListToMan opts inlines @@ -168,7 +172,6 @@ return $ literal ".PP" $$ caption' $$ literal ".TS" $$ literal "tab(@);" $$ coldescriptions $$ colheadings' $$ vcat body $$ literal ".TE" - blockToMan opts (BulletList items) = do contents <- mapM (bulletListItemToMan opts) items return (vcat contents) @@ -181,6 +184,8 @@ blockToMan opts (DefinitionList items) = do contents <- mapM (definitionListItemToMan opts) items return (vcat contents) +blockToMan opts (Figure attr capt body) = do + blockToMan opts (figureDiv attr capt body) -- | Convert bullet list item (list of blocks) to man. bulletListItemToMan :: PandocMonad m => WriterOptions -> [Block] -> StateT WriterState m (Doc Text) diff --git a/src/Text/Pandoc/Writers/Markdown.hs b/src/Text/Pandoc/Writers/Markdown.hs --- a/src/Text/Pandoc/Writers/Markdown.hs +++ b/src/Text/Pandoc/Writers/Markdown.hs @@ -2,9 +2,10 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE BangPatterns #-} {- | Module : Text.Pandoc.Writers.Markdown - Copyright : Copyright (C) 2006-2022 John MacFarlane + Copyright : Copyright (C) 2006-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> @@ -20,15 +21,17 @@ writeCommonMark, writeMarkua, writePlain) where -import Control.Monad.Reader -import Control.Monad.State.Strict +import Control.Monad (foldM, zipWithM, MonadPlus(..), when) +import Control.Monad.Reader ( asks, MonadReader(local) ) +import Control.Monad.State.Strict ( gets, modify ) import Data.Default -import Data.List (intersperse, sortOn) +import Data.List (intersperse, sortOn, union) import Data.List.NonEmpty (nonEmpty, NonEmpty(..)) import qualified Data.Map as M import Data.Maybe (fromMaybe, mapMaybe, isNothing) import qualified Data.Set as Set import Data.Text (Text) +import Data.Char (isSpace) import qualified Data.Text as T import Text.HTML.TagSoup (Tag (..), isTagText, parseTags) import Text.Pandoc.Class.PandocMonad (PandocMonad, report) @@ -230,8 +233,14 @@ mmdTitleBlock metadata | otherwise -> empty Nothing -> empty + let modifyTOC = + if isEnabled Ext_link_attributes opts || isEnabled Ext_attributes opts + then id + else walk $ \inln -> case inln of + Link _attr contents tgt -> Link nullAttr contents tgt + _ -> inln toc <- if writerTableOfContents opts - then blockToMarkdown opts ( toTableOfContents opts blocks ) + then blockToMarkdown opts . modifyTOC $ toTableOfContents opts blocks else return mempty -- Strip off final 'references' header if markdown citations enabled let blocks' = if isEnabled Ext_citations opts @@ -309,7 +318,7 @@ classOrAttrsToMarkdown attrs = attrsToMarkdown attrs -- | Ordered list start parser for use in Para below. -olMarker :: Parser Text ParserState () +olMarker :: Parsec Text ParserState () olMarker = do (start, style', delim) <- anyOrderedListMarker if delim == Period && (style' == UpperAlpha || (style' == UpperRoman && @@ -359,7 +368,6 @@ => WriterOptions -- ^ Options -> Block -- ^ Block element -> MD m (Doc Text) -blockToMarkdown' _ Null = return empty blockToMarkdown' opts (Div attrs ils) = do contents <- blockListToMarkdown opts ils variant <- asks envVariant @@ -396,7 +404,7 @@ blockToMarkdown' opts (Plain inlines) = do -- escape if para starts with ordered list marker variant <- asks envVariant - let escapeMarker = T.concatMap $ \x -> if x `elemText` ".()" + let escapeMarker = T.concatMap $ \x -> if T.any (== x) ".()" then T.pack ['\\', x] else T.singleton x let startsWithSpace (Space:_) = True @@ -418,14 +426,6 @@ _ -> inlines contents <- inlineListToMarkdown opts inlines' return $ contents <> cr -blockToMarkdown' opts (SimpleFigure attr alt (src, tit)) - | isEnabled Ext_raw_html opts && - not (isEnabled Ext_link_attributes opts || isEnabled Ext_attributes opts) && - attr /= nullAttr = -- use raw HTML - (<> blankline) . literal . T.strip <$> - writeHtml5String opts{ writerTemplate = Nothing } - (Pandoc nullMeta [SimpleFigure attr alt (src, tit)]) - | otherwise = blockToMarkdown opts (Para [Image attr alt (src,tit)]) blockToMarkdown' opts (Para inlines) = (<> blankline) `fmap` blockToMarkdown opts (Plain inlines) blockToMarkdown' opts (LineBlock lns) = @@ -448,6 +448,8 @@ Commonmark | f `elem` ["gfm", "commonmark", "commonmark_x", "markdown"] -> return $ literal str <> literal "\n" + | f `elem` ["html", "html5", "html4"] + -> return $ literal (removeBlankLinesInHTML str) <> literal "\n" Markdown | f `elem` ["markdown", "markdown_github", "markdown_phpextra", "markdown_mmd", "markdown_strict"] @@ -631,7 +633,7 @@ (id,) <$> pipeTable opts (all null headers) aligns' widths' rawHeaders rawRows | isEnabled Ext_raw_html opts -> fmap (id,) $ - literal <$> + literal . removeBlankLinesInHTML <$> writeHtml5String opts{ writerTemplate = Nothing } (Pandoc nullMeta [t]) | otherwise -> return (id, literal "[TABLE]") return $ nst (tbl $$ caption'') $$ blankline @@ -666,6 +668,33 @@ blockToMarkdown' opts (DefinitionList items) = do contents <- inList $ mapM (definitionListItemToMarkdown opts) items return $ mconcat contents <> blankline +blockToMarkdown' opts (Figure figattr capt body) = do + let combinedAttr imgattr = case imgattr of + ("", cls, kv) | (figid, [], []) <- figattr -> Just (figid, cls, kv) + _ -> Nothing + let combinedAlt alt = case capt of + Caption Nothing [] -> if null alt + then Just [Str "image"] + else Just alt + Caption Nothing [Plain captInlines] + | captInlines == alt -> Just captInlines + _ -> Nothing + case body of + [Plain [Image imgAttr alt (src, ttl)]] + | isEnabled Ext_implicit_figures opts + , Just descr <- combinedAlt alt + , Just imgAttr' <- combinedAttr imgAttr + , isEnabled Ext_link_attributes opts || imgAttr' == nullAttr + -> do + -- use implicit figures if possible + let tgt' = (src, fromMaybe ttl $ T.stripPrefix "fig:" ttl) + contents <- inlineListToMarkdown opts [Image imgAttr' descr tgt'] + return $ contents <> blankline + _ -> + -- fallback to raw html if possible or div otherwise + if isEnabled Ext_raw_html opts + then figureToMarkdown opts figattr capt body + else blockToMarkdown' opts $ figureDiv figattr capt body inList :: Monad m => MD m a -> MD m a inList p = local (\env -> env {envInList = True}) p @@ -679,6 +708,22 @@ x /= "markdown"] _ -> s +-- | Converts a figure to Markdown by wrapping it in a div named `figure`. +figureToMarkdown :: PandocMonad m + => WriterOptions + -> Attr + -> Caption + -> [Block] + -> MD m (Doc Text) +figureToMarkdown opts attr@(ident, classes, kvs) capt body + | isEnabled Ext_raw_html opts = + (<> blankline) . literal . T.strip <$> + writeHtml5String + opts{ writerTemplate = Nothing } + (Pandoc nullMeta [Figure attr capt body]) + | otherwise = let attr' = (ident, ["figure"] `union` classes, kvs) + in blockToMarkdown' opts (Div attr' body) + itemEndsWithTightList :: [Block] -> Bool itemEndsWithTightList bs = case bs of @@ -812,8 +857,8 @@ isListBlock (DefinitionList _) = True isListBlock _ = False commentSep - | variant == PlainText = Null - | variant == Markua = Null + | variant == PlainText = Plain [] + | variant == Markua = Plain [] | isEnabled Ext_raw_html opts = RawBlock "html" "<!-- -->\n" | otherwise = RawBlock "markdown" " \n" mconcat <$> mapM (blockToMarkdown opts) (fixBlocks blocks) @@ -822,3 +867,12 @@ lineBreakToSpace LineBreak = Space lineBreakToSpace SoftBreak = Space lineBreakToSpace x = x + +removeBlankLinesInHTML :: Text -> Text +removeBlankLinesInHTML = T.pack . go False . T.unpack + where go _ [] = [] + go True ('\n':cs) = " " <> go False cs + go False ('\n':cs) = '\n' : go True cs + go !afternewline (!c:cs) + | isSpace c = c : go afternewline cs + | otherwise = c : go False cs diff --git a/src/Text/Pandoc/Writers/Markdown/Inline.hs b/src/Text/Pandoc/Writers/Markdown/Inline.hs --- a/src/Text/Pandoc/Writers/Markdown/Inline.hs +++ b/src/Text/Pandoc/Writers/Markdown/Inline.hs @@ -3,7 +3,7 @@ {-# LANGUAGE ViewPatterns #-} {- | Module : Text.Pandoc.Writers.Markdown.Inline - Copyright : Copyright (C) 2006-2022 John MacFarlane + Copyright : Copyright (C) 2006-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> @@ -16,8 +16,11 @@ attrsToMarkdown, attrsToMarkua ) where +import Control.Monad (when, liftM2) import Control.Monad.Reader + ( asks, MonadReader(local) ) import Control.Monad.State.Strict + ( MonadState(get), gets, modify ) import Data.Char (isAlphaNum, isDigit) import Data.List (find, intersperse) import Data.List.NonEmpty (nonEmpty) @@ -32,7 +35,7 @@ import Text.Pandoc.Parsing hiding (blankline, blanklines, char, space) import Text.DocLayout import Text.Pandoc.Shared -import Text.Pandoc.Network.HTTP (urlEncode) +import Text.Pandoc.URI (urlEncode, escapeURI, isURI) import Text.Pandoc.Writers.Shared import Text.Pandoc.Walk import Text.Pandoc.Writers.HTML (writeHtml5String) @@ -66,6 +69,26 @@ _ -> '@':go cs go' cs = go cs go [] = [] + go ['\\'] = ['\\','\\'] + go ('-':'-':cs) + | isEnabled Ext_smart opts = '\\':'-':go('-':cs) + go ('.':'.':'.':cs) + | isEnabled Ext_smart opts = '\\':'.':'.':'.':go cs + go (c:'_':d:cs) + | isAlphaNum c + , isAlphaNum d = + if isEnabled Ext_intraword_underscores opts + then c:'_':go (d:cs) + else c:'\\':'_':go (d:cs) + go ('\\':c:cs) + | isEnabled Ext_raw_tex opts = '\\':'\\':go (c:cs) + | isAlphaNum c = '\\' : go (c:cs) + | otherwise = '\\':'\\': go cs + go ('!':'[':cs) = '\\':'!':'[': go cs + go ('=':'=':cs) + | isEnabled Ext_mark opts = '\\':'=':go ('=':cs) + go ('~':'~':cs) + | isEnabled Ext_strikeout opts = '\\':'~':go ('~':cs) go (c:cs) = case c of '[' -> '\\':c:go cs @@ -73,36 +96,17 @@ '`' -> '\\':c:go cs '*' -> '\\':c:go cs '_' -> '\\':c:go cs - '\\' | isEnabled Ext_raw_tex opts -> '\\':c:go cs - | otherwise -> - case cs of -- don't escape \ if we don't have to: - d:_ | isAlphaNum d -> c:go cs - _ -> '\\':c:go cs '>' | isEnabled Ext_all_symbols_escapable opts -> '\\':'>':go cs | otherwise -> ">" ++ go cs '<' | isEnabled Ext_all_symbols_escapable opts -> '\\':'<':go cs | otherwise -> "<" ++ go cs '|' | isEnabled Ext_pipe_tables opts -> '\\':'|':go cs '^' | isEnabled Ext_superscript opts -> '\\':'^':go cs - '~' | isEnabled Ext_subscript opts || - isEnabled Ext_strikeout opts -> '\\':'~':go cs + '~' | isEnabled Ext_subscript opts -> '\\':'~':go cs '$' | isEnabled Ext_tex_math_dollars opts -> '\\':'$':go cs '\'' | isEnabled Ext_smart opts -> '\\':'\'':go cs '"' | isEnabled Ext_smart opts -> '\\':'"':go cs - '-' | isEnabled Ext_smart opts -> - case cs of - '-':_ -> '\\':'-':go cs - _ -> '-':go cs - '.' | isEnabled Ext_smart opts -> - case cs of - '.':'.':rest -> '\\':'.':'.':'.':go rest - _ -> '.':go cs - _ -> case cs of - '_':x:xs - | isEnabled Ext_intraword_underscores opts - , isAlphaNum c - , isAlphaNum x -> c : '_' : x : go xs - _ -> c : go cs + _ -> c : go cs -- Escape the escape character, as well as formatting pairs escapeMarkuaString :: Text -> Text @@ -117,8 +121,8 @@ attribClasses = case attribs of (_,[],_) -> empty (_,cs,_) -> hsep $ - map (escAttr . ("."<>)) - cs + map (escAttr . ("."<>)) $ + filter (not . T.null) cs attribKeys = case attribs of (_,_,[]) -> empty (_,_,ks) -> hsep $ @@ -264,6 +268,11 @@ | T.all isDigit (T.take 1 t) -- starts with digit -- see #7058 = liftM2 (<>) (inlineToMarkdown opts x) (go (RawInline (Format "html") "<!-- -->" : y : zs)) + go (Str t : i : is) + | isLinkOrSpan i + , T.takeEnd 1 t == "!" + = do x <- inlineToMarkdown opts (Str (T.dropEnd 1 t)) + ((x <> "\\!") <>) <$> go (i:is) go (i:is) = case i of Link {} -> case is of -- If a link is followed by another link, or '[', '(' or ':' @@ -291,13 +300,17 @@ (RawInline _ (T.stripPrefix " [" -> Just _ )):_ -> unshortcutable _ -> shortcutable _ -> shortcutable - where shortcutable = liftM2 (<>) (inlineToMarkdown opts i) (go is) - unshortcutable = do - iMark <- local - (\env -> env { envRefShortcutable = False }) - (inlineToMarkdown opts i) - fmap (iMark <>) (go is) - thead = fmap fst . T.uncons + where + shortcutable = liftM2 (<>) (inlineToMarkdown opts i) (go is) + unshortcutable = do + iMark <- local + (\env -> env { envRefShortcutable = False }) + (inlineToMarkdown opts i) + fmap (iMark <>) (go is) + thead = fmap fst . T.uncons + isLinkOrSpan Link{} = True + isLinkOrSpan Span{} = True + isLinkOrSpan _ = False -- Remove breaking spaces that might cause bad wraps. avoidBadWraps :: Bool -> Doc Text -> Doc Text @@ -334,6 +347,10 @@ Just emojiname | isEnabled Ext_emoji opts -> return $ ":" <> literal emojiname <> ":" _ -> inlineToMarkdown opts (Str s) +inlineToMarkdown opts (Span ("",["mark"],[]) ils) + | isEnabled Ext_mark opts + = do contents <- inlineListToMarkdown opts ils + return $ "==" <> contents <> "==" inlineToMarkdown opts (Span attrs ils) = do variant <- asks envVariant contents <- inlineListToMarkdown opts ils @@ -634,6 +651,9 @@ case txt of [Str s] | escapeURI s == srcSuffix -> True _ -> False + let useWikilink = tit == "wikilink" && + (isEnabled Ext_wikilinks_title_after_pipe opts || + isEnabled Ext_wikilinks_title_before_pipe opts) let useRefLinks = writerReferenceLinks opts && not useAuto shortcutable <- asks envRefShortcutable let useShortcutRefLinks = shortcutable && @@ -650,7 +670,14 @@ | otherwise -> return $ result <> attrsToMarkua attributes where result = "[" <> linktext <> "](" <> (literal src) <> ")" attributes = addKeyValueToAttr attr ("title", tit) - _ | useAuto -> return $ "<" <> literal srcSuffix <> ">" + -- Use wikilinks where possible + _ | src == stringify txt && useWikilink -> + return $ "[[" <> literal (stringify txt) <> "]]" + | useAuto -> return $ "<" <> literal srcSuffix <> ">" + | useWikilink && isEnabled Ext_wikilinks_title_after_pipe opts -> return $ + "[[" <> literal src <> "|" <> literal (stringify txt) <> "]]" + | useWikilink && isEnabled Ext_wikilinks_title_before_pipe opts -> return $ + "[[" <> literal (stringify txt) <> "|" <> literal src <> "]]" | useRefLinks -> let first = "[" <> linktext <> "]" second = if getKey linktext == getKey reftext diff --git a/src/Text/Pandoc/Writers/Markdown/Table.hs b/src/Text/Pandoc/Writers/Markdown/Table.hs --- a/src/Text/Pandoc/Writers/Markdown/Table.hs +++ b/src/Text/Pandoc/Writers/Markdown/Table.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Writers.Markdown - Copyright : © 2006-2022 John MacFarlane + Copyright : © 2006-2023 John MacFarlane License : GPL-2.0-or-later Maintainer : John MacFarlane <jgm@berkeley.edu> diff --git a/src/Text/Pandoc/Writers/Markdown/Types.hs b/src/Text/Pandoc/Writers/Markdown/Types.hs --- a/src/Text/Pandoc/Writers/Markdown/Types.hs +++ b/src/Text/Pandoc/Writers/Markdown/Types.hs @@ -1,7 +1,6 @@ -{-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Writers.Markdown.Types - Copyright : Copyright (C) 2006-2022 John MacFarlane + Copyright : Copyright (C) 2006-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> @@ -78,5 +77,3 @@ , stIds = Set.empty , stNoteNum = 1 } - - diff --git a/src/Text/Pandoc/Writers/MediaWiki.hs b/src/Text/Pandoc/Writers/MediaWiki.hs --- a/src/Text/Pandoc/Writers/MediaWiki.hs +++ b/src/Text/Pandoc/Writers/MediaWiki.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Writers.MediaWiki - Copyright : Copyright (C) 2008-2022 John MacFarlane + Copyright : Copyright (C) 2008-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> @@ -16,9 +16,11 @@ import Control.Monad.Reader import Control.Monad.State.Strict import Data.Maybe (fromMaybe) +import qualified Data.List as DL import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as T +import Data.List.NonEmpty (NonEmpty((:|))) import Text.Pandoc.Class.PandocMonad (PandocMonad, report) import Text.Pandoc.Definition import Text.Pandoc.ImageSize @@ -26,7 +28,9 @@ import Text.Pandoc.Options import Text.DocLayout (render, literal) import Text.Pandoc.Shared +import Text.Pandoc.URI import Text.Pandoc.Templates (renderTemplate) +import qualified Text.Pandoc.Writers.AnnotatedTable as Ann import Text.Pandoc.Writers.Shared import Text.Pandoc.XML (escapeStringForXML) @@ -80,8 +84,6 @@ => Block -- ^ Block element -> MediaWikiWriter m Text -blockToMediaWiki Null = return "" - blockToMediaWiki (Div attrs bs) = do contents <- blockListToMediaWiki bs return $ render Nothing (tagWithAttrs "div" attrs) <> "\n\n" <> @@ -160,19 +162,8 @@ contents <- blockListToMediaWiki blocks return $ "<blockquote>" <> contents <> "</blockquote>" -blockToMediaWiki (Table _ blkCapt specs thead tbody tfoot) = do - let (capt, aligns, widths, headers, rows') = toLegacyTable blkCapt specs thead tbody tfoot - caption <- if null capt - then return "" - else do - c <- inlineListToMediaWiki capt - return $ "|+ " <> trimr c <> "\n" - let headless = all null headers - let allrows = if headless then rows' else headers:rows' - tableBody <- T.intercalate "|-\n" `fmap` - mapM (tableRowToMediaWiki headless aligns widths) - (zip [1..] allrows) - return $ "{|\n" <> caption <> tableBody <> "|}\n" +blockToMediaWiki (Table attr capt colSpecs thead tbody tfoot) = do + tableToMediaWiki (Ann.toTable attr capt colSpecs thead tbody tfoot) blockToMediaWiki x@(BulletList items) = do tags <- @@ -210,6 +201,9 @@ contents <- local (\s -> s { listLevel = listLevel s <> ";" }) $ mapM definitionListItemToMediaWiki items return $ vcat contents <> if null lev then "\n" else "" +blockToMediaWiki (Figure (ident, classes, kvs) _ body) = + blockToMediaWiki (Div (ident, ["figure"] `DL.union` classes, kvs) body) + -- Auxiliary functions for lists: -- | Convert ordered list attributes to HTML attribute string @@ -291,46 +285,77 @@ -- Auxiliary functions for tables: -tableRowToMediaWiki :: PandocMonad m - => Bool - -> [Alignment] - -> [Double] - -> (Int, [[Block]]) - -> MediaWikiWriter m Text -tableRowToMediaWiki headless alignments widths (rownum, cells) = do - cells' <- mapM (tableCellToMediaWiki headless rownum) - $ zip3 alignments widths cells - return $ T.unlines cells' +tableToMediaWiki :: PandocMonad m => Ann.Table -> MediaWikiWriter m Text +tableToMediaWiki (Ann.Table attr capt _ thead tbodies tfoot) = do + let (ident,classes,kvs) = attr + caption <- case capt of + Caption _ [] -> return mempty + Caption _ longCapt -> do + c <- blockListToMediaWiki longCapt + return [ "|+ " <> trimr c ] + head' <- tableHeadToMW thead + bodies' <- concat <$> mapM tableBodyToMW tbodies + foot' <- tableFootToMW tfoot + return $ T.unlines $ [ + "{|" <> (render Nothing (htmlAttrs (ident, "wikitable":classes, kvs))) + ] <> caption <> head' <> bodies' <> foot' <> [ + "|}" + ] -tableCellToMediaWiki :: PandocMonad m - => Bool - -> Int - -> (Alignment, Double, [Block]) - -> MediaWikiWriter m Text -tableCellToMediaWiki headless rownum (alignment, width, bs) = do - contents <- blockListToMediaWiki bs - let marker = if rownum == 1 && not headless then "!" else "|" - let percent w = tshow (truncate (100*w) :: Integer) <> "%" - let attrs = ["align=" <> tshow (alignmentToText alignment) | - alignment /= AlignDefault && alignment /= AlignLeft] <> - ["width=\"" <> percent width <> "\"" | - width /= 0.0 && rownum == 1] - let attr = if null attrs - then "" - else T.unwords attrs <> "|" - let sep = case bs of - [Plain _] -> " " - [Para _] -> " " - [] -> "" - _ -> "\n" - return $ marker <> attr <> sep <> trimr contents +tableHeadToMW :: PandocMonad m => Ann.TableHead -> MediaWikiWriter m [Text] +tableHeadToMW (Ann.TableHead _ rows) = headerRowsToMW rows -alignmentToText :: Alignment -> Text -alignmentToText alignment = case alignment of - AlignLeft -> "left" - AlignRight -> "right" - AlignCenter -> "center" - AlignDefault -> "left" +tableFootToMW :: PandocMonad m => Ann.TableFoot -> MediaWikiWriter m [Text] +tableFootToMW (Ann.TableFoot _ rows) = headerRowsToMW rows + +tableBodyToMW :: PandocMonad m => Ann.TableBody -> MediaWikiWriter m [Text] +tableBodyToMW (Ann.TableBody _ _ headerRows bodyRows) = do + headerRows' <- headerRowsToMW headerRows + bodyRows' <- bodyRowsToMW bodyRows + return $ headerRows' <> bodyRows' + +headerRowsToMW :: PandocMonad m => [Ann.HeaderRow] -> MediaWikiWriter m [Text] +headerRowsToMW rows = (\x -> mconcat x) <$> mapM headerRowToMW rows + +headerRowToMW :: PandocMonad m => Ann.HeaderRow -> MediaWikiWriter m [Text] +headerRowToMW (Ann.HeaderRow attr _ cells) = do + cells' <- (\x -> mconcat x) <$> mapM (cellToMW "!") cells + return $ ["|-" <> (render Nothing (htmlAttrs attr))] <> cells' + +bodyRowsToMW :: PandocMonad m => [Ann.BodyRow] -> MediaWikiWriter m [Text] +bodyRowsToMW rows = (\x -> mconcat x) <$> mapM bodyRowToMW rows + +bodyRowToMW :: PandocMonad m => Ann.BodyRow -> MediaWikiWriter m [Text] +bodyRowToMW (Ann.BodyRow attr _ headCells bodyCells) = do + headCells' <- (\x -> mconcat x) <$> mapM (cellToMW "!") headCells + bodyCells' <- (\x -> mconcat x) <$> mapM (cellToMW "|") bodyCells + return $ ["|-" <> (render Nothing (htmlAttrs attr))] <> headCells' <> bodyCells' + +cellToMW :: PandocMonad m => Text -> Ann.Cell -> MediaWikiWriter m [Text] +cellToMW marker (Ann.Cell (colSpec :| _) _ (Cell attr align rowspan colspan content)) = do + content' <- blockListToMediaWiki content + let (ident,classes,keyVals) = attr + + let align' = case align of + AlignDefault -> fst colSpec + _ -> align + let keyVals' = case (htmlAlignmentToString align') of + Nothing -> keyVals + Just alignStr -> htmlAddStyle ("text-align", alignStr) keyVals + let rowspan' = case rowspan of + RowSpan 1 -> mempty + RowSpan n -> [("rowspan", T.pack(show n))] + let colspan' = case colspan of + ColSpan 1 -> mempty + ColSpan n -> [("colspan", T.pack(show n))] + let attrs' = addPipeIfNotEmpty (render Nothing (htmlAttrs (ident, classes, rowspan' <> colspan' <> keyVals'))) + return [marker <> attrs' <> addSpaceIfNotEmpty(content')] + +addPipeIfNotEmpty :: Text -> Text +addPipeIfNotEmpty f = if T.null f then f else f <> "|" + +addSpaceIfNotEmpty :: Text -> Text +addSpaceIfNotEmpty f = if T.null f then f else " " <> f imageToMediaWiki :: PandocMonad m => Attr -> MediaWikiWriter m Text imageToMediaWiki attr = do diff --git a/src/Text/Pandoc/Writers/Ms.hs b/src/Text/Pandoc/Writers/Ms.hs --- a/src/Text/Pandoc/Writers/Ms.hs +++ b/src/Text/Pandoc/Writers/Ms.hs @@ -2,7 +2,7 @@ {-# LANGUAGE ViewPatterns #-} {- | Module : Text.Pandoc.Writers.Ms - Copyright : Copyright (C) 2007-2022 John MacFarlane + Copyright : Copyright (C) 2007-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> @@ -21,6 +21,9 @@ module Text.Pandoc.Writers.Ms ( writeMs ) where import Control.Monad.State.Strict + ( gets, modify, evalStateT ) +import Control.Monad ( MonadPlus(mplus), liftM, unless, forM ) +import Data.Containers.ListUtils (nubOrd) import Data.Char (isAscii, isLower, isUpper, ord) import Data.List (intercalate, intersperse) import Data.List.NonEmpty (nonEmpty) @@ -76,7 +79,6 @@ let context = defField "body" main $ defField "has-inline-math" hasInlineMath $ defField "hyphenate" True - $ defField "pandoc-version" pandocVersion $ defField "toc" (writerTableOfContents opts) $ defField "title-meta" titleMeta $ defField "author-meta" (T.intercalate "; " authorsMeta) @@ -127,7 +129,6 @@ => WriterOptions -- ^ Options -> Block -- ^ Block element -> MS m (Doc Text) -blockToMs _ Null = return empty blockToMs opts (Div (ident,cls,kvs) bs) = do let anchor = if T.null ident then empty @@ -174,7 +175,7 @@ doubleQuotes (literal (tshow (floor hp :: Int))) _ -> empty capt <- splitSentences <$> inlineListToMs' opts alt - return $ nowrap (literal ".PSPIC -C " <> + return $ nowrap (literal ".PSPIC " <> doubleQuotes (literal (escapeStr opts src)) <> sizeAttrs) $$ literal ".ce 1000" $$ @@ -301,7 +302,6 @@ then "" else ".nr LL \\n[LLold]") $$ literal ".ad" - blockToMs opts (BulletList items) = do contents <- mapM (bulletListItemToMs opts) items setFirstPara @@ -317,6 +317,7 @@ contents <- mapM (definitionListItemToMs opts) items setFirstPara return (vcat contents) +blockToMs opts (Figure attr _ body) = blockToMs opts $ Div attr body -- | Convert bullet list item (list of blocks) to ms. bulletListItemToMs :: PandocMonad m => WriterOptions -> [Block] -> MS m (Doc Text) @@ -454,7 +455,7 @@ Left il -> inlineToMs opts il Right r -> return $ literal "@" <> literal r <> literal "@" inlineToMs opts (Math DisplayMath str) = do - res <- convertMath writeEqn InlineMath str + res <- convertMath writeEqn DisplayMath str case res of Left il -> do contents <- inlineToMs opts il @@ -567,7 +568,7 @@ colordefs = map toColorDef allcolors toColorDef c = literal (".defcolor " <> hexColor c <> " rgb #" <> hexColor c) - allcolors = catMaybes $ ordNub $ + allcolors = catMaybes $ nubOrd $ [defaultColor sty, backgroundColor sty, lineNumberColor sty, lineNumberBackgroundColor sty] <> concatMap (colorsForToken. snd) (Map.toList (tokenStyles sty)) diff --git a/src/Text/Pandoc/Writers/Muse.hs b/src/Text/Pandoc/Writers/Muse.hs --- a/src/Text/Pandoc/Writers/Muse.hs +++ b/src/Text/Pandoc/Writers/Muse.hs @@ -25,9 +25,12 @@ even though it is supported only in Emacs Muse. -} module Text.Pandoc.Writers.Muse (writeMuse) where +import Control.Monad (zipWithM) import Control.Monad.Except (throwError) import Control.Monad.Reader + ( asks, MonadReader(local), ReaderT(runReaderT) ) import Control.Monad.State.Strict + ( StateT, gets, modify, evalStateT ) import Data.Char (isAlphaNum, isAsciiLower, isAsciiUpper, isDigit, isSpace) import Data.Default import Data.List (intersperse, transpose) @@ -43,6 +46,7 @@ import Text.Pandoc.Options import Text.DocLayout import Text.Pandoc.Shared +import Text.Pandoc.URI import Text.Pandoc.Templates (renderTemplate) import Text.Pandoc.Writers.Math import Text.Pandoc.Writers.Shared @@ -275,7 +279,8 @@ (length aligns :| length widths : map length (headers:rows)) isSimple = onlySimpleTableCells (headers : rows) && all (== 0) widths blockToMuse (Div _ bs) = flatBlockListToMuse bs -blockToMuse Null = return empty +blockToMuse (Figure attr capt body) = do + blockToMuse (figureDiv attr capt body) -- | Return Muse representation of notes collected so far. currentNotesToMuse :: PandocMonad m diff --git a/src/Text/Pandoc/Writers/Native.hs b/src/Text/Pandoc/Writers/Native.hs --- a/src/Text/Pandoc/Writers/Native.hs +++ b/src/Text/Pandoc/Writers/Native.hs @@ -1,7 +1,6 @@ -{-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Writers.Native - Copyright : Copyright (C) 2006-2022 John MacFarlane + Copyright : Copyright (C) 2006-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> diff --git a/src/Text/Pandoc/Writers/ODT.hs b/src/Text/Pandoc/Writers/ODT.hs --- a/src/Text/Pandoc/Writers/ODT.hs +++ b/src/Text/Pandoc/Writers/ODT.hs @@ -2,7 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Writers.ODT - Copyright : Copyright (C) 2008-2022 John MacFarlane + Copyright : Copyright (C) 2008-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> @@ -27,6 +27,7 @@ import Text.Collate.Lang (Lang (..), renderLang) import Text.Pandoc.Class.PandocMonad (PandocMonad, report, toLang) import qualified Text.Pandoc.Class.PandocMonad as P +import Text.Pandoc.Data (readDataFile) import Text.Pandoc.Definition import Text.Pandoc.Error (PandocError(..)) import Text.Pandoc.ImageSize @@ -34,7 +35,8 @@ import Text.Pandoc.MIME (extensionFromMimeType, getMimeType) import Text.Pandoc.Options (WrapOption (..), WriterOptions (..)) import Text.DocLayout -import Text.Pandoc.Shared (stringify, pandocVersion, tshow) +import Text.Pandoc.Shared (stringify, tshow) +import Text.Pandoc.Version (pandocVersionText) import Text.Pandoc.Writers.Shared (lookupMetaString, lookupMetaBlocks, fixDisplayMath, getLang, ensureValidXmlIdentifiers) @@ -45,6 +47,7 @@ import Text.Pandoc.XML.Light import Text.TeXMath import qualified Text.XML.Light as XL +import Network.URI (parseRelativeReference, URI(uriPath)) newtype ODTState = ODTState { stEntries :: [Entry] } @@ -59,10 +62,25 @@ writeODT opts doc = let initState = ODTState{ stEntries = [] } - doc' = ensureValidXmlIdentifiers doc + doc' = fixInternalLinks . ensureValidXmlIdentifiers $ doc in evalStateT (pandocToODT opts doc') initState +-- | ODT internal links are evaluated relative to an imaginary folder +-- structure that mirrors the zip structure. The result is that relative +-- links in the document need to start with `..`. See #3524. +fixInternalLinks :: Pandoc -> Pandoc +fixInternalLinks = walk go + where + go (Link attr ils (src,tit)) = + Link attr ils (fixRel src,tit) + go x = x + fixRel uri = + case parseRelativeReference (T.unpack uri) of + Just u + | not (null (uriPath u)) -> tshow $ u{ uriPath = "../" <> uriPath u } + _ -> uri + -- | Produce an ODT file from a Pandoc document. pandocToODT :: PandocMonad m => WriterOptions -- ^ Writer options @@ -75,9 +93,10 @@ lang <- toLang (getLang opts meta) refArchive <- case writerReferenceDoc opts of - Just f -> liftM toArchive $ lift $ P.readFileLazy f + Just f -> lift $ toArchive . B.fromStrict . fst <$> + (P.fetchItem (T.pack f)) Nothing -> lift $ toArchive . B.fromStrict <$> - P.readDataFile "reference.odt" + readDataFile "reference.odt" -- handle formulas and pictures -- picEntriesRef <- P.newIORef ([] :: [Entry]) doc' <- walkM (transformPicMath opts) $ walk fixDisplayMath doc @@ -139,7 +158,7 @@ ,("xmlns:ooo","http://openoffice.org/2004/office") ,("xmlns:grddl","http://www.w3.org/2003/g/data-view#") ,("office:version","1.2")] ( inTags True "office:meta" [] - ( metaTag "meta:generator" ("Pandoc/" <> pandocVersion) + ( metaTag "meta:generator" ("Pandoc/" <> pandocVersionText) $$ metaTag "dc:title" (stringify title) $$ diff --git a/src/Text/Pandoc/Writers/OOXML.hs b/src/Text/Pandoc/Writers/OOXML.hs --- a/src/Text/Pandoc/Writers/OOXML.hs +++ b/src/Text/Pandoc/Writers/OOXML.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Writers.OOXML - Copyright : Copyright (C) 2012-2022 John MacFarlane + Copyright : Copyright (C) 2012-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> @@ -24,7 +24,7 @@ ) where import Codec.Archive.Zip -import Control.Monad.Reader +import Control.Monad (mplus) import Control.Monad.Except (throwError) import Text.Pandoc.Error import qualified Data.ByteString as B diff --git a/src/Text/Pandoc/Writers/OPML.hs b/src/Text/Pandoc/Writers/OPML.hs --- a/src/Text/Pandoc/Writers/OPML.hs +++ b/src/Text/Pandoc/Writers/OPML.hs @@ -2,7 +2,7 @@ {-# LANGUAGE CPP #-} {- | Module : Text.Pandoc.Writers.OPML - Copyright : Copyright (C) 2013-2022 John MacFarlane + Copyright : Copyright (C) 2013-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> diff --git a/src/Text/Pandoc/Writers/OpenDocument.hs b/src/Text/Pandoc/Writers/OpenDocument.hs --- a/src/Text/Pandoc/Writers/OpenDocument.hs +++ b/src/Text/Pandoc/Writers/OpenDocument.hs @@ -15,7 +15,8 @@ -} module Text.Pandoc.Writers.OpenDocument ( writeOpenDocument ) where import Control.Arrow ((***), (>>>)) -import Control.Monad.State.Strict hiding (when) +import Control.Monad (unless, liftM) +import Control.Monad.State.Strict ( StateT(..), modify, gets, lift ) import Data.Char (chr) import Data.Foldable (find) import Data.List (sortOn, sortBy, foldl') @@ -26,8 +27,8 @@ import Data.Text (Text) import qualified Data.Text as T import Text.Collate.Lang (Lang (..), parseLang) -import Text.Pandoc.Class.PandocMonad (PandocMonad, report, translateTerm, - setTranslations, toLang) +import Text.Pandoc.Class.PandocMonad (PandocMonad, report, toLang) +import Text.Pandoc.Translations (translateTerm, setTranslations) import Text.Pandoc.Definition import qualified Text.Pandoc.Builder as B import Text.Pandoc.Logging @@ -59,7 +60,7 @@ data ReferenceType = HeaderRef | TableRef - | ImageRef + | FigureRef data WriterState = WriterState { stNotes :: [Doc Text] @@ -252,12 +253,11 @@ meta ((body, metadata),s) <- flip runStateT defaultWriterState $ do - let collectInlineIdent (Image (ident,_,_) _ _) = [(ident,ImageRef)] - collectInlineIdent _ = [] let collectBlockIdent (Header _ (ident,_,_) _) = [(ident,HeaderRef)] + collectBlockIdent (Figure (ident,_,_) _ _ ) = [(ident,FigureRef)] collectBlockIdent (Table (ident,_,_) _ _ _ _ _) = [(ident,TableRef)] collectBlockIdent _ = [] - modify $ \s -> s{ stIdentTypes = query collectBlockIdent blocks ++ query collectInlineIdent blocks } + modify $ \s -> s{ stIdentTypes = query collectBlockIdent blocks } m <- metaToContext opts (blocksToOpenDocument opts) (fmap chomp . inlinesToOpenDocument opts) @@ -376,7 +376,6 @@ Plain b -> if null b then return empty else inParagraphTags =<< inlinesToOpenDocument o b - SimpleFigure attr c (s, t) -> figure attr c s t Para b -> if null b && not (isEnabled Ext_empty_paragraphs o) then return empty @@ -397,7 +396,7 @@ b@(RawBlock f s) -> if f == Format "opendocument" then return $ text $ T.unpack s else empty <$ report (BlockNotRendered b) - Null -> return empty + Figure a capt b -> figure a capt b where defList b = do setInDefinitionList True r <- vcat <$> mapM (deflistItemToOpenDocument o) b @@ -453,15 +452,18 @@ , ("table:style-name", name) ] (vcat columns $$ th $$ vcat tr) return $ captionDoc $$ tableDoc - figure attr@(ident, _, _) caption source title | null caption = - withParagraphStyle o "Figure" [Para [Image attr caption (source,title)]] - | otherwise = do - imageDoc <- withParagraphStyle o "FigureWithCaption" [Para [Image attr caption (source,title)]] - captionDoc <- inlinesToOpenDocument o caption >>= - if isEnabled Ext_native_numbering o - then numberedFigureCaption ident - else unNumberedCaption "FigureCaption" - return $ imageDoc $$ captionDoc + figure (ident, _, _) (Caption _ longcapt) body = + case blocksToInlines longcapt of + [] -> + withParagraphStyle o "Figure" body + caption -> do + imageDoc <- withParagraphStyle o "FigureWithCaption" $ + map (\case {Plain i -> Para i; b -> b}) body + captionDoc <- inlinesToOpenDocument o caption >>= + if isEnabled Ext_native_numbering o + then numberedFigureCaption ident + else unNumberedCaption "FigureCaption" + return $ imageDoc $$ captionDoc numberedTableCaption :: PandocMonad m => Text -> Doc Text -> OD m (Doc Text) @@ -704,7 +706,7 @@ linkOrReference = case maybeIdentAndType of Just (ident, HeaderRef) -> bookmarkRef' ident Just (ident, TableRef) -> sequenceRef' ident - Just (ident, ImageRef) -> sequenceRef' ident + Just (ident, FigureRef) -> sequenceRef' ident _ -> link in if isEnabled Ext_xrefs_name o || isEnabled Ext_xrefs_number o then linkOrReference diff --git a/src/Text/Pandoc/Writers/Org.hs b/src/Text/Pandoc/Writers/Org.hs --- a/src/Text/Pandoc/Writers/Org.hs +++ b/src/Text/Pandoc/Writers/Org.hs @@ -3,8 +3,8 @@ {- | Module : Text.Pandoc.Writers.Org Copyright : © 2010-2015 Puneeth Chaganti <punchagan@gmail.com> - 2010-2022 John MacFarlane <jgm@berkeley.edu> - 2016-2022 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> + 2010-2023 John MacFarlane <jgm@berkeley.edu> + 2016-2023 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> License : GNU GPL, version 2 or above Maintainer : Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> @@ -16,21 +16,26 @@ Org-Mode: <http://orgmode.org> -} module Text.Pandoc.Writers.Org (writeOrg) where +import Control.Monad (zipWithM) import Control.Monad.State.Strict + ( StateT, gets, modify, evalStateT ) import Data.Char (isAlphaNum, isDigit) -import Data.List (intersect, intersperse, partition, transpose) +import Data.List (intersperse, partition, dropWhileEnd, transpose) import Data.List.NonEmpty (nonEmpty) +import Data.Maybe (isJust) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Map as M +import Text.DocLayout import Text.Pandoc.Class.PandocMonad (PandocMonad, report) import Text.Pandoc.Definition import Text.Pandoc.Logging import Text.Pandoc.Options -import Text.DocLayout import Text.Pandoc.Shared +import Text.Pandoc.URI import Text.Pandoc.Templates (renderTemplate) import Text.Pandoc.Citeproc.Locator (parseLocator, LocatorMap(..), LocatorInfo(..)) +import Text.Pandoc.Walk (query) import Text.Pandoc.Writers.Shared data WriterState = @@ -104,7 +109,6 @@ blockToOrg :: PandocMonad m => Block -- ^ Block element -> Org m (Doc Text) -blockToOrg Null = return empty blockToOrg (Div (_, ["cell", "code"], _) (CodeBlock attr t : bs)) = do -- ipynb code cell let (ident, classes, kvs) = attr @@ -120,12 +124,6 @@ then return mempty else divToOrg attr bs blockToOrg (Plain inlines) = inlineListToOrg inlines -blockToOrg (SimpleFigure attr txt (src, tit)) = do - capt <- if null txt - then return empty - else ("#+caption: " <>) `fmap` inlineListToOrg txt - img <- inlineToOrg (Image attr txt (src,tit)) - return $ capt $$ img $$ blankline blockToOrg (Para inlines) = do contents <- inlineListToOrg inlines return $ contents <> blankline @@ -150,12 +148,28 @@ return empty blockToOrg HorizontalRule = return $ blankline $$ "--------------" $$ blankline blockToOrg (Header level attr inlines) = do - contents <- inlineListToOrg inlines - let headerStr = text $ if level > 999 then " " else replicate level '*' + let tagName inline = case inline of + Span (_, _, kv) _ -> (:[]) <$> lookup "tag-name" kv + _ -> Nothing + let (htext, tagsInlines) = break (isJust . tagName) inlines + contents <- inlineListToOrg $ dropWhileEnd (== Space) htext + columns <- writerColumns <$> gets stOptions + let headerDoc = mconcat + [ text $ if level > 999 then " " else replicate level '*' + , literal " " + , contents + ] + let tags = case query tagName tagsInlines of + Nothing -> "" + Just ts -> T.cons ':' (T.intercalate ":" ts) `T.snoc` ':' + let tagsDoc = if T.null tags + then empty + else (<> literal tags) . text . (`replicate` ' ') . max 1 $ + columns - offset headerDoc - realLength tags let drawerStr = if attr == nullAttr then empty else cr <> propertiesDrawer attr - return $ headerStr <> " " <> contents <> drawerStr <> cr + return $ nowrap (headerDoc <> tagsDoc) <> drawerStr <> cr blockToOrg (CodeBlock (ident,classes,kvs) str) = do let name = if T.null ident then empty @@ -166,12 +180,11 @@ then " +n" <> startnum else " -n" <> startnum else "" - let at = map pandocLangToOrg classes `intersect` orgLangIdentifiers - let lang = case at of + let lang = case filter (`notElem` ["example","code"]) classes of [] -> Nothing l:_ -> if "code" `elem` classes -- check for ipynb code cell - then Just ("jupyter-" <> l) - else Just l + then Just ("jupyter-" <> pandocLangToOrg l) + else Just (pandocLangToOrg l) let args = mconcat $ [ " :" <> k <> " " <> v | (k, v) <- kvs, k `notElem` ["startFrom", "org-language"]] @@ -232,6 +245,18 @@ blockToOrg (DefinitionList items) = do contents <- mapM definitionListItemToOrg items return $ vcat contents $$ blankline +blockToOrg (Figure (ident, _, _) caption body) = do + -- Represent the figure as content that can be internally linked from other + -- parts of the document. + capt <- case caption of + Caption _ [] -> pure empty + Caption _ cpt -> ("#+caption: " <>) <$> + inlineListToOrg (blocksToInlines cpt) + contents <- blockListToOrg body + let anchor = if T.null ident + then empty + else "<<" <> literal ident <> ">>" + return (capt $$ anchor $$ contents $$ blankline) -- | Convert bullet list item (list of blocks) to Org. bulletListItemToOrg :: PandocMonad m => [Block] -> Org m (Doc Text) @@ -514,8 +539,8 @@ isUrl :: Text -> Bool isUrl cs = let (scheme, path) = T.break (== ':') cs - in T.all (\c -> isAlphaNum c || c `elemText` ".-") scheme - && not (T.null path) + in T.all (\c -> isAlphaNum c || T.any (== c) ".-") scheme + && not (T.null path) -- | Translate from pandoc's programming language identifiers to those used by -- org-mode. @@ -527,53 +552,6 @@ "r" -> "R" "bash" -> "sh" _ -> cs - --- | List of language identifiers recognized by org-mode. --- See <https://orgmode.org/manual/Languages.html>. -orgLangIdentifiers :: [Text] -orgLangIdentifiers = - [ "asymptote" - , "lisp" - , "awk" - , "lua" - , "C" - , "matlab" - , "C++" - , "mscgen" - , "clojure" - , "ocaml" - , "css" - , "octave" - , "D" - , "org" - , "ditaa" - , "oz" - , "calc" - , "perl" - , "emacs-lisp" - , "plantuml" - , "eshell" - , "processing" - , "fortran" - , "python" - , "gnuplot" - , "R" - , "screen" - , "ruby" - , "dot" - , "sass" - , "haskell" - , "scheme" - , "java" - , "sed" - , "js" - , "sh" - , "latex" - , "sql" - , "ledger" - , "sqlite" - , "lilypond" - , "vala" ] -- taken from oc-csl.el in the org source tree: locmap :: LocatorMap diff --git a/src/Text/Pandoc/Writers/Powerpoint/Output.hs b/src/Text/Pandoc/Writers/Powerpoint/Output.hs --- a/src/Text/Pandoc/Writers/Powerpoint/Output.hs +++ b/src/Text/Pandoc/Writers/Powerpoint/Output.hs @@ -21,9 +21,12 @@ module Text.Pandoc.Writers.Powerpoint.Output ( presentationToArchive ) where +import Control.Monad ( MonadPlus(mplus), foldM, unless ) import Control.Monad.Except (throwError, catchError) import Control.Monad.Reader + ( asks, MonadReader(local), ReaderT(runReaderT) ) import Control.Monad.State + ( StateT, gets, modify, evalStateT ) import Codec.Archive.Zip import Data.List (intercalate, stripPrefix, nub, union, isPrefixOf, intersperse) import Data.Bifunctor (bimap) @@ -47,6 +50,7 @@ import Text.Pandoc.Class.PandocMonad (PandocMonad) import Text.Pandoc.Error (PandocError(..)) import qualified Text.Pandoc.Class.PandocMonad as P +import Text.Pandoc.Data (readDataFile, readDefaultDataFile) import Text.Pandoc.Options import Text.Pandoc.MIME import qualified Data.ByteString.Lazy as BL @@ -572,11 +576,12 @@ => WriterOptions -> Meta -> Presentation -> m Archive presentationToArchive opts meta pres = do distArchive <- toArchive . BL.fromStrict <$> - P.readDefaultDataFile "reference.pptx" + readDefaultDataFile "reference.pptx" refArchive <- case writerReferenceDoc opts of - Just f -> toArchive <$> P.readFileLazy f + Just f -> toArchive . BL.fromStrict . fst + <$> P.fetchItem (T.pack f) Nothing -> toArchive . BL.fromStrict <$> - P.readDataFile "reference.pptx" + readDataFile "reference.pptx" let (referenceLayouts, defaultReferenceLayouts) = (getLayoutsFromArchive refArchive, getLayoutsFromArchive distArchive) diff --git a/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs b/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs --- a/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs +++ b/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs @@ -43,7 +43,7 @@ , LinkTarget(..) ) where - +import Control.Monad import Control.Monad.Reader import Control.Monad.State import Data.List (intercalate) @@ -537,6 +537,8 @@ | otherwise -> Nothing addIncremental env = env { envInIncrementalDiv = incremental } in local addIncremental (concatMapM blockToParagraphs blks) +blockToParagraphs (Figure attr capt blks) = + blockToParagraphs (Shared.figureDiv attr capt blks) blockToParagraphs blk = do addLogMessage $ BlockNotRendered blk return [] @@ -1041,9 +1043,9 @@ DefinitionList ds -> all (uncurry (&&) . bimap (all inlineIsBlank) (all (all blockIsBlank))) ds Header _ _ ils -> all inlineIsBlank ils HorizontalRule -> True + Figure _ _ bls -> all blockIsBlank bls Table{} -> False Div _ bls -> all blockIsBlank bls - Null -> True textIsBlank :: T.Text -> Bool textIsBlank = T.all isSpace diff --git a/src/Text/Pandoc/Writers/RST.hs b/src/Text/Pandoc/Writers/RST.hs --- a/src/Text/Pandoc/Writers/RST.hs +++ b/src/Text/Pandoc/Writers/RST.hs @@ -2,7 +2,7 @@ {-# LANGUAGE ViewPatterns #-} {- | Module : Text.Pandoc.Writers.RST - Copyright : Copyright (C) 2006-2022 John MacFarlane + Copyright : Copyright (C) 2006-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> @@ -14,8 +14,12 @@ reStructuredText: <http://docutils.sourceforge.net/rst.html> -} module Text.Pandoc.Writers.RST ( writeRST, flatten ) where -import Control.Monad.State.Strict -import Data.Char (isSpace) +import Control.Monad.State.Strict ( StateT, gets, modify, evalStateT ) +import Control.Monad (zipWithM, liftM) +import Data.Char (isSpace, generalCategory, isAscii, isAlphaNum, + GeneralCategory( + ClosePunctuation, OpenPunctuation, InitialQuote, + FinalQuote, DashPunctuation, OtherPunctuation)) import Data.List (transpose, intersperse, foldl') import qualified Data.List.NonEmpty as NE import Data.Maybe (fromMaybe) @@ -29,6 +33,7 @@ import Text.Pandoc.Options import Text.DocLayout import Text.Pandoc.Shared +import Text.Pandoc.URI import Text.Pandoc.Templates (renderTemplate) import Text.Pandoc.Writers.Shared import Text.Pandoc.Walk @@ -160,25 +165,62 @@ -- | Escape special characters for RST. escapeText :: WriterOptions -> Text -> Text -escapeText o = T.pack . escapeString' True o . T.unpack -- This ought to be parser - where - escapeString' _ _ [] = [] - escapeString' firstChar opts (c:cs) = - case c of - '\\' -> '\\':c:escapeString' False opts cs - _ | c `elemText` "`*_|" && - (firstChar || null cs) -> '\\':c:escapeString' False opts cs - '\'' | isEnabled Ext_smart opts -> '\\':'\'':escapeString' False opts cs - '"' | isEnabled Ext_smart opts -> '\\':'"':escapeString' False opts cs - '-' | isEnabled Ext_smart opts -> - case cs of - '-':_ -> '\\':'-':escapeString' False opts cs - _ -> '-':escapeString' False opts cs - '.' | isEnabled Ext_smart opts -> - case cs of - '.':'.':rest -> '\\':'.':'.':'.':escapeString' False opts rest - _ -> '.':escapeString' False opts cs - _ -> c : escapeString' False opts cs +escapeText opts t = + if T.any isSpecial t + then T.pack . escapeString' True . T.unpack $ t + else t -- optimization + where + isSmart = isEnabled Ext_smart opts + isSpecial c = c == '\\' || c == '_' || c == '`' || c == '*' || c == '|' + || (isSmart && (c == '-' || c == '.' || c == '"' || c == '\'')) + canFollowInlineMarkup c = c == '-' || c == '.' || c == ',' || c == ':' + || c == ';' || c == '!' || c == '?' || c == '\'' + || c == '"' || c == ')' || c == ']' || c == '}' + || c == '>' || isSpace c + || (not (isAscii c) && + generalCategory c `elem` + [OpenPunctuation, InitialQuote, FinalQuote, + DashPunctuation, OtherPunctuation]) + canPrecedeInlineMarkup c = c == '-' || c == ':' || c == '/' || c == '\'' + || c == '"' || c == '<' || c == '(' || c == '[' + || c == '{' || isSpace c + || (not (isAscii c) && + generalCategory c `elem` + [ClosePunctuation, InitialQuote, FinalQuote, + DashPunctuation, OtherPunctuation]) + escapeString' canStart cs = + case cs of + [] -> [] + d:ds + | d == '\\' + -> '\\' : d : escapeString' False ds + '\'':ds + | isSmart + -> '\\' : '\'' : escapeString' True ds + '"':ds + | isSmart + -> '\\' : '"' : escapeString' True ds + '-':'-':ds + | isSmart + -> '\\' : '-' : escapeString' False ('-':ds) + '.':'.':'.':ds + | isSmart + -> '\\' : '.' : escapeString' False ('.':'.':ds) + [e] + | e == '*' || e == '_' || e == '|' || e == '`' + -> ['\\',e] + d:ds + | canPrecedeInlineMarkup d + -> d : escapeString' True ds + e:d:ds + | e == '*' || e == '_' || e == '|' || e == '`' + , (not canStart && canFollowInlineMarkup d) + || (canStart && not (isSpace d)) + -> '\\' : e : escapeString' False (d:ds) + '_':d:ds + | not (isAlphaNum d) + -> '\\' : '_' : escapeString' False (d:ds) + d:ds -> d : escapeString' False ds titleToRST :: PandocMonad m => [Inline] -> [Inline] -> RST m (Doc Text) titleToRST [] _ = return empty @@ -199,7 +241,6 @@ blockToRST :: PandocMonad m => Block -- ^ Block element -> RST m (Doc Text) -blockToRST Null = return empty blockToRST (Div ("",["title"],[]) _) = return empty -- this is generated by the rst reader and can safely be -- omitted when we're generating rst @@ -221,20 +262,6 @@ nest 3 contents $$ blankline blockToRST (Plain inlines) = inlineListToRST inlines -blockToRST (SimpleFigure attr txt (src, tit)) = do - description <- inlineListToRST txt - dims <- imageDimsToRST attr - let fig = "figure:: " <> literal src - alt = ":alt: " <> if T.null tit then description else literal tit - capt = description - (_,cls,_) = attr - classes = case cls of - [] -> empty - ["align-right"] -> ":align: right" - ["align-left"] -> ":align: left" - ["align-center"] -> ":align: center" - _ -> ":figclass: " <> literal (T.unwords cls) - return $ hang 3 ".. " (fig $$ alt $$ classes $$ dims $+$ capt) $$ blankline blockToRST (Para [Image attr txt (src, _)]) = do description <- inlineListToRST txt dims <- imageDimsToRST attr @@ -311,7 +338,7 @@ blockToRST (BlockQuote blocks) = do contents <- blockListToRST blocks return $ nest 3 contents <> blankline -blockToRST (Table _ blkCapt specs thead tbody tfoot) = do +blockToRST (Table _attrs blkCapt specs thead tbody tfoot) = do let (caption, aligns, widths, headers, rows) = toLegacyTable blkCapt specs thead tbody tfoot caption' <- inlineListToRST caption let blocksToDoc opts bs = do @@ -321,18 +348,23 @@ modify $ \st -> st{ stOptions = oldOpts } return result opts <- gets stOptions - let isSimple = all (== 0) widths && length widths > 1 - tbl <- if isSimple - then do - tbl' <- simpleTable opts blocksToDoc headers rows - if offset tbl' > writerColumns opts - then gridTable opts blocksToDoc (all null headers) - (map (const AlignDefault) aligns) widths - headers rows - else return tbl' - else gridTable opts blocksToDoc (all null headers) - (map (const AlignDefault) aligns) widths - headers rows + let renderGrid = gridTable opts blocksToDoc (all null headers) + (map (const AlignDefault) aligns) widths + headers rows + isSimple = all (== 0) widths && length widths > 1 + renderSimple = do + tbl' <- simpleTable opts blocksToDoc headers rows + if offset tbl' > writerColumns opts + then renderGrid + else return tbl' + isList = writerListTables opts + renderList = tableToRSTList caption (map (const AlignDefault) aligns) + widths headers rows + rendered + | isList = renderList + | isSimple = renderSimple + | otherwise = renderGrid + tbl <- rendered return $ blankline $$ (if null caption then tbl @@ -362,6 +394,36 @@ -- ensure that sublists have preceding blank line return $ blankline $$ vcat contents $$ blankline +blockToRST (Figure (ident, classes, _) _ body) = do + let figure attr txt (src, tit) = do + description <- inlineListToRST txt + dims <- imageDimsToRST attr + let fig = "figure:: " <> literal src + alt = ":alt: " <> if T.null tit then description else literal tit + capt = description + (_,cls,_) = attr + align = case cls of + [] -> empty + ["align-right"] -> ":align: right" + ["align-left"] -> ":align: left" + ["align-center"] -> ":align: center" + _ -> ":figclass: " <> literal (T.unwords cls) + return $ hang 3 ".. " (fig $$ alt $$ align $$ dims $+$ capt) + $$ blankline + case body of + [Para [Image attr txt tgt]] -> figure attr txt tgt + [Plain [Image attr txt tgt]] -> figure attr txt tgt + _ -> do + content <- blockListToRST body + return $ blankline $$ ( + ".. container:: float" <> space <> + literal (T.unwords (filter (/= "container") classes))) $$ + (if T.null ident + then blankline + else " :name: " <> literal ident $$ blankline) $$ + nest 3 content $$ + blankline + -- | Convert bullet list item (list of blocks) to RST. bulletListItemToRST :: PandocMonad m => [Block] -> RST m (Doc Text) bulletListItemToRST items = do @@ -438,6 +500,79 @@ -> RST m (Doc Text) blockListToRST = blockListToRST' False +{- + +http://docutils.sourceforge.net/docs/ref/rst/restructuredtext.html#directives + +According to the terminology used in the spec, a marker includes a +final whitespace and a block includes the directive arguments. Here +the variable names have slightly different meanings because we don't +want to finish the line with a space if there are no arguments, it +would produce rST that differs from what users expect in a way that's +not easy to detect + +-} +toRSTDirective :: Doc Text -> Doc Text -> [(Doc Text, Doc Text)] -> Doc Text -> Doc Text +toRSTDirective typ args options content = marker <> spaceArgs <> cr <> block + where marker = ".. " <> typ <> "::" + block = nest 3 (fieldList $$ + blankline $$ + content $$ + blankline) + spaceArgs = if isEmpty args then "" else " " <> args + -- a field list could end up being an empty doc thus being + -- omitted by $$ + fieldList = foldl ($$) "" $ map joinField options + -- a field body can contain multiple lines + joinField (name, body) = ":" <> name <> ": " <> body + +tableToRSTList :: PandocMonad m + => [Inline] + -> [Alignment] + -> [Double] + -> [[Block]] + -> [[[Block]]] + -> RST m (Doc Text) +tableToRSTList caption _ propWidths headers rows = do + captionRST <- inlineListToRST caption + opts <- gets stOptions + content <- listTableContent toWrite + pure $ toRSTDirective "list-table" captionRST (directiveOptions opts) content + where directiveOptions opts = widths (writerColumns opts) propWidths <> + headerRows + toWrite = if noHeaders then rows else headers:rows + headerRows = [("header-rows", text $ show (1 :: Int)) | not noHeaders] + widths tot pro = [("widths", showWidths tot pro) | + not (null propWidths || all (==0.0) propWidths)] + noHeaders = all null headers + -- >>> showWidths 70 [0.5, 0.5] + -- "35 35" + showWidths :: Int -> [Double] -> Doc Text + showWidths tot = text . unwords . map (show . toColumns tot) + -- toColumns converts a width expressed as a proportion of the + -- total into a width expressed as a number of columns + toColumns :: Int -> Double -> Int + toColumns t p = round (p * fromIntegral t) + listTableContent :: PandocMonad m => [[[Block]]] -> RST m (Doc Text) + listTableContent = joinTable joinDocsM joinDocsM . + mapTable blockListToRST + -- joinDocsM adapts joinDocs in order to work in the `RST m` monad + joinDocsM :: PandocMonad m => [RST m (Doc Text)] -> RST m (Doc Text) + joinDocsM = fmap joinDocs . sequence + -- joinDocs will be used to join cells and to join rows + joinDocs :: [Doc Text] -> Doc Text + joinDocs items = blankline $$ + (chomp . vcat . map formatItem) items $$ + blankline + formatItem :: Doc Text -> Doc Text + formatItem i = hang 3 "- " (i <> cr) + -- apply a function to all table cells changing their type + mapTable :: (a -> b) -> [[a]] -> [[b]] + mapTable = map . map + -- function hor to join cells and function ver to join rows + joinTable :: ([a] -> a) -> ([a] -> a) -> [[a]] -> a + joinTable hor ver = ver . map hor + transformInlines :: [Inline] -> [Inline] transformInlines = insertBS . filter hasContents . @@ -507,14 +642,14 @@ okAfterComplex SoftBreak = True okAfterComplex LineBreak = True okAfterComplex (Str (T.uncons -> Just (c,_))) - = isSpace c || c `elemText` "-.,:;!?\\/'\")]}>–—" + = isSpace c || T.any (== c) "-.,:;!?\\/'\")]}>–—" okAfterComplex _ = False okBeforeComplex :: Inline -> Bool okBeforeComplex Space = True okBeforeComplex SoftBreak = True okBeforeComplex LineBreak = True okBeforeComplex (Str (T.unsnoc -> Just (_,c))) - = isSpace c || c `elemText` "-:/'\"<([{–—" + = isSpace c || T.any (== c) "-:/'\"<([{–—" okBeforeComplex _ = False isComplex :: Inline -> Bool isComplex (Emph _) = True @@ -624,6 +759,9 @@ -- | Convert Pandoc inline element to RST. inlineToRST :: PandocMonad m => Inline -> RST m (Doc Text) +inlineToRST (Span ("",["mark"],[]) ils) = do + contents <- writeInlines ils + return $ ":mark:`" <> contents <> "`" inlineToRST (Span (_,_,kvs) ils) = do contents <- writeInlines ils return $ @@ -672,7 +810,7 @@ -- we use :literal: when the code contains backticks, since -- :literal: allows backslash-escapes; see #3974 return $ - if '`' `elemText` str + if T.any (== '`') str then ":literal:`" <> literal (escapeText opts (trim str)) <> "`" else "``" <> literal (trim str) <> "``" inlineToRST (Str str) = do @@ -685,7 +823,7 @@ modify $ \st -> st{ stHasMath = True } return $ if t == InlineMath then ":math:`" <> literal str <> "`" - else if '\n' `elemText` str + else if T.any (== '\n') str then blankline $$ ".. math::" $$ blankline $$ nest 3 (literal str) $$ blankline else blankline $$ (".. math:: " <> literal str) $$ blankline diff --git a/src/Text/Pandoc/Writers/RTF.hs b/src/Text/Pandoc/Writers/RTF.hs --- a/src/Text/Pandoc/Writers/RTF.hs +++ b/src/Text/Pandoc/Writers/RTF.hs @@ -2,7 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Writers.RTF - Copyright : Copyright (C) 2006-2022 John MacFarlane + Copyright : Copyright (C) 2006-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> @@ -134,7 +134,7 @@ where surrogate x = not ( (0x0000 <= ord x && ord x <= 0xd7ff) || (0xe000 <= ord x && ord x <= 0xffff) ) - enc x = "\\u" <> tshow (ord x) <> "?" + enc x = "\\u" <> tshow (ord x) <> " ?" -- | Escape special characters. escapeSpecial :: Text -> Text @@ -230,7 +230,6 @@ -> Alignment -- ^ alignment -> Block -- ^ block to convert -> m Text -blockToRTF _ _ Null = return "" blockToRTF indent alignment (Div _ bs) = blocksToRTF indent alignment bs blockToRTF indent alignment (Plain lst) = @@ -270,6 +269,8 @@ else tableRowToRTF True indent aligns sizes headers rows' <- T.concat <$> mapM (tableRowToRTF False indent aligns sizes) rows return $ header' <> rows' <> rtfPar indent 0 alignment caption' +blockToRTF indent alignment (Figure attr capt body) = + blockToRTF indent alignment $ figureDiv attr capt body tableRowToRTF :: PandocMonad m => Bool -> Int -> [Alignment] -> [Double] -> [[Block]] -> m Text diff --git a/src/Text/Pandoc/Writers/Roff.hs b/src/Text/Pandoc/Writers/Roff.hs --- a/src/Text/Pandoc/Writers/Roff.hs +++ b/src/Text/Pandoc/Writers/Roff.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Writers.Roff - Copyright : Copyright (C) 2007-2022 John MacFarlane + Copyright : Copyright (C) 2007-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> diff --git a/src/Text/Pandoc/Writers/Shared.hs b/src/Text/Pandoc/Writers/Shared.hs --- a/src/Text/Pandoc/Writers/Shared.hs +++ b/src/Text/Pandoc/Writers/Shared.hs @@ -1,9 +1,11 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} {- | Module : Text.Pandoc.Writers.Shared - Copyright : Copyright (C) 2013-2022 John MacFarlane + Copyright : Copyright (C) 2013-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> @@ -22,6 +24,9 @@ , defField , getLang , tagWithAttrs + , htmlAddStyle + , htmlAlignmentToString + , htmlAttrs , isDisplayMath , fixDisplayMath , unsmartify @@ -42,7 +47,6 @@ where import Safe (lastMay) import qualified Data.ByteString.Lazy as BL -import Data.Maybe (fromMaybe, isNothing) import Control.Monad (zipWithM) import Data.Aeson (ToJSON (..), encode) import Data.Char (chr, ord, isSpace, isLetter) @@ -53,15 +57,17 @@ import qualified Data.Text as T import Data.Text (Text) import qualified Text.Pandoc.Builder as Builder +import Text.Pandoc.CSS (cssAttributes) import Text.Pandoc.Definition import Text.Pandoc.Options import Text.DocLayout import Text.Pandoc.Shared (stringify, makeSections, blocksToInlines) -import Text.Pandoc.Walk (walk) +import Text.Pandoc.Walk (Walkable(..)) import qualified Text.Pandoc.UTF8 as UTF8 import Text.Pandoc.XML (escapeStringForXML) import Text.DocTemplates (Context(..), Val(..), TemplateTarget, ToContext(..), FromContext(..)) +import Text.Pandoc.Chunks (tocToList, toTOCTree) -- | Create template Context from a 'Meta' and an association list -- of variables, specified at the command line or in the writer. @@ -165,10 +171,13 @@ _ -> Nothing -- | Produce an HTML tag with the given pandoc attributes. -tagWithAttrs :: HasChars a => Text -> Attr -> Doc a -tagWithAttrs tag (ident,classes,kvs) = hsep - ["<" <> text (T.unpack tag) - ,if T.null ident +tagWithAttrs :: HasChars a => a -> Attr -> Doc a +tagWithAttrs tag attr = "<" <> literal tag <> (htmlAttrs attr) <> ">" + +-- | Produce HTML for the given pandoc attributes, to be used in HTML tags +htmlAttrs :: HasChars a => Attr -> Doc a +htmlAttrs (ident, classes, kvs) = addSpaceIfNotEmpty (hsep [ + if T.null ident then empty else "id=" <> doubleQuotes (text $ T.unpack ident) ,if null classes @@ -176,8 +185,36 @@ else "class=" <> doubleQuotes (text $ T.unpack (T.unwords classes)) ,hsep (map (\(k,v) -> text (T.unpack k) <> "=" <> doubleQuotes (text $ T.unpack (escapeStringForXML v))) kvs) - ] <> ">" + ]) +addSpaceIfNotEmpty :: HasChars a => Doc a -> Doc a +addSpaceIfNotEmpty f = if isEmpty f then f else " " <> f + +-- | Adds a key-value pair to the @style@ attribute. +htmlAddStyle :: (Text, Text) -> [(Text, Text)] -> [(Text, Text)] +htmlAddStyle (key, value) kvs = + let cssToStyle = T.intercalate " " . map (\(k, v) -> k <> ": " <> v <> ";") + in case break ((== "style") . fst) kvs of + (_, []) -> + -- no style attribute yet, add new one + ("style", cssToStyle [(key, value)]) : kvs + (xs, (_,cssStyles):rest) -> + -- modify the style attribute + xs ++ ("style", cssToStyle modifiedCssStyles) : rest + where + modifiedCssStyles = + case break ((== key) . fst) $ cssAttributes cssStyles of + (cssAttribs, []) -> (key, value) : cssAttribs + (pre, _:post) -> pre ++ (key, value) : post + +-- | Get the html representation of an alignment key +htmlAlignmentToString :: Alignment -> Maybe Text +htmlAlignmentToString = \case + AlignLeft -> Just "left" + AlignRight -> Just "right" + AlignCenter -> Just "center" + AlignDefault -> Nothing + -- | Returns 'True' iff the argument is an inline 'Math' element of type -- 'DisplayMath'. isDisplayMath :: Inline -> Bool @@ -245,8 +282,9 @@ -- the number of columns will be used in case of even widths let numcols = maximum (length aligns :| length widths : map length (headers:rows)) - let officialWidthsInChars widths' = map ( - (\x -> if x < 1 then 1 else x) . + let officialWidthsInChars :: [Double] -> [Int] + officialWidthsInChars widths' = map ( + (max 1) . (\x -> x - 3) . floor . (fromIntegral (writerColumns opts) *) ) widths' @@ -426,34 +464,10 @@ toTableOfContents :: WriterOptions -> [Block] -> Block -toTableOfContents opts bs = - BulletList $ filter (not . null) - $ map (sectionToListItem opts) - $ makeSections (writerNumberSections opts) Nothing bs - --- | Converts a section Div to a list item for a table of contents; --- returns an empty list if the given block is not a section Div. -sectionToListItem :: WriterOptions -> Block -> [Block] -sectionToListItem opts (Div (ident,_,_) - (Header lev (_,classes,kvs) ils : subsecs)) - | lev <= writerTOCDepth opts - , not (isNothing (lookup "number" kvs) && "unlisted" `elem` classes) - = Plain headerLink : [BulletList listContents | not (null listContents)] - where - num = fromMaybe "" $ lookup "number" kvs - addNumber = if T.null num - then id - else (Span ("",["toc-section-number"],[]) - [Str num] :) . (Space :) - clean (Link _ xs _) = xs - clean (Note _) = [] - clean x = [x] - headerText' = addNumber $ walk (concatMap clean) ils - headerLink = if T.null ident - then headerText' - else [Link ("toc-" <> ident, [], []) headerText' ("#" <> ident, "")] - listContents = filter (not . null) $ map (sectionToListItem opts) subsecs -sectionToListItem _ _ = [] +toTableOfContents opts = + tocToList (writerNumberSections opts) (writerTOCDepth opts) + . toTOCTree + . makeSections (writerNumberSections opts) Nothing -- | Returns 'True' iff the list of blocks has a @'Plain'@ as its last -- element. diff --git a/src/Text/Pandoc/Writers/TEI.hs b/src/Text/Pandoc/Writers/TEI.hs --- a/src/Text/Pandoc/Writers/TEI.hs +++ b/src/Text/Pandoc/Writers/TEI.hs @@ -2,7 +2,7 @@ {-# LANGUAGE PatternGuards #-} {- | Module : Text.Pandoc.Writers.Docbook - Copyright : Copyright (C) 2006-2022 John MacFarlane + Copyright : Copyright (C) 2006-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> @@ -22,6 +22,7 @@ import Text.Pandoc.Options import Text.DocLayout import Text.Pandoc.Shared +import Text.Pandoc.URI import Text.Pandoc.Templates (renderTemplate) import Text.Pandoc.Writers.Shared import Text.Pandoc.XML @@ -98,7 +99,6 @@ -- | Convert a Pandoc block element to TEI. blockToTEI :: PandocMonad m => WriterOptions -> Block -> m (Doc Text) -blockToTEI _ Null = return empty blockToTEI opts (Div attr@(_,"section":_,_) (Header lvl _ ils : xs)) = do -- TEI doesn't allow sections with no content, so insert some if needed @@ -129,18 +129,6 @@ -- we use treat as Para to ensure that Plain text ends up contained by -- something: blockToTEI opts (Plain lst) = blockToTEI opts $ Para lst --- title beginning with fig: indicates that the image is a figure ---blockToTEI opts (Para [Image attr txt (src,'f':'i':'g':':':_)]) = --- let alt = inlinesToTEI opts txt --- capt = if null txt --- then empty --- else inTagsSimple "title" alt --- in inTagsIndented "figure" $ --- capt $$ --- (inTagsIndented "mediaobject" $ --- (inTagsIndented "imageobject" --- (imageToTEI opts attr src)) $$ --- inTagsSimple "textobject" (inTagsSimple "phrase" alt)) blockToTEI opts (Para lst) = inTags False "p" [] <$> inlinesToTEI opts lst blockToTEI opts (LineBlock lns) = @@ -192,6 +180,8 @@ selfClosingTag "milestone" [("unit","undefined") ,("type","separator") ,("rendition","line")] +blockToTEI opts (Figure attr capt bs) = + blockToTEI opts (figureDiv attr capt bs) -- TEI Tables -- TEI Simple's tables are composed of cells and rows; other diff --git a/src/Text/Pandoc/Writers/Texinfo.hs b/src/Text/Pandoc/Writers/Texinfo.hs --- a/src/Text/Pandoc/Writers/Texinfo.hs +++ b/src/Text/Pandoc/Writers/Texinfo.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Writers.Texinfo - Copyright : Copyright (C) 2008-2022 John MacFarlane + Copyright : Copyright (C) 2008-2023 John MacFarlane 2012 Peter Wang License : GNU GPL, version 2 or above @@ -12,8 +12,10 @@ Conversion of 'Pandoc' format into Texinfo. -} module Text.Pandoc.Writers.Texinfo ( writeTexinfo ) where +import Control.Monad (zipWithM) import Control.Monad.Except (throwError) import Control.Monad.State.Strict + ( StateT, MonadState(get), gets, modify, evalStateT ) import Data.Char (chr, ord, isAlphaNum) import Data.List (maximumBy, transpose, foldl') import Data.List.NonEmpty (nonEmpty) @@ -31,6 +33,7 @@ import Text.Pandoc.Options import Text.DocLayout import Text.Pandoc.Shared +import Text.Pandoc.URI import Text.Pandoc.Templates (renderTemplate) import Text.Pandoc.Writers.Shared import Text.Printf (printf) @@ -115,22 +118,11 @@ => Block -- ^ Block to convert -> TI m (Doc Text) -blockToTexinfo Null = return empty - blockToTexinfo (Div _ bs) = blockListToTexinfo bs blockToTexinfo (Plain lst) = inlineListToTexinfo lst --- title beginning with fig: indicates that the image is a figure -blockToTexinfo (SimpleFigure attr txt (src, tit)) = do - capt <- if null txt - then return empty - else (\c -> text "@caption" <> braces c) `fmap` - inlineListToTexinfo txt - img <- inlineToTexinfo (Image attr txt (src,tit)) - return $ text "@float" $$ img $$ capt $$ text "@end float" - blockToTexinfo (Para lst) = inlineListToTexinfo lst -- this is handled differently from Plain in blockListToTexinfo @@ -254,10 +246,43 @@ text "@end multitable" return $ if isEmpty captionText then tableBody <> blankline - else text "@float" $$ + else text "@float Table" $$ tableBody $$ inCmd "caption" captionText $$ text "@end float" + +blockToTexinfo (Figure _ caption [SimpleFigure attr figCaption tgt]) = do + let capt = if null figCaption + then let (Caption _ cblks) = caption + in blocksToInlines cblks + else figCaption + captionText <- if null capt + then return empty + else (text "@caption" <>) . braces <$> inlineListToTexinfo capt + img <- inlineToTexinfo (Image attr figCaption tgt) + return $ text "@float Figure" $$ img $$ captionText $$ text "@end float" + +blockToTexinfo (Figure _ fCaption [ + Table attr tCaption@(Caption _ cbody) specs thead tbody tfoot]) = do + let caption = case cbody of + [] -> fCaption + _ -> tCaption + blockToTexinfo (Table attr caption specs thead tbody tfoot) + +blockToTexinfo (Figure _ (Caption _ caption) body) = do + captionText <- inlineListToTexinfo $ blocksToInlines caption + content <- blockListToTexinfo body + return $ text ("@float" ++ floatType body) $$ content $$ ( + if isEmpty captionText + then empty + else inCmd "caption" captionText + ) $$ text "@end float" + where + -- floatType according to + -- https://www.gnu.org/software/texinfo/manual/texinfo/html_node/_0040float.html + floatType [SimpleFigure {}] = " Figure" + floatType [Table {}] = " Table" + floatType _ = "" tableHeadToTexinfo :: PandocMonad m => [Alignment] diff --git a/src/Text/Pandoc/Writers/Textile.hs b/src/Text/Pandoc/Writers/Textile.hs --- a/src/Text/Pandoc/Writers/Textile.hs +++ b/src/Text/Pandoc/Writers/Textile.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Writers.Textile - Copyright : Copyright (C) 2010-2022 John MacFarlane + Copyright : Copyright (C) 2010-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> @@ -13,7 +13,8 @@ Textile: <http://thresholdstate.com/articles/4312/the-textile-reference-manual> -} module Text.Pandoc.Writers.Textile ( writeTextile ) where -import Control.Monad.State.Strict +import Control.Monad (zipWithM, liftM) +import Control.Monad.State.Strict ( StateT, gets, modify, evalStateT ) import Data.Char (isSpace) import Data.Text (Text) import qualified Data.Text as T @@ -99,8 +100,6 @@ -> Block -- ^ Block element -> TW m Text -blockToTextile _ Null = return "" - blockToTextile opts (Div attr bs) = do let startTag = render Nothing $ tagWithAttrs "div" attr let endTag = "</div>" @@ -110,11 +109,6 @@ blockToTextile opts (Plain inlines) = inlineListToTextile opts inlines -blockToTextile opts (SimpleFigure attr txt (src, tit)) = do - capt <- blockToTextile opts (Para txt) - im <- inlineToTextile opts (Image attr txt (src,tit)) - return $ im <> "\n" <> capt - blockToTextile opts (Para inlines) = do useTags <- gets stUseTags listLevel <- gets stListLevel @@ -242,6 +236,19 @@ contents <- withUseTags $ mapM (definitionListItemToTextile opts) items return $ "<dl>\n" <> vcat contents <> "\n</dl>\n" +blockToTextile opts (Figure attr (Caption _ caption) body) = do + let startTag = render Nothing $ tagWithAttrs "figure" attr + let endTag = "</figure>" + let captionInlines = blocksToInlines caption + captionMarkup <- if null captionInlines + then return "" + else ((<> "\n\n</figcaption>\n\n") . ("<figcaption>\n\n" <>)) <$> + inlineListToTextile opts (blocksToInlines caption) + contents <- blockListToTextile opts body + return $ startTag <> "\n\n" <> + captionMarkup <> + contents <> "\n\n" <> endTag <> "\n" + -- Auxiliary functions for lists: -- | Convert ordered list attributes to HTML attribute string @@ -380,37 +387,37 @@ inlineToTextile opts (Emph lst) = do contents <- inlineListToTextile opts lst - return $ if '_' `elemText` contents + return $ if T.any (== '_') contents then "<em>" <> contents <> "</em>" else "_" <> contents <> "_" inlineToTextile opts (Underline lst) = do contents <- inlineListToTextile opts lst - return $ if '+' `elemText` contents + return $ if T.any (== '+') contents then "<u>" <> contents <> "</u>" else "+" <> contents <> "+" inlineToTextile opts (Strong lst) = do contents <- inlineListToTextile opts lst - return $ if '*' `elemText` contents + return $ if T.any (== '*') contents then "<strong>" <> contents <> "</strong>" else "*" <> contents <> "*" inlineToTextile opts (Strikeout lst) = do contents <- inlineListToTextile opts lst - return $ if '-' `elemText` contents + return $ if T.any (== '-') contents then "<del>" <> contents <> "</del>" else "-" <> contents <> "-" inlineToTextile opts (Superscript lst) = do contents <- inlineListToTextile opts lst - return $ if '^' `elemText` contents + return $ if T.any (== '^') contents then "<sup>" <> contents <> "</sup>" else "[^" <> contents <> "^]" inlineToTextile opts (Subscript lst) = do contents <- inlineListToTextile opts lst - return $ if '~' `elemText` contents + return $ if T.any (== '~') contents then "<sub>" <> contents <> "</sub>" else "[~" <> contents <> "~]" @@ -427,7 +434,7 @@ inlineToTextile opts (Cite _ lst) = inlineListToTextile opts lst inlineToTextile _ (Code _ str) = - return $ if '@' `elemText` str + return $ if T.any (== '@') str then "<tt>" <> escapeStringForXML str <> "</tt>" else "@" <> str <> "@" diff --git a/src/Text/Pandoc/Writers/XWiki.hs b/src/Text/Pandoc/Writers/XWiki.hs --- a/src/Text/Pandoc/Writers/XWiki.hs +++ b/src/Text/Pandoc/Writers/XWiki.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {- -Copyright (C) 2008-2017 John MacFarlane <jgm@berkeley.edu> +Copyright (C) 2008-2023 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 @@ -19,7 +19,7 @@ {- | Module : Text.Pandoc.Writers.XWiki - Copyright : Copyright (C) 2008-2017 John MacFarlane + Copyright : Copyright (C) 2008-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : Derek Chen-Becker <dchenbecker@gmail.com> @@ -42,8 +42,11 @@ import Text.Pandoc.Logging import Text.Pandoc.Options import Text.Pandoc.Shared +import Text.Pandoc.URI import Text.Pandoc.Writers.MediaWiki (highlightingLangs) -import Text.Pandoc.Writers.Shared (toLegacyTable) +import Text.Pandoc.Templates (renderTemplate) +import Text.Pandoc.Writers.Shared (defField, metaToContext, toLegacyTable) +import Text.DocLayout (render, literal) newtype WriterState = WriterState { listLevel :: Text -- String at the beginning of items @@ -53,9 +56,19 @@ -- | Convert Pandoc to XWiki. writeXWiki :: PandocMonad m => WriterOptions -> Pandoc -> m Text -writeXWiki _ (Pandoc _ blocks) = +writeXWiki opts (Pandoc meta blocks) = do let env = WriterState { listLevel = "" } - in runReaderT (blockListToXWiki blocks) env + metadata <- metaToContext opts + (fmap (literal . trimr) . (\bs -> runReaderT (blockListToXWiki bs) env)) + (fmap (literal . trimr) . (\is -> runReaderT (inlineListToXWiki is) env)) + meta + body <- runReaderT (blockListToXWiki blocks) env + let context = defField "body" body + $ defField "toc" (writerTableOfContents opts) metadata + return $ + case writerTemplate opts of + Just tpl -> render Nothing $ renderTemplate tpl context + Nothing -> body -- | Concatenates strings with line breaks between them. vcat :: [Text] -> Text @@ -74,8 +87,6 @@ blockToXWiki :: PandocMonad m => Block -> XWikiReader m Text -blockToXWiki Null = return "" - blockToXWiki (Div (id', _, _) blocks) = do content <- blockListToXWiki blocks return $ genAnchor id' <> content @@ -121,6 +132,12 @@ lev <- asks listLevel contents <- local (\s -> s { listLevel = listLevel s <> ";" }) $ mapM definitionListItemToMediaWiki items return $ vcat contents <> if Text.null lev then "\n" else "" + +-- Create a group according to +-- https://www.xwiki.org/xwiki/bin/view/Documentation/UserGuide/Features/XWikiSyntax/?syntax=2.1§ion=Groups +blockToXWiki (Figure attr _ body) = do + content <- blockToXWiki $ Div attr body + return $ intercalate content ["(((\n", "\n)))"] -- TODO: support more features blockToXWiki (Table _ blkCapt specs thead tbody tfoot) = do diff --git a/src/Text/Pandoc/Writers/ZimWiki.hs b/src/Text/Pandoc/Writers/ZimWiki.hs --- a/src/Text/Pandoc/Writers/ZimWiki.hs +++ b/src/Text/Pandoc/Writers/ZimWiki.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Writers.ZimWiki - Copyright : © 2008-2022 John MacFarlane, + Copyright : © 2008-2023 John MacFarlane, 2017-2019 Alex Ivkin License : GNU GPL, version 2 or above @@ -32,7 +32,8 @@ import Text.Pandoc.Options (WrapOption (..), WriterOptions (writerTableOfContents, writerTemplate, writerWrapText)) -import Text.Pandoc.Shared (escapeURI, isURI, linesToPara, removeFormatting, trimr) +import Text.Pandoc.Shared (figureDiv, linesToPara, removeFormatting, trimr) +import Text.Pandoc.URI (escapeURI, isURI) import Text.Pandoc.Templates (renderTemplate) import Text.Pandoc.Writers.Shared (defField, metaToContext, toLegacyTable) @@ -77,24 +78,12 @@ -- | Convert Pandoc block element to ZimWiki. blockToZimWiki :: PandocMonad m => WriterOptions -> Block -> ZW m Text -blockToZimWiki _ Null = return "" - blockToZimWiki opts (Div _attrs bs) = do contents <- blockListToZimWiki opts bs return $ contents <> "\n" blockToZimWiki opts (Plain inlines) = inlineListToZimWiki opts inlines --- ZimWiki doesn't support captions - so combine together alt and caption into alt -blockToZimWiki opts (SimpleFigure attr txt (src, tit)) = do - capt <- if null txt - then return "" - else (" " <>) `fmap` inlineListToZimWiki opts txt - let opt = if null txt - then "" - else "|" <> if T.null tit then capt else tit <> capt - return $ "{{" <> src <> imageDims opts attr <> opt <> "}}\n" - blockToZimWiki opts (Para inlines) = do indent <- gets stIndent -- useTags <- gets stUseTags @@ -178,6 +167,9 @@ blockToZimWiki opts (DefinitionList items) = do contents <- mapM (definitionListItemToZimWiki opts) items return $ vcat contents + +blockToZimWiki opts (Figure attr capt body) = do + blockToZimWiki opts (figureDiv attr capt body) definitionListItemToZimWiki :: PandocMonad m => WriterOptions diff --git a/src/Text/Pandoc/XML.hs b/src/Text/Pandoc/XML.hs --- a/src/Text/Pandoc/XML.hs +++ b/src/Text/Pandoc/XML.hs @@ -2,7 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.XML - Copyright : Copyright (C) 2006-2022 John MacFarlane + Copyright : Copyright (C) 2006-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> @@ -21,6 +21,7 @@ toEntities, toHtml5Entities, fromEntities, + lookupEntity, html4Attributes, html5Attributes, rdfaAttributes ) where @@ -28,11 +29,13 @@ import Data.Char (isAscii, isSpace, ord, isLetter, isDigit) import Data.Text (Text) import qualified Data.Text as T -import Text.HTML.TagSoup.Entity (lookupEntity, htmlEntities) +import Commonmark.Entity (lookupEntity) +import Text.HTML.TagSoup.Entity (htmlEntities) import Text.DocLayout + ( ($$), char, hcat, nest, text, Doc, HasChars ) import Text.Printf (printf) import qualified Data.Map as M -import Data.String +import Data.String ( IsString ) import qualified Data.Set as Set -- | Escape one character as needed for XML. @@ -117,8 +120,8 @@ (\new old -> if T.length new > T.length old then old else new) c ent' entmap - where ent' = T.takeWhile (/=';') (T.pack ent) - _ -> entmap + where ent' = T.takeWhile (/=';') (T.pack ent) + _ -> entmap -- | Converts a string into an NCName, i.e., an XML name without colons. -- Disallowed characters are escaped using @ux%x@, where @%x@ is the @@ -158,7 +161,7 @@ Just (';',ys) -> ys _ -> rest ent' = T.drop 1 ent <> ";" - in case T.pack <$> lookupEntity (T.unpack ent') of + in case lookupEntity ent' of Just c -> c <> fromEntities rest' Nothing -> ent <> fromEntities rest diff --git a/src/Text/Pandoc/XML/Light.hs b/src/Text/Pandoc/XML/Light.hs deleted file mode 100644 --- a/src/Text/Pandoc/XML/Light.hs +++ /dev/null @@ -1,114 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{- | - Module : Text.Pandoc.XML.Light - Copyright : Copyright (C) 2021-2022 John MacFarlane - License : GNU GPL, version 2 or above - - Maintainer : John MacFarlane <jgm@berkeley.edu> - Stability : alpha - Portability : portable - -xml-light, which we used in pandoc's the XML-based readers, has -some limitations: in particular, it produces nodes with String -instead of Text, and the parser falls over on processing instructions -(see #7091). - -This module exports much of the API of xml-light, but using Text instead -of String. In addition, the xml-light parsers are replaced by xml-conduit's -well-tested parser. (The xml-conduit types are mapped to types -isomorphic to xml-light's, to avoid the need for massive code modifications -elsewhere.) Bridge functions to map xml-light types to this module's -types are also provided (since libraries like texmath still use xml-light). - -Another advantage of the xml-conduit parser is that it gives us -detailed information on xml parse errors. - -In the future we may want to move to using xml-conduit or another -xml library in the code base, but this change gives us -better performance and accuracy without much change in the -code that used xml-light. --} -module Text.Pandoc.XML.Light - ( module Text.Pandoc.XML.Light.Types - , module Text.Pandoc.XML.Light.Proc - , module Text.Pandoc.XML.Light.Output - -- * Replacement for xml-light's Text.XML.Input - , parseXMLElement - , parseXMLContents - -- * Versions that allow passing in a custom entity table - , parseXMLElementWithEntities - , parseXMLContentsWithEntities - ) where - -import qualified Control.Exception as E -import qualified Text.XML as Conduit -import Text.XML.Unresolved (InvalidEventStream(..)) -import qualified Data.Text as T -import qualified Data.Text.Lazy as TL -import qualified Data.Map as M -import Data.Maybe (mapMaybe) -import Text.Pandoc.XML.Light.Types -import Text.Pandoc.XML.Light.Proc -import Text.Pandoc.XML.Light.Output -import qualified Data.XML.Types as XML - --- Drop in replacement for parseXMLDoc in xml-light. -parseXMLElement :: TL.Text -> Either T.Text Element -parseXMLElement = parseXMLElementWithEntities mempty - --- Drop in replacement for parseXMLDoc in xml-light. -parseXMLElementWithEntities :: M.Map T.Text T.Text - -> TL.Text -> Either T.Text Element -parseXMLElementWithEntities entityMap t = - elementToElement . Conduit.documentRoot <$> - either (Left . T.pack . E.displayException) Right - (Conduit.parseText Conduit.def{ Conduit.psRetainNamespaces = True - , Conduit.psDecodeEntities = decodeEnts } t) - where - decodeEnts ref = case M.lookup ref entityMap of - Nothing -> XML.ContentEntity ref - Just t' -> XML.ContentText t' - -parseXMLContents :: TL.Text -> Either T.Text [Content] -parseXMLContents = parseXMLContentsWithEntities mempty - -parseXMLContentsWithEntities :: M.Map T.Text T.Text - -> TL.Text -> Either T.Text [Content] -parseXMLContentsWithEntities entityMap t = - case Conduit.parseText Conduit.def{ Conduit.psRetainNamespaces = True - , Conduit.psDecodeEntities = decodeEnts - } t of - Left e -> - case E.fromException e of - Just (ContentAfterRoot _) -> - elContent <$> parseXMLElementWithEntities entityMap - ("<wrapper>" <> t <> "</wrapper>") - _ -> Left . T.pack . E.displayException $ e - Right x -> Right [Elem . elementToElement . Conduit.documentRoot $ x] - where - decodeEnts ref = case M.lookup ref entityMap of - Nothing -> XML.ContentEntity ref - Just t' -> XML.ContentText t' - -elementToElement :: Conduit.Element -> Element -elementToElement (Conduit.Element name attribMap nodes) = - Element (nameToQname name) attrs (mapMaybe nodeToContent nodes) Nothing - where - attrs = map (\(n,v) -> Attr (nameToQname n) v) $ - M.toList attribMap - nameToQname (Conduit.Name localName mbns mbpref) = - case mbpref of - Nothing -> - case T.stripPrefix "xmlns:" localName of - Just rest -> QName rest mbns (Just "xmlns") - Nothing -> QName localName mbns mbpref - _ -> QName localName mbns mbpref - -nodeToContent :: Conduit.Node -> Maybe Content -nodeToContent (Conduit.NodeElement el) = - Just (Elem (elementToElement el)) -nodeToContent (Conduit.NodeContent t) = - Just (Text (CData CDataText t Nothing)) -nodeToContent _ = Nothing - diff --git a/src/Text/Pandoc/XML/Light/Output.hs b/src/Text/Pandoc/XML/Light/Output.hs deleted file mode 100644 --- a/src/Text/Pandoc/XML/Light/Output.hs +++ /dev/null @@ -1,234 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{- | - Module : Text.Pandoc.XML.Light.Output - Copyright : Copyright (C) 2007 Galois, Inc., 2021-2022 John MacFarlane - License : GNU GPL, version 2 or above - - - Maintainer : John MacFarlane <jgm@berkeley.edu> - Stability : alpha - Portability : portable - - This code is based on code from xml-light, released under the BSD3 license. - We use a text Builder instead of ShowS. --} -module Text.Pandoc.XML.Light.Output - ( -- * Replacement for xml-light's Text.XML.Output - ppTopElement - , ppElement - , ppContent - , ppcElement - , ppcContent - , showTopElement - , showElement - , showContent - , useShortEmptyTags - , defaultConfigPP - , ConfigPP(..) - ) where - -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Lazy as TL -import Data.Text.Lazy.Builder (Builder, singleton, fromText, toLazyText) -import Text.Pandoc.XML.Light.Types - --- --- duplicates functinos from Text.XML.Output --- - --- | The XML 1.0 header -xmlHeader :: Text -xmlHeader = "<?xml version=\"1.0\" encoding=\"UTF-8\"?>" - - --------------------------------------------------------------------------------- -data ConfigPP = ConfigPP - { shortEmptyTag :: QName -> Bool - , prettify :: Bool - } - --- | Default pretty orinting configuration. --- * Always use abbreviate empty tags. -defaultConfigPP :: ConfigPP -defaultConfigPP = ConfigPP { shortEmptyTag = const True - , prettify = False - } - --- | The predicate specifies for which empty tags we should use XML's --- abbreviated notation <TAG />. This is useful if we are working with --- some XML-ish standards (such as certain versions of HTML) where some --- empty tags should always be displayed in the <TAG></TAG> form. -useShortEmptyTags :: (QName -> Bool) -> ConfigPP -> ConfigPP -useShortEmptyTags p c = c { shortEmptyTag = p } - - --- | Specify if we should use extra white-space to make document more readable. --- WARNING: This adds additional white-space to text elements, --- and so it may change the meaning of the document. -useExtraWhiteSpace :: Bool -> ConfigPP -> ConfigPP -useExtraWhiteSpace p c = c { prettify = p } - --- | A configuration that tries to make things pretty --- (possibly at the cost of changing the semantics a bit --- through adding white space.) -prettyConfigPP :: ConfigPP -prettyConfigPP = useExtraWhiteSpace True defaultConfigPP - - --------------------------------------------------------------------------------- - - --- | Pretty printing renders XML documents faithfully, --- with the exception that whitespace may be added\/removed --- in non-verbatim character data. -ppTopElement :: Element -> Text -ppTopElement = ppcTopElement prettyConfigPP - --- | Pretty printing elements -ppElement :: Element -> Text -ppElement = ppcElement prettyConfigPP - --- | Pretty printing content -ppContent :: Content -> Text -ppContent = ppcContent prettyConfigPP - --- | Pretty printing renders XML documents faithfully, --- with the exception that whitespace may be added\/removed --- in non-verbatim character data. -ppcTopElement :: ConfigPP -> Element -> Text -ppcTopElement c e = T.unlines [xmlHeader,ppcElement c e] - --- | Pretty printing elements -ppcElement :: ConfigPP -> Element -> Text -ppcElement c = TL.toStrict . toLazyText . ppElementS c mempty - --- | Pretty printing content -ppcContent :: ConfigPP -> Content -> Text -ppcContent c = TL.toStrict . toLazyText . ppContentS c mempty - -ppcCData :: ConfigPP -> CData -> Text -ppcCData c = TL.toStrict . toLazyText . ppCDataS c mempty - -type Indent = Builder - --- | Pretty printing content using ShowT -ppContentS :: ConfigPP -> Indent -> Content -> Builder -ppContentS c i x = case x of - Elem e -> ppElementS c i e - Text t -> ppCDataS c i t - CRef r -> showCRefS r - -ppElementS :: ConfigPP -> Indent -> Element -> Builder -ppElementS c i e = i <> tagStart (elName e) (elAttribs e) <> - (case elContent e of - [] | "?" `T.isPrefixOf` qName name -> fromText " ?>" - | shortEmptyTag c name -> fromText " />" - [Text t] -> singleton '>' <> ppCDataS c mempty t <> tagEnd name - cs -> singleton '>' <> nl <> - mconcat (map ((<> nl) . ppContentS c (sp <> i)) cs) <> - i <> tagEnd name - where (nl,sp) = if prettify c then ("\n"," ") else ("","") - ) - where name = elName e - -ppCDataS :: ConfigPP -> Indent -> CData -> Builder -ppCDataS c i t = i <> if cdVerbatim t /= CDataText || not (prettify c) - then showCDataS t - else foldr cons mempty (T.unpack (showCData t)) - where cons :: Char -> Builder -> Builder - cons '\n' ys = singleton '\n' <> i <> ys - cons y ys = singleton y <> ys - - - --------------------------------------------------------------------------------- - --- | Adds the <?xml?> header. -showTopElement :: Element -> Text -showTopElement c = xmlHeader <> showElement c - -showContent :: Content -> Text -showContent = ppcContent defaultConfigPP - -showElement :: Element -> Text -showElement = ppcElement defaultConfigPP - -showCData :: CData -> Text -showCData = ppcCData defaultConfigPP - --- Note: crefs should not contain '&', ';', etc. -showCRefS :: Text -> Builder -showCRefS r = singleton '&' <> fromText r <> singleton ';' - --- | Convert a text element to characters. -showCDataS :: CData -> Builder -showCDataS cd = - case cdVerbatim cd of - CDataText -> escStr (cdData cd) - CDataVerbatim -> fromText "<![CDATA[" <> escCData (cdData cd) <> - fromText "]]>" - CDataRaw -> fromText (cdData cd) - --------------------------------------------------------------------------------- -escCData :: Text -> Builder -escCData t - | "]]>" `T.isPrefixOf` t = - fromText "]]]]><![CDATA[>" <> fromText (T.drop 3 t) -escCData t - = case T.uncons t of - Nothing -> mempty - Just (c,t') -> singleton c <> escCData t' - -escChar :: Char -> Builder -escChar c = case c of - '<' -> fromText "<" - '>' -> fromText ">" - '&' -> fromText "&" - '"' -> fromText """ - -- we use ' instead of ' because IE apparently has difficulties - -- rendering ' in xhtml. - -- Reported by Rohan Drape <rohan.drape@gmail.com>. - '\'' -> fromText "'" - _ -> singleton c - - {- original xml-light version: - -- NOTE: We escape '\r' explicitly because otherwise they get lost - -- when parsed back in because of then end-of-line normalization rules. - _ | isPrint c || c == '\n' -> singleton c - | otherwise -> showText "&#" . showsT oc . singleton ';' - where oc = ord c - -} - -escStr :: Text -> Builder -escStr cs = if T.any needsEscape cs - then mconcat (map escChar (T.unpack cs)) - else fromText cs - where - needsEscape '<' = True - needsEscape '>' = True - needsEscape '&' = True - needsEscape '"' = True - needsEscape '\'' = True - needsEscape _ = False - -tagEnd :: QName -> Builder -tagEnd qn = fromText "</" <> showQName qn <> singleton '>' - -tagStart :: QName -> [Attr] -> Builder -tagStart qn as = singleton '<' <> showQName qn <> as_str - where as_str = if null as - then mempty - else mconcat (map showAttr as) - -showAttr :: Attr -> Builder -showAttr (Attr qn v) = singleton ' ' <> showQName qn <> - singleton '=' <> - singleton '"' <> escStr v <> singleton '"' - -showQName :: QName -> Builder -showQName q = - case qPrefix q of - Nothing -> fromText (qName q) - Just p -> fromText p <> singleton ':' <> fromText (qName q) diff --git a/src/Text/Pandoc/XML/Light/Proc.hs b/src/Text/Pandoc/XML/Light/Proc.hs deleted file mode 100644 --- a/src/Text/Pandoc/XML/Light/Proc.hs +++ /dev/null @@ -1,139 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{- | - Module : Text.Pandoc.XML.Light.Proc - Copyright : Copyright (C) 2007 Galois, Inc., 2021-2022 John MacFarlane - License : GNU GPL, version 2 or above - - Maintainer : John MacFarlane <jgm@berkeley.edu> - Stability : alpha - Portability : portable - - This code is taken from xml-light, released under the BSD3 license. --} -module Text.Pandoc.XML.Light.Proc - ( - -- * Replacement for xml-light's Text.XML.Proc - strContent - , onlyElems - , elChildren - , onlyText - , findChildren - , filterChildren - , filterChildrenName - , findChild - , filterChild - , filterChildName - , findElement - , filterElement - , filterElementName - , findElements - , filterElements - , filterElementsName - , findAttr - , lookupAttr - , lookupAttrBy - , findAttrBy - ) where - -import Data.Text (Text) -import Data.Maybe (listToMaybe) -import Data.List(find) -import Text.Pandoc.XML.Light.Types - --- --- copied from xml-light Text.XML.Proc --- - --- | Get the text value of an XML element. This function --- ignores non-text elements, and concatenates all text elements. -strContent :: Element -> Text -strContent = mconcat . map cdData . onlyText . elContent - --- | Select only the elements from a list of XML content. -onlyElems :: [Content] -> [Element] -onlyElems xs = [ x | Elem x <- xs ] - --- | Select only the elements from a parent. -elChildren :: Element -> [Element] -elChildren e = [ x | Elem x <- elContent e ] - --- | Select only the text from a list of XML content. -onlyText :: [Content] -> [CData] -onlyText xs = [ x | Text x <- xs ] - --- | Find all immediate children with the given name. -findChildren :: QName -> Element -> [Element] -findChildren q e = filterChildren ((q ==) . elName) e - --- | Filter all immediate children wrt a given predicate. -filterChildren :: (Element -> Bool) -> Element -> [Element] -filterChildren p e = filter p (onlyElems (elContent e)) - - --- | Filter all immediate children wrt a given predicate over their names. -filterChildrenName :: (QName -> Bool) -> Element -> [Element] -filterChildrenName p e = filter (p.elName) (onlyElems (elContent e)) - - --- | Find an immediate child with the given name. -findChild :: QName -> Element -> Maybe Element -findChild q e = listToMaybe (findChildren q e) - --- | Find an immediate child with the given name. -filterChild :: (Element -> Bool) -> Element -> Maybe Element -filterChild p e = listToMaybe (filterChildren p e) - --- | Find an immediate child with name matching a predicate. -filterChildName :: (QName -> Bool) -> Element -> Maybe Element -filterChildName p e = listToMaybe (filterChildrenName p e) - --- | Find the left-most occurrence of an element matching given name. -findElement :: QName -> Element -> Maybe Element -findElement q e = listToMaybe (findElements q e) - --- | Filter the left-most occurrence of an element wrt. given predicate. -filterElement :: (Element -> Bool) -> Element -> Maybe Element -filterElement p e = listToMaybe (filterElements p e) - --- | Filter the left-most occurrence of an element wrt. given predicate. -filterElementName :: (QName -> Bool) -> Element -> Maybe Element -filterElementName p e = listToMaybe (filterElementsName p e) - --- | Find all non-nested occurrences of an element. --- (i.e., once we have found an element, we do not search --- for more occurrences among the element's children). -findElements :: QName -> Element -> [Element] -findElements qn e = filterElementsName (qn==) e - --- | Find all non-nested occurrences of an element wrt. given predicate. --- (i.e., once we have found an element, we do not search --- for more occurrences among the element's children). -filterElements :: (Element -> Bool) -> Element -> [Element] -filterElements p e - | p e = [e] - | otherwise = concatMap (filterElements p) $ onlyElems $ elContent e - --- | Find all non-nested occurrences of an element wrt a predicate over element names. --- (i.e., once we have found an element, we do not search --- for more occurrences among the element's children). -filterElementsName :: (QName -> Bool) -> Element -> [Element] -filterElementsName p e = filterElements (p.elName) e - --- | Lookup the value of an attribute. -findAttr :: QName -> Element -> Maybe Text -findAttr x e = lookupAttr x (elAttribs e) - --- | Lookup attribute name from list. -lookupAttr :: QName -> [Attr] -> Maybe Text -lookupAttr x = lookupAttrBy (x ==) - --- | Lookup the first attribute whose name satisfies the given predicate. -lookupAttrBy :: (QName -> Bool) -> [Attr] -> Maybe Text -lookupAttrBy p as = attrVal `fmap` find (p . attrKey) as - --- | Lookup the value of the first attribute whose name --- satisfies the given predicate. -findAttrBy :: (QName -> Bool) -> Element -> Maybe Text -findAttrBy p e = lookupAttrBy p (elAttribs e) - - diff --git a/src/Text/Pandoc/XML/Light/Types.hs b/src/Text/Pandoc/XML/Light/Types.hs deleted file mode 100644 --- a/src/Text/Pandoc/XML/Light/Types.hs +++ /dev/null @@ -1,193 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE DeriveDataTypeable #-} -{- | - Module : Text.Pandoc.XML.Light.Types - Copyright : Copyright (C) 2007 Galois, Inc., 2021-2022 John MacFarlane - License : GNU GPL, version 2 or above - - Maintainer : John MacFarlane <jgm@berkeley.edu> - Stability : alpha - Portability : portable - - This code is taken from xml-light, released under the BSD3 license. - It has been modified to use Text instead of String, and the fromXL* - functions have been added. --} -module Text.Pandoc.XML.Light.Types - ( -- * Basic types, duplicating those from xml-light but with Text - -- instead of String - Line - , Content(..) - , Element(..) - , Attr(..) - , CData(..) - , CDataKind(..) - , QName(..) - , Node(..) - , unode - , unqual - , add_attr - , add_attrs - -- * Conversion functions from xml-light types - , fromXLQName - , fromXLCData - , fromXLElement - , fromXLAttr - , fromXLContent - ) where - -import Data.Text (Text) -import qualified Data.Text as T -import Data.Data (Data) -import Data.Typeable (Typeable) -import qualified Text.XML.Light as XL - --- --- type definitions lightly modified from xml-light --- - --- | A line is an Integer -type Line = Integer - --- | XML content -data Content = Elem Element - | Text CData - | CRef Text - deriving (Show, Typeable, Data, Ord, Eq) - --- | XML elements -data Element = Element { - elName :: QName, - elAttribs :: [Attr], - elContent :: [Content], - elLine :: Maybe Line - } deriving (Show, Typeable, Data, Ord, Eq) - --- | XML attributes -data Attr = Attr { - attrKey :: QName, - attrVal :: Text - } deriving (Eq, Ord, Show, Typeable, Data) - --- | XML CData -data CData = CData { - cdVerbatim :: CDataKind, - cdData :: Text, - cdLine :: Maybe Line - } deriving (Show, Typeable, Data, Ord, Eq) - -data CDataKind - = CDataText -- ^ Ordinary character data; pretty printer escapes &, < etc. - | CDataVerbatim -- ^ Unescaped character data; pretty printer embeds it in <![CDATA[.. - | CDataRaw -- ^ As-is character data; pretty printer passes it along without any escaping or CDATA wrap-up. - deriving ( Eq, Ord, Show, Typeable, Data ) - --- | XML qualified names -data QName = QName { - qName :: Text, - qURI :: Maybe Text, - qPrefix :: Maybe Text - } deriving (Show, Typeable, Data) - - -instance Eq QName where - q1 == q2 = compare q1 q2 == EQ - -instance Ord QName where - compare q1 q2 = - case compare (qName q1) (qName q2) of - EQ -> case (qURI q1, qURI q2) of - (Nothing,Nothing) -> compare (qPrefix q1) (qPrefix q2) - (u1,u2) -> compare u1 u2 - x -> x - -class Node t where - node :: QName -> t -> Element - -instance Node ([Attr],[Content]) where - node n (attrs,cont) = Element { elName = n - , elAttribs = attrs - , elContent = cont - , elLine = Nothing - } - -instance Node [Attr] where node n as = node n (as,[]::[Content]) -instance Node Attr where node n a = node n [a] -instance Node () where node n () = node n ([]::[Attr]) - -instance Node [Content] where node n cs = node n ([]::[Attr],cs) -instance Node Content where node n c = node n [c] -instance Node ([Attr],Content) where node n (as,c) = node n (as,[c]) -instance Node (Attr,Content) where node n (a,c) = node n ([a],[c]) - -instance Node ([Attr],[Element]) where - node n (as,cs) = node n (as,map Elem cs) - -instance Node ([Attr],Element) where node n (as,c) = node n (as,[c]) -instance Node (Attr,Element) where node n (a,c) = node n ([a],c) -instance Node [Element] where node n es = node n ([]::[Attr],es) -instance Node Element where node n e = node n [e] - -instance Node ([Attr],[CData]) where - node n (as,cs) = node n (as,map Text cs) - -instance Node ([Attr],CData) where node n (as,c) = node n (as,[c]) -instance Node (Attr,CData) where node n (a,c) = node n ([a],c) -instance Node [CData] where node n es = node n ([]::[Attr],es) -instance Node CData where node n e = node n [e] - -instance Node ([Attr],Text) where - node n (as,t) = node n (as, CData { cdVerbatim = CDataText - , cdData = t - , cdLine = Nothing }) - -instance Node (Attr,Text ) where node n (a,t) = node n ([a],t) -instance Node Text where node n t = node n ([]::[Attr],t) - --- | Create node with unqualified name -unode :: Node t => Text -> t -> Element -unode = node . unqual - -unqual :: Text -> QName -unqual x = QName x Nothing Nothing - --- | Add an attribute to an element. -add_attr :: Attr -> Element -> Element -add_attr a e = add_attrs [a] e - --- | Add some attributes to an element. -add_attrs :: [Attr] -> Element -> Element -add_attrs as e = e { elAttribs = as ++ elAttribs e } - --- --- conversion from xml-light --- - -fromXLQName :: XL.QName -> QName -fromXLQName qn = QName { qName = T.pack $ XL.qName qn - , qURI = T.pack <$> XL.qURI qn - , qPrefix = T.pack <$> XL.qPrefix qn } - -fromXLCData :: XL.CData -> CData -fromXLCData cd = CData { cdVerbatim = case XL.cdVerbatim cd of - XL.CDataText -> CDataText - XL.CDataVerbatim -> CDataVerbatim - XL.CDataRaw -> CDataRaw - , cdData = T.pack $ XL.cdData cd - , cdLine = XL.cdLine cd } - -fromXLElement :: XL.Element -> Element -fromXLElement el = Element { elName = fromXLQName $ XL.elName el - , elAttribs = map fromXLAttr $ XL.elAttribs el - , elContent = map fromXLContent $ XL.elContent el - , elLine = XL.elLine el } - -fromXLAttr :: XL.Attr -> Attr -fromXLAttr (XL.Attr qn s) = Attr (fromXLQName qn) (T.pack s) - -fromXLContent :: XL.Content -> Content -fromXLContent (XL.Elem el) = Elem $ fromXLElement el -fromXLContent (XL.Text cd) = Text $ fromXLCData cd -fromXLContent (XL.CRef s) = CRef (T.pack s) - - diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -5,47 +5,25 @@ old-random: false packages: - '.' +- 'pandoc-cli' +- 'pandoc-lua-engine' +- 'pandoc-server' extra-deps: -- skylighting-core-0.13 -- skylighting-0.13 -- skylighting-format-ansi-0.1 -- skylighting-format-latex-0.1 -- skylighting-format-blaze-html-0.1 -- emojis-0.1.2 -- gridtables-0.0.3.0 -- lpeg-1.0.3 -- hslua-2.2.1 -- hslua-aeson-2.2.1 -- hslua-classes-2.2.0 -- hslua-core-2.2.1 -- hslua-marshalling-2.2.1 -- hslua-module-doclayout-1.0.4 -- hslua-module-path-1.0.3 -- hslua-module-system-1.0.2 -- hslua-module-text-1.0.2 -- hslua-module-version-1.0.2 -- hslua-objectorientation-2.2.1 -- hslua-packaging-2.2.1 -- lua-2.2.1 -- lua-arbitrary-1.0.1 -- tasty-hslua-1.0.2 -- tasty-lua-1.0.2 -- pandoc-lua-marshal-0.1.7 -- aeson-pretty-0.8.9 -- unicode-transforms-0.4.0.1 -- unicode-data-0.3.0 -- commonmark-pandoc-0.2.1.2 -- ipynb-0.2 -- pandoc-types-1.22.2.1 -- commonmark-0.2.2 -- commonmark-extensions-0.2.3.2 -- doclayout-0.4 -- doctemplates-0.10.0.2 -- citeproc-0.8.0.1 -- texmath-0.12.5.2 +- gridtables-0.1.0.0 +- hslua-cli-1.2.0 +- hslua-list-1.1.0 +- hslua-module-zip-1.0.0 +- jira-wiki-markup-1.5.0 +- mime-types-0.1.1.0 +- doctemplates-0.11 +- texmath-0.12.5.5 +- citeproc-0.8.1 +- pandoc-types-1.23 +- pandoc-lua-marshal-0.2.0 +- commonmark-pandoc-0.2.1.3 ghc-options: "$locals": -fhide-source-paths -Wno-missing-home-modules -resolver: lts-18.10 +resolver: lts-20.6 nix: packages: [zlib] diff --git a/test/Tests/Command.hs b/test/Tests/Command.hs --- a/test/Tests/Command.hs +++ b/test/Tests/Command.hs @@ -1,7 +1,7 @@ {-# LANGUAGE BangPatterns #-} {- | Module : Tests.Command - Copyright : © 2006-2022 John MacFarlane + Copyright : © 2006-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley@edu> @@ -31,7 +31,7 @@ contain "=> " followed by the exit status. -} -module Tests.Command (runTest, tests) +module Tests.Command (tests) where import Data.Maybe (fromMaybe) @@ -76,21 +76,6 @@ "| " ++ "test-pandoc --emulate" ++ pandocToEmulate False cs pandocToEmulate _ (c:cs) = c : pandocToEmulate False cs pandocToEmulate _ [] = [] - --- | Run a test, return True if test passed. -runTest :: String -- ^ Path to test executable - -> String -- ^ Title of test - -> String -- ^ Shell command - -> String -- ^ Input text - -> String -- ^ Expected output - -> TestTree -runTest testExePath testname cmd inp norm = testCase testname $ do - (_ec, out) <- execTest testExePath cmd inp - result <- if out == norm - then return TestPassed - else return $ TestFailed cmd "expected" - $ getDiff (lines out) (lines norm) - assertBool (show result) (result == TestPassed) tests :: TestTree {-# NOINLINE tests #-} diff --git a/test/Tests/Helpers.hs b/test/Tests/Helpers.hs --- a/test/Tests/Helpers.hs +++ b/test/Tests/Helpers.hs @@ -3,7 +3,7 @@ {-# LANGUAGE FlexibleInstances #-} {- | Module : Tests.Helpers - Copyright : © 2006-2022 John MacFarlane + Copyright : © 2006-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley@edu> @@ -155,7 +155,7 @@ toString = toString . B.fromList instance ToString Block where - toString = toString . B.singleton + toString = toString . B.singleton instance ToString Inlines where toString = unpack . trimr . purely (writeNative def) . toPandoc diff --git a/test/Tests/Lua.hs b/test/Tests/Lua.hs deleted file mode 100644 --- a/test/Tests/Lua.hs +++ /dev/null @@ -1,247 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{- | - Module : Tests.Lua - Copyright : © 2017-2022 Albert Krewinkel - License : GNU GPL, version 2 or above - - Maintainer : Albert Krewinkel <albert@zeitkraut.de> - Stability : alpha - Portability : portable - -Unit and integration tests for pandoc's Lua subsystem. --} -module Tests.Lua ( runLuaTest, tests ) where - -import HsLua as Lua hiding (Operation (Div), error) -import System.FilePath ((</>)) -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit ((@=?), Assertion, HasCallStack, assertEqual, testCase) -import Text.Pandoc.Arbitrary () -import Text.Pandoc.Builder (bulletList, definitionList, displayMath, divWith, - doc, doubleQuoted, emph, header, lineBlock, - linebreak, math, orderedList, para, plain, rawBlock, - singleQuoted, space, str, strong, - HasMeta (setMeta)) -import Text.Pandoc.Class (runIOorExplode, setUserDataDir) -import Text.Pandoc.Definition (Attr, Block (BlockQuote, Div, Para), Pandoc, - Inline (Emph, Str), pandocTypesVersion) -import Text.Pandoc.Error (PandocError (PandocLuaError)) -import Text.Pandoc.Filter (Filter (LuaFilter), applyFilters) -import Text.Pandoc.Lua (Global (..), runLua, setGlobals) -import Text.Pandoc.Options (def) -import Text.Pandoc.Shared (pandocVersion) - -import qualified Control.Monad.Catch as Catch -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE - -tests :: [TestTree] -tests = - [ testCase "macro expansion via filter" $ - assertFilterConversion "a '{{helloworld}}' string is expanded" - "strmacro.lua" - (doc . para $ str "{{helloworld}}") - (doc . para . emph $ str "Hello, World") - - , testCase "convert all plains to paras" $ - assertFilterConversion "plains become para" - "plain-to-para.lua" - (doc $ bulletList [plain (str "alfa"), plain (str "bravo")]) - (doc $ bulletList [para (str "alfa"), para (str "bravo")]) - - , testCase "convert display math to inline math" $ - assertFilterConversion "display math becomes inline math" - "math.lua" - (doc $ para (displayMath "5+5")) - (doc $ para (math "5+5")) - - , testCase "make hello world document" $ - assertFilterConversion "Document contains 'Hello, World!'" - "hello-world-doc.lua" - (doc . para $ str "Hey!" <> linebreak <> str "What's up?") - (doc . para $ str "Hello," <> space <> str "World!") - - , testCase "implicit doc filter" $ - assertFilterConversion "Document contains 'Hello, World!'" - "implicit-doc-filter.lua" - (doc . plain $ linebreak) - (doc . para $ str "Hello," <> space <> str "World!") - - , testCase "parse raw markdown blocks" $ - assertFilterConversion "raw markdown block is converted" - "markdown-reader.lua" - (doc $ rawBlock "markdown" "*charly* **delta**") - (doc . para $ emph "charly" <> space <> strong "delta") - - , testCase "allow shorthand functions for quote types" $ - assertFilterConversion "single quoted becomes double quoted string" - "single-to-double-quoted.lua" - (doc . para . singleQuoted $ str "simple") - (doc . para . doubleQuoted $ str "simple") - - , testCase "Count inlines via metatable catch-all" $ - assertFilterConversion "filtering with metatable catch-all failed" - "metatable-catch-all.lua" - (doc . para $ "four words, three spaces") - (doc . para $ str "7") - - , testCase "Count blocks via Block-specific catch-all" $ - assertFilterConversion "filtering with Block catch-all failed" - "block-count.lua" - (doc $ para "one" <> para "two") - (doc $ para "2") - - , testCase "Smart constructors" $ - assertFilterConversion "smart constructors returned a wrong result" - "smart-constructors.lua" - (doc $ para "") - (doc $ mconcat - [ bulletList [para "Hello", para "World"] - , definitionList [("foo", [para "placeholder"])] - , lineBlock ["Moin", "Welt"] - , orderedList [plain "one", plain "two"] - ]) - - , testCase "Convert header upper case" $ - assertFilterConversion "converting header to upper case failed" - "uppercase-header.lua" - (doc $ header 1 "les états-unis" <> para "text") - (doc $ header 1 "LES ÉTATS-UNIS" <> para "text") - - , testCase "Attribute lists are convenient to use" $ - let kv_before = [("one", "1"), ("two", "2"), ("three", "3")] - kv_after = [("one", "eins"), ("three", "3"), ("five", "5")] - in assertFilterConversion "Attr doesn't behave as expected" - "attr-test.lua" - (doc $ divWith ("", [], kv_before) (para "nil")) - (doc $ divWith ("", [], kv_after) (para "nil")) - - , testCase "Filter list of inlines" $ - assertFilterConversion "List of inlines" - "inlines-filter.lua" - (doc $ para ("Hello," <> linebreak <> "World! Wassup?")) - (doc $ para "Hello, World! Wassup?") - - , testCase "Filter list of blocks" $ - assertFilterConversion "List of blocks" - "blocks-filter.lua" - (doc $ para "one." <> para "two." <> para "three.") - (doc $ plain "3") - - , testCase "Filter Meta" $ - let setMetaBefore = setMeta "old" ("old" :: T.Text) - . setMeta "bool" False - setMetaAfter = setMeta "new" ("new" :: T.Text) - . setMeta "bool" True - in assertFilterConversion "Meta filtering" - "meta.lua" - (setMetaBefore . doc $ mempty) - (setMetaAfter . doc $ mempty) - - , testCase "Script filename is set" $ - assertFilterConversion "unexpected script name" - "script-name.lua" - (doc $ para "ignored") - (doc $ para (str $ T.pack $ "lua" </> "script-name.lua")) - - , testCase "Pandoc version is set" . runLuaTest $ do - Lua.getglobal "PANDOC_VERSION" - Lua.liftIO . - assertEqual "pandoc version is wrong" (TE.encodeUtf8 pandocVersion) - =<< Lua.tostring' Lua.top - - , testCase "Pandoc types version is set" . runLuaTest $ do - Lua.getglobal "PANDOC_API_VERSION" - Lua.liftIO . assertEqual "pandoc-types version is wrong" pandocTypesVersion - =<< Lua.peek Lua.top - - , testCase "require file" $ - assertFilterConversion "requiring file failed" - "require-file.lua" - (doc $ para "ignored") - (doc $ para (str . T.pack $ "lua" </> "require-file.lua")) - - , testCase "Allow singleton inline in constructors" . runLuaTest $ do - Lua.liftIO . assertEqual "Not the expected Emph" - (Emph [Str "test"]) =<< do - Lua.OK <- Lua.dostring "return pandoc.Emph" - Lua.push @Inline (Str "test") - Lua.call 1 1 - Lua.peek @Inline top - Lua.liftIO . assertEqual "Unexpected element" - (Para [Str "test"]) =<< do - Lua.getglobal' "pandoc.Para" - Lua.pushString "test" - Lua.call 1 1 - Lua.peek @Block top - 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 @Block Lua.top - ) - - , testCase "Elements with Attr have `attr` accessor" . runLuaTest $ do - Lua.push (Div ("hi", ["moin"], []) - [Para [Str "ignored"]]) - Lua.getfield Lua.top "attr" - Lua.liftIO . assertEqual "no accessor" (("hi", ["moin"], []) :: Attr) - =<< Lua.peek @Attr Lua.top - - , testCase "module `pandoc.system` is present" . runLuaTest $ do - Lua.getglobal' "pandoc.system" - ty <- Lua.ltype Lua.top - Lua.liftIO $ assertEqual "module should be a table" Lua.TypeTable ty - - , testGroup "global modules" - [ testCase "module 'lpeg' is loaded into a global" . runLuaTest $ do - s <- Lua.dostring "assert(type(lpeg)=='table')" - Lua.liftIO $ Lua.OK @=? s - - , testCase "module 're' is loaded into a global" . runLuaTest $ do - s <- Lua.dostring "assert(type(re)=='table')" - Lua.liftIO $ Lua.OK @=? s - - , testCase "module 'lpeg' is available via `require`" . runLuaTest $ do - s <- Lua.dostring - "package.path = ''; package.cpath = ''; require 'lpeg'" - Lua.liftIO $ Lua.OK @=? s - - , testCase "module 're' is available via `require`" . runLuaTest $ do - s <- Lua.dostring - "package.path = ''; package.cpath = ''; require 're'" - Lua.liftIO $ Lua.OK @=? s - ] - - , testCase "informative error messages" . runLuaTest $ do - Lua.pushboolean True - -- Lua.newtable - eitherPandoc <- Catch.try (peek @Pandoc Lua.top) - case eitherPandoc of - Left (PandocLuaError msg) -> do - let expectedMsg = "Pandoc expected, got boolean\n" - <> "\twhile retrieving Pandoc" - Lua.liftIO $ assertEqual "unexpected error message" expectedMsg msg - Left e -> error ("Expected a Lua error, but got " <> show e) - Right _ -> error "Getting a Pandoc element from a bool should fail." - ] - -assertFilterConversion :: String -> FilePath -> Pandoc -> Pandoc -> Assertion -assertFilterConversion msg filterPath docIn expectedDoc = do - actualDoc <- runIOorExplode $ do - setUserDataDir (Just "../data") - applyFilters def [LuaFilter ("lua" </> filterPath)] ["HTML"] docIn - assertEqual msg expectedDoc actualDoc - -runLuaTest :: HasCallStack => Lua.LuaE PandocError a -> IO a -runLuaTest op = runIOorExplode $ do - res <- runLua $ do - setGlobals [ PANDOC_WRITER_OPTIONS def ] - op - case res of - Left e -> error (show e) - Right x -> return x diff --git a/test/Tests/Lua/Module.hs b/test/Tests/Lua/Module.hs deleted file mode 100644 --- a/test/Tests/Lua/Module.hs +++ /dev/null @@ -1,41 +0,0 @@ -{- | -Module : Tests.Lua.Module -Copyright : © 2019-2022 Albert Krewinkel -License : GNU GPL, version 2 or above - -Maintainer : Albert Krewinkel <albert@zeitkraut.de> -Stability : alpha -Portability : portable - -Lua module tests --} -module Tests.Lua.Module (tests) where - -import System.FilePath ((</>)) -import Test.Tasty (TestName, TestTree) -import Test.Tasty.Lua (testLuaFile) - -import Tests.Lua (runLuaTest) - -tests :: [TestTree] -tests = - [ testPandocLua "pandoc" - ("lua" </> "module" </> "pandoc.lua") - , testPandocLua "pandoc.List" - ("lua" </> "module" </> "pandoc-list.lua") - , testPandocLua "pandoc.mediabag" - ("lua" </> "module" </> "pandoc-mediabag.lua") - , testPandocLua "pandoc.path" - ("lua" </> "module" </> "pandoc-path.lua") - , testPandocLua "pandoc.template" - ("lua" </> "module" </> "pandoc-template.lua") - , testPandocLua "pandoc.types" - ("lua" </> "module" </> "pandoc-types.lua") - , testPandocLua "pandoc.utils" - ("lua" </> "module" </> "pandoc-utils.lua") - , testPandocLua "globals" - ("lua" </> "module" </> "globals.lua") - ] - -testPandocLua :: TestName -> FilePath -> TestTree -testPandocLua = testLuaFile runLuaTest diff --git a/test/Tests/Old.hs b/test/Tests/Old.hs --- a/test/Tests/Old.hs +++ b/test/Tests/Old.hs @@ -1,6 +1,6 @@ {- | Module : Tests.Old - Copyright : © 2006-2022 John MacFarlane + Copyright : © 2006-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley@edu> @@ -128,7 +128,10 @@ , fb2WriterTest' "testsuite" [] "testsuite.native" "writer.fb2" ] , testGroup "mediawiki" - [ testGroup "writer" $ writerTests' "mediawiki" + [ testGroup "writer" $ mconcat [ + writerTests' "mediawiki" + , extWriterTests' "mediawiki" + ] , test' "reader" ["-r", "mediawiki", "-w", "native", "-s"] "mediawiki-reader.wiki" "mediawiki-reader.native" ] @@ -193,12 +196,6 @@ , testGroup "creole" [ test' "reader" ["-r", "creole", "-w", "native", "-s"] "creole-reader.txt" "creole-reader.native" - ] - , testGroup "custom writer" - [ test' "basic" ["-f", "native", "-t", "../data/sample.lua"] - "testsuite.native" "writer.custom" - , test' "tables" ["-f", "native", "-t", "../data/sample.lua"] - "tables.native" "tables.custom" ] , testGroup "man" [ test' "reader" ["-r", "man", "-w", "native", "-s"] diff --git a/test/Tests/Readers/Creole.hs b/test/Tests/Readers/Creole.hs --- a/test/Tests/Readers/Creole.hs +++ b/test/Tests/Readers/Creole.hs @@ -2,7 +2,7 @@ {- | Module : Tests.Readers.Creole Copyright : © 2017 Sascha Wilde - 2017-2022 John MacFarlane + 2017-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : Sascha Wilde <wilde@sha-bang.de> diff --git a/test/Tests/Readers/EPUB.hs b/test/Tests/Readers/EPUB.hs --- a/test/Tests/Readers/EPUB.hs +++ b/test/Tests/Readers/EPUB.hs @@ -1,6 +1,6 @@ {- | Module : Tests.Readers.EPUB - Copyright : © 2006-2022 John MacFarlane + Copyright : © 2006-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.eu> diff --git a/test/Tests/Readers/HTML.hs b/test/Tests/Readers/HTML.hs --- a/test/Tests/Readers/HTML.hs +++ b/test/Tests/Readers/HTML.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Tests.Readers.HTML - Copyright : © 2006-2022 John MacFarlane + Copyright : © 2006-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> @@ -97,6 +97,18 @@ doc (para (text "hello") <> divWith ("", [], [("role", "main")]) (plain (text "main content"))) , test htmlNativeDivs "<main> followed by text" $ "<main>main content</main>non-main content" =?> doc (divWith ("", [], [("role", "main")]) (plain (text "main content")) <> plain (text "non-main content")) + ] + , testGroup "code" + [ + test html "inline code block" $ + "<code>Answer is 42</code>" =?> + plain (codeWith ("",[],[]) "Answer is 42") + ] + , testGroup "tt" + [ + test html "inline tt block" $ + "<tt>Answer is 42</tt>" =?> + plain (codeWith ("",[],[]) "Answer is 42") ] , testGroup "samp" [ diff --git a/test/Tests/Readers/Jira.hs b/test/Tests/Readers/Jira.hs --- a/test/Tests/Readers/Jira.hs +++ b/test/Tests/Readers/Jira.hs @@ -2,7 +2,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {- | Module : Tests.Readers.Jira - Copyright : © 2019-2022 Albert Krewinel + Copyright : © 2019-2023 Albert Krewinel License : GNU GPL, version 2 or above Maintainer : Albert Krewinkel <tarleb@zeitkraut.de> diff --git a/test/Tests/Readers/LaTeX.hs b/test/Tests/Readers/LaTeX.hs --- a/test/Tests/Readers/LaTeX.hs +++ b/test/Tests/Readers/LaTeX.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Tests.Readers.LaTeX - Copyright : © 2006-2022 John MacFarlane + Copyright : © 2006-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> diff --git a/test/Tests/Readers/Man.hs b/test/Tests/Readers/Man.hs --- a/test/Tests/Readers/Man.hs +++ b/test/Tests/Readers/Man.hs @@ -2,7 +2,7 @@ {- | Module : Tests.Readers.Man Copyright : © 2018-2019 Yan Pas <yanp.bugz@gmail.com>, - 2018-2022 John MacFarlane + 2018-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> diff --git a/test/Tests/Readers/Markdown.hs b/test/Tests/Readers/Markdown.hs --- a/test/Tests/Readers/Markdown.hs +++ b/test/Tests/Readers/Markdown.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Tests.Readers.Markdown - Copyright : © 2006-2022 John MacFarlane + Copyright : © 2006-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> @@ -34,8 +34,8 @@ Ext_compact_definition_lists pandocExtensions } markdownGH :: Text -> Pandoc -markdownGH = purely $ readMarkdown def { - readerExtensions = githubMarkdownExtensions } +markdownGH = purely $ readMarkdown def {readerExtensions = enableExtension + Ext_wikilinks_title_before_pipe githubMarkdownExtensions } markdownMMD :: Text -> Pandoc markdownMMD = purely $ readMarkdown def { @@ -308,6 +308,26 @@ , "no bare URI inside link" =: "[https://example.org(](url)" =?> para (link "url" "" (text "https://example.org(")) + ] + , testGroup "Github wiki links" + [ test markdownGH "autolink" $ + "[[https://example.org]]" =?> + para (link "https://example.org" "wikilink" (str "https://example.org")) + , test markdownGH "link with title" $ + "[[title|https://example.org]]" =?> + para (link "https://example.org" "wikilink" (str "title")) + , test markdownGH "bad link with title" $ + "[[title|random string]]" =?> + para (link "random string" "wikilink" (str "title")) + , test markdownGH "autolink not being a link" $ + "[[Name of page]]" =?> + para (link "Name of page" "wikilink" (str "Name of page")) + , test markdownGH "autolink not being a link with a square bracket" $ + "[[Name of ]page]]" =?> + para (link "Name of ]page" "wikilink" (str "Name of ]page")) + , test markdownGH "link with inline start should be a link" $ + "[[t`i*t_le|https://example.org]]" =?> + para (link "https://example.org" "wikilink" (str "t`i*t_le")) ] , testGroup "Headers" [ "blank line before header" =: diff --git a/test/Tests/Readers/ODT.hs b/test/Tests/Readers/ODT.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Readers/ODT.hs @@ -0,0 +1,187 @@ +{-# LANGUAGE OverloadedStrings #-} +{- | + Module : Tests.Readers.ODT + Copyright : © 2015-2023 John MacFarlane + 2015 Martin Linnemann + License : GNU GPL, version 2 or above + + Maintainer : John MacFarlane <jgm@berkeley.edu> + Stability : alpha + Portability : portable + +Tests for the ODT reader. +-} +module Tests.Readers.ODT (tests) where + +import Control.Monad (liftM) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as B +import qualified Data.Map as M +import Data.Text (unpack) +import System.IO.Unsafe (unsafePerformIO) +import Test.Tasty +import Tests.Helpers +import Text.Pandoc +import qualified Text.Pandoc.UTF8 as UTF8 + +defopts :: ReaderOptions +defopts = def{ readerExtensions = getDefaultExtensions "odt" } + +tests :: [TestTree] +tests = testsComparingToMarkdown ++ testsComparingToNative + +testsComparingToMarkdown :: [TestTree] +testsComparingToMarkdown = map nameToTest namesOfTestsComparingToMarkdown + where nameToTest name = createTest + compareODTToMarkdown + name + (toODTPath name) + (toMarkdownPath name) + toODTPath name = "odt/odt/" ++ name ++ ".odt" + toMarkdownPath name = "odt/markdown/" ++ name ++ ".md" + +testsComparingToNative :: [TestTree] +testsComparingToNative = map nameToTest namesOfTestsComparingToNative + where nameToTest name = createTest + compareODTToNative + name + (toODTPath name) + (toNativePath name) + toODTPath name = "odt/odt/" ++ name ++ ".odt" + toNativePath name = "odt/native/" ++ name ++ ".native" + + +newtype NoNormPandoc = NoNormPandoc {unNoNorm :: Pandoc} + deriving ( Show ) + +instance ToString NoNormPandoc where + toString d = unpack $ + purely (writeNative def{ writerTemplate = s }) $ toPandoc d + where s = case d of + NoNormPandoc (Pandoc (Meta m) _) + | M.null m -> Nothing + | otherwise -> Just mempty -- need this for Meta output + +instance ToPandoc NoNormPandoc where + toPandoc = unNoNorm + +getNoNormVia :: (a -> Pandoc) -> String -> Either PandocError a -> NoNormPandoc +getNoNormVia _ readerName (Left _) = error (readerName ++ " reader failed") +getNoNormVia f _ (Right a) = NoNormPandoc (f a) + +type TestCreator = ReaderOptions + -> FilePath -> FilePath + -> IO (NoNormPandoc, NoNormPandoc) + +compareODTToNative :: TestCreator +compareODTToNative opts odtPath nativePath = do + nativeFile <- UTF8.toText <$> BS.readFile nativePath + odtFile <- B.readFile odtPath + native <- getNoNormVia id "native" <$> runIO (readNative def nativeFile) + odt <- getNoNormVia id "odt" <$> runIO (readODT opts odtFile) + return (odt,native) + +compareODTToMarkdown :: TestCreator +compareODTToMarkdown opts odtPath markdownPath = do + markdownFile <- UTF8.toText <$> BS.readFile markdownPath + odtFile <- B.readFile odtPath + markdown <- getNoNormVia id "markdown" <$> + runIO (readMarkdown def{ readerExtensions = pandocExtensions } + markdownFile) + odt <- getNoNormVia id "odt" <$> runIO (readODT opts odtFile) + return (odt,markdown) + + +createTest :: TestCreator + -> TestName + -> FilePath -> FilePath + -> TestTree +createTest creator name path1 path2 = + unsafePerformIO $ liftM (test id name) (creator defopts path1 path2) + +{- +-- + +getMedia :: FilePath -> FilePath -> IO (Maybe B.ByteString) +getMedia archivePath mediaPath = do + zf <- B.readFile archivePath >>= return . toArchive + return $ findEntryByPath ("Pictures/" ++ mediaPath) zf >>= (Just . fromEntry) + +compareMediaPathIO :: FilePath -> MediaBag -> FilePath -> IO Bool +compareMediaPathIO mediaPath mediaBag odtPath = do + odtMedia <- getMedia odtPath mediaPath + let mbBS = case lookupMedia mediaPath mediaBag of + Just (_, bs) -> bs + Nothing -> error ("couldn't find " ++ + mediaPath ++ + " in media bag") + odtBS = case odtMedia of + Just bs -> bs + Nothing -> error ("couldn't find " ++ + mediaPath ++ + " in media bag") + return $ mbBS == odtBS + +compareMediaBagIO :: FilePath -> IO Bool +compareMediaBagIO odtFile = do + df <- B.readFile odtFile + let (_, mb) = readODT def df + bools <- mapM + (\(fp, _, _) -> compareMediaPathIO fp mb odtFile) + (mediaDirectory mb) + return $ and bools + +testMediaBagIO :: String -> FilePath -> IO TestTree +testMediaBagIO name odtFile = do + outcome <- compareMediaBagIO odtFile + return $ testCase name (assertBool + ("Media didn't match media bag in file " ++ odtFile) + outcome) + +testMediaBag :: String -> FilePath -> TestTree +testMediaBag name odtFile = buildTest $ testMediaBagIO name odtFile +-} +-- + + + +namesOfTestsComparingToMarkdown :: [ String ] +namesOfTestsComparingToMarkdown = [ "bold" +-- , "citation" + , "endnote" + , "externalLink" + , "footnote" + , "formula" + , "headers" +-- , "horizontalRule" + , "italic" +-- , "listBlocks" + , "paragraph" + , "strikeout" +-- , "trackedChanges" + , "underlined" + ] + +namesOfTestsComparingToNative :: [ String ] +namesOfTestsComparingToNative = [ "blockquote" + , "image" + , "imageIndex" + , "imageWithCaption" + , "inlinedCode" + , "orderedListMixed" + , "orderedListRoman" + , "orderedListSimple" + , "orderedListHeader" + , "referenceToChapter" + , "referenceToListItem" + , "referenceToText" + , "simpleTable" + , "simpleTableWithCaption" + , "tab" +-- , "table" + , "textMixedStyles" + , "tableWithContents" + , "unicode" + , "unorderedList" + , "unorderedListHeader" + ] diff --git a/test/Tests/Readers/Odt.hs b/test/Tests/Readers/Odt.hs deleted file mode 100644 --- a/test/Tests/Readers/Odt.hs +++ /dev/null @@ -1,187 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{- | - Module : Tests.Readers.Odt - Copyright : © 2015-2022 John MacFarlane - 2015 Martin Linnemann - License : GNU GPL, version 2 or above - - Maintainer : John MacFarlane <jgm@berkeley.edu> - Stability : alpha - Portability : portable - -Tests for the ODT reader. --} -module Tests.Readers.Odt (tests) where - -import Control.Monad (liftM) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as B -import qualified Data.Map as M -import Data.Text (unpack) -import System.IO.Unsafe (unsafePerformIO) -import Test.Tasty -import Tests.Helpers -import Text.Pandoc -import qualified Text.Pandoc.UTF8 as UTF8 - -defopts :: ReaderOptions -defopts = def{ readerExtensions = getDefaultExtensions "odt" } - -tests :: [TestTree] -tests = testsComparingToMarkdown ++ testsComparingToNative - -testsComparingToMarkdown :: [TestTree] -testsComparingToMarkdown = map nameToTest namesOfTestsComparingToMarkdown - where nameToTest name = createTest - compareOdtToMarkdown - name - (toOdtPath name) - (toMarkdownPath name) - toOdtPath name = "odt/odt/" ++ name ++ ".odt" - toMarkdownPath name = "odt/markdown/" ++ name ++ ".md" - -testsComparingToNative :: [TestTree] -testsComparingToNative = map nameToTest namesOfTestsComparingToNative - where nameToTest name = createTest - compareOdtToNative - name - (toOdtPath name) - (toNativePath name) - toOdtPath name = "odt/odt/" ++ name ++ ".odt" - toNativePath name = "odt/native/" ++ name ++ ".native" - - -newtype NoNormPandoc = NoNormPandoc {unNoNorm :: Pandoc} - deriving ( Show ) - -instance ToString NoNormPandoc where - toString d = unpack $ - purely (writeNative def{ writerTemplate = s }) $ toPandoc d - where s = case d of - NoNormPandoc (Pandoc (Meta m) _) - | M.null m -> Nothing - | otherwise -> Just mempty -- need this for Meta output - -instance ToPandoc NoNormPandoc where - toPandoc = unNoNorm - -getNoNormVia :: (a -> Pandoc) -> String -> Either PandocError a -> NoNormPandoc -getNoNormVia _ readerName (Left _) = error (readerName ++ " reader failed") -getNoNormVia f _ (Right a) = NoNormPandoc (f a) - -type TestCreator = ReaderOptions - -> FilePath -> FilePath - -> IO (NoNormPandoc, NoNormPandoc) - -compareOdtToNative :: TestCreator -compareOdtToNative opts odtPath nativePath = do - nativeFile <- UTF8.toText <$> BS.readFile nativePath - odtFile <- B.readFile odtPath - native <- getNoNormVia id "native" <$> runIO (readNative def nativeFile) - odt <- getNoNormVia id "odt" <$> runIO (readOdt opts odtFile) - return (odt,native) - -compareOdtToMarkdown :: TestCreator -compareOdtToMarkdown opts odtPath markdownPath = do - markdownFile <- UTF8.toText <$> BS.readFile markdownPath - odtFile <- B.readFile odtPath - markdown <- getNoNormVia id "markdown" <$> - runIO (readMarkdown def{ readerExtensions = pandocExtensions } - markdownFile) - odt <- getNoNormVia id "odt" <$> runIO (readOdt opts odtFile) - return (odt,markdown) - - -createTest :: TestCreator - -> TestName - -> FilePath -> FilePath - -> TestTree -createTest creator name path1 path2 = - unsafePerformIO $ liftM (test id name) (creator defopts path1 path2) - -{- --- - -getMedia :: FilePath -> FilePath -> IO (Maybe B.ByteString) -getMedia archivePath mediaPath = do - zf <- B.readFile archivePath >>= return . toArchive - return $ findEntryByPath ("Pictures/" ++ mediaPath) zf >>= (Just . fromEntry) - -compareMediaPathIO :: FilePath -> MediaBag -> FilePath -> IO Bool -compareMediaPathIO mediaPath mediaBag odtPath = do - odtMedia <- getMedia odtPath mediaPath - let mbBS = case lookupMedia mediaPath mediaBag of - Just (_, bs) -> bs - Nothing -> error ("couldn't find " ++ - mediaPath ++ - " in media bag") - odtBS = case odtMedia of - Just bs -> bs - Nothing -> error ("couldn't find " ++ - mediaPath ++ - " in media bag") - return $ mbBS == odtBS - -compareMediaBagIO :: FilePath -> IO Bool -compareMediaBagIO odtFile = do - df <- B.readFile odtFile - let (_, mb) = readOdt def df - bools <- mapM - (\(fp, _, _) -> compareMediaPathIO fp mb odtFile) - (mediaDirectory mb) - return $ and bools - -testMediaBagIO :: String -> FilePath -> IO TestTree -testMediaBagIO name odtFile = do - outcome <- compareMediaBagIO odtFile - return $ testCase name (assertBool - ("Media didn't match media bag in file " ++ odtFile) - outcome) - -testMediaBag :: String -> FilePath -> TestTree -testMediaBag name odtFile = buildTest $ testMediaBagIO name odtFile --} --- - - - -namesOfTestsComparingToMarkdown :: [ String ] -namesOfTestsComparingToMarkdown = [ "bold" --- , "citation" - , "endnote" - , "externalLink" - , "footnote" - , "formula" - , "headers" --- , "horizontalRule" - , "italic" --- , "listBlocks" - , "paragraph" - , "strikeout" --- , "trackedChanges" - , "underlined" - ] - -namesOfTestsComparingToNative :: [ String ] -namesOfTestsComparingToNative = [ "blockquote" - , "image" - , "imageIndex" - , "imageWithCaption" - , "inlinedCode" - , "orderedListMixed" - , "orderedListRoman" - , "orderedListSimple" - , "orderedListHeader" - , "referenceToChapter" - , "referenceToListItem" - , "referenceToText" - , "simpleTable" - , "simpleTableWithCaption" - , "tab" --- , "table" - , "textMixedStyles" - , "tableWithContents" - , "unicode" - , "unorderedList" - , "unorderedListHeader" - ] diff --git a/test/Tests/Readers/Org.hs b/test/Tests/Readers/Org.hs --- a/test/Tests/Readers/Org.hs +++ b/test/Tests/Readers/Org.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Tests.Shared - Copyright : © 2014-2022 Albert Krewinkel + Copyright : © 2014-2023 Albert Krewinkel License : GNU GPL, version 2 or above Maintainer : Albert Krewinkel <albert@zeitkraut.de> diff --git a/test/Tests/Readers/Org/Block.hs b/test/Tests/Readers/Org/Block.hs --- a/test/Tests/Readers/Org/Block.hs +++ b/test/Tests/Readers/Org/Block.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Tests.Readers.Org.Block - Copyright : © 2014-2022 Albert Krewinkel + Copyright : © 2014-2023 Albert Krewinkel License : GNU GPL, version 2 or above Maintainer : Albert Krewinkel <albert@zeitkraut.de> diff --git a/test/Tests/Readers/Org/Block/CodeBlock.hs b/test/Tests/Readers/Org/Block/CodeBlock.hs --- a/test/Tests/Readers/Org/Block/CodeBlock.hs +++ b/test/Tests/Readers/Org/Block/CodeBlock.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Tests.Readers.Org.Block.CodeBlock - Copyright : © 2014-2022 Albert Krewinkel + Copyright : © 2014-2023 Albert Krewinkel License : GNU GPL, version 2 or above Maintainer : Albert Krewinkel <albert@zeitkraut.de> diff --git a/test/Tests/Readers/Org/Block/Figure.hs b/test/Tests/Readers/Org/Block/Figure.hs --- a/test/Tests/Readers/Org/Block/Figure.hs +++ b/test/Tests/Readers/Org/Block/Figure.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Tests.Readers.Org.Block.Figure - Copyright : © 2014-2022 Albert Krewinkel + Copyright : © 2014-2023 Albert Krewinkel License : GNU GPL, version 2 or above Maintainer : Albert Krewinkel <albert@zeitkraut.de> @@ -15,31 +15,34 @@ import Test.Tasty (TestTree) import Tests.Helpers ((=?>)) import Tests.Readers.Org.Shared ((=:)) -import Text.Pandoc.Builder (image, imageWith, para) +import Text.Pandoc.Builder ( emptyCaption, figure, figureWith, image + , plain, simpleCaption, simpleFigure ) import qualified Data.Text as T tests :: [TestTree] tests = [ "Figure" =: - T.unlines [ "#+caption: A very courageous man." - , "#+name: goodguy" + T.unlines [ "#+caption: A courageous man." + , "#+name: ed" , "[[file:edward.jpg]]" ] =?> - para (image "edward.jpg" "fig:goodguy" "A very courageous man.") + figure (plainCaption "A courageous man.") + (plain $ image "edward.jpg" "ed" "") , "Figure with no name" =: T.unlines [ "#+caption: I've been through the desert on this" , "[[file:horse.png]]" ] =?> - para (image "horse.png" "fig:" "I've been through the desert on this") + figure (plainCaption "I've been through the desert on this") + (plain $ image "horse.png" "" "") , "Figure with `fig:` prefix in name" =: T.unlines [ "#+caption: Used as a metapher in evolutionary biology." , "#+name: fig:redqueen" , "[[./the-red-queen.jpg]]" ] =?> - para (image "./the-red-queen.jpg" "fig:redqueen" - "Used as a metapher in evolutionary biology.") + figure (plainCaption "Used as a metapher in evolutionary biology.") + (plain $ image "./the-red-queen.jpg" "fig:redqueen" "") , "Figure with HTML attributes" =: T.unlines [ "#+caption: mah brain just explodid" @@ -48,28 +51,33 @@ , "[[file:lambdacat.jpg]]" ] =?> let kv = [("style", "color: blue"), ("role", "button")] - name = "fig:lambdacat" - caption = "mah brain just explodid" - in para (imageWith (mempty, mempty, kv) "lambdacat.jpg" name caption) + name = "lambdacat" + capt = plain "mah brain just explodid" + in figureWith (mempty, mempty, kv) (simpleCaption capt) + (plain $ image "lambdacat.jpg" name "") , "LaTeX attributes are ignored" =: T.unlines [ "#+caption: Attribute after caption" , "#+attr_latex: :float nil" , "[[file:test.png]]" ] =?> - para (image "test.png" "fig:" "Attribute after caption") + simpleFigure "Attribute after caption" + "test.png" "" , "Labelled figure" =: T.unlines [ "#+caption: My figure" , "#+label: fig:myfig" , "[[file:blub.png]]" ] =?> - let attr = ("fig:myfig", mempty, mempty) - in para (imageWith attr "blub.png" "fig:" "My figure") + figureWith ("fig:myfig", mempty, mempty) + (simpleCaption $ plain "My figure") + (plain (image "blub.png" "" "")) , "Figure with empty caption" =: T.unlines [ "#+caption:" , "[[file:guess.jpg]]" ] =?> - para (image "guess.jpg" "fig:" "") + figure emptyCaption (plain (image "guess.jpg" "" "")) ] + where + plainCaption = simpleCaption . plain diff --git a/test/Tests/Readers/Org/Block/Header.hs b/test/Tests/Readers/Org/Block/Header.hs --- a/test/Tests/Readers/Org/Block/Header.hs +++ b/test/Tests/Readers/Org/Block/Header.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Tests.Readers.Org.Block.Header - Copyright : © 2014-2022 Albert Krewinkel + Copyright : © 2014-2023 Albert Krewinkel License : GNU GPL, version 2 or above Maintainer : Albert Krewinkel <albert@zeitkraut.de> diff --git a/test/Tests/Readers/Org/Block/List.hs b/test/Tests/Readers/Org/Block/List.hs --- a/test/Tests/Readers/Org/Block/List.hs +++ b/test/Tests/Readers/Org/Block/List.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Tests.Readers.Org.Block.Header - Copyright : © 2014-2022 Albert Krewinkel + Copyright : © 2014-2023 Albert Krewinkel License : GNU GPL, version 2 or above Maintainer : Albert Krewinkel <albert@zeitkraut.de> diff --git a/test/Tests/Readers/Org/Block/Table.hs b/test/Tests/Readers/Org/Block/Table.hs --- a/test/Tests/Readers/Org/Block/Table.hs +++ b/test/Tests/Readers/Org/Block/Table.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Tests.Readers.Org.Block.Table - Copyright : © 2014-2022 Albert Krewinkel + Copyright : © 2014-2023 Albert Krewinkel License : GNU GPL, version 2 or above Maintainer : Albert Krewinkel <albert@zeitkraut.de> diff --git a/test/Tests/Readers/Org/Directive.hs b/test/Tests/Readers/Org/Directive.hs --- a/test/Tests/Readers/Org/Directive.hs +++ b/test/Tests/Readers/Org/Directive.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Tests.Readers.Org.Directive - Copyright : © 2014-2022 Albert Krewinkel + Copyright : © 2014-2023 Albert Krewinkel License : GNU GPL, version 2 or above Maintainer : Albert Krewinkel <albert@zeitkraut.de> diff --git a/test/Tests/Readers/Org/Inline.hs b/test/Tests/Readers/Org/Inline.hs --- a/test/Tests/Readers/Org/Inline.hs +++ b/test/Tests/Readers/Org/Inline.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Tests.Readers.Org.Inline - Copyright : © 2014-2022 Albert Krewinkel + Copyright : © 2014-2023 Albert Krewinkel License : GNU GPL, version 2 or above Maintainer : Albert Krewinkel <albert@zeitkraut.de> @@ -104,8 +104,10 @@ "[fn::Schreib mir eine E-Mail]" =?> para (note $ para "Schreib mir eine E-Mail") - , "Markup-chars not occurring on word break are symbols" =: - T.unlines [ "this+that+ +so+on" + , "By default, markup-chars not occurring on word break are symbols" =: + T.unlines [ "#+pandoc-emphasis-pre:" + , "#+pandoc-emphasis-post:" + , "this+that+ +so+on" , "seven*eight* nine*" , "+not+funny+" ] =?> diff --git a/test/Tests/Readers/Org/Inline/Citation.hs b/test/Tests/Readers/Org/Inline/Citation.hs --- a/test/Tests/Readers/Org/Inline/Citation.hs +++ b/test/Tests/Readers/Org/Inline/Citation.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Tests.Readers.Org.Inline.Citation - Copyright : © 2014-2022 Albert Krewinkel + Copyright : © 2014-2023 Albert Krewinkel License : GNU GPL, version 2 or above Maintainer : Albert Krewinkel <albert@zeitkraut.de> diff --git a/test/Tests/Readers/Org/Inline/Note.hs b/test/Tests/Readers/Org/Inline/Note.hs --- a/test/Tests/Readers/Org/Inline/Note.hs +++ b/test/Tests/Readers/Org/Inline/Note.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Tests.Readers.Org.Inline.Note - Copyright : © 2014-2022 Albert Krewinkel + Copyright : © 2014-2023 Albert Krewinkel License : GNU GPL, version 2 or above Maintainer : Albert Krewinkel <albert@zeitkraut.de> diff --git a/test/Tests/Readers/Org/Inline/Smart.hs b/test/Tests/Readers/Org/Inline/Smart.hs --- a/test/Tests/Readers/Org/Inline/Smart.hs +++ b/test/Tests/Readers/Org/Inline/Smart.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Tests.Readers.Org.Inline.Smart - Copyright : © 2014-2022 Albert Krewinkel + Copyright : © 2014-2023 Albert Krewinkel License : GNU GPL, version 2 or above Maintainer : Albert Krewinkel <albert@zeitkraut.de> diff --git a/test/Tests/Readers/Org/Meta.hs b/test/Tests/Readers/Org/Meta.hs --- a/test/Tests/Readers/Org/Meta.hs +++ b/test/Tests/Readers/Org/Meta.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Tests.Readers.Org.Meta - Copyright : © 2014-2022 Albert Krewinkel + Copyright : © 2014-2023 Albert Krewinkel License : GNU GPL, version 2 or above Maintainer : Albert Krewinkel <albert@zeitkraut.de> @@ -208,12 +208,19 @@ ] , testGroup "emphasis config" - [ "Changing pre and post chars for emphasis" =: - T.unlines [ "#+pandoc-emphasis-pre: \"[)\"" - , "#+pandoc-emphasis-post: \"]\\n\"" - , "([/emph/])*foo*" + [ "Changing pre chars for emphasis" =: + T.unlines [ "#+pandoc-emphasis-pre: \"[)$a1%\"" + , "[/emph/.)*strong*.a~code~" ] =?> - para ("([" <> emph "emph" <> "])" <> strong "foo") + para ("[" <> emph "emph" <> ".)" <> strong "strong" <> + ".a" <> code "code") + + , "Changing post chars for emphasis" =: + T.unlines [ "#+pandoc-emphasis-post: \"(]$a1%\"" + , "/emph/('*strong*]'~code~a" + ] =?> + para (emph "emph" <> "('" <> strong "strong" <> "]'" <> + code "code" <> "a") , "setting an invalid value restores the default" =: T.unlines [ "#+pandoc-emphasis-pre: \"[\"" diff --git a/test/Tests/Readers/Org/Shared.hs b/test/Tests/Readers/Org/Shared.hs --- a/test/Tests/Readers/Org/Shared.hs +++ b/test/Tests/Readers/Org/Shared.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Tests.Readers.Org.Shared - Copyright : © 2014-2022 Albert Krewinkel + Copyright : © 2014-2023 Albert Krewinkel License : GNU GPL, version 2 or above Maintainer : Albert Krewinkel <albert@zeitkraut.de> diff --git a/test/Tests/Readers/RST.hs b/test/Tests/Readers/RST.hs --- a/test/Tests/Readers/RST.hs +++ b/test/Tests/Readers/RST.hs @@ -2,7 +2,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {- | Module : Tests.Readers.RST - Copyright : © 2006-2022 John MacFarlane + Copyright : © 2006-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> diff --git a/test/Tests/Readers/RTF.hs b/test/Tests/Readers/RTF.hs --- a/test/Tests/Readers/RTF.hs +++ b/test/Tests/Readers/RTF.hs @@ -1,6 +1,6 @@ {- | Module : Tests.Readers.RTF - Copyright : © 2021-2022 John MacFarlane + Copyright : © 2021-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : jgm@berkeley.edu @@ -39,4 +39,3 @@ , "table_simple" , "table_error_codes" ] - diff --git a/test/Tests/Readers/Txt2Tags.hs b/test/Tests/Readers/Txt2Tags.hs --- a/test/Tests/Readers/Txt2Tags.hs +++ b/test/Tests/Readers/Txt2Tags.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Tests.Readers.Txt2Tags - Copyright : © 2014-2022 John MacFarlane, + Copyright : © 2014-2023 John MacFarlane, © 2014 Matthew Pickering License : GNU GPL, version 2 or above diff --git a/test/Tests/Shared.hs b/test/Tests/Shared.hs --- a/test/Tests/Shared.hs +++ b/test/Tests/Shared.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Tests.Shared - Copyright : © 2006-2022 John MacFarlane + Copyright : © 2006-2023 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley@edu> @@ -73,11 +73,11 @@ bulletList [plain "H1a" <> bulletList [plain "H2"]] , givesTOC "only referenced headers" $ header 1 "H1a" <> headerId "h2" 2 "H2" =?> - bulletList [plain "H1a" <> + bulletList [plain "H1a" <> bulletList [plain $ linkId "toc-h2" "#h2" "" "H2"]] , givesTOC "section id used as backup" $ divWith ("sec",["section"],[]) (header 1 "H1") =?> - bulletList [plain $ linkId "toc-sec" "#sec" "" "H1"] + bulletList [plain $ linkId "toc-sec" "#sec" "" "H1"] ] testCollapse :: [TestTree] diff --git a/test/Tests/Writers/AsciiDoc.hs b/test/Tests/Writers/AsciiDoc.hs --- a/test/Tests/Writers/AsciiDoc.hs +++ b/test/Tests/Writers/AsciiDoc.hs @@ -93,4 +93,3 @@ ] ] ] - diff --git a/test/Tests/Writers/ConTeXt.hs b/test/Tests/Writers/ConTeXt.hs --- a/test/Tests/Writers/ConTeXt.hs +++ b/test/Tests/Writers/ConTeXt.hs @@ -9,6 +9,7 @@ import Text.Pandoc import Text.Pandoc.Arbitrary () import Text.Pandoc.Builder +import qualified Data.Text as T context :: (ToPandoc a) => a -> String context = unpack . purely (writeConTeXt def) . toPandoc @@ -44,16 +45,17 @@ tests :: [TestTree] tests = [ testGroup "inline code" - [ "with '}'" =: code "}" =?> "\\mono{\\}}" + [ "with '}'" =: code "}" =?> "\\type\"}\"" , "without '}'" =: code "]" =?> "\\type{]}" , "span with ID" =: spanWith ("city", [], []) "Berlin" =?> "\\reference[city]{}Berlin" - , testProperty "code property" $ \s -> null s || '\n' `elem` s || - if '{' `elem` s || '}' `elem` s - then context' (code $ pack s) == "\\mono{" ++ - context' (str $ pack s) ++ "}" - else context' (code $ pack s) == "\\type{" ++ s ++ "}" + , testProperty "code property" $ \s -> + null s || '\n' `elem` s || + case T.stripPrefix "\\type" (pack $ context' (code $ pack s)) + >>= T.uncons of + Just (c, _) -> c `notElem` s + Nothing -> False ] , testGroup "headers" [ "level 1" =: diff --git a/test/Tests/Writers/DocBook.hs b/test/Tests/Writers/DocBook.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Writers/DocBook.hs @@ -0,0 +1,431 @@ +{-# LANGUAGE OverloadedStrings #-} +module Tests.Writers.DocBook (tests) where + +import Data.Text (unpack) +import Test.Tasty +import Tests.Helpers +import Text.Pandoc +import Text.Pandoc.Arbitrary () +import Text.Pandoc.Builder + +docbook :: (ToPandoc a) => a -> String +docbook = docbookWithOpts def{ writerWrapText = WrapNone } + +docbook5 :: (ToPandoc a) => a -> String +docbook5 = docbook5WithOpts def{ writerWrapText = WrapNone } + +docbookWithOpts :: ToPandoc a => WriterOptions -> a -> String +docbookWithOpts opts = unpack . purely (writeDocBook4 opts) . toPandoc + +docbook5WithOpts :: ToPandoc a => WriterOptions -> a -> String +docbook5WithOpts opts = unpack . purely (writeDocBook5 opts) . toPandoc +{- + "my test" =: X =?> Y + +is shorthand for + + test docbook "my test" $ X =?> Y + +which is in turn shorthand for + + test docbook "my test" (X,Y) +-} + +infix 4 =: +(=:), testDb4, testDb5 :: (ToString a, ToPandoc a) + => String -> (a, String) -> TestTree +(=:) = test docbook +testDb4 = test docbook +testDb5 = test docbook5 + +lineblock :: Blocks +lineblock = para ("some text" <> linebreak <> + "and more lines" <> linebreak <> + "and again") +lineblock_out :: [String] +lineblock_out = [ "<literallayout>some text" + , "and more lines" + , "and again</literallayout>" + ] + +tests :: [TestTree] +tests = [ testGroup "inline elements" + [ testGroup "links" + [ testDb4 "db4 external link" $ link "https://example.com" "" "Hello" + =?> "<ulink url=\"https://example.com\">Hello</ulink>" + , testDb5 "db5 external link" $ link "https://example.com" "" "Hello" + =?> "<link xlink:href=\"https://example.com\">Hello</link>" + , testDb5 "anchor" $ link "#foo" "" "Hello" + =?> "<link linkend=\"foo\">Hello</link>" + , testDb5 "automatic anchor" $ link "#foo" "" "" + =?> "<xref linkend=\"foo\"></xref>" + ] + ] + , testGroup "line blocks" + [ "none" =: para "This is a test" + =?> unlines + [ "<para>" + , " This is a test" + , "</para>" + ] + , "basic" =: lineblock + =?> unlines lineblock_out + , "blockquote" =: blockQuote lineblock + =?> unlines + ( [ "<blockquote>" ] ++ + lineblock_out ++ + [ "</blockquote>" ] + ) + , "footnote" =: para ("This is a test" <> + note lineblock <> + " of footnotes") + =?> unlines + ( [ "<para>" + , " This is a test<footnote>" ] ++ + lineblock_out ++ + [ " </footnote> of footnotes" + , "</para>" ] + ) + ] + , testGroup "divs" + [ "admonition" =: divWith ("foo", ["warning"], []) (para "This is a test") + =?> unlines + [ "<warning id=\"foo\">" + , " <para>" + , " This is a test" + , " </para>" + , "</warning>" + ] + , "admonition-with-title" =: + divWith ("foo", ["note"], []) ( + divWith ("foo", ["title"], []) + (plain (text "This is title")) <> + para "This is a test" + ) + =?> unlines + [ "<note id=\"foo\">" + , " <title>This is title" + , " " + , " This is a test" + , " " + , "" + ] + , "admonition-with-title-in-para" =: + divWith ("foo", ["note"], []) ( + divWith ("foo", ["title"], []) + (para "This is title") <> + para "This is a test" + ) + =?> unlines + [ "" + , " This is title" + , " " + , " This is a test" + , " " + , "" + ] + , "single-child" =: + divWith ("foo", [], []) (para "This is a test") + =?> unlines + [ "" + , " This is a test" + , "" + ] + , "single-literal-child" =: + divWith ("foo", [], []) lineblock + =?> unlines + [ "some text" + , "and more lines" + , "and again" + ] + , "multiple-children" =: + divWith ("foo", [], []) ( + para "This is a test" <> + para "This is an another test" + ) + =?> unlines + [ "" + , "" + , " This is a test" + , "" + , "" + , " This is an another test" + , "" + ] + ] + , testGroup "compact lists" + [ testGroup "bullet" + [ "compact" =: bulletList [plain "a", plain "b", plain "c"] + =?> unlines + [ "" + , " " + , " " + , " a" + , " " + , " " + , " " + , " " + , " b" + , " " + , " " + , " " + , " " + , " c" + , " " + , " " + , "" + ] + , "loose" =: bulletList [para "a", para "b", para "c"] + =?> unlines + [ "" + , " " + , " " + , " a" + , " " + , " " + , " " + , " " + , " b" + , " " + , " " + , " " + , " " + , " c" + , " " + , " " + , "" + ] + ] + , testGroup "ordered" + [ "compact" =: orderedList [plain "a", plain "b", plain "c"] + =?> unlines + [ "" + , " " + , " " + , " a" + , " " + , " " + , " " + , " " + , " b" + , " " + , " " + , " " + , " " + , " c" + , " " + , " " + , "" + ] + , "loose" =: orderedList [para "a", para "b", para "c"] + =?> unlines + [ "" + , " " + , " " + , " a" + , " " + , " " + , " " + , " " + , " b" + , " " + , " " + , " " + , " " + , " c" + , " " + , " " + , "" + ] + ] + , testGroup "definition" + [ "compact" =: definitionList [ ("an", [plain "apple" ]) + , ("a", [plain "banana"]) + , ("an", [plain "orange"])] + =?> unlines + [ "" + , " " + , " " + , " an" + , " " + , " " + , " " + , " apple" + , " " + , " " + , " " + , " " + , " " + , " a" + , " " + , " " + , " " + , " banana" + , " " + , " " + , " " + , " " + , " " + , " an" + , " " + , " " + , " " + , " orange" + , " " + , " " + , " " + , "" + ] + , "loose" =: definitionList [ ("an", [para "apple" ]) + , ("a", [para "banana"]) + , ("an", [para "orange"])] + =?> unlines + [ "" + , " " + , " " + , " an" + , " " + , " " + , " " + , " apple" + , " " + , " " + , " " + , " " + , " " + , " a" + , " " + , " " + , " " + , " banana" + , " " + , " " + , " " + , " " + , " " + , " an" + , " " + , " " + , " " + , " orange" + , " " + , " " + , " " + , "" + ] + ] + ] + , testGroup "writer options" + [ testGroup "top-level division" $ + let + headers = header 1 (text "header1") + <> header 2 (text "header2") + <> header 3 (text "header3") + + docbookTopLevelDiv :: (ToPandoc a) + => TopLevelDivision -> a -> String + docbookTopLevelDiv division = + docbookWithOpts def{ writerTopLevelDivision = division } + in + [ test (docbookTopLevelDiv TopLevelSection) "sections as top-level" $ + headers =?> + unlines [ "" + , " header1" + , " " + , " header2" + , " " + , " header3" + , " " + , " " + , " " + , " " + , "" + ] + , test (docbookTopLevelDiv TopLevelChapter) "chapters as top-level" $ + headers =?> + unlines [ "" + , " header1" + , " " + , " header2" + , " " + , " header3" + , " " + , " " + , " " + , " " + , "" + ] + , test (docbookTopLevelDiv TopLevelPart) "parts as top-level" $ + headers =?> + unlines [ "" + , " header1" + , " " + , " header2" + , " " + , " header3" + , " " + , " " + , " " + , " " + , "" + ] + , test (docbookTopLevelDiv TopLevelDefault) "default top-level" $ + headers =?> + unlines [ "" + , " header1" + , " " + , " header2" + , " " + , " header3" + , " " + , " " + , " " + , " " + , "" + ] + ] + ] + , testGroup "section attributes" $ + let + headers = headerWith ("myid1",["unnumbered","ignored"],[("role","internal"),("xml:id","anotherid"),("dir","rtl")]) 1 "header1" + <> headerWith ("myid2",["unnumbered"],[("invalidname","value"),("arch","linux"),("dir","invaliddir")]) 1 "header2" + <> headerWith ("myid3",["ignored"],[]) 1 "header3" + in + [ test docbook5 "sections with attributes (db5)" $ + headers =?> + unlines [ "
" + , " header1" + , " " + , " " + , "
" + , "
" + , " header2" + , " " + , " " + , "
" + , "
" + , " header3" + , " " + , " " + , "
" + ] + , test docbook "sections with attributes (db4)" $ + headers =?> + unlines [ "" + , " header1" + , " " + , " " + , "" + , "" + , " header2" + , " " + , " " + , "" + , "" + , " header3" + , " " + , " " + , "" + ] + ] + ] diff --git a/test/Tests/Writers/Docbook.hs b/test/Tests/Writers/Docbook.hs deleted file mode 100644 --- a/test/Tests/Writers/Docbook.hs +++ /dev/null @@ -1,420 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Tests.Writers.Docbook (tests) where - -import Data.Text (unpack) -import Test.Tasty -import Tests.Helpers -import Text.Pandoc -import Text.Pandoc.Arbitrary () -import Text.Pandoc.Builder - -docbook :: (ToPandoc a) => a -> String -docbook = docbookWithOpts def{ writerWrapText = WrapNone } - -docbook5 :: (ToPandoc a) => a -> String -docbook5 = docbook5WithOpts def{ writerWrapText = WrapNone } - -docbookWithOpts :: ToPandoc a => WriterOptions -> a -> String -docbookWithOpts opts = unpack . purely (writeDocbook4 opts) . toPandoc - -docbook5WithOpts :: ToPandoc a => WriterOptions -> a -> String -docbook5WithOpts opts = unpack . purely (writeDocbook5 opts) . toPandoc -{- - "my test" =: X =?> Y - -is shorthand for - - test docbook "my test" $ X =?> Y - -which is in turn shorthand for - - test docbook "my test" (X,Y) --} - -infix 4 =: -(=:), testDb4, testDb5 :: (ToString a, ToPandoc a) - => String -> (a, String) -> TestTree -(=:) = test docbook -testDb4 = test docbook -testDb5 = test docbook5 - -lineblock :: Blocks -lineblock = para ("some text" <> linebreak <> - "and more lines" <> linebreak <> - "and again") -lineblock_out :: [String] -lineblock_out = [ "some text" - , "and more lines" - , "and again" - ] - -tests :: [TestTree] -tests = [ testGroup "inline elements" - [ testGroup "links" - [ testDb4 "db4 external link" $ link "https://example.com" "" "Hello" - =?> "Hello" - , testDb5 "db5 external link" $ link "https://example.com" "" "Hello" - =?> "Hello" - , testDb5 "anchor" $ link "#foo" "" "Hello" - =?> "Hello" - , testDb5 "automatic anchor" $ link "#foo" "" "" - =?> "" - ] - ] - , testGroup "line blocks" - [ "none" =: para "This is a test" - =?> unlines - [ "" - , " This is a test" - , "" - ] - , "basic" =: lineblock - =?> unlines lineblock_out - , "blockquote" =: blockQuote lineblock - =?> unlines - ( [ "
" ] ++ - lineblock_out ++ - [ "
" ] - ) - , "footnote" =: para ("This is a test" <> - note lineblock <> - " of footnotes") - =?> unlines - ( [ "" - , " This is a test" ] ++ - lineblock_out ++ - [ " of footnotes" - , "" ] - ) - ] - , testGroup "divs" - [ "admonition" =: divWith ("foo", ["warning"], []) (para "This is a test") - =?> unlines - [ "" - , " " - , " This is a test" - , " " - , "" - ] - , "admonition-with-title" =: - divWith ("foo", ["note"], []) ( - divWith ("foo", ["title"], []) - (plain (text "This is title")) <> - para "This is a test" - ) - =?> unlines - [ "" - , " This is title" - , " " - , " This is a test" - , " " - , "" - ] - , "admonition-with-title-in-para" =: - divWith ("foo", ["note"], []) ( - divWith ("foo", ["title"], []) - (para "This is title") <> - para "This is a test" - ) - =?> unlines - [ "" - , " This is title" - , " " - , " This is a test" - , " " - , "" - ] - , "single-child" =: - divWith ("foo", [], []) (para "This is a test") - =?> unlines - [ "" - , " This is a test" - , "" - ] - , "single-literal-child" =: - divWith ("foo", [], []) lineblock - =?> unlines - [ "some text" - , "and more lines" - , "and again" - ] - , "multiple-children" =: - divWith ("foo", [], []) ( - para "This is a test" <> - para "This is an another test" - ) - =?> unlines - [ "" - , "" - , " This is a test" - , "" - , "" - , " This is an another test" - , "" - ] - ] - , testGroup "compact lists" - [ testGroup "bullet" - [ "compact" =: bulletList [plain "a", plain "b", plain "c"] - =?> unlines - [ "" - , " " - , " " - , " a" - , " " - , " " - , " " - , " " - , " b" - , " " - , " " - , " " - , " " - , " c" - , " " - , " " - , "" - ] - , "loose" =: bulletList [para "a", para "b", para "c"] - =?> unlines - [ "" - , " " - , " " - , " a" - , " " - , " " - , " " - , " " - , " b" - , " " - , " " - , " " - , " " - , " c" - , " " - , " " - , "" - ] - ] - , testGroup "ordered" - [ "compact" =: orderedList [plain "a", plain "b", plain "c"] - =?> unlines - [ "" - , " " - , " " - , " a" - , " " - , " " - , " " - , " " - , " b" - , " " - , " " - , " " - , " " - , " c" - , " " - , " " - , "" - ] - , "loose" =: orderedList [para "a", para "b", para "c"] - =?> unlines - [ "" - , " " - , " " - , " a" - , " " - , " " - , " " - , " " - , " b" - , " " - , " " - , " " - , " " - , " c" - , " " - , " " - , "" - ] - ] - , testGroup "definition" - [ "compact" =: definitionList [ ("an", [plain "apple" ]) - , ("a", [plain "banana"]) - , ("an", [plain "orange"])] - =?> unlines - [ "" - , " " - , " " - , " an" - , " " - , " " - , " " - , " apple" - , " " - , " " - , " " - , " " - , " " - , " a" - , " " - , " " - , " " - , " banana" - , " " - , " " - , " " - , " " - , " " - , " an" - , " " - , " " - , " " - , " orange" - , " " - , " " - , " " - , "" - ] - , "loose" =: definitionList [ ("an", [para "apple" ]) - , ("a", [para "banana"]) - , ("an", [para "orange"])] - =?> unlines - [ "" - , " " - , " " - , " an" - , " " - , " " - , " " - , " apple" - , " " - , " " - , " " - , " " - , " " - , " a" - , " " - , " " - , " " - , " banana" - , " " - , " " - , " " - , " " - , " " - , " an" - , " " - , " " - , " " - , " orange" - , " " - , " " - , " " - , "" - ] - ] - ] - , testGroup "writer options" - [ testGroup "top-level division" $ - let - headers = header 1 (text "header1") - <> header 2 (text "header2") - <> header 3 (text "header3") - - docbookTopLevelDiv :: (ToPandoc a) - => TopLevelDivision -> a -> String - docbookTopLevelDiv division = - docbookWithOpts def{ writerTopLevelDivision = division } - in - [ test (docbookTopLevelDiv TopLevelSection) "sections as top-level" $ - headers =?> - unlines [ "" - , " header1" - , " " - , " header2" - , " " - , " header3" - , " " - , " " - , " " - , " " - , "" - ] - , test (docbookTopLevelDiv TopLevelChapter) "chapters as top-level" $ - headers =?> - unlines [ "" - , " header1" - , " " - , " header2" - , " " - , " header3" - , " " - , " " - , " " - , " " - , "" - ] - , test (docbookTopLevelDiv TopLevelPart) "parts as top-level" $ - headers =?> - unlines [ "" - , " header1" - , " " - , " header2" - , " " - , " header3" - , " " - , " " - , " " - , " " - , "" - ] - , test (docbookTopLevelDiv TopLevelDefault) "default top-level" $ - headers =?> - unlines [ "" - , " header1" - , " " - , " header2" - , " " - , " header3" - , " " - , " " - , " " - , " " - , "" - ] - ] - ] - , testGroup "section attributes" $ - let - headers = headerWith ("myid1",[],[("role","internal"),("xml:id","anotherid"),("dir","rtl")]) 1 "header1" - <> headerWith ("myid2",[],[("invalidname","value"),("arch","linux"),("dir","invaliddir")]) 1 "header2" - in - [ test docbook5 "sections with attributes (db5)" $ - headers =?> - unlines [ "
" - , " header1" - , " " - , " " - , "
" - , "
" - , " header2" - , " " - , " " - , "
" - ] - , test docbook "sections with attributes (db4)" $ - headers =?> - unlines [ "" - , " header1" - , " " - , " " - , "" - , "" - , " header2" - , " " - , " " - , "" - ] - ] - ] diff --git a/test/Tests/Writers/HTML.hs b/test/Tests/Writers/HTML.hs --- a/test/Tests/Writers/HTML.hs +++ b/test/Tests/Writers/HTML.hs @@ -84,6 +84,11 @@ doubleQuoted (spanWith ("", [], [("cite", "http://example.org")]) (str "examples")) =?> "examples" ] + , testGroup "code" + [ "code should be rendered correctly" =: + plain (codeWith ("",[],[]) "Answer is 42") =?> + "Answer is 42" + ] , testGroup "sample" [ "sample should be rendered correctly" =: plain (codeWith ("",["sample"],[]) "Answer is 42") =?> diff --git a/test/Tests/Writers/JATS.hs b/test/Tests/Writers/JATS.hs --- a/test/Tests/Writers/JATS.hs +++ b/test/Tests/Writers/JATS.hs @@ -11,7 +11,7 @@ import qualified Data.Text as T jats :: (ToPandoc a) => a -> Text -jats = purely (writeJATS def{ writerWrapText = WrapNone }) +jats = purely (writeJatsArchiving def{ writerWrapText = WrapNone }) . toPandoc jatsArticleAuthoring :: (ToPandoc a) => a -> Text @@ -88,7 +88,7 @@ , " " , "

caption

" , " - " xlink:href=\"a.png\" xlink:title=\"\" />" + " xlink:href=\"a.png\" />" , " " , "

" , " " diff --git a/test/Tests/Writers/LaTeX.hs b/test/Tests/Writers/LaTeX.hs --- a/test/Tests/Writers/LaTeX.hs +++ b/test/Tests/Writers/LaTeX.hs @@ -76,11 +76,11 @@ [ "struck out and highlighted" =: strikeout (codeWith ("",["haskell"],[]) "foo" <> space <> str "bar") =?> - "\\sout{\\mbox{\\VERB|\\NormalTok{foo}|} bar}" + "\\st{\\mbox{\\VERB|\\NormalTok{foo}|} bar}" , "struck out and not highlighted" =: strikeout (code "foo" <> space <> str "bar") =?> - "\\sout{\\mbox{\\texttt{foo}} bar}" + "\\st{\\mbox{\\texttt{foo}} bar}" , "single quotes" =: code "dog's" =?> "\\texttt{dog\\textquotesingle{}s}" , "backtick" =: diff --git a/test/Tests/Writers/Muse.hs b/test/Tests/Writers/Muse.hs --- a/test/Tests/Writers/Muse.hs +++ b/test/Tests/Writers/Muse.hs @@ -430,7 +430,6 @@ , "div with bullet list" =: divWith nullAttr (bulletList [para "foo"]) =?> unlines [ " - foo" ] -- Making sure bullets are indented - -- Null is trivial ] , testGroup "inline elements" [ testGroup "string" diff --git a/test/command/2118.md b/test/command/2118.md --- a/test/command/2118.md +++ b/test/command/2118.md @@ -7,11 +7,16 @@ \label{fig:setminus} \end{figure} ^D -[ Para - [ Image - ( "fig:setminus" , [] , [ ( "width" , "80%" ) ] ) - [ Str "Set" , Space , Str "subtraction" ] - ( "setminus.png" , "fig:" ) +[ Figure + ( "fig:setminus" , [] , [] ) + (Caption + Nothing [ Plain [ Str "Set" , Space , Str "subtraction" ] ]) + [ Plain + [ Image + ( "" , [] , [ ( "width" , "80%" ) ] ) + [] + ( "setminus.png" , "" ) + ] ] ] ``` diff --git a/test/command/2378.md b/test/command/2378.md --- a/test/command/2378.md +++ b/test/command/2378.md @@ -13,15 +13,16 @@ ^D \begin{longtable}[]{@{}ll@{}} \caption{a table}\tabularnewline -\toprule() +\toprule\noalign{} x & y\footnote{a footnote} \\ -\midrule() +\midrule\noalign{} \endfirsthead -\toprule() +\toprule\noalign{} x & y{} \\ -\midrule() +\midrule\noalign{} \endhead +\bottomrule\noalign{} +\endlastfoot 1 & 2 \\ -\bottomrule() \end{longtable} ``` diff --git a/test/command/2465.md b/test/command/2465.md new file mode 100644 --- /dev/null +++ b/test/command/2465.md @@ -0,0 +1,59 @@ +``` +% pandoc -f textile -t native +This list starts: + +# one +# two + +This list should continue at 3: + +#3 three +# four + +This list should restart at 1: + +# one again +# two again +^D +[ Para + [ Str "This" , Space , Str "list" , Space , Str "starts:" ] +, OrderedList + ( 1 , DefaultStyle , DefaultDelim ) + [ [ Plain [ Str "one" ] ] , [ Plain [ Str "two" ] ] ] +, Para + [ Str "This" + , Space + , Str "list" + , Space + , Str "should" + , Space + , Str "continue" + , Space + , Str "at" + , Space + , Str "3:" + ] +, OrderedList + ( 3 , DefaultStyle , DefaultDelim ) + [ [ Plain [ Str "three" ] ] , [ Plain [ Str "four" ] ] ] +, Para + [ Str "This" + , Space + , Str "list" + , Space + , Str "should" + , Space + , Str "restart" + , Space + , Str "at" + , Space + , Str "1:" + ] +, OrderedList + ( 1 , DefaultStyle , DefaultDelim ) + [ [ Plain [ Str "one" , Space , Str "again" ] ] + , [ Plain [ Str "two" , Space , Str "again" ] ] + ] +] +``` + diff --git a/test/command/2649.md b/test/command/2649.md --- a/test/command/2649.md +++ b/test/command/2649.md @@ -17,7 +17,7 @@ % pandoc -f mediawiki -t html5 {| border="4" cellspacing="2" cellpadding="0" WIDTH="100%" |----- -| peildatum Simbase || november 2005 || '''uitslagen Flohrgambiet''' || +| peildatum Simbase || november 2005 || colspan=2 | '''uitslagen Flohrgambiet''' || |----- | totaal aantal partijen Simbase || 7.316.773 | wit wint || 53% @@ -34,8 +34,7 @@

peildatum Simbase

november 2005

-

uitslagen Flohrgambiet

- +

uitslagen Flohrgambiet

totaal aantal partijen Simbase

@@ -90,20 +89,20 @@

1

-

Sébastien -Loeb

+

Sébastien Loeb

78

2

-

Sébastien -Ogier

+

Sébastien Ogier

38

10

-

Hannu -Mikkola

+

Hannu Mikkola

18

diff --git a/test/command/3577.md b/test/command/3577.md --- a/test/command/3577.md +++ b/test/command/3577.md @@ -16,13 +16,16 @@ \end{figure} ^D
-Caption 1 - +
+ +
Caption 1
-Caption 2 - + +
Caption 2
+
Subfigure with Subfloat
+
``` ``` % pandoc -f latex -t html5 @@ -32,7 +35,7 @@ \end{figure} ^D
-Caption 3 - + +
Caption 3
``` diff --git a/test/command/4183.md b/test/command/4183.md --- a/test/command/4183.md +++ b/test/command/4183.md @@ -4,7 +4,13 @@ bar ^D -[ Para [ Image ( "" , [] , [] ) [] ( "foo" , "fig:" ) ] ] +[ Figure + ( "" , [] , [] ) + (Caption Nothing []) + [ Plain + [ Image ( "" , [] , [] ) [ Str "bar" ] ( "foo" , "" ) ] + ] +] ``` ``` @@ -18,8 +24,13 @@ ^D -[ Para - [ Image ( "" , [] , [] ) [ Str "baz" ] ( "foo" , "fig:" ) ] +[ Figure + ( "" , [] , [] ) + (Caption + Nothing [ Div ( "" , [] , [] ) [ Plain [ Str "baz" ] ] ]) + [ Plain + [ Image ( "" , [] , [] ) [ Str "bar" ] ( "foo" , "" ) ] + ] ] ``` @@ -30,9 +41,9 @@

baz

^D -[ Para - [ Image - ( "" , [] , [] ) [ Emph [ Str "baz" ] ] ( "foo" , "fig:" ) - ] +[ Figure + ( "" , [] , [] ) + (Caption Nothing [ Para [ Emph [ Str "baz" ] ] ]) + [ Plain [ Image ( "" , [] , [] ) [] ( "foo" , "" ) ] ] ] ``` diff --git a/test/command/4420.md b/test/command/4420.md --- a/test/command/4420.md +++ b/test/command/4420.md @@ -2,10 +2,8 @@ % pandoc -f native -t rst [Para [Image ("",["align-right"],[("width","100px")]) [Str "image"] ("foo.png","fig:test")]] ^D -.. figure:: foo.png - :alt: test +.. image:: foo.png + :alt: image :align: right :width: 100px - - image ``` diff --git a/test/command/4564.md b/test/command/4564.md new file mode 100644 --- /dev/null +++ b/test/command/4564.md @@ -0,0 +1,65 @@ +``` +% pandoc -f native -t rst --list-tables +[BlockQuote + [Table ("",[],[]) (Caption Nothing + []) + [(AlignDefault,ColWidth 0.1527777777777778) + ,(AlignDefault,ColWidth 0.1388888888888889) + ,(AlignDefault,ColWidth 0.16666666666666666) + ,(AlignDefault,ColWidth 0.375)] + (TableHead ("",[],[]) + [Row ("",[],[]) + [Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1) + [Plain [Str "Centered",SoftBreak,Str "Header"]] + ,Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1) + [Plain [Str "Left",SoftBreak,Str "Aligned"]] + ,Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1) + [Plain [Str "Right",SoftBreak,Str "Aligned"]] + ,Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1) + [Plain [Str "Default",Space,Str "aligned"]]]]) + [(TableBody ("",[],[]) (RowHeadColumns 0) + [] + [Row ("",[],[]) + [Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1) + [Plain [Str "First"]] + ,Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1) + [Plain [Str "row"]] + ,Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1) + [Plain [Str "12.0"]] + ,Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1) + [Plain [Str "Example",Space,Str "of",Space,Str "a",Space,Str "row",Space,Str "that",SoftBreak,Str "spans",Space,Str "multiple",Space,Str "lines."]]] + ,Row ("",[],[]) + [Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1) + [Plain [Str "Second"]] + ,Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1) + [Plain [Str "row"]] + ,Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1) + [Plain [Str "5.0"]] + ,Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1) + [Plain [Str "Here\8217s",Space,Str "another",Space,Str "one.",Space,Str "Note",SoftBreak,Str "the",Space,Str "blank",Space,Str "line",Space,Str "between",SoftBreak,Str "rows."]]]])] + (TableFoot ("",[],[]) + [])]] +^D + .. list-table:: + :widths: 11 10 12 27 + :header-rows: 1 + + - + + - Centered Header + - Left Aligned + - Right Aligned + - Default 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. +``` diff --git a/test/command/4677.md b/test/command/4677.md --- a/test/command/4677.md +++ b/test/command/4677.md @@ -2,8 +2,8 @@ % pandoc --to "markdown-bracketed_spans-fenced_divs-link_attributes-simple_tables-multiline_tables-grid_tables-pipe_tables-fenced_code_attributes-markdown_in_html_blocks-table_captions-smart" ![Caption](img.png){#img:1} ^D -
-Caption +
+Caption
``` diff --git a/test/command/4794.md b/test/command/4794.md --- a/test/command/4794.md +++ b/test/command/4794.md @@ -4,7 +4,8 @@ | ------- | ------- | ------- | | text | | text | ^D -{| +{| class="wikitable" +|- ! Column1 ! Column2 ! Column3 diff --git a/test/command/5321.md b/test/command/5321.md --- a/test/command/5321.md +++ b/test/command/5321.md @@ -7,9 +7,14 @@ ^D -[ Para - [ Image - ( "fig-1" , [] , [] ) [ Str "bar" ] ( "foo.png" , "fig:" ) +[ Figure + ( "fig-1" , [] , [] ) + (Caption Nothing [ Plain [ Str "bar" ] ]) + [ Div + ( "" , [ "caption" ] , [] ) + [ Header 6 ( "" , [] , [] ) [] , Para [ Str "bar" ] ] + , Para + [ Image ( "" , [] , [] ) [ Str "baz" ] ( "foo.png" , "" ) ] ] ] ``` @@ -24,11 +29,17 @@ ^D -[ Para - [ Image - ( "fig-1" , [] , [] ) - [ Str "foo" , LineBreak , Str "bar" ] - ( "foo.png" , "fig:" ) +[ Figure + ( "fig-1" , [] , [] ) + (Caption + Nothing [ Plain [ Str "foo" , LineBreak , Str "bar" ] ]) + [ Div + ( "" , [ "caption" ] , [] ) + [ Header 6 ( "" , [] , [] ) [ Str "foo" ] + , Para [ Str "bar" ] + ] + , Para + [ Image ( "" , [] , [] ) [ Str "baz" ] ( "foo.png" , "" ) ] ] ] ``` diff --git a/test/command/5367.md b/test/command/5367.md --- a/test/command/5367.md +++ b/test/command/5367.md @@ -23,20 +23,21 @@ \begin{longtable}[]{@{} >{\centering\arraybackslash}p{(\columnwidth - 0\tabcolsep) * \real{0.1667}}@{}} \caption[Sample table.]{Sample table.\footnote{caption footnote}}\tabularnewline -\toprule() +\toprule\noalign{} \begin{minipage}[b]{\linewidth}\centering Fruit\footnote{header footnote} \end{minipage} \\ -\midrule() +\midrule\noalign{} \endfirsthead -\toprule() +\toprule\noalign{} \begin{minipage}[b]{\linewidth}\centering Fruit{} \end{minipage} \\ -\midrule() +\midrule\noalign{} \endhead +\bottomrule\noalign{} +\endlastfoot Bans\footnote{table cell footnote} \\ -\bottomrule() \end{longtable} dolly\footnote{doc footnote} diff --git a/test/command/5368.md b/test/command/5368.md --- a/test/command/5368.md +++ b/test/command/5368.md @@ -15,21 +15,32 @@ [ OrderedList ( 1 , Decimal , Period ) [ [ Para [ Str "foo" ] - , Para - [ Image - ( "" , [] , [] ) [ Str "bar" ] ( "bar.png" , "fig:" ) + , Figure + ( "" , [] , [] ) + (Caption Nothing [ Plain [ Str "bar" ] ]) + [ Plain + [ Image ( "" , [] , [] ) [ Str "bar" ] ( "bar.png" , "" ) + ] ] ] , [ Para [ Str "foo2" ] - , Para - [ Image - ( "" , [] , [] ) [ Str "bar2" ] ( "bar2.png" , "fig:" ) + , Figure + ( "" , [] , [] ) + (Caption Nothing [ Plain [ Str "bar2" ] ]) + [ Plain + [ Image + ( "" , [] , [] ) [ Str "bar2" ] ( "bar2.png" , "" ) + ] ] ] , [ Para [ Str "foo3" ] - , Para - [ Image - ( "" , [] , [] ) [ Str "foo3" ] ( "foo3.png" , "fig:" ) + , Figure + ( "" , [] , [] ) + (Caption Nothing [ Plain [ Str "foo3" ] ]) + [ Plain + [ Image + ( "" , [] , [] ) [ Str "foo3" ] ( "foo3.png" , "" ) + ] ] ] ] diff --git a/test/command/5529.md b/test/command/5529.md --- a/test/command/5529.md +++ b/test/command/5529.md @@ -4,7 +4,7 @@ ~~_`hello world`_~~ ^D -\sout{\mbox{\texttt{hello\ world}}} +\st{\mbox{\texttt{hello\ world}}} -\sout{\emph{\mbox{\texttt{hello\ world}}}} +\st{\emph{\mbox{\texttt{hello\ world}}}} ``` diff --git a/test/command/5619.md b/test/command/5619.md --- a/test/command/5619.md +++ b/test/command/5619.md @@ -6,32 +6,40 @@ The caption. Here's what piggybacking on caption would look like {#fig:1} ^D -[ Para - [ Image - ( "test" , [] , [ ( "width" , "1in" ) ] ) - [ Str "The" - , Space - , Str "caption." - , Space - , Str "Here's" - , Space - , Str "what" - , Space - , Str "piggybacking" - , Space - , Str "on" - , Space - , Str "caption" - , Space - , Str "would" - , Space - , Str "look" - , Space - , Str "like" - , Space - , Str "{#fig:1}" +[ Figure + ( "" , [] , [] ) + (Caption + Nothing + [ Plain + [ Str "The" + , Space + , Str "caption." + , Space + , Str "Here's" + , Space + , Str "what" + , Space + , Str "piggybacking" + , Space + , Str "on" + , Space + , Str "caption" + , Space + , Str "would" + , Space + , Str "look" + , Space + , Str "like" + , Space + , Str "{#fig:1}" + ] + ]) + [ Plain + [ Image + ( "test" , [] , [ ( "width" , "1in" ) ] ) + [ Str "img1.jpg" ] + ( "img1.jpg" , "" ) ] - ( "img1.jpg" , "fig:" ) ] ] ``` diff --git a/test/command/6137.md b/test/command/6137.md --- a/test/command/6137.md +++ b/test/command/6137.md @@ -134,24 +134,32 @@ , Space , Str "fine." ] -, Para - [ Image - ( "fig:label" , [] , [ ( "width" , "\\textwidth" ) ] ) - [ Str "A" - , Space - , Str "numbered" - , Space - , Str "caption," - , Space - , Str "if" - , Space - , Str "I" - , Space - , Str "use" - , Space - , Str "pandoc-crossref." +, Figure + ( "fig:label" , [] , [] ) + (Caption + Nothing + [ Plain + [ Str "A" + , Space + , Str "numbered" + , Space + , Str "caption," + , Space + , Str "if" + , Space + , Str "I" + , Space + , Str "use" + , Space + , Str "pandoc-crossref." + ] + ]) + [ Plain + [ Image + ( "" , [] , [ ( "width" , "\\textwidth" ) ] ) + [] + ( "example.png" , "" ) ] - ( "example.png" , "fig:" ) ] ] ``` diff --git a/test/command/6384.md b/test/command/6384.md new file mode 100644 --- /dev/null +++ b/test/command/6384.md @@ -0,0 +1,16 @@ +``` +% pandoc --wrap=preserve --file-scope command/file1.txt command/file2.txt +^D +
+

Zed

+

foo +and Zed +and other Zed +and other file +and foreign Zed

+
+
+

Zed

+

foo

+
+``` diff --git a/test/command/6774.md b/test/command/6774.md --- a/test/command/6774.md +++ b/test/command/6774.md @@ -13,7 +13,7 @@ % pandoc -f native -t opendocument+xrefs_name --quiet [Header 1 ("chapter1",[],[]) [Str "The",Space,Str "Chapter"] ,Para [Str "Chapter",Space,Str "1",Space,Str "references",Space,Link ("",[],[]) [Str "The",Space,Str "Chapter"] ("#chapter1","")] -,Para [Image ("lalune",[],[]) [Str "lalune"] ("lalune.jpg","fig:Voyage dans la Lune")] +,Figure ("lalune",[],[]) (Caption Nothing [Para [Str "Voyage dans la Lune"]]) [Plain [Image ("",[],[]) [Str "lalune"] ("lalune.jpg","")]] ,Para [Str "Image",Space,Str "1",Space,Str "references",Space,Link ("",[],[]) [Str "La",Space,Str "Lune"] ("#lalune","")]] ^D The @@ -22,7 +22,7 @@ The Chapter -lalune +Voyage dans la Lune Image 1 references La Lune @@ -31,7 +31,7 @@ % pandoc -f native -t opendocument+xrefs_number --quiet [Header 1 ("chapter1",[],[]) [Str "The",Space,Str "Chapter"] ,Para [Str "Chapter",Space,Str "1",Space,Str "references",Space,Link ("",[],[]) [Str "The",Space,Str "Chapter"] ("#chapter1","")] -,Para [Image ("lalune",[],[]) [Str "lalune"] ("lalune.jpg","fig:Voyage dans la Lune")] +,Figure ("lalune",[],[]) (Caption Nothing [Para [Str "lalune"]]) [Plain [Image ("",[],[]) [Str "lalune"] ("lalune.jpg","Voyage dans la Lune")]] ,Para [Str "Image",Space,Str "1",Space,Str "references",Space,Link ("",[],[]) [Str "La",Space,Str "Lune"] ("#lalune","")]] ^D The @@ -47,7 +47,7 @@ % pandoc -f native -t opendocument+xrefs_number+xrefs_name --quiet [Header 1 ("chapter1",[],[]) [Str "The",Space,Str "Chapter"] ,Para [Str "Chapter",Space,Str "1",Space,Str "references",Space,Link ("",[],[]) [Str "The",Space,Str "Chapter"] ("#chapter1","")] -,Para [Image ("lalune",[],[]) [Str "lalune"] ("lalune.jpg","fig:Voyage dans la Lune")] +,Figure ("lalune",[],[]) (Caption Nothing [Para [Str "Voyage dans la Lune"]]) [Plain [Image ("",[],[]) [Str "lalune"] ("lalune.jpg","")]] ,Para [Str "Image",Space,Str "1",Space,Str "references",Space,Link ("",[],[]) [Str "La",Space,Str "Lune"] ("#lalune","")]] ^D The @@ -56,7 +56,7 @@ The Chapter -lalune +Voyage dans la Lune Image 1 references La Lune diff --git a/test/command/7272.md b/test/command/7272.md --- a/test/command/7272.md +++ b/test/command/7272.md @@ -16,12 +16,13 @@ ^D \begin{longtable}[]{@{} >{\raggedright\arraybackslash}p{(\columnwidth - 0\tabcolsep) * \real{1.0000}}@{}} -\toprule() +\toprule\noalign{} \endhead +\bottomrule\noalign{} +\endlastfoot \begin{minipage}[t]{\linewidth}\raggedright { text\\ text2 }\strut \end{minipage} \\ -\bottomrule() \end{longtable} ``` diff --git a/test/command/7678.md b/test/command/7678.md new file mode 100644 --- /dev/null +++ b/test/command/7678.md @@ -0,0 +1,31 @@ +``` +% pandoc -f bibtex -t csljson +@misc{doe, + author = "Jane Doe", + title = "Work", + year = "2021", + url = "%20and%20" +} +^D +[ + { + "URL": "%20and%20", + "author": [ + { + "family": "Doe", + "given": "Jane" + } + ], + "id": "doe", + "issued": { + "date-parts": [ + [ + 2021 + ] + ] + }, + "title": "Work", + "type": "" + } +] +``` diff --git a/test/command/7743.md b/test/command/7743.md new file mode 100644 --- /dev/null +++ b/test/command/7743.md @@ -0,0 +1,56 @@ +``` +% pandoc -f markdown+mark -t html +==Hi== +^D +

Hi

+``` + +``` +% pandoc -f markdown+mark -t latex +==Hi== +^D +\hl{Hi} +``` + +``` +% pandoc -f markdown+mark -t rst +==Hi== +^D +:mark:`Hi` +``` + +``` +% pandoc -f html -t markdown+mark +Hi +^D +==Hi== +``` + +``` +% pandoc -f html -t markdown +Hi +^D +[Hi]{.mark} +``` + +``` +% pandoc -f rst -t markdown+mark +:mark:`Hi` +^D +==Hi== +``` + +``` +% pandoc -f markdown+mark -t docx -o - | pandoc -f docx -t markdown+mark +==Hi== +^D +==Hi== +``` + +``` +% pandoc -f latex -t markdown+mark +\hl{Hi} +^D +==Hi== +``` + diff --git a/test/command/8070.md b/test/command/8070.md --- a/test/command/8070.md +++ b/test/command/8070.md @@ -7,6 +7,7 @@ ^D https://docs.oracle.com/database/121/BRADV/rcmxplat.htm#BRADV724[12.1 manual, Database Backup and Recovery User’s Guide: -[.enumeration_chapter]#Chapter 28# Transporting Data Across Platforms, -Steps to Transport a Database to a Different Platform Using Backup Sets] +[.enumeration_chapter]#Chapter 28# Transporting Data Across +Platforms, Steps to Transport a Database to a Different Platform +Using Backup Sets] ``` diff --git a/test/command/8131.md b/test/command/8131.md new file mode 100644 --- /dev/null +++ b/test/command/8131.md @@ -0,0 +1,41 @@ +# TOC in gfm contains no HTML by default +``` +% pandoc --to=gfm --toc --standalone +# Head + +Content +^D +- [Head](#head) + +# Head + +Content +``` + +# Same in Markdown if link_attributes extension is disabled +``` +% pandoc --to=markdown-link_attributes --toc --standalone +# Head + +Content +^D +- [Head](#head) + +# Head + +Content +``` + +# IDs are added to TOC with the "attributes" CommonMark extension +``` +% pandoc --to=commonmark+gfm_auto_identifiers+attributes --toc -s +# Nam a sapien + +Lorem ipsum dolor sit amet, consectetuer adipiscing elit. +^D +- [Nam a sapien](#nam-a-sapien){#toc-nam-a-sapien} + +# Nam a sapien + +Lorem ipsum dolor sit amet, consectetuer adipiscing elit. +``` diff --git a/test/command/8155.md b/test/command/8155.md deleted file mode 100644 --- a/test/command/8155.md +++ /dev/null @@ -1,19 +0,0 @@ -``` -% pandoc -f native -t revealjs -[ Null -, Header - 2 - ( "header-after-null" , [] , [] ) - [ Str "Header" - , Space - , Str "after" - , Space - , Str "null" - ] -] -^D -
-

Header after null

- -
-``` diff --git a/test/command/8174.md b/test/command/8174.md new file mode 100644 --- /dev/null +++ b/test/command/8174.md @@ -0,0 +1,44 @@ +```` +% pandoc -t native +```yaml {#id} +some: code +``` +^D +[ CodeBlock ( "id" , [ "yaml" ] , [] ) "some: code" ] +```` + +```` +% pandoc -t native +```yaml {.class #id} +some: code +``` +^D +[ CodeBlock + ( "id" , [ "yaml" , "class" ] , [] ) "some: code" +] +```` + + +```` +% pandoc -t native +```ab``` +^D +[ Para [ Code ( "" , [] , [] ) "ab" ] ] +```` + +```` +% pandoc -t native +```ab```{.class} +^D +[ Para [ Code ( "" , [ "class" ] , [] ) "ab" ] ] +```` + + +```` +% pandoc -t native +``` foo}{.bar} +test +``` +^D +[ Para [ Code ( "" , [] , [] ) "foo}{.bar} test" ] ] +```` diff --git a/test/command/8219.md b/test/command/8219.md --- a/test/command/8219.md +++ b/test/command/8219.md @@ -6,9 +6,11 @@ ^D \begin{longtable}[]{@{}ll@{}} \caption{}\label{test}\tabularnewline -\toprule() +\toprule\noalign{} +\endfirsthead \endhead +\bottomrule\noalign{} +\endlastfoot one & two \\ -\bottomrule() \end{longtable} ``` diff --git a/test/command/8243.md b/test/command/8243.md new file mode 100644 --- /dev/null +++ b/test/command/8243.md @@ -0,0 +1,23 @@ +``` +% pandoc -f latex +\newenvironment{topics}{ +\newcommand{\topic}[2]{ \item{##1 / ##2} } +Topics: +\begin{itemize} +} +{ +\end{itemize} +} + +\begin{topics} +\topic{Foo}{Bar} +\topic{Baz}{Bim} +\end{topics} +^D +

Topics:

+
    +

  • Foo / Bar

    • +

  • Baz / Bim

    • +
+``` + diff --git a/test/command/8251.md b/test/command/8251.md new file mode 100644 --- /dev/null +++ b/test/command/8251.md @@ -0,0 +1,13 @@ +``` +% pandoc -f native -t html +Link ("",["", "", ""],[]) [Str "foo"] ("https://example.com","") +^D +foo +``` + +``` +% pandoc -f native -t markdown +Link ("",["", "", ""],[]) [Str "foo"] ("https://example.com","") +^D +[foo](https://example.com){} +``` diff --git a/test/command/8257.md b/test/command/8257.md new file mode 100644 --- /dev/null +++ b/test/command/8257.md @@ -0,0 +1,41 @@ +``` +% pandoc -f markdown -t html5 ++------+-------+ +| Item | Price | ++======+=======+ +| Eggs | 5£ | ++------+-------+ +| Spam | 3£ | ++======+=======+ +| Sum | 8£ | ++======+=======+ +^D + ++++ + + + + + + + + + + + + + + + + + + + + + + +
ItemPrice
Eggs5£
Spam3£
Sum8£
+``` diff --git a/test/command/8281.md b/test/command/8281.md new file mode 100644 --- /dev/null +++ b/test/command/8281.md @@ -0,0 +1,15 @@ +``` +% pandoc -t html +# Title + +test + +. . . + +test +^D +

Title

+

test

+

. . .

+

test

+``` diff --git a/test/command/8302.md b/test/command/8302.md new file mode 100644 --- /dev/null +++ b/test/command/8302.md @@ -0,0 +1,6 @@ +``` +% pandoc -f org -t markdown +some text cite:&long-2004-tecton-evolut +^D +some text @long-2004-tecton-evolut +``` diff --git a/test/command/8307.md b/test/command/8307.md new file mode 100644 --- /dev/null +++ b/test/command/8307.md @@ -0,0 +1,49 @@ +``` +% pandoc -t commonmark -f html + + + + + + +
hello
+^D + + + + + + +
hello
+``` + +```` +% pandoc -t commonmark -f markdown +``` {=html} + + + + + + +
hello
+``` +^D + + + + + + +
hello
+```` diff --git a/test/command/8344.md b/test/command/8344.md new file mode 100644 --- /dev/null +++ b/test/command/8344.md @@ -0,0 +1,90 @@ +``` +% pandoc -t jats -s +--- +title: |- + My\ + document +... + +# Section\ +with line break + +Paragraph\ +with line break + +-------- +A B +--- --- +1\ 3 +2 4 + +*1\ 5\ +2* 6 + + 7 +-------- + +^D + + +
+ + + + + + + + + + + + +Mydocument + + + + + + + + Section<break/> +

with line break

+

Paragraph + with line break

+ + + + + + + + + + + + + + + + + + + + + + + + + + +
AB
123 4
1 + 256
7
+ + + + + +
+``` diff --git a/test/command/8354.md b/test/command/8354.md new file mode 100644 --- /dev/null +++ b/test/command/8354.md @@ -0,0 +1,38 @@ +``` +% pandoc -f markdown -t html --citeproc +--- +title: test +nocite: '[@*]' +references: +- author: + - family: Fekete + given: Jean-Daniel + - family: Freire + given: Juliana + DOI: 10.1109/MCG.2020.3006412 + id: feketeExploringReproducibilityVisualization2020 + ISSN: 1558-1756 + issue: 5 + issued: 2020-09 + page: 108-119 + source: IEEE Xplore + title: Exploring Reproducibility in Visualization + container-title: IEEE Computer Graphics and Applications + type: article-journal + volume: 40 +--- + +## References +^D +

References

+
+
+Fekete, Jean-Daniel, and Juliana Freire. 2020. “Exploring +Reproducibility in Visualization.” IEEE Computer Graphics and +Applications 40 (5): 108–19. https://doi.org/10.1109/MCG.2020.3006412. +
+
+``` diff --git a/test/command/8380.md b/test/command/8380.md new file mode 100644 --- /dev/null +++ b/test/command/8380.md @@ -0,0 +1,31 @@ +``` +% pandoc -f man -t rst +LC_* +^D +LC\_\* +``` + +These examples of things that don't require escaping are taken +from the RST documentation: + +``` +% pandoc -f native -t rst +[Para [Str "2*x a**b O(N**2) e**(x*y) f(x)*f(y) a|b"] +,Para [Str "a**b O(N**2) e**(x*y) f(x)*f(y)"] +] +^D +2*x a**b O(N**2) e**(x*y) f(x)*f(y) a|b + +a**b O(N**2) e**(x*y) f(x)*f(y) +``` + +These examples of things that do require escaping are taken +from the RST documentation: + +``` +% pandoc -f native -t rst +Str "*4, class_, *args, **kwargs, `TeX-quoted', *ML, *.txt" +^D +\*4, class\_, \*args, \**kwargs, \`TeX-quoted', \*ML, \*.txt +``` + diff --git a/test/command/8402.md b/test/command/8402.md new file mode 100644 --- /dev/null +++ b/test/command/8402.md @@ -0,0 +1,52 @@ +``` +% pandoc --toc -s -t markdown +::: {.cell .markdown id="6u8qXoeFGdqt"} +# Summary +> Expand to see summary + +## Overview and Explanation +::: + +# Details + +## inner 1 +text + +## inner 2 + +### inner inner 1 + +## inner 3 +text +^D +- [Summary](#summary){#toc-summary} + - [Overview and + Explanation](#overview-and-explanation){#toc-overview-and-explanation} +- [Details](#details){#toc-details} + - [inner 1](#inner-1){#toc-inner-1} + - [inner 2](#inner-2){#toc-inner-2} + - [inner inner 1](#inner-inner-1){#toc-inner-inner-1} + - [inner 3](#inner-3){#toc-inner-3} + +::: {#6u8qXoeFGdqt .cell .markdown} +# Summary + +> Expand to see summary + +## Overview and Explanation +::: + +# Details + +## inner 1 + +text + +## inner 2 + +### inner inner 1 + +## inner 3 + +text +``` diff --git a/test/command/8437.md b/test/command/8437.md new file mode 100644 --- /dev/null +++ b/test/command/8437.md @@ -0,0 +1,44 @@ +``` +% pandoc -f markdown -t asciidoctor +[![alt](https://img.shields.io/badge/License-Apache%202.0-blue.svg "title")](http://www.apache.org/licenses/LICENSE-2.0) +^D +http://www.apache.org/licenses/LICENSE-2.0[image:https://img.shields.io/badge/License-Apache%202.0-blue.svg[alt,title="title"]] +``` + +``` +% pandoc -f markdown -t docbook +[![alt](https://img.shields.io/badge/License-Apache%202.0-blue.svg "title")](http://www.apache.org/licenses/LICENSE-2.0) +^D + + + + + title + + + + + alt + + + +``` + +``` +% pandoc -f docbook -t markdown + + + + + title + + + + + alt + + + +^D +[![alt](https://img.shields.io/badge/License-Apache%202.0-blue.svg "title")](http://www.apache.org/licenses/LICENSE-2.0) +``` diff --git a/test/command/8486.md b/test/command/8486.md new file mode 100644 --- /dev/null +++ b/test/command/8486.md @@ -0,0 +1,55 @@ +# Unnumbered and unlisted headings in ConTeXt + +``` +% pandoc --to=context +# Preface {.unlisted -} + +Nullam rutrum. + +# Introduction + +Nullam eu ante vel est convallis dignissim. + +# Methods + +Sed diam. Nulla posuere. Praesent fermentum tempor tellus. Nam +vestibulum accumsan nisl. Nam vestibulum accumsan nisl. + +# References {-} +^D +\startsubject[title={Preface},reference={preface},number=no,incrementnumber=no] + +Nullam rutrum. + +\stopsubject + +\startsectionlevel[title={Introduction},reference={introduction}] + +Nullam eu ante vel est convallis dignissim. + +\stopsectionlevel + +\startsectionlevel[title={Methods},reference={methods}] + +Sed diam. Nulla posuere. Praesent fermentum tempor tellus. Nam +vestibulum accumsan nisl. Nam vestibulum accumsan nisl. + +\stopsectionlevel + +\startsectionlevel[title={References},reference={references},number=no,incrementnumber=no] + +\stopsectionlevel +``` + +## Semantic Headings with `--top-level-division` +``` +% pandoc --to=context --top-level-division=chapter +# Bibliography {-} +None +^D +\startchapter[title={Bibliography},reference={bibliography},number=no,incrementnumber=no] + +None + +\stopchapter +``` diff --git a/test/command/8487.md b/test/command/8487.md new file mode 100644 --- /dev/null +++ b/test/command/8487.md @@ -0,0 +1,14 @@ +``` +% pandoc -f textile -t native +p>. + +p=. Links: +^D +[ Div + ( "" , [] , [ ( "style" , "text-align:right;" ) ] ) + [ Para [] ] +, Div + ( "" , [] , [ ( "style" , "text-align:center;" ) ] ) + [ Para [ Str "Links:" ] ] +] +``` diff --git a/test/command/8504.md b/test/command/8504.md new file mode 100644 --- /dev/null +++ b/test/command/8504.md @@ -0,0 +1,90 @@ +``` +% pandoc -f markdown -s -t biblatex +--- +references: +- id: Larsson_2016 + author: + - family: Larsson + given: Johan + citation-key: Larsson_2016 + issued: + - year: 2016 + medium: Windows + title: 'qualpalr: Automatic Generation of Qualitative Color Palettes' + type: software + URL: https://cran.r-project.org/package=qualpalr + version: 0.3.1 +... +^D +@software{Larsson_2016, + author = {Larsson, Johan}, + title = {Qualpalr: {Automatic} {Generation} of {Qualitative} {Color} + {Palettes}}, + version = {0.3.1}, + date = {2016}, + url = {https://cran.r-project.org/package=qualpalr} +} +``` + +``` +% pandoc -f markdown -s -t bibtex +--- +references: +- id: Larsson_2016 + author: + - family: Larsson + given: Johan + citation-key: Larsson_2016 + issued: + - year: 2016 + medium: Windows + title: 'qualpalr: Automatic Generation of Qualitative Color Palettes' + type: software + URL: https://cran.r-project.org/package=qualpalr + version: 0.3.1 +... +^D +@misc{Larsson_2016, + author = {Larsson, Johan}, + title = {Qualpalr: {Automatic} {Generation} of {Qualitative} {Color} + {Palettes}}, + year = {2016}, + url = {https://cran.r-project.org/package=qualpalr} +} +``` + +``` +% pandoc -f biblatex -s -t csljson +@software{Larsson_2016, + author = {Larsson, Johan}, + title = {Qualpalr: {Automatic} {Generation} of {Qualitative} {Color} + {Palettes}}, + version = {0.3.1}, + date = {2016}, + url = {https://cran.r-project.org/package=qualpalr} +} +^D +[ + { + "URL": "https://cran.r-project.org/package=qualpalr", + "author": [ + { + "family": "Larsson", + "given": "Johan" + } + ], + "id": "Larsson_2016", + "issued": { + "date-parts": [ + [ + 2016 + ] + ] + }, + "title": "Qualpalr: Automatic Generation of Qualitative Color Palettes", + "title-short": "Qualpalr", + "type": "software", + "version": "0.3.1" + } +] +``` diff --git a/test/command/8508.md b/test/command/8508.md new file mode 100644 --- /dev/null +++ b/test/command/8508.md @@ -0,0 +1,14 @@ +``` +% pandoc -t man +SEE ALSO +======== + +* [Milk](https://en.wikipedia.org/wiki/Milk) +* [EBNF](https://en.wikipedia.org/wiki/Extended_Backus–Naur_form) +^D +.SH SEE ALSO +.IP \[bu] 2 +Milk (https://en.wikipedia.org/wiki/Milk) +.IP \[bu] 2 +EBNF (https://en.wikipedia.org/wiki/Extended_Backus–Naur_form) +``` diff --git a/test/command/8511.md b/test/command/8511.md new file mode 100644 --- /dev/null +++ b/test/command/8511.md @@ -0,0 +1,16 @@ +# Conversion of icon-like sequences followed by alphanum char +## to Jira +``` +% pandoc -t jira +:P :P_ :PA :Pa :P2 +^D +\:P \:P\_ :PA :Pa :P2 +``` + +## from jira +``` +% pandoc -f jira -t markdown +\:PA +^D +\\:PA +``` diff --git a/test/command/8513.md b/test/command/8513.md new file mode 100644 --- /dev/null +++ b/test/command/8513.md @@ -0,0 +1,27 @@ +# Round-tripping tags in org +``` +% pandoc --from org --to org --columns=72 +* Header with tag :tag: +^D +* Header with tag :tag: +:PROPERTIES: +:CUSTOM_ID: header-with-tag +:END: +``` + +Multiple tags +``` +% pandoc --from org-auto_identifiers --to org --columns=78 +* Header with two tags :first:second: +^D +* Header with two tags :first:second: +``` + +Check that long headings work with tags + +``` +% pandoc --from org-auto_identifiers --to org --columns=40 +* Header with tag and more words which are not that interesting :tag: +^D +* Header with tag and more words which are not that interesting :tag: +``` diff --git a/test/command/figures-context.md b/test/command/figures-context.md new file mode 100644 --- /dev/null +++ b/test/command/figures-context.md @@ -0,0 +1,48 @@ +# Figure with one image, caption and label + +``` +% pandoc -t context -f html +
+ +
The Mandrill, a photo used in + image processing tests.
+
+^D +\startplacefigure[title={\quotation{The Mandrill}, a photo used in image +processing tests.}] +{\externalfigure[mandrill.jpg]} +\stopplacefigure +``` + +# Nested figures + +``` +% pandoc -t context -f html +
+
+ +
The Mandrill is a commonly used test image.
+
+
+ +
Another test image. This one is called peppers.
+
+
Signal processing test images.
+
+^D +\startplacefigure[reference=test-images,title={Signal processing test +images.}] +\startfloatcombination +\startplacefigure[reference=mandrill,title={\quotation{The Mandrill} is +a commonly used test image.}] +{\externalfigure[../testing/mandrill.jpg]} +\stopplacefigure + +\startplacefigure[reference=peppers,title={Another test image. This one +is called \quotation{peppers}.}] +{\externalfigure[../testing/peppers.webp]} +\stopplacefigure + +\stopfloatcombination +\stopplacefigure +``` diff --git a/test/command/figures-fb2.md b/test/command/figures-fb2.md new file mode 100644 --- /dev/null +++ b/test/command/figures-fb2.md @@ -0,0 +1,8 @@ +``` +% pandoc -f native -t fb2 +[Figure ("fig-id",[],[]) (Caption Nothing []) [Para [Str "content"]]] + +^D + +unrecognisedpandoc<p />

content

 +``` diff --git a/test/command/figures-haddock.md b/test/command/figures-haddock.md new file mode 100644 --- /dev/null +++ b/test/command/figures-haddock.md @@ -0,0 +1,7 @@ +``` +% pandoc -f native -t haddock +[Figure ("fig-id",[],[]) (Caption Nothing []) [Para [Str "content"]]] + +^D +content +``` diff --git a/test/command/figures-html.md b/test/command/figures-html.md new file mode 100644 --- /dev/null +++ b/test/command/figures-html.md @@ -0,0 +1,92 @@ +# Writer + +HTML5 figure with caption and content. + +``` +% pandoc -f native -t html5 +[Figure ("fig-id",[],[]) (Caption Nothing [Plain [Str "caption"]]) [Para [Str "content"]]] + +^D +
+

content

+
caption
+
+``` + +HTML5 figure with NO caption and content. + +``` +% pandoc -f native -t html5 +[Figure ("fig-id",[],[]) (Caption Nothing []) [Para [Str "content"]]] + +^D +
+

content

+
+``` + +HTML4 figure with caption and content. + +``` +% pandoc -f native -t html4 +[Figure ("fig-id",[],[]) (Caption Nothing [Plain [Str "caption"]]) [Para [Str "content"]]] + +^D +
+

content

+
caption
+
+``` + +HTML4 figure with NO caption and content. + +``` +% pandoc -f native -t html4 +[Figure ("fig-id",[],[]) (Caption Nothing []) [Para [Str "content"]]] + +^D +
+

content

+
+``` + +# Reader + +Figure with caption and multiple elements. + +``` +% pandoc -f html -t native +
+ +
  • ITEM
+
CAP2
+
+^D +[ Figure + ( "" , [ "important" ] , [] ) + (Caption Nothing [ Plain [ Str "CAP2" ] ]) + [ Plain + [ Image ( "" , [] , [] ) [] ( "../media/rId25.jpg" , "" ) ] + , BulletList [ [ Plain [ Str "ITEM" ] ] ] + ] +] +``` + +Figure without caption. + +``` +% pandoc -f html -t native +
+ +
  • ITEM
+
+^D +[ Figure + ( "" , [ "important" ] , [] ) + (Caption Nothing []) + [ Plain + [ Image ( "" , [] , [] ) [] ( "../media/rId25.jpg" , "" ) ] + , BulletList [ [ Plain [ Str "ITEM" ] ] ] + ] +] +``` diff --git a/test/command/figures-jats.md b/test/command/figures-jats.md new file mode 100644 --- /dev/null +++ b/test/command/figures-jats.md @@ -0,0 +1,14 @@ +Figure float with caption at the figure level. + +``` +% pandoc -f native -t jats +[Figure ("fig-id",[],[]) (Caption Nothing [Para [Str "Caption"]]) [Para [Str "Text"], +Para [Image ("fig-id-2",[],[]) [] ("foo.png", "fig:")]]] + +^D + +

Caption

+

Text

+ + +``` diff --git a/test/command/figures-jira.md b/test/command/figures-jira.md new file mode 100644 --- /dev/null +++ b/test/command/figures-jira.md @@ -0,0 +1,9 @@ +A figure with title +``` +% pandoc -f native -t jira +[Figure ("fig-id",[],[("title","This is the title")]) (Caption Nothing []) []] +^D +{panel:title=This is the title} +{anchor:fig-id} +{panel} +``` diff --git a/test/command/figures-latex.md b/test/command/figures-latex.md new file mode 100644 --- /dev/null +++ b/test/command/figures-latex.md @@ -0,0 +1,83 @@ +# Figure with one image, caption and label + +``` +% pandoc -f latex -t native +\begin{document} + \begin{figure} + \includegraphics{../../media/rId25.jpg} + \caption{CAP} + \label{LAB} + \end{figure} +\end{document} +^D +[ Figure + ( "LAB" , [] , [] ) + (Caption Nothing [ Plain [ Str "CAP" ] ]) + [ Plain + [ Image ( "" , [] , [] ) [] ( "../../media/rId25.jpg" , "" ) + ] + ] +] +``` + +# Nested figures + +``` +% pandoc -f latex -t native +\begin{figure} + \begin{subfigure}[b]{0.5\textwidth} + \begin{subfigure}[b]{0.5\textwidth} + \centering + \includegraphics{test/media/rId25.jpg} + \caption{CAP1.1} + \end{subfigure} + \begin{subfigure}[b]{0.5\textwidth} + \centering + \includegraphics{test/media/rId25.jpg} + \caption{CAP1.2} + \end{subfigure} + \caption{CAP1} + \label{fig:inner1} + \end{subfigure} + \begin{subfigure}[b]{0.5\textwidth} + \includegraphics{test/media/rId25.jpg} + \caption{CAP2} + \label{fig:inner2} + \end{subfigure} + \caption{CAP} + \label{fig:outer} +\end{figure} +^D +[ Figure + ( "fig:outer" , [] , [] ) + (Caption Nothing [ Plain [ Str "CAP" ] ]) + [ Figure + ( "fig:inner1" , [] , [] ) + (Caption Nothing [ Plain [ Str "CAP1" ] ]) + [ Figure + ( "" , [] , [] ) + (Caption Nothing [ Plain [ Str "CAP1.1" ] ]) + [ Plain + [ Image + ( "" , [] , [] ) [] ( "test/media/rId25.jpg" , "" ) + ] + ] + , Figure + ( "" , [] , [] ) + (Caption Nothing [ Plain [ Str "CAP1.2" ] ]) + [ Plain + [ Image + ( "" , [] , [] ) [] ( "test/media/rId25.jpg" , "" ) + ] + ] + ] + , Figure + ( "fig:inner2" , [] , [] ) + (Caption Nothing [ Plain [ Str "CAP2" ] ]) + [ Plain + [ Image ( "" , [] , [] ) [] ( "test/media/rId25.jpg" , "" ) + ] + ] + ] +] +``` diff --git a/test/command/figures-markdown.md b/test/command/figures-markdown.md new file mode 100644 --- /dev/null +++ b/test/command/figures-markdown.md @@ -0,0 +1,12 @@ +Figure float with caption at the figure level. + +``` +% pandoc -f native -t markdown +[Figure ("fig-id",[],[]) (Caption Nothing [Para [Str "Caption"]]) [Para [Image ("",[],[]) [] ("foo.png", "fig:")]]] + +^D +
+

+

Caption

+
+``` diff --git a/test/command/figures-mediawiki.md b/test/command/figures-mediawiki.md new file mode 100644 --- /dev/null +++ b/test/command/figures-mediawiki.md @@ -0,0 +1,14 @@ +Figure float with caption at the figure level. + +``` +% pandoc -f native -t mediawiki +[Figure ("fig-id",[],[]) (Caption Nothing [Para [Str "Caption"]]) [Para [Image ("",[],[]) [] ("foo.png", "fig:")]]] + +^D +
+ +[[File:foo.png|thumb|none]] + + +
+``` diff --git a/test/command/figures-org.md b/test/command/figures-org.md new file mode 100644 --- /dev/null +++ b/test/command/figures-org.md @@ -0,0 +1,16 @@ +``` +% pandoc -f native -t org +[Figure ("fig-id",[],[]) (Caption Nothing []) [Para [Str "content"]]] + +^D +<> +content +``` + +``` +% pandoc -f native -t org +[Figure ("",[],[]) (Caption Nothing []) [Para [Str "content"]]] + +^D +content +``` diff --git a/test/command/figures-rst.md b/test/command/figures-rst.md new file mode 100644 --- /dev/null +++ b/test/command/figures-rst.md @@ -0,0 +1,10 @@ +Figure float with caption at the figure level. + +``` +% pandoc -f native -t rst +[Figure ("fig-id",[],[]) (Caption Nothing [Para [Str "Caption"]]) [Para [Image ("",[],[]) [] ("foo.png", "fig:")]]] + +^D +.. figure:: foo.png + :alt: fig: +``` diff --git a/test/command/figures-texinfo.md b/test/command/figures-texinfo.md new file mode 100644 --- /dev/null +++ b/test/command/figures-texinfo.md @@ -0,0 +1,115 @@ +Figure float with caption at the figure level. + +``` +% pandoc -f native -t texinfo +[Figure ("fig-id",[],[]) (Caption Nothing [Para [Str "Caption"]]) [Para [Image ("",[],[]) [] ("foo.png", "fig:")]]] + +^D +@node Top +@top Top + +@float Figure +@image{foo,,,,png} +@caption{Caption} +@end float +``` + +Float that has no caption and doesn't contain a `SimpleFigure` + +``` +% pandoc -f native -t texinfo +[Figure ("fig-id",[],[]) (Caption Nothing []) [Para [Image ("",[],[]) [] ("foo.png", "")]]] + +^D +@node Top +@top Top + +@float +@image{foo,,,,png} +@end float +``` + +Table float with caption at the figure level. + +``` +% pandoc -f native -t texinfo +[Figure ("fig-id",[],[]) (Caption Nothing [Para [Str "Caption"]]) +[Table ("",[],[]) (Caption Nothing + []) + [(AlignDefault,ColWidthDefault) + ,(AlignDefault,ColWidthDefault) + ,(AlignDefault,ColWidthDefault)] + (TableHead ("",[],[]) + [Row ("",[],[]) + [Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1) + [Plain [Str "Fruit"]] + ,Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1) + [Plain [Str "Price"]] + ,Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1) + [Plain [Str "Quantity"]]]]) + [(TableBody ("",[],[]) (RowHeadColumns 0) + [] + [Row ("",[],[]) + [Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1) + [Plain [Str "Apple"]] + ,Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1) + [Plain [Str "25",Space,Str "cents"]] + ,Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1) + [Plain [Str "33"]]] + ,Row ("",[],[]) + [Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1) + [Plain [Str "\"Navel\"",Space,Str "Orange"]] + ,Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1) + [Plain [Str "35",Space,Str "cents"]] + ,Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1) + [Plain [Str "22"]]] + ,Row ("",[],[]) + [Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1) + [] + ,Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1) + [] + ,Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1) + [Plain [Str "45"]]]])] + (TableFoot ("",[],[]) + [])]] + +^D +@node Top +@top Top + +@float Table +@multitable {"Navel" Orange} {35 cents} {Quantity} +@headitem +Fruit + @tab Price + @tab Quantity +@item +Apple + @tab 25 cents + @tab 33 +@item +"Navel" Orange + @tab 35 cents + @tab 22 +@item +45 +@end multitable +@caption{Caption} +@end float +``` + +Float the isn't a table nor a figure. + +``` +% pandoc -f native -t texinfo +[Figure ("fig-id",[],[]) (Caption Nothing [Para[ Str "Caption"]]) [Para [Str "Content"]]] + +^D +@node Top +@top Top + +@float +Content +@caption{Caption} +@end float +``` diff --git a/test/command/figures-textile.md b/test/command/figures-textile.md new file mode 100644 --- /dev/null +++ b/test/command/figures-textile.md @@ -0,0 +1,31 @@ +``` +% pandoc -f native -t textile +[Figure ("fig-id",[],[]) (Caption Nothing [Para [Str "Caption"]]) [Para [Image ("",[],[]) [] ("foo.png", "")]]] + +^D +
+ +
+ +Caption + +
+ +!foo.png! + + +
+``` + +``` +% pandoc -f native -t textile +[Figure ("fig-id",[],[]) (Caption Nothing []) [Para [Image ("",[],[]) [] ("foo.png", "")]]] + +^D +
+ +!foo.png! + + +
+``` diff --git a/test/command/figures-xwiki.md b/test/command/figures-xwiki.md new file mode 100644 --- /dev/null +++ b/test/command/figures-xwiki.md @@ -0,0 +1,10 @@ +``` +% pandoc -f native -t xwiki +[Figure ("fig-id",[],[]) (Caption Nothing []) [Para [Str "content"]]] + +^D +((( +{{id name="fig-id" /}}content + +))) +``` diff --git a/test/command/figures-zimwiki.md b/test/command/figures-zimwiki.md new file mode 100644 --- /dev/null +++ b/test/command/figures-zimwiki.md @@ -0,0 +1,9 @@ +``` +% pandoc -f native -t zimwiki +[Figure ("fig-id",[],[]) (Caption Nothing []) [Para [Str "content"]]] + +^D +content + + +``` diff --git a/test/command/file1.txt b/test/command/file1.txt new file mode 100644 --- /dev/null +++ b/test/command/file1.txt @@ -0,0 +1,9 @@ +# Zed + +[foo]: bar + +[foo] +and [Zed](#zed) +and [other Zed](command/file2.txt#zed) +and [other file](command/file2.txt) +and [foreign Zed](c.md#zed) diff --git a/test/command/file2.txt b/test/command/file2.txt new file mode 100644 --- /dev/null +++ b/test/command/file2.txt @@ -0,0 +1,5 @@ +## Zed + +[foo]: baz + +[foo] diff --git a/test/command/html-read-figure.md b/test/command/html-read-figure.md --- a/test/command/html-read-figure.md +++ b/test/command/html-read-figure.md @@ -5,9 +5,11 @@
bar
^D -[ Para - [ Image - ( "" , [] , [] ) [ Str "bar" ] ( "foo.png" , "fig:voyage" ) +[ Figure + ( "" , [] , [] ) + (Caption Nothing [ Plain [ Str "bar" ] ]) + [ Plain + [ Image ( "" , [] , [] ) [] ( "foo.png" , "voyage" ) ] ] ] ``` @@ -19,9 +21,11 @@ ^D -[ Para - [ Image - ( "" , [] , [] ) [ Str "bar" ] ( "foo.png" , "fig:voyage" ) +[ Figure + ( "" , [] , [] ) + (Caption Nothing [ Plain [ Str "bar" ] ]) + [ Plain + [ Image ( "" , [] , [] ) [] ( "foo.png" , "voyage" ) ] ] ] ``` @@ -32,8 +36,12 @@ ^D -[ Para - [ Image ( "" , [] , [] ) [] ( "foo.png" , "fig:voyage" ) ] +[ Figure + ( "" , [] , [] ) + (Caption Nothing []) + [ Plain + [ Image ( "" , [] , [] ) [] ( "foo.png" , "voyage" ) ] + ] ] ``` @@ -44,9 +52,11 @@
bar
^D -[ Para - [ Image - ( "" , [] , [] ) [ Str "bar" ] ( "foo.png" , "fig:voyage" ) +[ Figure + ( "" , [] , [] ) + (Caption Nothing [ Plain [ Str "bar" ] ]) + [ Para + [ Image ( "" , [] , [] ) [] ( "foo.png" , "voyage" ) ] ] ] ``` @@ -55,11 +65,17 @@ % pandoc -f html -t native
this is ignored
bar baz
^D -[ Para - [ Image - ( "" , [] , [] ) - [ Str "bar" , Space , Strong [ Str "baz" ] ] - ( "foo.png" , "fig:voyage" ) +[ Figure + ( "" , [] , [] ) + (Caption + Nothing + [ Plain [ Str "bar" , Space , Strong [ Str "baz" ] ] ]) + [ Plain + [ Image + ( "" , [] , [] ) + [ Str "this" , Space , Str "is" , Space , Str "ignored" ] + ( "foo.png" , "voyage" ) + ] ] ] ``` diff --git a/test/command/html-writer-a-in-a.md b/test/command/html-writer-a-in-a.md new file mode 100644 --- /dev/null +++ b/test/command/html-writer-a-in-a.md @@ -0,0 +1,7 @@ +a is not allowed inside a in HTML, so we remove links in link text: +``` +% pandoc -f native -t html +[ Link ("",[],[]) [Link ("",[],[]) [Str "Lo"] ("url2","") ] ("url","") ] +^D +Lo +``` diff --git a/test/command/jats-figure-alt-text.md b/test/command/jats-figure-alt-text.md --- a/test/command/jats-figure-alt-text.md +++ b/test/command/jats-figure-alt-text.md @@ -8,11 +8,15 @@ ^D -[ Para - [ Image - ( "fig-1" , [] , [ ( "alt" , "alternative-decription" ) ] ) - [ Str "bar" ] - ( "foo.png" , "fig:" ) +[ Figure + ( "fig-1" , [] , [] ) + (Caption Nothing [ Plain [ Str "bar" ] ]) + [ Div + ( "" , [ "caption" ] , [] ) + [ Header 6 ( "" , [] , [] ) [] , Para [ Str "bar" ] ] + , Plain [ Str "alternative-decription" ] + , Para + [ Image ( "" , [] , [] ) [ Str "baz" ] ( "foo.png" , "" ) ] ] ] ``` diff --git a/test/command/lua-pandoc-state.lua b/test/command/lua-pandoc-state.lua deleted file mode 100644 --- a/test/command/lua-pandoc-state.lua +++ /dev/null @@ -1,11 +0,0 @@ -function report (what, value) - print(string.format('%16s: %s', what, value)) -end -report('# input files', #PANDOC_STATE.input_files) -report('output file', PANDOC_STATE.output_file) -report('# request header', #PANDOC_STATE.request_headers) -report('resource path', table.concat(PANDOC_STATE.resource_path, ', ')) -report('source URL', PANDOC_STATE.source_url) -report('user data dir', PANDOC_STATE.user_data_dir and 'defined' or 'unset') -report('trace', PANDOC_STATE.trace) -report('verbosity', PANDOC_STATE.verbosity) diff --git a/test/command/lua-pandoc-state.md b/test/command/lua-pandoc-state.md deleted file mode 100644 --- a/test/command/lua-pandoc-state.md +++ /dev/null @@ -1,14 +0,0 @@ -``` -% pandoc --lua-filter=command/lua-pandoc-state.lua --data-dir=foo -Hello -^D - # input files: 1 - output file: nil -# request header: 0 - resource path: . - source URL: nil - user data dir: defined - trace: false - verbosity: WARNING -

Hello

-``` diff --git a/test/command/pandoc-citeproc-locators-delimited.md b/test/command/pandoc-citeproc-locators-delimited.md --- a/test/command/pandoc-citeproc-locators-delimited.md +++ b/test/command/pandoc-citeproc-locators-delimited.md @@ -100,7 +100,7 @@ [^6]: Subsequent, p. {(a)}. -[^7]: Ibid-with-locator. +[^7]: Ibid. [^8]: Ibid 123-35 numbers are suffix. diff --git a/test/command/refs.md b/test/command/refs.md --- a/test/command/refs.md +++ b/test/command/refs.md @@ -133,11 +133,12 @@ Figure \ref{fig:Logo} illustrated the SVG logo ^D -[ Para - [ Image - ( "fig:Logo" , [] , [] ) - [ Str "Logo" ] - ( "command/SVG_logo.svg" , "fig:" ) +[ Figure + ( "fig:Logo" , [] , [] ) + (Caption Nothing [ Plain [ Str "Logo" ] ]) + [ Plain + [ Image ( "" , [] , [] ) [] ( "command/SVG_logo.svg" , "" ) + ] ] , Para [ Str "Figure" @@ -195,25 +196,28 @@ Figure \ref{fig:Logo3} illustrated the SVG logo ^D [ Header 1 ( "one" , [] , [] ) [ Str "One" ] -, Para - [ Image - ( "fig:Logo" , [] , [] ) - [ Str "Logo" ] - ( "command/SVG_logo.svg" , "fig:" ) +, Figure + ( "fig:Logo" , [] , [] ) + (Caption Nothing [ Plain [ Str "Logo" ] ]) + [ Plain + [ Image ( "" , [] , [] ) [] ( "command/SVG_logo.svg" , "" ) + ] ] -, Para - [ Image - ( "fig:Logo2" , [] , [] ) - [ Str "Logo2" ] - ( "command/SVG_logo2.svg" , "fig:" ) +, Figure + ( "fig:Logo2" , [] , [] ) + (Caption Nothing [ Plain [ Str "Logo2" ] ]) + [ Plain + [ Image ( "" , [] , [] ) [] ( "command/SVG_logo2.svg" , "" ) + ] ] , Header 1 ( "two" , [] , [] ) [ Str "Two" ] , Header 2 ( "subone" , [] , [] ) [ Str "Subone" ] -, Para - [ Image - ( "fig:Logo3" , [] , [] ) - [ Str "Logo3" ] - ( "command/SVG_logo3.svg" , "fig:" ) +, Figure + ( "fig:Logo3" , [] , [] ) + (Caption Nothing [ Plain [ Str "Logo3" ] ]) + [ Plain + [ Image ( "" , [] , [] ) [] ( "command/SVG_logo3.svg" , "" ) + ] ] , Para [ Str "Figure" diff --git a/test/command/short-caption.md b/test/command/short-caption.md new file mode 100644 --- /dev/null +++ b/test/command/short-caption.md @@ -0,0 +1,42 @@ +``` +% pandoc -f latex -t native +\begin{table} +\caption[short caption]{long caption} +\begin{tabular}{ll} +hi & hi \\ +\end{tabular} +\end{table} +^D +[ Table + ( "" , [] , [] ) + (Caption + (Just [ Str "short" , Space , Str "caption" ]) + [ Plain [ Str "long" , Space , Str "caption" ] ]) + [ ( AlignLeft , ColWidthDefault ) + , ( AlignLeft , ColWidthDefault ) + ] + (TableHead ( "" , [] , [] ) []) + [ TableBody + ( "" , [] , [] ) + (RowHeadColumns 0) + [] + [ Row + ( "" , [] , [] ) + [ Cell + ( "" , [] , [] ) + AlignDefault + (RowSpan 1) + (ColSpan 1) + [ Plain [ Str "hi" ] ] + , Cell + ( "" , [] , [] ) + AlignDefault + (RowSpan 1) + (ColSpan 1) + [ Plain [ Str "hi" ] ] + ] + ] + ] + (TableFoot ( "" , [] , [] ) []) +] +``` diff --git a/test/command/wikilinks_title_after_pipe.md b/test/command/wikilinks_title_after_pipe.md new file mode 100644 --- /dev/null +++ b/test/command/wikilinks_title_after_pipe.md @@ -0,0 +1,73 @@ +# CommonMark + +## Reader +``` +% pandoc --from commonmark_x+wikilinks_title_after_pipe -t html --columns 90 +[[https://example.org]] + +[[https://example.org|title]] + +[[name of page]] + +[[name of page|title]] +^D +

https://example.org

+

title

+

name of page

+

title

+``` + +## Writer + +``` +% pandoc -t commonmark_x+wikilinks_title_after_pipe -f html +

https://example.org

+

title

+

Home

+

Title

+^D +[[https://example.org]] + +[[https://example.org|title]] + +[[Home]] + +[[Name%20of%20page|Title]] +``` + +# Markdown +## Reader + +``` +% pandoc --from markdown+wikilinks_title_after_pipe -t html --columns 90 +[[https://example.org]] + +[[https://example.org|title]] + +[[name of page]] + +[[name of page|title]] +^D +

https://example.org

+

title

+

name of page

+

title

+``` + +## Writer + +``` +% pandoc -t markdown+wikilinks_title_after_pipe -f html +

https://example.org

+

title

+

Home

+

Title

+^D +[[https://example.org]] + +[[https://example.org|title]] + +[[Home]] + +[[Name%20of%20page|Title]] +``` diff --git a/test/command/wikilinks_title_before_pipe.md b/test/command/wikilinks_title_before_pipe.md new file mode 100644 --- /dev/null +++ b/test/command/wikilinks_title_before_pipe.md @@ -0,0 +1,84 @@ +# CommonMark + +## Reader + +``` +% pandoc -f commonmark+wikilinks_title_before_pipe -t html --columns 90 +[[https://example.org]] + +[[title|https://example.org]] + +[[Name of page]] + +[[Title|Name of page]] +^D +

https://example.org

+

title

+

Name of page

+

Title

+``` + +## Writer + +``` +% pandoc -t commonmark_x+wikilinks_title_before_pipe -f html +

https://example.org

+

title

+

Home

+

Title

+^D +[[https://example.org]] + +[[title|https://example.org]] + +[[Home]] + +[[Title|Name%20of%20page]] +``` + +## Regular links should still work + +``` +% pandoc -f commonmark+wikilinks_title_before_pipe -t html +[Title](Name%20of%20page) +^D +

Title

+``` + +# Markdown + +## Reader + +``` +% pandoc -f markdown+wikilinks_title_before_pipe -t html --columns 90 +[[https://example.org]] + +[[title|https://example.org]] + +[[Name of page]] + +[[Title|Name of page]] +^D +

https://example.org

+

title

+

Name of page

+

Title

+``` + +## Writer + +``` +% pandoc -t markdown+wikilinks_title_before_pipe -f html +

https://example.org

+

title

+

Home

+

Title

+^D +[[https://example.org]] + +[[title|https://example.org]] + +[[Home]] + +[[Title|Name%20of%20page]] +``` diff --git a/test/command/yaml-with-chomp.md b/test/command/yaml-with-chomp.md --- a/test/command/yaml-with-chomp.md +++ b/test/command/yaml-with-chomp.md @@ -12,13 +12,7 @@ { unMeta = fromList [ ( "ml" - , MetaInlines - [ Str "TEST" - , Space - , Str "\182" - , Space - , Str "BLOCK" - ] + , MetaInlines [ Str "TEST" , LineBreak , Str "BLOCK" ] ) ] } diff --git a/test/docx/comments.native b/test/docx/comments.native --- a/test/docx/comments.native +++ b/test/docx/comments.native @@ -1,4 +1,4 @@ [Para [Str "I",Space,Str "want",Space,Span ("",["comment-start"],[("id","0"),("author","Jesse Rosenthal"),("date","2016-05-09T16:13:00Z")]) [Str "I",Space,Str "left",Space,Str "a",Space,Str "comment."],Str "some",Space,Str "text",Space,Str "to",Space,Str "have",Space,Str "a",Space,Str "comment",Space,Span ("",["comment-end"],[("id","0")]) [],Str "on",Space,Str "it."] ,Para [Str "This",Space,Str "is",Space,Span ("",["comment-start"],[("id","1"),("author","Jesse Rosenthal"),("date","2016-05-09T16:13:00Z")]) [Str "A",Space,Str "comment",Space,Str "across",Space,Str "paragraphs."],Str "a",Space,Str "new",Space,Str "paragraph."] ,Para [Str "And",Space,Str "so",Span ("",["comment-end"],[("id","1")]) [],Space,Str "is",Space,Str "this."] -,Para [Str "One",Space,Span ("",["comment-start"],[("id","2"),("author","Jesse Rosenthal"),("date","2016-05-09T16:14:00Z")]) [Str "This",Space,Str "one",Space,Str "has",Space,Str "multiple",Space,Str "paragraphs.",Space,Str "\182",Space,Str "See?"],Str "more",Span ("",["comment-end"],[("id","2")]) [],Str ".",Space,Str "And",Space,Str "this",Space,Str "is",Space,Str "one",Space,Str "with",Space,Str "a",Space,Span ("",["comment-start"],[("id","3"),("author","Jesse Rosenthal"),("date","2016-06-22T14:35:00Z")]) [Str "Do",Space,Str "something."],Span ("",["comment-start"],[("id","4"),("author","Jesse Rosenthal"),("date","2016-06-22T14:36:00Z")]) [Str "Do",Space,Str "something",Space,Str "else."],Str "comment",Space,Str "in",Space,Str "a",Space,Str "comment",Span ("",["comment-end"],[("id","3")]) [Span ("",["comment-end"],[("id","4")]) []],Str "."]] +,Para [Str "One",Space,Span ("",["comment-start"],[("id","2"),("author","Jesse Rosenthal"),("date","2016-05-09T16:14:00Z")]) [Str "This",Space,Str "one",Space,Str "has",Space,Str "multiple",Space,Str "paragraphs.",LineBreak, Str "See?"],Str "more",Span ("",["comment-end"],[("id","2")]) [],Str ".",Space,Str "And",Space,Str "this",Space,Str "is",Space,Str "one",Space,Str "with",Space,Str "a",Space,Span ("",["comment-start"],[("id","3"),("author","Jesse Rosenthal"),("date","2016-06-22T14:35:00Z")]) [Str "Do",Space,Str "something."],Span ("",["comment-start"],[("id","4"),("author","Jesse Rosenthal"),("date","2016-06-22T14:36:00Z")]) [Str "Do",Space,Str "something",Space,Str "else."],Str "comment",Space,Str "in",Space,Str "a",Space,Str "comment",Span ("",["comment-end"],[("id","3")]) [Span ("",["comment-end"],[("id","4")]) []],Str "."]] diff --git a/test/docx/deep_normalize.native b/test/docx/deep_normalize.native --- a/test/docx/deep_normalize.native +++ b/test/docx/deep_normalize.native @@ -3,4 +3,4 @@ ,OrderedList (1,LowerAlpha,DefaultDelim) [[Para [Str "This",Space,Str "is",Space,Str "at",Space,Str "the",Space,Str "second",Space,Str "level"] ,OrderedList (1,LowerRoman,DefaultDelim) - [[Para [Str "This",Space,Str "is",Space,Emph [Str "at",Space,Strong [Str "the",Space,Str "third",Space,Str "level"],Str ",",Space,Str "and",Space,Str "I",Space,Str "want",Space,Str "to"],Space,Str "test",Space,Str "normalization",Space,Str "here."]]]]]]]] + [[Para [Str "This",Space,Str "is",Space,Emph [Str "at",Space,Strong [Str "the",Space,Span ("",["mark"],[]) [Str "th"],Str "i",Span ("",["mark"],[]) [Str "rd"],Space,Str "level"],Str ",",Space,Str "and",Space,Str "I",Space,Str "want",Space,Str "to"],Space,Str "test",Space,Str "normalization",Space,Str "here."]]]]]]]] diff --git a/test/docx/golden/comments.docx b/test/docx/golden/comments.docx Binary files a/test/docx/golden/comments.docx and b/test/docx/golden/comments.docx differ diff --git a/test/docx/golden/image.docx b/test/docx/golden/image.docx Binary files a/test/docx/golden/image.docx and b/test/docx/golden/image.docx differ diff --git a/test/fb2/images-embedded.fb2 b/test/fb2/images-embedded.fb2 --- a/test/fb2/images-embedded.fb2 +++ b/test/fb2/images-embedded.fb2 @@ -1,2 +1,2 @@ -unrecognisedpandoc<p />
This image was embedded using data URI scheme

This image was embedded using data URI scheme

iVBORw0KGgoAAAANSUhEUgAAADAAAAAgCAIAAADbtmxLAAABmGlDQ1BpY2MAAHjapdG/axMBGMbxTy4tldJSwSAiHW4ootKCqIOrVShIkRIrJNUluUvaQi4Nd1dEXAQHF4cOXVRcLOLirJv4BygIggqCi7sUBRcpcbiDgtBBfOGF5/315eV9qR7qRUk2EpL087S+MB82mivh2BeBcUcddrwVZYOLS0uLDrRfH1Xgw1wvSjL/ZpNxJ4uohFiKBmlOZYC7t/JBTmUXtWitFROMYDZtNFcIzqDWLvRl1FYL3UAtXa5fIughXC30A4TtQr9AGK2lCcFbzMRJPybYxWScxDFVGE16m1G5ZwUTnf71aziPaXUsYB4h2tjEOnrIMVfG/QJyAC/GtKvYKFlRqQe4jbTkrGKtZM+WvZvI0CnjbtnfKb1XMtBoroR//yzrnjtbbDRxhdFvw+HP04w9Zu/+cPj76XC4t0P1M2+29+c3trnwnerWfm7mCVP3ePl6P9d+xqstjn0dtNIWitMG3S4/njPZ5Mh7xm/8b734Z1m384nlOyy+4+EjTnSZunkyzsP1ft5J+63eKWT1hXn4AzDofghlJQBJAAAACXBIWXMAAAsSAAALEgHS3X78AAACInpUWHRSYXcgcHJvZmlsZSB0eXBlIGV4aWYAAHjahVRJtiQhCNx7ijpCMIhyHNPU9/oGffxeaNY3p/5VC5IAQkAhtL9/evh8Pp+PiwaNKZubAYDuugNcMH4ZIAN6A6ATo68kdAA8VQ1DkoEIq2EILiBiALIQDTISWvz3SSQNJHwnilWTGgC/ZMSa1Fc8TDznZH4rgWOtRrwQKGh8VyNZ8bAY9Ccj1EGXUI0JwNE3n3itxrzis7Sq1TgBiNMwesKo1TjfcdZqXBaiWRpLrcbbEjBLU63G9QGv1bit+CSKWi2W8+3QLDluF/wIBgBEaNQWNSjFzHj7/zgOP92EBap3v2BqlNi2pEbGVi0yBNwkcRPiTVxIJDVLRgJxEXGLRgAgLBASkiIIwlIEYgyBJCnC4lKExN6yGSW6SD961nvvQaxhBZq4rbptbX1HlJPSokN37t9m9957a5utDux7Xwk06WnWWOJ2yqgkPqW4e2urnmNPK0HMtq0Hkkc7ZbSXUleHiNMIoGy7r/ppEwAIV+Amv1rS/3ghgCz23ns+m/HrASdJMWT2chsBiS2z73fcLGd+3E8hZ05nQ81zzOW2n8Saj1VzwTMHZ+g6xcPg5ozLASM7Z/hl9kaPnPFQmrcyvm8lFKbrAQwAoegtYFy34rEXRSFP/qEo4tmQ0wywlwPyG5G/BJQXvF5wOR4k7m9HjlupR/y6Mp42RjhWxm+Oh99BvMrwD3UCiGvkpxuRAAAACXZwQWcAAAAwAAAAIACELJ4GAAALGklEQVRYw11YW48dV1b+1tq7qs6t+/TldPsSx3bbcRwncWY0A4LMCOYFXpgHJCR4QvwAnpAQj/wB/gR/ACR4QUKDECMUEjLOZew4zsRxuu122+52n9Pnfuqy9/p4qNNtD1tLpVKpap/vrMu31rdl/nAgIjSpF0kAJAEHGJwAAIQheqeARVqomCQZGUkjSYLmTAyAkCJiESRVNYQAaL3h8k3SzPj6MjEzsr7SqyoAcRABQItRVZ14kqifmNEkTZNiUZiZ934xm4WE3mva8GYGAA5UJ8YYIyCipiKk1ZuTBAhQBGZQFRKvTAgBaQBIeOekBqpa+0gBxFgAlmhqhixJzUKMRVEUx/3RWmel3z9xzrVX2+tuRb3WnrDKVFUEgKlCVWI055WMZ76AieipX0AYzYwQUZqZqJD0tKCqFJAxhKiqSZKooirj06fPMt/odlezhngFYar+0e7jxWLR6/Vc7ubzpNnM4BlDSDLvvQ8hnAYFIlCFRUDEjASgIGFGEcBIoSrMCFAVhgiKTxJPkgJVSeBBhKqaTCb5Ip4cD/efPP/g9q2soSvdTp7nAuv2Vk/2BoHFyWgRYxVjbDezRiMDMicNxqCqqhIZVZxZVK3zaRkgXYaMdeDMoMoapSpo8GSE1t6ihaCqPs3WV/VwPpxOp8fHRw++cUmq7XYzSbLV1W5vu3fw7Emn0xwcD+ZzF8vKQtlI09R7J6SXOldgEDEwAmdguMyYV/lEVWEkARExEkoVBxHWxeUSFefK6fTJ48dlme/sXN7a3vjVnf8NIQ6Hk1ajOZ+Nf/3ZZ9Uij0V+fedqM0v2nz5ut7LtCz1GC2WVJqmry1KgZKLqlbo0qLPanJrAVKgSRX/LPElxQF0smiDy6Ojo7pd3qXLjxo2r1y8fnwxORpN8Nt/u9fLF5OTFcRVKDWE0HJZF2O71IsOzZ0+e7D3tdDo7168miU9SJ6IhBIGD2KuKMpHaPwoFXkXq9Aak+/u//TsFRCEgEAljjFtbW+UiHPb765sbJ8M+Y9HtdAbDgWs0pSge7O1u9Tar+Xwwmy0m03I0XpgbjydZlk2n43armaVOJIqQDEIIIKBABK/iBYuAnT4HwJrx1CkhRosAIRBBo93ImunO25dv/eBmb231+rUrRTH/we1ba+udhw/uSoZGOzt38Vx/1D85folYLhazqpg3mj5ruNWVTqPhxcEsAOa8ihJiAhMEQVChCgXmhKcWT41O6IGq5kCjqPOTk9F4PF7rrlvKRtQHjx/d2Lk+mgy+evrwhzs3Xuzv0tmbb5z79LNPzm9utdorEoNkzPPx+x+812o10tR7DyCqUwCMQUUIUqm2JOolbb/GjmbwoDGS9GZBnYM4IS0E5+TChS1Nk7Z28uPhW29euvPRf2fN1pdffNE1vXnzxsGgf/B036duvbce5tXG2uZkfnL79q3t8+sA4Rws0CJIAOI8LADUusLqeC0rTl4RJgyg1Fe+fB7yUrxTQoRWVoExbWTjl6P5fD7dO6yIF4P+bDK/92T3hzffLWGffPq5c7K1uf7hj3+PrLqbqxffuDQc9VdWVtY31846l1CFqJlalk8gr/UxAIzLLrZkbVK5WHgHhFIYmS+K6ZhFkY/Hi/5gPOhLUzvnu73L59KVxjyffXH314vFIsbYaTXeuXFtcHx4sPd9S+3l84PMwTsyBrMgQhUIgrEUREWUU4O8uhcLdW45BsWpiVRgoSyYTxYn/ee7e9/f/2Z8eOwYm8pko4EktDvpzOZXL5z3Dd3b2/vi/r1G0795cat//GxrvWPTaW+lvdVdXUkTCaVagAUrF6wKVSAGxIAQJEZYiVjSSrBSq4SVWCFWKINYpQzK4FHmhqjOgbF/+Hx0dJyXtv/46ZuXtrrd1V6ruRhNJqPZlfbq5999/Dt/+LNf/tf/nEyH585t73338OrVS3E8Pnl+MJnOi7i4fG1no7cJ79Sh7vPISwCwZYCERN3TjQCFZFxGE3FJV97iXCGIKBZlcyV799zbIdhsNnvyaP/x3r6Z+Tx02i6Kv/7WO8bFX/3ZT37xyZ2yf9Ta2n73vZ1vf/Xlv338+R/97MOVjc63X99fbXduvfuONBJTAlDxiBGAWKQZSVn2BZ4lDYwAlDQzkF7LEmYQyUSTdkvTzNuiZLz25vlOt3N0cPTwxcH7W2/9+NbN0Uef3Pvs6w/+9KcraePb3+z+6NKF+cHLvvN/89d/2SQsTSdr3clwMh0M1nvr0ki4yI0iQgBSu8dYOwxm4BIEyTrTEY1mHrNpZD3KiMIhlLEokljKWueyytsX3ji/2rqzuzt4Obh95eLd3+ztf7Xv1e2sp8OXw73h8Od//FNNtIh5Rqx322tZWoWimo1c7hQi4mgBxtPpA3VBkXQ0M8BOh5VoS3D8j3+CACqsR4EYzUyIalqaCqCxyIsB/uFf//lPfv93R/2jf/z4m0Zmf/6j977af/wXH/7B6ubK+dVV2+g6D0Yzg4OoA0kRrYoiEXcarFfzq7IueJKsYZktAXl7MRURiARakiQ08xAACHCGybj/i3v3ZoNyDa3/vPPg59cuf/fi4GKjPRmH99cuHT5+Ouv3ipV5b2ve2lxRdfPJLMa4ttKxEEl68ZH52bh4xkDhbLI2OYNiBpL+cHfmnKvfq2nf+eWXi2L+6PgQh42nk+GVc1uf7h9+f1T8ZOftXz76flu7L07Gs7FttCYvknH74PiDt24kjWa/PyvLElupJ2OMZFXBROS3hnoz8sxBS9+YYemhrw9L55xCFCYSalgR7Ehy/+DFnChC0kq3m37j9nr2L7uPnrw8UBb//t2emGsnybW8OW9M3uhc+fbprNWW0Qwh6MwKAQGEEIhlpccYSVLl/wkPM4unqEj6+7MyUZeIpj6pRxOJjDGO5qNpbNLsWTiSyt/dex5mR1Ui+9Phxe72w+moI1mmViSbG7xQNNpHlrhKBnkkcbIwi5WZGegpgMYYq6oCoKoiamZAfB1TWCoq+o/2DxzEiU/TNHXeBCGEqqqKGKGIDPOFTedDY8x8M5HEIRlXi5D7TtrsVpv5cDbZyB69eL7a6IjIfD6NNBHJy1A3tcRJCOV4Nmq1OiqZUgFznonzZVWIECoqXjWpijJGevVipFkZqipYKt6JE1XXjj5tJHk+n41jptrtrifqptNpq9WaTMcqyXon9VlqxHgyi5GjWa6qeZ5DJcsyM6OomVm04WQwnY3XIGkCQGEhzktjORoN8yp3zqVpI0lSUNXB59OhiChE1RdaSK0XSTNqoSSbmQe8F8Bi4jRN00WRr3TY7jSzJAEAQZIkCBUQo1aqmtSTHmJkrGApQtu7lodKKXDQGCyaaJo4mgeAEEPM667sd59/dyoQpUYDUQBCpZiqqmrNIgCEIKlgWS1OTl4OYl9gRoo40VgrRhGpP0G9qMZgFieTKgaKOFXQgolaCE7MBOrgnEO0aKWfLI7rWRaAnC4ATv3ZpiLiVQFYoCmzLAuhHI5eMsInIBkNUXTZUAERAVlvFSrziZoZFxOaaK3HAJOw1K9ArQXKMl/MJ7Ld6Z0l/1m86qMCGEXEe7+EW0+g4iFljCHxLQGcWq0NUp/Ur52K+Vc3ohrrFrs8PzhlJgBiKt7MYoxVKIpiIRudtdc9QSxheTPnHIAYCaNzTlXNzKg+YWRQpgKQRjGIB8Pyb0BJnv1ikFoYOwBEBKAEqFQlaRalFtqkc440n3IZrNp7Z4LExMpgy4SAVBaFVp9zhBCIaBQnDqhPSQgKIAJPksal+AG8ogpRnQCIUVRFoSEE9QIaLNCpqiPFQUK0/wPxadi/ncvxsAAAACV0RVh0ZGF0ZTpjcmVhdGUAMjAxMS0wMi0yOFQwMjo1NTowMiswMTowMGbLlncAAAAldEVYdGRhdGU6bW9kaWZ5ADIwMTEtMDItMjhUMDI6NTU6MDIrMDE6MDAXli7LAAAAEXRFWHRqcGVnOmNvbG9yc3BhY2UAMix1VZ8AAAAgdEVYdGpwZWc6c2FtcGxpbmctZmFjdG9yADF4MSwxeDEsMXgx6ZX8cAAAAABJRU5ErkJggg== +unrecognisedpandoc<p />
This image was embedded using data URI scheme

This image was embedded using data URI scheme

iVBORw0KGgoAAAANSUhEUgAAADAAAAAgCAIAAADbtmxLAAABmGlDQ1BpY2MAAHjapdG/axMBGMbxTy4tldJSwSAiHW4ootKCqIOrVShIkRIrJNUluUvaQi4Nd1dEXAQHF4cOXVRcLOLirJv4BygIggqCi7sUBRcpcbiDgtBBfOGF5/315eV9qR7qRUk2EpL087S+MB82mivh2BeBcUcddrwVZYOLS0uLDrRfH1Xgw1wvSjL/ZpNxJ4uohFiKBmlOZYC7t/JBTmUXtWitFROMYDZtNFcIzqDWLvRl1FYL3UAtXa5fIughXC30A4TtQr9AGK2lCcFbzMRJPybYxWScxDFVGE16m1G5ZwUTnf71aziPaXUsYB4h2tjEOnrIMVfG/QJyAC/GtKvYKFlRqQe4jbTkrGKtZM+WvZvI0CnjbtnfKb1XMtBoroR//yzrnjtbbDRxhdFvw+HP04w9Zu/+cPj76XC4t0P1M2+29+c3trnwnerWfm7mCVP3ePl6P9d+xqstjn0dtNIWitMG3S4/njPZ5Mh7xm/8b734Z1m384nlOyy+4+EjTnSZunkyzsP1ft5J+63eKWT1hXn4AzDofghlJQBJAAAACXBIWXMAAAsSAAALEgHS3X78AAACInpUWHRSYXcgcHJvZmlsZSB0eXBlIGV4aWYAAHjahVRJtiQhCNx7ijpCMIhyHNPU9/oGffxeaNY3p/5VC5IAQkAhtL9/evh8Pp+PiwaNKZubAYDuugNcMH4ZIAN6A6ATo68kdAA8VQ1DkoEIq2EILiBiALIQDTISWvz3SSQNJHwnilWTGgC/ZMSa1Fc8TDznZH4rgWOtRrwQKGh8VyNZ8bAY9Ccj1EGXUI0JwNE3n3itxrzis7Sq1TgBiNMwesKo1TjfcdZqXBaiWRpLrcbbEjBLU63G9QGv1bit+CSKWi2W8+3QLDluF/wIBgBEaNQWNSjFzHj7/zgOP92EBap3v2BqlNi2pEbGVi0yBNwkcRPiTVxIJDVLRgJxEXGLRgAgLBASkiIIwlIEYgyBJCnC4lKExN6yGSW6SD961nvvQaxhBZq4rbptbX1HlJPSokN37t9m9957a5utDux7Xwk06WnWWOJ2yqgkPqW4e2urnmNPK0HMtq0Hkkc7ZbSXUleHiNMIoGy7r/ppEwAIV+Amv1rS/3ghgCz23ns+m/HrASdJMWT2chsBiS2z73fcLGd+3E8hZ05nQ81zzOW2n8Saj1VzwTMHZ+g6xcPg5ozLASM7Z/hl9kaPnPFQmrcyvm8lFKbrAQwAoegtYFy34rEXRSFP/qEo4tmQ0wywlwPyG5G/BJQXvF5wOR4k7m9HjlupR/y6Mp42RjhWxm+Oh99BvMrwD3UCiGvkpxuRAAAACXZwQWcAAAAwAAAAIACELJ4GAAALGklEQVRYw11YW48dV1b+1tq7qs6t+/TldPsSx3bbcRwncWY0A4LMCOYFXpgHJCR4QvwAnpAQj/wB/gR/ACR4QUKDECMUEjLOZew4zsRxuu122+52n9Pnfuqy9/p4qNNtD1tLpVKpap/vrMu31rdl/nAgIjSpF0kAJAEHGJwAAIQheqeARVqomCQZGUkjSYLmTAyAkCJiESRVNYQAaL3h8k3SzPj6MjEzsr7SqyoAcRABQItRVZ14kqifmNEkTZNiUZiZ934xm4WE3mva8GYGAA5UJ8YYIyCipiKk1ZuTBAhQBGZQFRKvTAgBaQBIeOekBqpa+0gBxFgAlmhqhixJzUKMRVEUx/3RWmel3z9xzrVX2+tuRb3WnrDKVFUEgKlCVWI055WMZ76AieipX0AYzYwQUZqZqJD0tKCqFJAxhKiqSZKooirj06fPMt/odlezhngFYar+0e7jxWLR6/Vc7ubzpNnM4BlDSDLvvQ8hnAYFIlCFRUDEjASgIGFGEcBIoSrMCFAVhgiKTxJPkgJVSeBBhKqaTCb5Ip4cD/efPP/g9q2soSvdTp7nAuv2Vk/2BoHFyWgRYxVjbDezRiMDMicNxqCqqhIZVZxZVK3zaRkgXYaMdeDMoMoapSpo8GSE1t6ihaCqPs3WV/VwPpxOp8fHRw++cUmq7XYzSbLV1W5vu3fw7Emn0xwcD+ZzF8vKQtlI09R7J6SXOldgEDEwAmdguMyYV/lEVWEkARExEkoVBxHWxeUSFefK6fTJ48dlme/sXN7a3vjVnf8NIQ6Hk1ajOZ+Nf/3ZZ9Uij0V+fedqM0v2nz5ut7LtCz1GC2WVJqmry1KgZKLqlbo0qLPanJrAVKgSRX/LPElxQF0smiDy6Ojo7pd3qXLjxo2r1y8fnwxORpN8Nt/u9fLF5OTFcRVKDWE0HJZF2O71IsOzZ0+e7D3tdDo7168miU9SJ6IhBIGD2KuKMpHaPwoFXkXq9Aak+/u//TsFRCEgEAljjFtbW+UiHPb765sbJ8M+Y9HtdAbDgWs0pSge7O1u9Tar+Xwwmy0m03I0XpgbjydZlk2n43armaVOJIqQDEIIIKBABK/iBYuAnT4HwJrx1CkhRosAIRBBo93ImunO25dv/eBmb231+rUrRTH/we1ba+udhw/uSoZGOzt38Vx/1D85folYLhazqpg3mj5ruNWVTqPhxcEsAOa8ihJiAhMEQVChCgXmhKcWT41O6IGq5kCjqPOTk9F4PF7rrlvKRtQHjx/d2Lk+mgy+evrwhzs3Xuzv0tmbb5z79LNPzm9utdorEoNkzPPx+x+812o10tR7DyCqUwCMQUUIUqm2JOolbb/GjmbwoDGS9GZBnYM4IS0E5+TChS1Nk7Z28uPhW29euvPRf2fN1pdffNE1vXnzxsGgf/B036duvbce5tXG2uZkfnL79q3t8+sA4Rws0CJIAOI8LADUusLqeC0rTl4RJgyg1Fe+fB7yUrxTQoRWVoExbWTjl6P5fD7dO6yIF4P+bDK/92T3hzffLWGffPq5c7K1uf7hj3+PrLqbqxffuDQc9VdWVtY31846l1CFqJlalk8gr/UxAIzLLrZkbVK5WHgHhFIYmS+K6ZhFkY/Hi/5gPOhLUzvnu73L59KVxjyffXH314vFIsbYaTXeuXFtcHx4sPd9S+3l84PMwTsyBrMgQhUIgrEUREWUU4O8uhcLdW45BsWpiVRgoSyYTxYn/ee7e9/f/2Z8eOwYm8pko4EktDvpzOZXL5z3Dd3b2/vi/r1G0795cat//GxrvWPTaW+lvdVdXUkTCaVagAUrF6wKVSAGxIAQJEZYiVjSSrBSq4SVWCFWKINYpQzK4FHmhqjOgbF/+Hx0dJyXtv/46ZuXtrrd1V6ruRhNJqPZlfbq5999/Dt/+LNf/tf/nEyH585t73338OrVS3E8Pnl+MJnOi7i4fG1no7cJ79Sh7vPISwCwZYCERN3TjQCFZFxGE3FJV97iXCGIKBZlcyV799zbIdhsNnvyaP/x3r6Z+Tx02i6Kv/7WO8bFX/3ZT37xyZ2yf9Ta2n73vZ1vf/Xlv338+R/97MOVjc63X99fbXduvfuONBJTAlDxiBGAWKQZSVn2BZ4lDYwAlDQzkF7LEmYQyUSTdkvTzNuiZLz25vlOt3N0cPTwxcH7W2/9+NbN0Uef3Pvs6w/+9KcraePb3+z+6NKF+cHLvvN/89d/2SQsTSdr3clwMh0M1nvr0ki4yI0iQgBSu8dYOwxm4BIEyTrTEY1mHrNpZD3KiMIhlLEokljKWueyytsX3ji/2rqzuzt4Obh95eLd3+ztf7Xv1e2sp8OXw73h8Od//FNNtIh5Rqx322tZWoWimo1c7hQi4mgBxtPpA3VBkXQ0M8BOh5VoS3D8j3+CACqsR4EYzUyIalqaCqCxyIsB/uFf//lPfv93R/2jf/z4m0Zmf/6j977af/wXH/7B6ubK+dVV2+g6D0Yzg4OoA0kRrYoiEXcarFfzq7IueJKsYZktAXl7MRURiARakiQ08xAACHCGybj/i3v3ZoNyDa3/vPPg59cuf/fi4GKjPRmH99cuHT5+Ouv3ipV5b2ve2lxRdfPJLMa4ttKxEEl68ZH52bh4xkDhbLI2OYNiBpL+cHfmnKvfq2nf+eWXi2L+6PgQh42nk+GVc1uf7h9+f1T8ZOftXz76flu7L07Gs7FttCYvknH74PiDt24kjWa/PyvLElupJ2OMZFXBROS3hnoz8sxBS9+YYemhrw9L55xCFCYSalgR7Ehy/+DFnChC0kq3m37j9nr2L7uPnrw8UBb//t2emGsnybW8OW9M3uhc+fbprNWW0Qwh6MwKAQGEEIhlpccYSVLl/wkPM4unqEj6+7MyUZeIpj6pRxOJjDGO5qNpbNLsWTiSyt/dex5mR1Ui+9Phxe72w+moI1mmViSbG7xQNNpHlrhKBnkkcbIwi5WZGegpgMYYq6oCoKoiamZAfB1TWCoq+o/2DxzEiU/TNHXeBCGEqqqKGKGIDPOFTedDY8x8M5HEIRlXi5D7TtrsVpv5cDbZyB69eL7a6IjIfD6NNBHJy1A3tcRJCOV4Nmq1OiqZUgFznonzZVWIECoqXjWpijJGevVipFkZqipYKt6JE1XXjj5tJHk+n41jptrtrifqptNpq9WaTMcqyXon9VlqxHgyi5GjWa6qeZ5DJcsyM6OomVm04WQwnY3XIGkCQGEhzktjORoN8yp3zqVpI0lSUNXB59OhiChE1RdaSK0XSTNqoSSbmQe8F8Bi4jRN00WRr3TY7jSzJAEAQZIkCBUQo1aqmtSTHmJkrGApQtu7lodKKXDQGCyaaJo4mgeAEEPM667sd59/dyoQpUYDUQBCpZiqqmrNIgCEIKlgWS1OTl4OYl9gRoo40VgrRhGpP0G9qMZgFieTKgaKOFXQgolaCE7MBOrgnEO0aKWfLI7rWRaAnC4ATv3ZpiLiVQFYoCmzLAuhHI5eMsInIBkNUXTZUAERAVlvFSrziZoZFxOaaK3HAJOw1K9ArQXKMl/MJ7Ld6Z0l/1m86qMCGEXEe7+EW0+g4iFljCHxLQGcWq0NUp/Ur52K+Vc3ohrrFrs8PzhlJgBiKt7MYoxVKIpiIRudtdc9QSxheTPnHIAYCaNzTlXNzKg+YWRQpgKQRjGIB8Pyb0BJnv1ikFoYOwBEBKAEqFQlaRalFtqkc440n3IZrNp7Z4LExMpgy4SAVBaFVp9zhBCIaBQnDqhPSQgKIAJPksal+AG8ogpRnQCIUVRFoSEE9QIaLNCpqiPFQUK0/wPxadi/ncvxsAAAACV0RVh0ZGF0ZTpjcmVhdGUAMjAxMS0wMi0yOFQwMjo1NTowMiswMTowMGbLlncAAAAldEVYdGRhdGU6bW9kaWZ5ADIwMTEtMDItMjhUMDI6NTU6MDIrMDE6MDAXli7LAAAAEXRFWHRqcGVnOmNvbG9yc3BhY2UAMix1VZ8AAAAgdEVYdGpwZWc6c2FtcGxpbmctZmFjdG9yADF4MSwxeDEsMXgx6ZX8cAAAAABJRU5ErkJggg== diff --git a/test/ipynb/simple.out.native b/test/ipynb/simple.out.native --- a/test/ipynb/simple.out.native +++ b/test/ipynb/simple.out.native @@ -83,7 +83,7 @@ , Image ( "" , [] , [] ) [ Str "the" , Space , Str "moon" ] - ( "lalune.jpg" , "" ) + ( "uid6-lalune.jpg" , "" ) , Space , Str "will" , Space diff --git a/test/lhs-test.html b/test/lhs-test.html --- a/test/lhs-test.html +++ b/test/lhs-test.html @@ -7,9 +7,6 @@ lhs-test - -

Multiline:

- - - - - -

Code block:

- -
<!-- Comment -->
- -

Just plain comment, with trailing spaces on the line:

- - - -

Code:

- -
<hr />
- -

Hr’s:

- -
- -
- -
- -
- -
- -
- -
- -
- -
- -
- -

Inline Markup

- -

This is emphasized, and so is this.

- -

This is strong, and so is this.

- -

An emphasized link.

- -

This is strong and em.

- -

So is this word.

- -

This is strong and em.

- -

So is this word.

- -

This is code: >, $, \, \$, <html>.

- -

This is strikeout.

- -

Superscripts: abcd ahello ahello there.

- -

Subscripts: H2O, H23O, Hmany of themO.

- -

These should not be superscripts or subscripts, -because of the unescaped spaces: a^b c^d, a~b c~d.

- -
- -

Smart quotes, ellipses, dashes

- -

“Hello,” said the spider. “‘Shelob’ is my name.”

- -

‘A’, ‘B’, and ‘C’ are letters.

- -

‘Oak,’ ‘elm,’ and ‘beech’ are names of trees. -So is ‘pine.’

- -

‘He said, “I want to go.”’ Were you alive in the -70’s?

- -

Here is some quoted ‘code’ and a “quoted link”.

- -

Some dashes: one—two — three—four — five.

- -

Dashes between numbers: 5–7, 255–66, 1987–1999.

- -

Ellipses…and…and….

- -
- -

LaTeX

- -
    -
  • -
  • \(2+2=4\)
    • -
  • \(x \in y\)
    • -
  • \(\alpha \wedge \omega\)
    • -
  • \(223\)
    • -
  • \(p\)-Tree
    • -
  • Here’s some display math: -\[\frac{d}{dx}f(x)=\lim_{h\to 0}\frac{f(x+h)-f(x)}{h}\]
    • -
  • Here’s one that has a line break in it: \(\alpha + \omega \times x^2\).
    • -
- -

These shouldn’t be math:

- -
    -
  • To get the famous equation, write $e = mc^2$.
    • -
  • $22,000 is a lot of money. So is $34,000. -(It worked if “lot” is emphasized.)
    • -
  • Shoes ($20) and socks ($5).
    • -
  • Escaped $: $73 this should be emphasized 23$.
    • -
- -

Here’s a LaTeX table:

- - - -
- -

Special Characters

- -

Here is some unicode:

- -
    -
  • I hat: Î
    • -
  • o umlaut: ö
    • -
  • section: §
    • -
  • set membership: ∈
    • -
  • copyright: ©
    • -
- -

AT&T has an ampersand in their name.

- -

AT&T is another way to write it.

- -

This & that.

- -

4 < 5.

- -

6 > 5.

- -

Backslash: \

- -

Backtick: `

- -

Asterisk: *

- -

Underscore: _

- -

Left brace: {

- -

Right brace: }

- -

Left bracket: [

- -

Right bracket: ]

- -

Left paren: (

- -

Right paren: )

- -

Greater-than: >

- -

Hash: #

- -

Period: .

- -

Bang: !

- -

Plus: +

- -

Minus: -

- -
- -

Links

- -

Explicit

- -

Just a URL.

- -

URL and title.

- -

URL and title.

- -

URL and title.

- -

URL and title

- -

URL and title

- -

with_underscore

- -

Email link

- -

Empty.

- -

Reference

- -

Foo bar.

- -

With embedded [brackets].

- -

b by itself should be a link.

- -

Indented once.

- -

Indented twice.

- -

Indented thrice.

- -

This should [not][] be a link.

- -
[not]: /url
- -

Foo bar.

- -

Foo biz.

- -

With ampersands

- -

Here’s a link with an ampersand in the URL.

- -

Here’s a link with an amersand in the link text: AT&T.

- -

Here’s an inline link.

- -

Here’s an inline link in pointy braces.

- - - -

With an ampersand: http://example.com/?foo=1&bar=2

- - - -

An e-mail address:

- -
-

Blockquoted: http://example.com/

-
- -

Auto-links should not occur here: <http://example.com/>

- -
or here: <http://example.com/>
- -
- -

Images

- -

From “Voyage dans la Lune” by Georges Melies (1902):

- -
-lalune
lalune
-
- -

Here is a movie icon.

- -
- -

Footnotes

- -

Here is a footnote reference,1 and another.2 -This should not be a footnote reference, because it -contains a space.[^my note] Here is an inline note.3

- -
-

Notes can go in quotes.4

-
- -
    -
  1. And in list items.5
    2. -
- -

This paragraph should not be part of the note, as it is not indented.

-
    -

  1. Here is the footnote. It can go anywhere after the footnote -reference. It need not be placed at the end of the document. ↩

    2. -

  2. Here’s the long note. This one contains multiple -blocks.

    - -

    Subsequent blocks are indented to show that they belong to the -footnote (as with list items).

    - -
      { <code> }
    - -

    If you want, you can indent every line, but you can also be -lazy and just indent the first line of each block. ↩

    3. -

  3. This -is easier to type. Inline notes may contain -links and ] verbatim characters, -as well as [bracketed text]. ↩

    4. -

  4. In quote. ↩

    5. -

  5. In list. ↩

    6. -
diff --git a/test/writer.docbook4 b/test/writer.docbook4 --- a/test/writer.docbook4 +++ b/test/writer.docbook4 @@ -1358,6 +1358,9 @@ + + movie + icon. diff --git a/test/writer.docbook5 b/test/writer.docbook5 --- a/test/writer.docbook5 +++ b/test/writer.docbook5 @@ -1333,6 +1333,9 @@ + + movie + icon. diff --git a/test/writer.dokuwiki b/test/writer.dokuwiki --- a/test/writer.dokuwiki +++ b/test/writer.dokuwiki @@ -619,7 +619,9 @@ From “Voyage dans la Lune” by Georges Melies (1902): -{{lalune.jpg|Voyage dans la Lune lalune}} +{{lalune.jpg|Voyage dans la Lune}} +lalune + Here is a movie {{movie.jpg|movie}} icon. diff --git a/test/writer.haddock b/test/writer.haddock --- a/test/writer.haddock +++ b/test/writer.haddock @@ -614,6 +614,7 @@ From “Voyage dans la Lune” by Georges Melies (1902): <> +lalune Here is a movie <> icon. diff --git a/test/writer.html4 b/test/writer.html4 --- a/test/writer.html4 +++ b/test/writer.html4 @@ -10,9 +10,6 @@ Pandoc Test Suite - - -
-
-
-

Try pandoc!

-
-
- 

-    

-  

-  

-    

-      
-       
-      
-      

-      
-      
-      

-      
-      

-      
-      
-
-    

-    

-      
-      
-      
-      
-      
-      
-      

-      

-      

-    

-  

-

-

- 
pandoc version 

-

-
-
-
-
-
diff --git a/trypandoc/trypandoc.js b/trypandoc/trypandoc.js
deleted file mode 100644
--- a/trypandoc/trypandoc.js
+++ /dev/null
@@ -1,166 +0,0 @@
-"use strict";
-
-var params = {
-  text: '"hello *world*"',
-  to: 'html5',
-  from: 'markdown',
-  standalone: false,
-  citeproc: false };
-
-function permalink() {
-  let input = document.getElementById("text").value;
-  let from = document.getElementById("from").value;
-  let to = document.getElementById("to").value;
-  let standalone = document.getElementById("standalone").checked ? true : false;
-  let citeproc = document.getElementById("citeproc").checked ? true : false;
-  let href = window.location.href;
-  const URLparams = new URLSearchParams(Object.entries({text: input, from: from, to: to, standalone: standalone, citeproc: citeproc}));
-  return href.replace(/([?].*)?$/,"?" + URLparams);
-}
-
-const binaryFormats = {
-   docx: { extension: "docx",
-           mime: "application/vnd.openxmlformats-officedocument.wordprocessingml.document" },
-    odt: { extension: "odt",
-           mime: "application/vnd.oasis.opendocument.text" },
-    pptx: { extension: "pptx",
-            mime: "application/vnd.openxmlformats-officedocument.presentationml.presentation" },
-    epub:  { extension: "epub",
-             mime: "application/epub+zip" },
-    epub2: { extension: "epub",
-             mime: "application/epub+zip" },
-    epub3: { extension: "epub",
-             mime: "application/epub+zip" }
-};
-
-const binaryMimeTypes = {
-  ["application/epub+zip"]: true,
-  ["application/vnd.openxmlformats-officedocument.wordprocessingml.document"]: true,
-  ["application/vnd.openxmlformats-officedocument.presentationml.presentation"]: true,
-  ["application/vnd.oasis.opendocument.text"]: true
-};
-
-function paramsFromURL() {
-  if (window.location.search.length > 0) {
-    const uparams = new URLSearchParams(window.location.search);
-    params.text = uparams.get("text") || "";
-    params.from = uparams.get("from") || "markdown";
-    params.to = uparams.get("to") || "html5";
-    params.standalone = uparams.get("standalone") === "true";
-    params.citeproc = uparams.get("citeproc") === "true";
-  }
-}
-
-function handleErrors(response) {
-    if (response.status == 503) {
-        throw Error("Conversion timed out.")
-//    } else if (!response.ok) {
-//        throw Error(response.statusText);
-    }
-    return response;
-}
-
-function convert() {
-    document.getElementById("results").textContent = "";
-    let text = document.getElementById("text").value;
-    let from = document.getElementById("from").value;
-    let to = document.getElementById("to").value;
-    let standalone = document.getElementById("standalone").checked;
-    let citeproc = document.getElementById("citeproc").checked;
-    params = { text: text, from: from, to: to, standalone: standalone,
-               citeproc: citeproc };
-
-    if (text && text != "") {
-       let commandString = "pandoc"
-         + " --from " + from + " --to " + to
-         + (standalone ? " --standalone" : "")
-         + (citeproc ? " --citeproc" : "") ;
-       document.getElementById("command").textContent = commandString;
-       fetch("/cgi-bin/pandoc-server.cgi", {
-         method: "POST",
-         headers: {"Content-Type": "application/json"},
-         body: JSON.stringify({ from: params.from,
-                                to: params.to,
-                                text: params.text,
-                                standalone: params.standalone,
-                                citeproc: params.citeproc })
-        })
-       .then(handleErrors)
-       .then(response => response.text())
-       .then(restext => {
-            let binary = binaryFormats[to];
-            if (binary) {
-            document.getElementById("results").innerHTML =
-                'click to download trypandoc.' + binary.extension + '';
-          } else {
-            document.getElementById("results").textContent = restext;
-          }
-          document.getElementById("permalink").href = permalink();
-       })
-       .catch(error => {
-         document.getElementById("results").textContent = error
-       }
-       );
-    };
-}
-
-(function() {
-    paramsFromURL();
-    document.getElementById("text").value = params.text;
-    document.getElementById("from").value = params.from;
-    document.getElementById("to").value = params.to;
-    document.getElementById("standalone").checked = params.standalone;
-    document.getElementById("citeproc").checked = params.citeproc;
-
-    document.getElementById("convert").onclick = convert;
-    document.getElementById("from").onchange = convert;
-    document.getElementById("to").onchange = convert;
-    document.getElementById("standalone").onchange = convert;
-    document.getElementById("citeproc").onchange = convert;
-
-    document.getElementById("examples").onchange =
-      (e => window.location.href = e.target.value );
-
-    const fileInput = document.getElementById('loadfile');
-
-    // Listen for the change event so we can capture the file
-    fileInput.addEventListener('change', (e) => {
-      // Get a reference to the file
-      const file = e.target.files[0];
-      const mimetype = file.type;
-      let binary = binaryMimeTypes[mimetype];
-
-      // Encode the file using the FileReader API
-      const reader = new FileReader();
-      let inputtext = document.getElementById("text");
-      reader.onloadend = () => {
-        // Use a regex to remove data url part
-        if (binary) {
-          const base64String = reader.result
-           .replace('data:', '')
-           .replace(/^.+,/, '');
-          inputtext.value = base64String;
-	} else {
-          inputtext.value = reader.result;
-        }
-      };
-      if (binary) {
-        reader.readAsDataURL(file);
-      } else {
-        reader.readAsText(file);
-      }
-    });
-
-    fetch("/cgi-bin/pandoc-server.cgi/version")
-       .then(handleErrors)
-       .then(response => response.text())
-       .then(restext =>
-           document.getElementById("version").textContent = restext
-         );
-
-    convert();
-
-})();
-
diff --git a/xml-light/Text/Pandoc/XML/Light.hs b/xml-light/Text/Pandoc/XML/Light.hs
new file mode 100644
--- /dev/null
+++ b/xml-light/Text/Pandoc/XML/Light.hs
@@ -0,0 +1,113 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{- |
+   Module      : Text.Pandoc.XML.Light
+   Copyright   : Copyright (C) 2021-2023 John MacFarlane
+   License     : GNU GPL, version 2 or above
+
+   Maintainer  : John MacFarlane 
+   Stability   : alpha
+   Portability : portable
+
+xml-light, which we used in pandoc's the XML-based readers, has
+some limitations: in particular, it produces nodes with String
+instead of Text, and the parser falls over on processing instructions
+(see #7091).
+
+This module exports much of the API of xml-light, but using Text instead
+of String. In addition, the xml-light parsers are replaced by xml-conduit's
+well-tested parser.  (The xml-conduit types are mapped to types
+isomorphic to xml-light's, to avoid the need for massive code modifications
+elsewhere.)  Bridge functions to map xml-light types to this module's
+types are also provided (since libraries like texmath still use xml-light).
+
+Another advantage of the xml-conduit parser is that it gives us
+detailed information on xml parse errors.
+
+In the future we may want to move to using xml-conduit or another
+xml library in the code base, but this change gives us
+better performance and accuracy without much change in the
+code that used xml-light.
+-}
+module Text.Pandoc.XML.Light
+  ( module Text.Pandoc.XML.Light.Types
+  , module Text.Pandoc.XML.Light.Proc
+  , module Text.Pandoc.XML.Light.Output
+    -- * Replacement for xml-light's Text.XML.Input
+  , parseXMLElement
+  , parseXMLContents
+    --  * Versions that allow passing in a custom entity table
+  , parseXMLElementWithEntities
+  , parseXMLContentsWithEntities
+  ) where
+
+import qualified Control.Exception as E
+import qualified Text.XML as Conduit
+import Text.XML.Unresolved (InvalidEventStream(..))
+import qualified Data.Text as T
+import qualified Data.Text.Lazy as TL
+import qualified Data.Map as M
+import Data.Maybe (mapMaybe)
+import Text.Pandoc.XML.Light.Types
+import Text.Pandoc.XML.Light.Proc
+import Text.Pandoc.XML.Light.Output
+import qualified Data.XML.Types as XML
+
+-- Drop in replacement for parseXMLDoc in xml-light.
+parseXMLElement :: TL.Text -> Either T.Text Element
+parseXMLElement = parseXMLElementWithEntities mempty
+
+-- Drop in replacement for parseXMLDoc in xml-light.
+parseXMLElementWithEntities :: M.Map T.Text T.Text
+                            -> TL.Text -> Either T.Text Element
+parseXMLElementWithEntities entityMap t =
+  elementToElement .  Conduit.documentRoot <$>
+    either (Left . T.pack . E.displayException) Right
+    (Conduit.parseText Conduit.def{ Conduit.psRetainNamespaces = True
+                                  , Conduit.psDecodeEntities = decodeEnts } t)
+ where
+   decodeEnts ref = case M.lookup ref entityMap of
+                      Nothing -> XML.ContentEntity ref
+                      Just t' -> XML.ContentText t'
+
+parseXMLContents :: TL.Text -> Either T.Text [Content]
+parseXMLContents = parseXMLContentsWithEntities mempty
+
+parseXMLContentsWithEntities :: M.Map T.Text T.Text
+                             -> TL.Text -> Either T.Text [Content]
+parseXMLContentsWithEntities entityMap t =
+  case Conduit.parseText Conduit.def{ Conduit.psRetainNamespaces = True
+                                    , Conduit.psDecodeEntities = decodeEnts
+                                    } t of
+    Left e ->
+      case E.fromException e of
+        Just (ContentAfterRoot _) ->
+          elContent <$> parseXMLElementWithEntities entityMap
+                          ("" <> t <> "")
+        _ -> Left . T.pack . E.displayException $ e
+    Right x -> Right [Elem . elementToElement . Conduit.documentRoot $ x]
+ where
+   decodeEnts ref = case M.lookup ref entityMap of
+                      Nothing -> XML.ContentEntity ref
+                      Just t' -> XML.ContentText t'
+
+elementToElement :: Conduit.Element -> Element
+elementToElement (Conduit.Element name attribMap nodes) =
+  Element (nameToQname name) attrs (mapMaybe nodeToContent nodes) Nothing
+ where
+  attrs = map (\(n,v) -> Attr (nameToQname n) v) $
+              M.toList attribMap
+  nameToQname (Conduit.Name localName mbns mbpref) =
+    case mbpref of
+      Nothing ->
+        case T.stripPrefix "xmlns:" localName of
+          Just rest -> QName rest mbns (Just "xmlns")
+          Nothing   -> QName localName mbns mbpref
+      _ -> QName localName mbns mbpref
+
+nodeToContent :: Conduit.Node -> Maybe Content
+nodeToContent (Conduit.NodeElement el) =
+  Just (Elem (elementToElement el))
+nodeToContent (Conduit.NodeContent t) =
+  Just (Text (CData CDataText t Nothing))
+nodeToContent _ = Nothing
diff --git a/xml-light/Text/Pandoc/XML/Light/Output.hs b/xml-light/Text/Pandoc/XML/Light/Output.hs
new file mode 100644
--- /dev/null
+++ b/xml-light/Text/Pandoc/XML/Light/Output.hs
@@ -0,0 +1,234 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{- |
+   Module      : Text.Pandoc.XML.Light.Output
+   Copyright   : Copyright (C) 2007 Galois, Inc., 2021-2023 John MacFarlane
+   License     : GNU GPL, version 2 or above
+
+
+   Maintainer  : John MacFarlane 
+   Stability   : alpha
+   Portability : portable
+
+   This code is based on code from xml-light, released under the BSD3 license.
+   We use a text Builder instead of ShowS.
+-}
+module Text.Pandoc.XML.Light.Output
+  ( -- * Replacement for xml-light's Text.XML.Output
+    ppTopElement
+  , ppElement
+  , ppContent
+  , ppcElement
+  , ppcContent
+  , showTopElement
+  , showElement
+  , showContent
+  , useShortEmptyTags
+  , defaultConfigPP
+  , ConfigPP(..)
+  ) where
+
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.Lazy as TL
+import Data.Text.Lazy.Builder (Builder, singleton, fromText, toLazyText)
+import Text.Pandoc.XML.Light.Types
+
+--
+-- duplicates functinos from Text.XML.Output
+--
+
+-- | The XML 1.0 header
+xmlHeader :: Text
+xmlHeader = ""
+
+
+--------------------------------------------------------------------------------
+data ConfigPP = ConfigPP
+  { shortEmptyTag :: QName -> Bool
+  , prettify      :: Bool
+  }
+
+-- | Default pretty orinting configuration.
+--  * Always use abbreviate empty tags.
+defaultConfigPP :: ConfigPP
+defaultConfigPP = ConfigPP { shortEmptyTag = const True
+                           , prettify      = False
+                           }
+
+-- | The predicate specifies for which empty tags we should use XML's
+-- abbreviated notation .  This is useful if we are working with
+-- some XML-ish standards (such as certain versions of HTML) where some
+-- empty tags should always be displayed in the  form.
+useShortEmptyTags :: (QName -> Bool) -> ConfigPP -> ConfigPP
+useShortEmptyTags p c = c { shortEmptyTag = p }
+
+
+-- | Specify if we should use extra white-space to make document more readable.
+-- WARNING: This adds additional white-space to text elements,
+-- and so it may change the meaning of the document.
+useExtraWhiteSpace :: Bool -> ConfigPP -> ConfigPP
+useExtraWhiteSpace p c  = c { prettify = p }
+
+-- | A configuration that tries to make things pretty
+-- (possibly at the cost of changing the semantics a bit
+-- through adding white space.)
+prettyConfigPP     :: ConfigPP
+prettyConfigPP      = useExtraWhiteSpace True defaultConfigPP
+
+
+--------------------------------------------------------------------------------
+
+
+-- | Pretty printing renders XML documents faithfully,
+-- with the exception that whitespace may be added\/removed
+-- in non-verbatim character data.
+ppTopElement       :: Element -> Text
+ppTopElement        = ppcTopElement prettyConfigPP
+
+-- | Pretty printing elements
+ppElement          :: Element -> Text
+ppElement           = ppcElement prettyConfigPP
+
+-- | Pretty printing content
+ppContent          :: Content -> Text
+ppContent           = ppcContent prettyConfigPP
+
+-- | Pretty printing renders XML documents faithfully,
+-- with the exception that whitespace may be added\/removed
+-- in non-verbatim character data.
+ppcTopElement      :: ConfigPP -> Element -> Text
+ppcTopElement c e   = T.unlines [xmlHeader,ppcElement c e]
+
+-- | Pretty printing elements
+ppcElement         :: ConfigPP -> Element -> Text
+ppcElement c        = TL.toStrict . toLazyText . ppElementS c mempty
+
+-- | Pretty printing content
+ppcContent         :: ConfigPP -> Content -> Text
+ppcContent c        = TL.toStrict . toLazyText . ppContentS c mempty
+
+ppcCData           :: ConfigPP -> CData -> Text
+ppcCData c         = TL.toStrict . toLazyText . ppCDataS c mempty
+
+type Indent = Builder
+
+-- | Pretty printing content using ShowT
+ppContentS         :: ConfigPP -> Indent -> Content -> Builder
+ppContentS c i x = case x of
+                     Elem e -> ppElementS c i e
+                     Text t -> ppCDataS c i t
+                     CRef r -> showCRefS r
+
+ppElementS         :: ConfigPP -> Indent -> Element -> Builder
+ppElementS c i e = i <> tagStart (elName e) (elAttribs e) <>
+  (case elContent e of
+    [] | "?" `T.isPrefixOf` qName name -> fromText " ?>"
+       | shortEmptyTag c name  -> fromText " />"
+    [Text t] -> singleton '>' <> ppCDataS c mempty t <> tagEnd name
+    cs -> singleton '>' <> nl <>
+          mconcat (map ((<> nl) . ppContentS c (sp <> i)) cs) <>
+          i <> tagEnd name
+      where (nl,sp)  = if prettify c then ("\n","  ") else ("","")
+  )
+  where name = elName e
+
+ppCDataS           :: ConfigPP -> Indent -> CData -> Builder
+ppCDataS c i t     = i <> if cdVerbatim t /= CDataText || not (prettify c)
+                             then showCDataS t
+                             else foldr cons mempty (T.unpack (showCData t))
+  where cons         :: Char -> Builder -> Builder
+        cons '\n' ys  = singleton '\n' <> i <> ys
+        cons y ys     = singleton y <> ys
+
+
+
+--------------------------------------------------------------------------------
+
+-- | Adds the  header.
+showTopElement     :: Element -> Text
+showTopElement c    = xmlHeader <> showElement c
+
+showContent        :: Content -> Text
+showContent         = ppcContent defaultConfigPP
+
+showElement        :: Element -> Text
+showElement         = ppcElement defaultConfigPP
+
+showCData          :: CData -> Text
+showCData           = ppcCData defaultConfigPP
+
+-- Note: crefs should not contain '&', ';', etc.
+showCRefS          :: Text -> Builder
+showCRefS r         = singleton '&' <> fromText r <> singleton ';'
+
+-- | Convert a text element to characters.
+showCDataS         :: CData -> Builder
+showCDataS cd =
+ case cdVerbatim cd of
+   CDataText     -> escStr (cdData cd)
+   CDataVerbatim -> fromText " escCData (cdData cd) <>
+                    fromText "]]>"
+   CDataRaw      -> fromText (cdData cd)
+
+--------------------------------------------------------------------------------
+escCData           :: Text -> Builder
+escCData t
+  | "]]>" `T.isPrefixOf` t =
+     fromText "]]]]>" <> fromText (T.drop 3 t)
+escCData t
+  = case T.uncons t of
+      Nothing     -> mempty
+      Just (c,t') -> singleton c <> escCData t'
+
+escChar            :: Char -> Builder
+escChar c = case c of
+  '<'   -> fromText "<"
+  '>'   -> fromText ">"
+  '&'   -> fromText "&"
+  '"'   -> fromText """
+  -- we use ' instead of ' because IE apparently has difficulties
+  -- rendering ' in xhtml.
+  -- Reported by Rohan Drape .
+  '\''  -> fromText "'"
+  _     -> singleton c
+
+  {- original xml-light version:
+  -- NOTE: We escape '\r' explicitly because otherwise they get lost
+  -- when parsed back in because of then end-of-line normalization rules.
+  _ | isPrint c || c == '\n' -> singleton c
+    | otherwise -> showText "&#" . showsT oc . singleton ';'
+      where oc = ord c
+  -}
+
+escStr             :: Text -> Builder
+escStr cs          = if T.any needsEscape cs
+                        then mconcat (map escChar (T.unpack cs))
+                        else fromText cs
+ where
+  needsEscape '<' = True
+  needsEscape '>' = True
+  needsEscape '&' = True
+  needsEscape '"' = True
+  needsEscape '\'' = True
+  needsEscape _ = False
+
+tagEnd             :: QName -> Builder
+tagEnd qn           = fromText " showQName qn <> singleton '>'
+
+tagStart           :: QName -> [Attr] -> Builder
+tagStart qn as      = singleton '<' <> showQName qn <> as_str
+ where as_str       = if null as
+                         then mempty
+                         else mconcat (map showAttr as)
+
+showAttr           :: Attr -> Builder
+showAttr (Attr qn v) = singleton ' ' <> showQName qn <>
+                       singleton '=' <>
+                       singleton '"' <> escStr v <> singleton '"'
+
+showQName          :: QName -> Builder
+showQName q         =
+  case qPrefix q of
+    Nothing -> fromText (qName q)
+    Just p  -> fromText p <> singleton ':' <> fromText (qName q)
diff --git a/xml-light/Text/Pandoc/XML/Light/Proc.hs b/xml-light/Text/Pandoc/XML/Light/Proc.hs
new file mode 100644
--- /dev/null
+++ b/xml-light/Text/Pandoc/XML/Light/Proc.hs
@@ -0,0 +1,137 @@
+{-# LANGUAGE FlexibleInstances #-}
+{- |
+   Module      : Text.Pandoc.XML.Light.Proc
+   Copyright   : Copyright (C) 2007 Galois, Inc., 2021-2023 John MacFarlane
+   License     : GNU GPL, version 2 or above
+
+   Maintainer  : John MacFarlane 
+   Stability   : alpha
+   Portability : portable
+
+   This code is taken from xml-light, released under the BSD3 license.
+-}
+module Text.Pandoc.XML.Light.Proc
+  (
+    -- * Replacement for xml-light's Text.XML.Proc
+    strContent
+  , onlyElems
+  , elChildren
+  , onlyText
+  , findChildren
+  , filterChildren
+  , filterChildrenName
+  , findChild
+  , filterChild
+  , filterChildName
+  , findElement
+  , filterElement
+  , filterElementName
+  , findElements
+  , filterElements
+  , filterElementsName
+  , findAttr
+  , lookupAttr
+  , lookupAttrBy
+  , findAttrBy
+  ) where
+
+import Data.Text (Text)
+import Data.Maybe (listToMaybe)
+import Data.List(find)
+import Text.Pandoc.XML.Light.Types
+
+--
+-- copied from xml-light Text.XML.Proc
+--
+
+-- | Get the text value of an XML element.  This function
+-- ignores non-text elements, and concatenates all text elements.
+strContent         :: Element -> Text
+strContent          = mconcat . map cdData . onlyText . elContent
+
+-- | Select only the elements from a list of XML content.
+onlyElems          :: [Content] -> [Element]
+onlyElems xs        = [ x | Elem x <- xs ]
+
+-- | Select only the elements from a parent.
+elChildren         :: Element -> [Element]
+elChildren e        = [ x | Elem x <- elContent e ]
+
+-- | Select only the text from a list of XML content.
+onlyText           :: [Content] -> [CData]
+onlyText xs         = [ x | Text x <- xs ]
+
+-- | Find all immediate children with the given name.
+findChildren       :: QName -> Element -> [Element]
+findChildren q e    = filterChildren ((q ==) . elName) e
+
+-- | Filter all immediate children wrt a given predicate.
+filterChildren       :: (Element -> Bool) -> Element -> [Element]
+filterChildren p e    = filter p (onlyElems (elContent e))
+
+
+-- | Filter all immediate children wrt a given predicate over their names.
+filterChildrenName      :: (QName -> Bool) -> Element -> [Element]
+filterChildrenName p e   = filter (p.elName) (onlyElems (elContent e))
+
+
+-- | Find an immediate child with the given name.
+findChild          :: QName -> Element -> Maybe Element
+findChild q e       = listToMaybe (findChildren q e)
+
+-- | Find an immediate child with the given name.
+filterChild          :: (Element -> Bool) -> Element -> Maybe Element
+filterChild p e       = listToMaybe (filterChildren p e)
+
+-- | Find an immediate child with name matching a predicate.
+filterChildName      :: (QName -> Bool) -> Element -> Maybe Element
+filterChildName p e   = listToMaybe (filterChildrenName p e)
+
+-- | Find the left-most occurrence of an element matching given name.
+findElement        :: QName -> Element -> Maybe Element
+findElement q e     = listToMaybe (findElements q e)
+
+-- | Filter the left-most occurrence of an element wrt. given predicate.
+filterElement        :: (Element -> Bool) -> Element -> Maybe Element
+filterElement p e     = listToMaybe (filterElements p e)
+
+-- | Filter the left-most occurrence of an element wrt. given predicate.
+filterElementName     :: (QName -> Bool) -> Element -> Maybe Element
+filterElementName p e  = listToMaybe (filterElementsName p e)
+
+-- | Find all non-nested occurrences of an element.
+-- (i.e., once we have found an element, we do not search
+-- for more occurrences among the element's children).
+findElements       :: QName -> Element -> [Element]
+findElements qn e = filterElementsName (qn==) e
+
+-- | Find all non-nested occurrences of an element wrt. given predicate.
+-- (i.e., once we have found an element, we do not search
+-- for more occurrences among the element's children).
+filterElements       :: (Element -> Bool) -> Element -> [Element]
+filterElements p e
+ | p e        = [e]
+ | otherwise  = concatMap (filterElements p) $ onlyElems $ elContent e
+
+-- | Find all non-nested occurrences of an element wrt a predicate over element names.
+-- (i.e., once we have found an element, we do not search
+-- for more occurrences among the element's children).
+filterElementsName       :: (QName -> Bool) -> Element -> [Element]
+filterElementsName p e = filterElements (p.elName) e
+
+-- | Lookup the value of an attribute.
+findAttr          :: QName -> Element -> Maybe Text
+findAttr x e       = lookupAttr x (elAttribs e)
+
+-- | Lookup attribute name from list.
+lookupAttr        :: QName -> [Attr] -> Maybe Text
+lookupAttr x       = lookupAttrBy (x ==)
+
+-- | Lookup the first attribute whose name satisfies the given predicate.
+lookupAttrBy       :: (QName -> Bool) -> [Attr] -> Maybe Text
+lookupAttrBy p as   = attrVal `fmap` find (p . attrKey) as
+
+-- | Lookup the value of the first attribute whose name
+-- satisfies the given predicate.
+findAttrBy         :: (QName -> Bool) -> Element -> Maybe Text
+findAttrBy p e      = lookupAttrBy p (elAttribs e)
diff --git a/xml-light/Text/Pandoc/XML/Light/Types.hs b/xml-light/Text/Pandoc/XML/Light/Types.hs
new file mode 100644
--- /dev/null
+++ b/xml-light/Text/Pandoc/XML/Light/Types.hs
@@ -0,0 +1,191 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{- |
+   Module      : Text.Pandoc.XML.Light.Types
+   Copyright   : Copyright (C) 2007 Galois, Inc., 2021-2023 John MacFarlane
+   License     : GNU GPL, version 2 or above
+
+   Maintainer  : John MacFarlane 
+   Stability   : alpha
+   Portability : portable
+
+   This code is taken from xml-light, released under the BSD3 license.
+   It has been modified to use Text instead of String, and the fromXL*
+   functions have been added.
+-}
+module Text.Pandoc.XML.Light.Types
+  ( -- * Basic types, duplicating those from xml-light but with Text
+    -- instead of String
+    Line
+  , Content(..)
+  , Element(..)
+  , Attr(..)
+  , CData(..)
+  , CDataKind(..)
+  , QName(..)
+  , Node(..)
+  , unode
+  , unqual
+  , add_attr
+  , add_attrs
+  -- * Conversion functions from xml-light types
+  , fromXLQName
+  , fromXLCData
+  , fromXLElement
+  , fromXLAttr
+  , fromXLContent
+  ) where
+
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Data (Data)
+import Data.Typeable (Typeable)
+import qualified Text.XML.Light as XL
+
+--
+-- type definitions lightly modified from xml-light
+--
+
+-- | A line is an Integer
+type Line     = Integer
+
+-- | XML content
+data Content  = Elem Element
+              | Text CData
+              | CRef Text
+                deriving (Show, Typeable, Data, Ord, Eq)
+
+-- | XML elements
+data Element  = Element {
+                  elName      :: QName,
+                  elAttribs   :: [Attr],
+                  elContent   :: [Content],
+                  elLine      :: Maybe Line
+                } deriving (Show, Typeable, Data, Ord, Eq)
+
+-- | XML attributes
+data Attr     = Attr {
+                  attrKey :: QName,
+                  attrVal :: Text
+                } deriving (Eq, Ord, Show, Typeable, Data)
+
+-- | XML CData
+data CData    = CData {
+                  cdVerbatim  :: CDataKind,
+                  cdData      :: Text,
+                  cdLine      :: Maybe Line
+                } deriving (Show, Typeable, Data, Ord, Eq)
+
+data CDataKind
+ = CDataText      -- ^ Ordinary character data; pretty printer escapes &, < etc.
+ | CDataVerbatim  -- ^ Unescaped character data; pretty printer embeds it in  case (qURI q1, qURI q2) of
+               (Nothing,Nothing) -> compare (qPrefix q1) (qPrefix q2)
+               (u1,u2)           -> compare u1 u2
+      x   -> x
+
+class Node t where
+ node :: QName -> t -> Element
+
+instance Node ([Attr],[Content]) where
+  node n (attrs,cont) = Element { elName     = n
+                                , elAttribs  = attrs
+                                , elContent  = cont
+                                , elLine     = Nothing
+                                }
+
+instance Node [Attr]             where node n as   = node n (as,[]::[Content])
+instance Node Attr               where node n a    = node n [a]
+instance Node ()                 where node n ()   = node n ([]::[Attr])
+
+instance Node [Content]          where node n cs     = node n ([]::[Attr],cs)
+instance Node Content            where node n c      = node n [c]
+instance Node ([Attr],Content)   where node n (as,c) = node n (as,[c])
+instance Node (Attr,Content)     where node n (a,c)  = node n ([a],[c])
+
+instance Node ([Attr],[Element]) where
+  node n (as,cs) = node n (as,map Elem cs)
+
+instance Node ([Attr],Element)   where node n (as,c) = node n (as,[c])
+instance Node (Attr,Element)     where node n (a,c)  = node n ([a],c)
+instance Node [Element]          where node n es     = node n ([]::[Attr],es)
+instance Node Element            where node n e      = node n [e]
+
+instance Node ([Attr],[CData])   where
+  node n (as,cs) = node n (as,map Text cs)
+
+instance Node ([Attr],CData)     where node n (as,c) = node n (as,[c])
+instance Node (Attr,CData)       where node n (a,c)  = node n ([a],c)
+instance Node [CData]            where node n es     = node n ([]::[Attr],es)
+instance Node CData              where node n e      = node n [e]
+
+instance Node ([Attr],Text)      where
+  node n (as,t) = node n (as, CData { cdVerbatim = CDataText
+                                    , cdData = t
+                                    , cdLine = Nothing })
+
+instance Node (Attr,Text )       where node n (a,t)  = node n ([a],t)
+instance Node Text               where node n t      = node n ([]::[Attr],t)
+
+-- | Create node with unqualified name
+unode :: Node t => Text -> t -> Element
+unode = node . unqual
+
+unqual :: Text -> QName
+unqual x = QName x Nothing Nothing
+
+-- | Add an attribute to an element.
+add_attr :: Attr -> Element -> Element
+add_attr a e = add_attrs [a] e
+
+-- | Add some attributes to an element.
+add_attrs :: [Attr] -> Element -> Element
+add_attrs as e = e { elAttribs = as ++ elAttribs e }
+
+--
+-- conversion from xml-light
+--
+
+fromXLQName :: XL.QName -> QName
+fromXLQName qn = QName { qName = T.pack $ XL.qName qn
+                       , qURI = T.pack <$> XL.qURI qn
+                       , qPrefix = T.pack <$> XL.qPrefix qn }
+
+fromXLCData :: XL.CData -> CData
+fromXLCData cd = CData { cdVerbatim = case XL.cdVerbatim cd of
+                                        XL.CDataText -> CDataText
+                                        XL.CDataVerbatim -> CDataVerbatim
+                                        XL.CDataRaw -> CDataRaw
+                       , cdData = T.pack $ XL.cdData cd
+                       , cdLine = XL.cdLine cd }
+
+fromXLElement :: XL.Element -> Element
+fromXLElement el = Element { elName = fromXLQName $ XL.elName el
+                           , elAttribs = map fromXLAttr $ XL.elAttribs el
+                           , elContent = map fromXLContent $ XL.elContent el
+                           , elLine = XL.elLine el }
+
+fromXLAttr :: XL.Attr -> Attr
+fromXLAttr (XL.Attr qn s) = Attr (fromXLQName qn) (T.pack s)
+
+fromXLContent :: XL.Content -> Content
+fromXLContent (XL.Elem el) = Elem $ fromXLElement el
+fromXLContent (XL.Text cd) = Text $ fromXLCData cd
+fromXLContent (XL.CRef s)  = CRef (T.pack s)