diff --git a/AUTHORS.md b/AUTHORS.md --- a/AUTHORS.md +++ b/AUTHORS.md @@ -62,11 +62,13 @@ - Daniele D'Orazio - David A Roberts - David Lazar +- David Martschenko - David Röthlisberger - Denis Laxalde - Denis Maier - Derek Chen-Becker - Diego Balseiro +- Dimitri Sabadie - Dmitry Pogodin - Dmitry Volodin - Douglas Calvert @@ -161,6 +163,8 @@ - Leif Metcalf - Leonard Rosenthol - Lila +- Loïc Grobol +- Lorenzo - Lucas Escot - Luke Plant - Marc Schreiber @@ -194,10 +198,12 @@ - Nathan Gass - Neil Mayhew - Nick Bart +- Nick Berendsen - Nick Fleisher - Nicolas Kaiser - Nikolay Yakimov - Nils Carlson +- Nixon Enraght-Moony - Nokome Bentley - Ole Martin Ruud - Oliver Matthews diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -372,7 +372,7 @@ -------- Pandoc has a publicly accessible git repository on -GitHub: . To get a local copy of the source: +GitHub: . To get a local copy of the source: git clone https://github.com/jgm/pandoc.git @@ -382,7 +382,7 @@ The modules `Text.Pandoc.Definition`, `Text.Pandoc.Builder`, and `Text.Pandoc.Generic` are in a separate library `pandoc-types`. The code can -be found in . +be found in . To build pandoc, you will need a working installation of the [Haskell platform]. @@ -445,14 +445,14 @@ [closed issues]: https://github.com/jgm/pandoc/issues?q=is%3Aissue+is%3Aclosed [latest released version]: https://github.com/jgm/pandoc/releases/latest [Nightly builds]: https://github.com/jgm/pandoc/actions?query=workflow%3ANightly -[pandoc-discuss]: http://groups.google.com/group/pandoc-discuss +[pandoc-discuss]: https://groups.google.com/group/pandoc-discuss [issue tracker]: https://github.com/jgm/pandoc/issues -[User's Guide]: http://pandoc.org/MANUAL.html -[FAQs]: http://pandoc.org/faqs.html -[EditorConfig]: http://editorconfig.org/ -[Haskell platform]: http://www.haskell.org/platform/ +[User's Guide]: https://pandoc.org/MANUAL.html +[FAQs]: https://pandoc.org/faqs.html +[EditorConfig]: https://editorconfig.org/ +[Haskell platform]: https://www.haskell.org/platform/ [hlint]: https://hackage.haskell.org/package/hlint -[hsb2hs]: http://hackage.haskell.org/package/hsb2hs +[hsb2hs]: https://hackage.haskell.org/package/hsb2hs [pre-commit hook]: https://git-scm.com/book/en/v2/Customizing-Git-Git-Hooks [GitHub labels]: https://github.com/jgm/pandoc/labels [good first issue]:https://github.com/jgm/pandoc/labels/good%20first%20issue diff --git a/COPYING.md b/COPYING.md --- a/COPYING.md +++ b/COPYING.md @@ -357,5 +357,5 @@ you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the [GNU Lesser General Public -License](http://www.gnu.org/licenses/lgpl.html) instead of this +License](https://www.gnu.org/licenses/lgpl.html) instead of this License. diff --git a/COPYRIGHT b/COPYRIGHT --- a/COPYRIGHT +++ b/COPYRIGHT @@ -22,11 +22,11 @@ the source distribution. On Debian systems, the complete text of the GPL can be found in `/usr/share/common-licenses/GPL`. -[GPL]: http://www.gnu.org/copyleft/gpl.html +[GPL]: https://www.gnu.org/copyleft/gpl.html Pandoc's complete source code is available from the [Pandoc home page]. -[Pandoc home page]: http://pandoc.org +[Pandoc home page]: https://pandoc.org Pandoc includes some code with different copyrights, or subject to different licenses. The copyright and license statements for these sources are included @@ -176,7 +176,7 @@ ---------------------------------------------------------------------- The dzslides template contains JavaScript and CSS from Paul Rouget's dzslides template. -http://github.com/paulrouget/dzslides +https://github.com/paulrouget/dzslides Released under the Do What the Fuck You Want To Public License. diff --git a/INSTALL.md b/INSTALL.md --- a/INSTALL.md +++ b/INSTALL.md @@ -45,7 +45,7 @@ and running it with `perl uninstall-pandoc.pl`. Alternatively, you can install pandoc using -[Homebrew](http://brew.sh): +[Homebrew](https://brew.sh): brew install pandoc @@ -116,7 +116,7 @@ you can install it with `apt-get install haskell-platform`. For PDF output, you'll need LaTeX. We recommend installing -[TeX Live](http://www.tug.org/texlive/) via your package +[TeX Live](https://www.tug.org/texlive/) via your package manager. (On Debian/Ubuntu, `apt-get install texlive`.) ## Chrome OS @@ -238,7 +238,7 @@ pandoc --help - [Not sure where `$CABALDIR` is?](http://www.haskell.org/haskellwiki/Cabal-Install#The_cabal-install_configuration_file) + [Not sure where `$CABALDIR` is?](https://wiki.haskell.org/Cabal-Install#The_cabal-install_configuration_file) 5. By default `pandoc` uses the "i;unicode-casemap" method to sort bibliography entries (RFC 5051). If you would like to @@ -383,30 +383,29 @@ [Arch]: https://www.archlinux.org/packages/community/x86_64/pandoc/ -[Cabal User's Guide]: http://www.haskell.org/cabal/release/latest/doc/users-guide/builders.html#setup-configure-paths +[Cabal User's Guide]: https://cabal.readthedocs.io/ [Debian]: https://packages.debian.org/pandoc [Fedora]: https://apps.fedoraproject.org/packages/pandoc -[FreeBSD ports]: http://www.freshports.org/textproc/hs-pandoc/ -[GHC]: http://www.haskell.org/ghc/ -[GPL]: http://www.gnu.org/copyleft/gpl.html -[Haskell platform]: http://hackage.haskell.org/platform/ -[MacPorts]: http://trac.macports.org/browser/trunk/dports/textproc/pandoc/Portfile +[FreeBSD ports]: https://www.freshports.org/textproc/hs-pandoc/ +[GHC]: https://www.haskell.org/ghc/ +[Haskell platform]: https://hackage.haskell.org/platform/ +[MacPorts]: https://trac.macports.org/browser/trunk/dports/textproc/pandoc/Portfile [MacTeX]: https://tug.org/mactex/ -[BasicTeX]: http://www.tug.org/mactex/morepackages.html +[BasicTeX]: https://www.tug.org/mactex/morepackages.html [LaTeX]: https://www.latex-project.org -[MiKTeX]: http://miktex.org/ +[MiKTeX]: https://miktex.org/ [librsvg]: https://wiki.gnome.org/Projects/LibRsvg [Python]: https://www.python.org -[NetBSD]: http://pkgsrc.se/wip/pandoc +[NetBSD]: https://pkgsrc.se/wip/pandoc [NixOS]: https://nixos.org/nixos/packages.html [Slackware]: https://www.slackbuilds.org/result/?search=pandoc&sv= [Ubuntu]: https://packages.ubuntu.com/pandoc [download page]: https://github.com/jgm/pandoc/releases/latest -[gentoo]: http://packages.gentoo.org/package/app-text/pandoc +[gentoo]: https://packages.gentoo.org/package/app-text/pandoc [haskell repository]: https://wiki.archlinux.org/index.php/Haskell_Package_Guidelines#.5Bhaskell.5D [openSUSE]: https://software.opensuse.org/package/pandoc -[source tarball]: http://hackage.haskell.org/package/pandoc +[source tarball]: https://hackage.haskell.org/package/pandoc [stack]: https://docs.haskellstack.org/en/stable/install_and_upgrade.html -[cabal-install]: http://hackage.haskell.org/package/cabal-install +[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 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: January 21, 2021 +date: March 8, 2021 --- # Synopsis @@ -136,7 +136,7 @@ When using LaTeX, the following packages need to be available (they are included with all recent versions of [TeX Live]): [`amsfonts`], [`amsmath`], [`lm`], [`unicode-math`], -[`ifxetex`], [`ifluatex`], [`listings`] (if the +[`iftex`], [`listings`] (if the `--listings` option is used), [`fancyvrb`], [`longtable`], [`booktabs`], [`graphicx`] (if the document contains images), [`hyperref`], [`xcolor`], @@ -180,8 +180,7 @@ [`graphicx`]: https://ctan.org/pkg/graphicx [`grffile`]: https://ctan.org/pkg/grffile [`hyperref`]: https://ctan.org/pkg/hyperref -[`ifluatex`]: https://ctan.org/pkg/ifluatex -[`ifxetex`]: https://ctan.org/pkg/ifxetex +[`iftex`]: https://ctan.org/pkg/iftex [`listings`]: https://ctan.org/pkg/listings [`lm`]: https://ctan.org/pkg/lm [`longtable`]: https://ctan.org/pkg/longtable @@ -362,15 +361,15 @@ will be used. On \*nix and macOS systems this will be the `pandoc` subdirectory of the XDG data directory (by default, `$HOME/.local/share`, overridable by setting the `XDG_DATA_HOME` - environment variable). If that directory does not exist, - `$HOME/.pandoc` will be used (for backwards compatibility). - In Windows the default user data directory is + environment variable). If that directory does not exist and + `$HOME/.pandoc` exists, it will be used (for backwards compatibility). + On Windows the default user data directory is `C:\Users\USERNAME\AppData\Roaming\pandoc`. You can find the default user data directory on your system by looking at the output of `pandoc --version`. - A `reference.odt`, `reference.docx`, `epub.css`, `templates`, - `slidy`, `slideous`, or `s5` directory - placed in this directory will override pandoc's normal defaults. + Data files placed in this directory (for example, `reference.odt`, + `reference.docx`, `epub.css`, `templates`) will override + pandoc's normal defaults. `-d` *FILE*, `--defaults=`*FILE* @@ -487,7 +486,7 @@ [Emacs Org mode]: https://orgmode.org [AsciiDoc]: https://www.methods.co.nz/asciidoc/ [AsciiDoctor]: https://asciidoctor.org/ -[DZSlides]: http://paulrouget.com/dzslides/ +[DZSlides]: https://paulrouget.com/dzslides/ [Word docx]: https://en.wikipedia.org/wiki/Office_Open_XML [PDF]: https://www.adobe.com/pdf/ [reveal.js]: https://revealjs.com/ @@ -692,9 +691,9 @@ system default, use `pandoc --print-default-data-file=abbreviations`. The only use pandoc makes of this list is in the Markdown reader. - Strings ending in a period that are found in this list will - be followed by a nonbreaking space, so that the period will - not produce sentence-ending space in formats like LaTeX. + Strings found in this list will be followed by a nonbreaking + space, and the period will not produce sentence-ending space + in formats like LaTeX. The strings may not contain spaces. [`pandocfilters`]: https://github.com/jgm/pandocfilters [PHP]: https://github.com/vinai/pandocfilters-php @@ -892,6 +891,11 @@ will not be searched. For example: `--resource-path=.:test` will search the working directory and the `test` subdirectory, in that order. + This option can be used repeatedly. Search path components + that come later on the command line will be searched before + those that come earlier, so + `--resource-path foo:bar --resource-path baz:bim` is + equivalent to `--resource-path baz:bim:foo:bar`. `--request-header=`*NAME*`:`*VAL* @@ -1465,6 +1469,7 @@ 24 PandocCiteprocError 31 PandocEpubSubdirectoryError 43 PandocPDFError + 44 PandocXMLError 47 PandocPDFProgramNotFoundError 61 PandocHttpError 62 PandocShouldNeverHappenError @@ -1477,6 +1482,7 @@ 91 PandocMacroLoop 92 PandocUTF8DecodingError 93 PandocIpynbDecodingError + 94 PandocUnsupportedCharsetError 97 PandocCouldNotFindDataFileError 99 PandocResourceNotFound ----- ------------------------------------ @@ -1568,8 +1574,11 @@ verbosity: INFO log-file: log.json -# citeproc, natbib, or biblatex +# citeproc, natbib, or biblatex. This only affects LaTeX +# output. If you want to use citeproc to format citations, +# you should also set 'citeproc: true' (see above). cite-method: citeproc + # part, chapter, section, or default: top-level-division: chapter abbreviations: @@ -1668,6 +1677,34 @@ verbosity: INFO ``` +In fields that expect a file path (or list of file paths), the +following syntax may be used to interpolate environment variables: + +``` yaml +csl: ${HOME}/mycsldir/special.csl +``` + +`${USERDATA}` may also be used; this will always resolve to the +user data directory that is current when the defaults file is +parsed, regardless of the setting of the environment +variable `USERDATA`. + +`${.}` will resolve to the directory containing the default +file itself. This allows you to refer to resources contained +in that directory: + +``` yaml +epub-cover-image: ${.}/cover.jpg +epub-metadata: ${.}/meta.xml +resource-path: +- . # the working directory from which pandoc is run +- ${.}/images # the images subdirectory of the directory + # containing this defaults file +``` + +This environment variable interpolation syntax *only* works in +fields that expect file paths. + Default files can be placed in the `defaults` subdirectory of the user data directory and used from any directory. For example, one could create a file specifying defaults for writing @@ -1895,7 +1932,8 @@ ``` (If a partial is not found in the directory of the -template, it will also be sought in the `templates` +template and the template path is given as a relative +path, it will also be sought in the `templates` subdirectory of the user data directory.) Partials may optionally be applied to variables using @@ -3477,6 +3515,9 @@ | 200 Main St. | Berkeley, CA 94718 +Inline formatting (such as emphasis) is allowed in the content, +but not block-level formatting (such as block quotes or lists). + This syntax is borrowed from [reStructuredText]. ## Lists @@ -4356,7 +4397,8 @@ them and they won't be treated as math delimiters. For display math, use `$$` delimiters. (In this case, the delimiters -may be separated from the formula by whitespace.) +may be separated from the formula by whitespace. However, there can be +no blank lines betwen the opening and closing `$$` delimiters.) TeX math will be printed in all output formats. How it is rendered depends on the output format: @@ -5929,7 +5971,16 @@ `rights` ~ A string value. + +`belongs-to-collection` + ~ A string value. identifies the name of a collection to which + the EPUB Publication belongs. +`group-position` + ~ The `group-position` field indicates the numeric position in which + the EPUB Publication belongs relative to other works belonging to + the same `belongs-to-collection` field. + `cover-image` ~ A string value (path to cover image). @@ -6295,6 +6346,21 @@ subdirectory of your user data directory (see [Templates]). [Lua]: https://www.lua.org + +# Reproducible builds + +Some of the document formats pandoc targets (such as EPUB, +docx, and ODT) include build timestamps in the generated document. +That means that the files generated on successive builds will +differ, even if the source does not. To avoid this, set the +`SOURCE_DATE_EPOCH` environment variable, and the timestamp will +be taken from it instead of the current time. +`SOURCE_DATE_EPOCH` should contain an integer unix timestamp +(specifying the number of second since midnight UTC January 1, 1970). + +Some document formats also include a unique identifier. For +EPUB, this can be set explicitly by setting the `identifier` +metadata field (see [EPUB Metadata], above). # A note on security diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -8,10 +8,10 @@ [![github release](https://img.shields.io/github/release/jgm/pandoc.svg?label=current+release)](https://github.com/jgm/pandoc/releases) [![hackage -release](https://img.shields.io/hackage/v/pandoc.svg?label=hackage)](http://hackage.haskell.org/package/pandoc) -[![homebrew](https://img.shields.io/homebrew/v/pandoc.svg)](http://brewformulas.org/Pandoc) +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](http://stackage.org/package/pandoc/badge/lts)](http://stackage.org/lts/package/pandoc) +package](https://stackage.org/package/pandoc/badge/lts)](https://www.stackage.org/lts/package/pandoc-types) [![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) @@ -20,7 +20,7 @@ ## The universal markup converter -Pandoc is a [Haskell](http://haskell.org) library for converting from +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* @@ -175,7 +175,7 @@ and JavaScript slide show) - `slidy` ([Slidy](https://www.w3.org/Talks/Tools/Slidy2/) HTML and JavaScript slide show) -- `dzslides` ([DZSlides](http://paulrouget.com/dzslides/) HTML5 + +- `dzslides` ([DZSlides](https://paulrouget.com/dzslides/) HTML5 + JavaScript slide show), - `revealjs` ([reveal.js](https://revealjs.com/) HTML5 + JavaScript slide show) @@ -239,6 +239,6 @@ ## License © 2006-2021 John MacFarlane (jgm@berkeley.edu). Released under the -[GPL](http://www.gnu.org/copyleft/gpl.html "GNU General Public License"), +[GPL](https://www.gnu.org/licenses/old-licenses/gpl-2.0.html "GNU General Public License"), version 2 or greater. This software carries no warranty of any kind. (See COPYRIGHT for full copyright and warranty notices.) diff --git a/app/pandoc.hs b/app/pandoc.hs --- a/app/pandoc.hs +++ b/app/pandoc.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} {- | Module : Main Copyright : Copyright (C) 2006-2021 John MacFarlane @@ -12,7 +11,6 @@ writers. -} module Main where -import Prelude import qualified Control.Exception as E import Text.Pandoc.App (convertWithOpts, defaultOpts, options, parseOptions) import Text.Pandoc.Error (handleError) diff --git a/benchmark/benchmark-pandoc.hs b/benchmark/benchmark-pandoc.hs --- a/benchmark/benchmark-pandoc.hs +++ b/benchmark/benchmark-pandoc.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {- Copyright (C) 2012-2021 John MacFarlane @@ -17,52 +16,43 @@ along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -} -import Prelude import Text.Pandoc import Text.Pandoc.MIME -import Control.Monad.Except (throwError, liftIO) +import Control.Monad (when) +import Control.Monad.Except (throwError) import qualified Text.Pandoc.UTF8 as UTF8 import qualified Data.ByteString as B import qualified Data.Text as T -import Criterion.Main -import Criterion.Types (Config(..)) -import Data.List (intersect) -import Data.Maybe (mapMaybe, catMaybes) -import System.Environment (getArgs) +import Test.Tasty.Bench import qualified Data.ByteString.Lazy as BL - -data Input = InputText {unInputText :: T.Text} - | InputBS {unInputBS :: BL.ByteString} +import Data.Maybe (mapMaybe) +import Data.List (sortOn) readerBench :: Pandoc -> T.Text - -> IO (Maybe Benchmark) -readerBench doc name = do - let (rdr, rexts) = either (error . show) id . runPure $ getReader name - res <- runIO $ do - (wtr, wexts) <- getWriter name - case (rdr, wtr) of - (TextReader r, TextWriter w) -> do - setResourcePath ["./test"] - inp <- w def{ writerWrapText = WrapAuto - , writerExtensions = wexts } doc - return (r def{ readerExtensions = rexts } . unInputText, InputText inp) - (ByteStringReader r, ByteStringWriter w) -> do - setResourcePath ["./test"] - tmpl <- Just <$> compileDefaultTemplate name - inp <- w def{ writerWrapText = WrapAuto - , writerExtensions = wexts - , writerTemplate = tmpl } doc - liftIO $ BL.writeFile "/tmp/test.odt" inp - return (r def{ readerExtensions = rexts } . unInputBS, InputBS inp) - _ -> throwError $ PandocSomeError $ "text/bytestring format mismatch: " - <> name - return $ case res of - Right (readerFun, inp) -> - Just $ bench (T.unpack $ name <> " reader") - $ nf (\i -> either (error . show) id $ runPure (readerFun i)) - inp - Left _ -> Nothing + -> Maybe Benchmark +readerBench doc name = either (const Nothing) Just $ + runPure $ do + when (name `elem` ["bibtex", "biblatex", "csljson"]) $ + throwError $ PandocSomeError $ name <> " not supported for benchmark" + (rdr, rexts) <- getReader name + (wtr, wexts) <- getWriter name + case (rdr, wtr) of + (TextReader r, TextWriter w) -> do + inp <- w def{ writerWrapText = WrapAuto + , writerExtensions = wexts } doc + return $ bench (T.unpack name) $ + nf (either (error . show) id . runPure . r def) inp + (ByteStringReader r, ByteStringWriter w) -> do + tmpl <- Just <$> compileDefaultTemplate name + inp <- w def{ writerWrapText = WrapAuto + , writerExtensions = wexts + , writerTemplate = tmpl } doc + return $ bench (T.unpack name) $ + nf (either (error . show) id . + runPure . r def{readerExtensions = rexts}) inp + _ -> throwError $ PandocSomeError $ "text/bytestring format mismatch: " + <> name getImages :: IO [(FilePath, MimeType, BL.ByteString)] getImages = do @@ -71,52 +61,42 @@ return [("lalune.jpg", "image/jpg", ll) ,("movie.jpg", "image/jpg", mv)] -writerBench :: Pandoc +writerBench :: [(FilePath, MimeType, BL.ByteString)] + -> Pandoc -> T.Text -> Maybe Benchmark -writerBench doc name = - case res of - Right writerFun -> - Just $ env getImages $ \imgs -> - bench (T.unpack $ name <> " writer") +writerBench imgs doc name = either (const Nothing) Just $ + runPure $ do + when (name `elem` ["bibtex", "biblatex", "csljson"]) $ + throwError $ PandocSomeError $ name <> " not supported for benchmark" + (wtr, wexts) <- getWriter name + case wtr of + TextWriter writerFun -> + return $ bench (T.unpack name) $ nf (\d -> either (error . show) id $ - runPure (do mapM_ - (\(fp, mt, bs) -> - insertMedia fp (Just mt) bs) - imgs - writerFun d)) doc - Left _ -> Nothing - where res = runPure $ do - (wtr, wexts) <- getWriter name - case wtr of - TextWriter w -> - return $ w def{ writerExtensions = wexts } - _ -> throwError $ PandocSomeError - $ "could not get text writer for " <> name + runPure $ do + mapM_ (\(fp,mt,bs) -> insertMedia fp (Just mt) bs) imgs + writerFun def{ writerExtensions = wexts} d) + doc + ByteStringWriter writerFun -> + return $ bench (T.unpack name) + $ nf (\d -> either (error . show) id $ + runPure $ do + mapM_ (\(fp,mt,bs) -> insertMedia fp (Just mt) bs) imgs + writerFun def{ writerExtensions = wexts} d) + doc main :: IO () main = do - args <- filter (\x -> T.take 1 x /= "-") . fmap T.pack <$> getArgs - print args - let matchReader (n, _) = - null args || ("reader" `elem` args && n `elem` args) - matchWriter (n, TextWriter _) = - null args || ("writer" `elem` args && n `elem` args) - matchWriter _ = False - allWriters = map fst (writers :: [(T.Text, Writer PandocPure)]) - matchedReaders = map fst (filter matchReader readers - :: [(T.Text, Reader PandocPure)]) - matchedWriters = map fst (filter matchWriter writers - :: [(T.Text, Writer PandocPure)]) inp <- UTF8.toText <$> B.readFile "test/testsuite.txt" let opts = def let doc = either (error . show) id $ runPure $ readMarkdown opts inp - readerBs <- fmap catMaybes - $ mapM (readerBench doc) - $ filter (/="haddock") - (matchedReaders `intersect` allWriters) - -- we need the corresponding writer to generate - -- input for the reader - let writerBs = mapMaybe (writerBench doc) matchedWriters - defaultMainWith defaultConfig{ timeLimit = 6.0 } - (writerBs ++ readerBs) + imgs <- getImages + defaultMain + [ bgroup "writers" $ mapMaybe (writerBench imgs doc . fst) + (sortOn fst + writers :: [(T.Text, Writer PandocPure)]) + , bgroup "readers" $ mapMaybe (readerBench doc . fst) + (sortOn fst + readers :: [(T.Text, Reader PandocPure)]) + ] diff --git a/benchmark/weigh-pandoc.hs b/benchmark/weigh-pandoc.hs deleted file mode 100644 --- a/benchmark/weigh-pandoc.hs +++ /dev/null @@ -1,50 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{- | - Module : Main - Copyright : © 2016-2021 John MacFarlane - License : GNU GPL, version 2 or above - - Maintainer : John MacFarlane - Stability : alpha - Portability : portable - -Benchmarks to determine resource use of readers and writers. --} -import Prelude -import Weigh -import Text.Pandoc -import Data.Text (Text, unpack) - -main :: IO () -main = do - doc <- read <$> readFile "test/testsuite.native" - mainWith $ do - func "Pandoc document" id doc - mapM_ - (\(n,r) -> weighReader doc n (either (error . show) id . runPure . r def{readerExtensions = pandocExtensions})) - [("markdown", readMarkdown) - ,("html", readHtml) - ,("docbook", readDocBook) - ,("latex", readLaTeX) - ,("commonmark", readCommonMark) - ] - mapM_ - (\(n,w) -> weighWriter doc n (either (error . show) id . runPure . w def)) - [("markdown", writeMarkdown) - ,("html", writeHtml5String) - ,("docbook", writeDocbook5) - ,("latex", writeLaTeX) - ,("commonmark", writeCommonMark) - ] - -weighWriter :: Pandoc -> String -> (Pandoc -> Text) -> Weigh () -weighWriter doc name writer = func (name ++ " writer") writer doc - -weighReader :: Pandoc -> Text -> (Text -> Pandoc) -> Weigh () -weighReader doc name reader = - case lookup name writers of - Just (TextWriter writer) -> - let inp = either (error . show) id $ runPure $ writer def{ writerWrapText = WrapAuto} doc - in func (unpack $ name <> " reader") reader inp - _ -> return () -- no writer for reader diff --git a/cabal.project b/cabal.project --- a/cabal.project +++ b/cabal.project @@ -3,8 +3,8 @@ tests: True package pandoc - flags: +embed_data_files -trypandoc - ghc-options: -j +RTS -A64m -RTS + flags: +embed_data_files + ghc-options: -j +RTS -A256m -RTS -- source-repository-package -- type: git diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,5 +1,494 @@ # Revision history for pandoc +## pandoc 2.12 (2021-03-08) + + * `--resource-path` now accumulates if specified multiple + times (#6152). Resource paths specified later on the command line are + prepended to those specified earlier. Thus, + `--resource-path foo --resource-path bar:baz` is equivalent to + `--resource-path bar:bas:foo`. (The previous behavior was + for the last `--resource-path` to replace all the rest.) + `resource-path` in defaults files behaves the same way: it + will be prepended to the resource path set by earlier + command line options or defaults files. This change + facilitates the use of multiple defaults files: each can + specify a directory containing resources it refers to + without clobbering the resource paths set by the others. + + * Allow defaults files to refer to the home directory, the + user data directory, and the directory containing the defaults file + itself (#5871, #5982, #5977). In fields that expect file paths + (and only in these fields), + + + `${VARIABLE}` will expand to the value of the environment variable + `VARIABLE` (and in particular `${HOME}` will expand to the path + of the home directory). A warning will be raised for undefined + variables. + + `${USERDATA}` will expand to the path of the user data + directory in force when the defaults file is being processed. + + `${.}` will expand to the directory containing the defaults file. + (This allows default files to be placed in a directory containing + resources they make use of.) + + * When downloading content from URL arguments, be sensitive to + the character encoding (#5600). We can properly handle UTF-8 and latin1 + (ISO-8859-1); for others we raise an error. Fall back to latin1 if + no charset is given in the mime type and UTF-8 decoding fails. + + * Allow abbreviations that don't end in a period to be + specified using `--abbreviations` (#7124). + + * Add new unexported module Text.Pandoc.XML.Light, as well + as Text.Pandoc.XML.Light.Types, Text.Pantoc.XML.Light.Proc, + Text.Pandoc.XML.Light.Output. (Closes #6001, #6565, #7091). + + This module exports definitions of `Element` and `Content` + that are isomorphic to xml-light's, but with Text + instead of String. This allows us to keep most of the code in existing + readers that use xml-light, but avoid lots of unnecessary allocation. + + We also add versions of the functions from xml-light's + Text.XML.Light.Output and Text.XML.Light.Proc that operate on our + modified XML types, and functions that convert xml-light types to our + types (since some of our dependencies, like texmath, use xml-light). + + We export functions that use xml-conduit's parser to produce an + `Element` or `[Content]`. This allows existing pandoc code to use + a better parser without much modification. + + The new parser is used in all places where xml-light's parser was + previously used. Benchmarks show a significant performance improvement + in parsing XML-based formats (with docbook, opml, jats, and docx + almost twice as fast, odt and fb2 more than twice as fast). + + In addition, the new parser gives us better error reporting than + xml-light. We report XML errors, when possible, using the new + `PandocXMLError` constructor in `PandocError`. + + These changes revealed the need for some changes in the tests. The + docbook-reader.docbook test lacked definitions for the entities it used; + these have been added. And the docx golden tests have been updated, + because the new parser does not preserve the order of attributes. + + * DocBook reader: + + + Avoid expensive tree normalization step, as it is not necessary + with the new XML parser. + + Support `informalfigure` (#7079) (Nils Carlson). + + * Docx reader: + + + Use Map instead of list for Namespaces. This gives a speedup of + about 5-10%. With this and the XML parsing changes, the docx reader + is now about twice as fast as in the previous release. + + * HTML reader: + + + Small performance tweaks. + + Also, remove exported class `NamedTag(..)` [API change]. This was just + intended to smooth over the transition from String to Text and is no + longer needed. + + As a result, the functions `isInlineTag` and `isBlockTag` + are no longer polymorphic; they apply to a `Tag Text` [API change]. + + Do a lookahead to find the right parser to use. This takes + benchmarks from 34ms to 23ms, with less allocation. + + Fix bad handling of empty `src` attribute in `iframe` (#7099). + If `src` is empty, we simply skip the `iframe`. + If `src` is invalid or cannot be fetched, we issue a warning + nd skip instead of failing with an error. + + * JATS reader: + + + Avoid tree normalization, which is no longer necessary given the + new XML parser. + + * LaTeX reader: + + + Don't export `tokenize`, `untokenize` [API change]. These are internal + implementation details, which were only exported for testing. + They don't belong in the public API. + + Improved efficiency of the parser. With these changes the reader + is almost twice as fast as in the last release in our benchmarks. + + Code cleanup, removing some unnecessary things. + + Rewrite `withRaw` so it doesn't rely on fragile assumptions + about token positions (which break when macros are expanded) + (#7092). This requires the addition of `sEnableWithRaw` and + `sRawTokens` in `LaTeXState`, and a new combinator `disablingWithRaw` + to disable collecting of raw tokens in certain contexts. + Add `parseFromToks` to Text.Pandoc.Readers.LaTeX.Parsing. + Fix parsing of single character tokens so it doesn't mess + up the new raw token collecting. These changes slightly increase + allocations and have a small performance impact. + + Handle some bibtex/biblatex-specific commands that used to be + dealt with in pandoc-citeproc (#7049). + + Optimize `satisfyTok`, avoiding unnecessary macro expansion steps. + Benchmarks after this change show 2/3 of the run time and 2/3 of the + allocation of the Feb. 10 benchmarks. + + Removed `sExpanded` in state. This isn't actually needed and checking + it doesn't change anything. + + Improve `braced'`. Remove the parameter, have it parse the + opening brace, and make it more efficient. + + Factor out pieces of the LaTeX reader to make the module smaller. + This reduces memory demands when compiling. Created + Text.Pandoc.Readers.{LaTeX,Math,Citation,Table,Macro,Inline}. + Changed Text.Pandoc.Readers.LaTeX.SIunitx to export a command map + instead of individual commands. + + Handle table cells containing `&` in `\verb` (#7129). + + * Make Text.Pandoc.Readers.LaTeX.Types an unexported module [API change]. + + * Markdown reader: + + + Improved handling of mmd link attributes in references (#7080). + Previously they only worked for links that had titles. + + Improved efficiency of the parser (benchmarks show a 15% speedup). + + * OPML reader: + + + Avoid tree normalization, which is no longer necessary with the + new XML parser. + + * ODT reader: + + + Finer-grained errors on parse failure (#7091). + + Give more information if the zip container can't be unpacked. + + * Org reader: + + + Support `task_lists` extension (Albert Krewinkel, #6336). + + Fix bug in org-ref citation parsing (Albert Krewinkel, #7101). + The org-ref syntax allows to list multiple citations separated by + comma. Previously commas were accepted as part of the citation id, + so all citation lists were parsed as one single citation. + + * RST reader: + + + Use `getTimestamp` instead of `getCurrentTime` to fetch timestamp. + Setting `SOURCE_DATE_EPOCH` will allow reproducible builds. + + RST reader: fix handling of header in CSV tables (#7064). + The interpretation of this line is not affected by the delim option. + + * Jira reader: + + + Modified the Doc parser to skip leading blank lines. This fixes + parsing of documents which start with multiple blank lines (Albert + Krewinkel, #7095). + + Prevent URLs within link aliases to be treated as autolinks (Albert + Krewinkel, #6944). + + * Text.Pandoc.Shared + + + Remove formerly exported functions that are no longer used in the + code base: `splitByIndices`, `splitStringByIndicies`, `substitute`, + and `underlineSpan` (which had been deprecated in April 2020) + [API change]. + + Export `handleTaskListItem` (Albert Krewinkel) [API change]. + + Change `defaultUserDataDirs` to `defaultUserDataDir` [API + change]. We determine what is the default user data directory + by seeing whether the XDG directory and/or legacy + directory exist. + + * BibTeX writer: + + + BibTeX writer: use doclayout and doctemplate. This change allows + bibtex/biblatex output to wrap as other formats do, + depending on the settings of `--wrap` and `--columns` (#7068). + + * CSL JSON writer: + + + Output `[]` if no references in input, instead of raising a + PandocAppError as before. + + * Docx writer: + + + Use `getTimestamp` instead of `getCurrentTime` for timestamp. + Setting `SOURCE_DATE_EPOCH` will allow reproducible builds. + + * EPUB writer: + + + Use `getTimestamp` instead of `getCurrentTime` for timestamp. + Setting `SOURCE_DATE_EPOCH` will allow reproducible builds (#7093). + This does not suffice to fully enable reproducible in EPUB, since + a unique id is still being generated for each build. + + Support `belongs-to-collection` metadata (#7063) (Nick Berendsen). + + * JATS writer: + + + Escape special chars in reference elements (Albert Krewinkel). + Prevents the generation of invalid markup if a citation element + contains an ampersand or another character with a special meaning + in XML. + + * Jira writer: + + + Use Span identifiers as anchors (Albert Krewinkel). + + Use `{noformat}` instead of `{code}` for unknown languages (Albert + Krewinkel). Code blocks which are not marked as a language supported + by Jira are rendered as preformatted text via `{noformat}` blocks. + + * LaTeX writer: + + + Adjust hypertargets to beginnings of paragraphs (#7078). + Use `\vadjust pre` so that the hypertarget takes you to the beginning + of the paragraph rather than one line down. + This makes a particular difference for links to citations using + `--citeproc` and `link-citations: true`. + + Change BCP47 lang tag from `jp` to `ja` (Mauro Bieg, #7047). + + Use function instead of map for accent lookup (should be + more efficient). + + Split the module to make it easier to compile on low-memory + systems: added Text.Pandoc.Writers.LaTeX.{Util,Citation,Lang}. + + * Markdown writer: + + + Handle math right before digit. We insert an HTML comment to + avoid a `$` right before a digit, which pandoc will not recognize + as a math delimiter. + + Split the module to make it easier to compile on low-memory + systems: added Text.Pandoc.Writers.Markdown.{Types,Inline}. + + * ODT writer: + + + Use `getTimestamp` instead of `getCurrentTime` for timestamp. + Setting `SOURCE_DATE_EPOCH` will allow reproducible builds. + + Update default ODT style (Lorenzo). Previously, the "First paragraph" + style inherited from "Standard" but not from "Text body." Now + it is adjusted to inherit from "Text body", to avoid some ugly + spacing issues. It may be necessary to update a custom `reference.odt` + in light of this change. + + * Org writer: + + + Support `task_lists` extension (Albert Krewinkel, #6336). + + * Pptx writer: + + + Use `getTimestamp` instead of `getCurrentTime` for timestamp. + Setting `SOURCE_DATE_EPOCH` will allow reproducible builds. + + * JATS templates: tag `author.name` as `string-name` (Albert Krewinkel). + The partitioning the components of a name into surname, given names, + etc. is not always possible or not available. Using `author.name` + allows to give the full name as a fallback to be used when + `author.surname` is not available. + + * Add default templates for bibtex and biblatex, so that + the variables `header-include`, `include-before`, `include-after` + (or alternatively the command line options + `--include-in-header`, `--include-before-body`, `--include-after-body`) + may be used. + + * LaTeX template: + + + Update to iftex package (#7073) (Andrew Dunning) + + Wrap url colours in braces (#7121) (Loïc Grobol). + + * revealjs template: Add 'center' option for vertical slide centering. + (maurerle, #7104). + + * Text.Pandoc.XML: Improve efficiency of `fromEntities`. + + * Text.Pandoc.MIME + + + Add exported function `getCharset` [API change]. + + * Text.Pandoc.UTF8: change IO functions to return Text, not String + [API change]. This affects `readFile`, `getContents`, `writeFileWith`, + `writeFile`, `putStrWith`, `putStr`, `putStrLnWith`, `putStrLn`. + `hPutStrWith`, `hPutStr`, `hPutStrLnWith`, `hPutStrLn`, `hGetContents`. + This avoids the need to uselessly create a linked list of characters + when emiting output. + + * Text.Pandoc.App + + + Add `parseOptionsFromArgs` [API change, new exported function]. + + Add fields for CSL options to `Opt` [API change]: + `optCSL`, `optbibliography`, `optCitationAbbreviations`. + + * Text.Pandoc.Citeproc.BibTeX + + + `Text.Pandoc.Citeproc.writeBibTeXString` now returns + `Doc Text` instead of `Text` (#7068). + + Correctly handle `pages` (= `page` in CSL) (#7067). + + Correctly handle BibLaTeX `langid` (= `language` in CSL, #7067). + + In BibTeX output, protect foreign titles since there's no language + field (#7067). + + Clean up BibTeX parsing (#7049). Previously there was a messy code + path that gave strange results in some cases, not passing through raw + tex but trying to extract a string content. This was an artefact of + trying to handle some special bibtex-specific commands in the BibTeX + reader. Now we just handle these in the LaTeX reader and simplify + parsing in the BibTeX reader. This does mean that more raw tex will + be passed through (and currently this is not sensitive to the + `raw_tex` extension; this should be fixed). + + * Text.Pandoc.Citeproc.MetaValue + + + Correctly parse "raw" date value in markdown references metadata. + (See jgm/citeproc#53.) + + * Text.Pandoc.Citeproc + + + Use https URLs for links (Salim B, #7122). + + * Text.Pandoc.Class + + + Add `getTimestamp` [API change]. This attempts to read the + `SOURCE_DATE_EPOCH` environment variable and parse a UTC time + from it (treating it as a unix date stamp, see + https://reproducible-builds.org/specs/source-date-epoch/). If the + variable is not set or can't be parsed as a unix date stamp, then the + function returns the current date. + + * Text.Pandoc.Error + + + Add `PandocUnsupportedCharsetError` constructor for + `PandocError` [API change]. + + Export `renderError` [API change]. + + Refactor `handleError` to use `renderError`. This allows us render + error messages without exiting. + + * Text.Pandoc.Extensions + + + `Ext_task_lists` is now supported by org (and turned + on by default) (Albert Krewinkel, #6336). + + Remove `Ext_fenced_code_attributes` from allowed commonmark attributes + (#7097). This attribute was listed as allowed, but it didn't actually + do anything. Use `attributes` for code attributes and more. + + * Lua subsystem: + + + Always load built-in Lua scripts from default data-dir (Albert + Krewinkel). The Lua modules `pandoc` and `pandoc.List` are now always + loaded from the system's default data directory. Loading from a + different directory by overriding the default path, e.g. via + `--data-dir`, is no longer supported to avoid unexpected behavior + and to address security concerns. + + Add module "pandoc.path" (Albert Krewinkel, #6001, #6565). + The module allows to work with file paths in a convenient and + platform-independent manner. + + Use strict evaluation when retrieving AST value from the stack + (Albert Krewinkel, #6674). + + * Text.Pandoc.PDF + + + Disable `smart` extension when building PDF via LaTeX. + This is to prevent accidental creation of ligatures like + `` ?` `` and `` !` `` (especially in languages with quotations like + German), and similar ligature issues. (See jgm/citeproc#54.) + + * Text.Pandoc.CSV: + + + Fix parsing of unquoted values (#7112). Previously we didn't allow + unescaped quotes in unquoted values, but they are allowed + in CSV. + + * Test suite: + + + Use a more robust method for testing the executable. Many + of our tests require running the pandoc executable. This + is problematic for a few different reasons. First, + cabal-install will sometimes run the test suite after + building the library but before building the executable, + which means the executable isn't in place for the tests. + One can work around that by first building, then building + and running the tests, but that's fragile. Second, we + have to find the executable. So far, we've done that using + a function `findPandoc` that attempts to locate it + relative to the test executable (which can be located + using findExecutablePath). But the logic here is delicate + and work with every combination of options. To solve both + problems, we add an `--emulate` option to the + `test-pandoc` executable. When `--emulate` occurs as the + first argument passed to `test-pandoc`, the program simply + emulates the regular pandoc executable, using the rest of + the arguments (after `--emulate`). Thus, `test-pandoc + --emulate -f markdown -t latex` is just like `pandoc -f + markdown -t latex`. Since all the work is done by library + functions, implementing this emulation just takes a couple + lines of code and should be entirely reliable. With this + change, we can test the pandoc executable by running the + test program itself (locatable using `findExecutablePath`) + with the `--emulate` option. This removes the need for the + fragile `findPandoc` step, and it means we can run our + integration tests even when we're just building the + library, not the executable. [Note: part of this change + involved simplifying some complex handling to set + environment variables for dynamic library paths. I have + tested a build with `--enable-dynamic-executable`, and it + works, but further testing may be needed.] + + Print accurate location if a test fails (Albert + Krewinkel). Ensures that tasty-hunit reports the location + of the failing test instead of the location of the helper + `test` function. + + * Documentation: Update URLs and use `https` where possible (#7122, + Salim B). + + * Add `doc/libraries.md`, a description of libraries that support pandoc. + + * MANUAL.txt + + + MANUAL: block-level formatting is not allowed in line blocks (#7107). + + Clarify `tex_math_dollars` extension. Note that no blank lines + are allowed between the delimiters in display math. + + Add MANUAL section on reproducible builds. + + Document no template fallback for absolute path (#7077, Nixon + Enraght-Moony.) + + Improve docs for cite-method. + + Update README and man page. + + * Makefile: in `make bench`, create CSV files for comparison and compare + against previous benchmark run. Add timestamp to CSV filenames. + + * cabal.project: don't explicitly set -trypandoc. + If we do, this can't be overridden on the cabal command line. + + * doc/lua-filters.md: improve documentation for + `pandoc.mediabag.insert`, `pandoc.mediabag.fetch`, + `directory`, `normalize` (Albert Krewinkel). + + * Allow base64-bytestring-1.2.* (Dmitrii Kovanikov) + + * Require jira-wiki-markup 1.3.3 (Albert Krewinkel) + + * Require citeproc 0.3.0.8, which correctly titlecases when titles + contain non-ASCII characters. + + * Use skylighting 0.10.4. This version of skylighting uses xml-conduit + rather than hxt. This speeds up parsing of XML syntax definitions + fourfold, and removes four packages from pandoc's dependency graph: + hxt-charproperties, hxt-unicode, hxt-regex-xmlschema, hxt. + + * Add script `tools/parseTimings.pl` to help pin down which + modules take the most time and memory to compile. + + * Avoid unnecessary use of NoImplicitPrelude pragma (#7089) (Albert + Krewinkel) + + * Benchmarks + + + Use the lighter-weight tasty-bench instead of criterion. + + Run writer benchmarks for binary formats too. + + Alphabetize benchmarks. + + Don't run benchmarks for bibliography formats + (yet; we need a special input for them). + + Show allocation data + + Clean up benchmark code. + + Allow specifying patterns using `-p blah'. + + * trypandoc: add 2 second timeout. + + * Use `-split-sections` in creating linux release binary. + This reduces executable size significantly (by about 30%). + + * Remove `weigh-pandoc`. It's not really useful any more, now that our + regular benchmarks include data on allocation. + + * Improve linux package build process and add script to + automate building an arm64 binary package. + + ## pandoc 2.11.4 (2021-01-22) * Add `biblatex`, `bibtex` as output formats (closes #7040). @@ -591,8 +1080,11 @@ translated to `C:\/foo/bar`, which caused problems. With this fix, the backslashes are removed. - * Text.Pandoc.Logging: Add constructor `ATXHeadingInLHS` constructor - to `LogMessage` [API change]. + * Text.Pandoc.Logging: + + + Add constructor `ATXHeadingInLHS` to `LogMessage` [API change]. + + Add constructor `EnvironmentVariableUndefined` to + `LogMessage` [API change]. * Fix error that is given when people specify `doc` output (#6834, gison93). diff --git a/data/odt/styles.xml b/data/odt/styles.xml --- a/data/odt/styles.xml +++ b/data/odt/styles.xml @@ -350,7 +350,7 @@ diff --git a/data/templates/article.jats_publishing b/data/templates/article.jats_publishing --- a/data/templates/article.jats_publishing +++ b/data/templates/article.jats_publishing @@ -30,10 +30,10 @@ $endif$ $if(journal.pissn)$ -$journal.pissn$ +$journal.pissn$ $endif$ $if(journal.eissn)$ -$journal.eissn$ +$journal.eissn$ $endif$ $-- At least one issn element is required; use empty issn as fallback $if(journal.pissn)$ @@ -95,6 +95,8 @@ $author.surname$ $author.given-names$ +$elseif(author.name)$ +$author.name$ $else$ $author$ $endif$ @@ -128,7 +130,7 @@ $endif$ $if(date)$ - + $if(date.day)$ $date.day$ $endif$ diff --git a/data/templates/default.biblatex b/data/templates/default.biblatex new file mode 100644 --- /dev/null +++ b/data/templates/default.biblatex @@ -0,0 +1,10 @@ +$for(header-includes)$ +$header-includes$ +$endfor$ +$for(include-before)$ +$include-before$ +$endfor$ +$body$ +$for(include-after)$ +$include-after$ +$endfor$ diff --git a/data/templates/default.bibtex b/data/templates/default.bibtex new file mode 100644 --- /dev/null +++ b/data/templates/default.bibtex @@ -0,0 +1,10 @@ +$for(header-includes)$ +$header-includes$ +$endfor$ +$for(include-before)$ +$include-before$ +$endfor$ +$body$ +$for(include-after)$ +$include-after$ +$endfor$ diff --git a/data/templates/default.jats_articleauthoring b/data/templates/default.jats_articleauthoring --- a/data/templates/default.jats_articleauthoring +++ b/data/templates/default.jats_articleauthoring @@ -28,6 +28,8 @@ $author.surname$ $author.given-names$ +$elseif(author.name)$ +$author.name$ $else$ $author$ $endif$ diff --git a/data/templates/default.latex b/data/templates/default.latex --- a/data/templates/default.latex +++ b/data/templates/default.latex @@ -98,14 +98,14 @@ $if(linestretch)$ \usepackage{setspace} $endif$ -\usepackage{ifxetex,ifluatex} -\ifnum 0\ifxetex 1\fi\ifluatex 1\fi=0 % if pdftex +\usepackage{iftex} +\ifPDFTeX \usepackage[$if(fontenc)$$fontenc$$else$T1$endif$]{fontenc} \usepackage[utf8]{inputenc} \usepackage{textcomp} % provide euro and other symbols \else % if luatex or xetex $if(mathspec)$ - \ifxetex + \ifXeTeX \usepackage{mathspec} \else \usepackage{unicode-math} @@ -129,7 +129,7 @@ $endfor$ $if(mathfont)$ $if(mathspec)$ - \ifxetex + \ifXeTeX \setmathfont(Digits,Latin,Greek)[$for(mathfontoptions)$$mathfontoptions$$sep$,$endfor$]{$mathfont$} \else \setmathfont[$for(mathfontoptions)$$mathfontoptions$$sep$,$endfor$]{$mathfont$} @@ -139,18 +139,18 @@ $endif$ $endif$ $if(CJKmainfont)$ - \ifxetex + \ifXeTeX \usepackage{xeCJK} \setCJKmainfont[$for(CJKoptions)$$CJKoptions$$sep$,$endfor$]{$CJKmainfont$} \fi $endif$ $if(luatexjapresetoptions)$ - \ifluatex + \ifLuaTeX \usepackage[$for(luatexjapresetoptions)$$luatexjapresetoptions$$sep$,$endfor$]{luatexja-preset} \fi $endif$ $if(CJKmainfont)$ - \ifluatex + \ifLuaTeX \usepackage[$for(luatexjafontspecoptions)$$luatexjafontspecoptions$$sep$,$endfor$]{luatexja-fontspec} \setmainjfont[$for(CJKoptions)$$CJKoptions$$sep$,$endfor$]{$CJKmainfont$} \fi @@ -219,10 +219,10 @@ $endif$ $if(colorlinks)$ colorlinks=true, - linkcolor=$if(linkcolor)$$linkcolor$$else$Maroon$endif$, - filecolor=$if(filecolor)$$filecolor$$else$Maroon$endif$, - citecolor=$if(citecolor)$$citecolor$$else$Blue$endif$, - urlcolor=$if(urlcolor)$$urlcolor$$else$Blue$endif$, + linkcolor={$if(linkcolor)$$linkcolor$$else$Maroon$endif$}, + filecolor={$if(filecolor)$$filecolor$$else$Maroon$endif$}, + citecolor={$if(citecolor)$$citecolor$$else$Blue$endif$}, + urlcolor={$if(urlcolor)$$urlcolor$$else$Blue$endif$}, $else$ hidelinks, $endif$ @@ -329,7 +329,7 @@ $header-includes$ $endfor$ $if(lang)$ -\ifxetex +\ifXeTeX % Load polyglossia as late as possible: uses bidi with RTL langages (e.g. Hebrew, Arabic) \usepackage{polyglossia} \setmainlanguage[$for(polyglossia-lang.options)$$polyglossia-lang.options$$sep$,$endfor$]{$polyglossia-lang.name$} @@ -346,15 +346,15 @@ $endif$ \fi $endif$ -\ifluatex +\ifLuaTeX \usepackage{selnolig} % disable illegal ligatures \fi $if(dir)$ -\ifxetex +\ifXeTeX % Load bidi as late as possible as it modifies e.g. graphicx \usepackage{bidi} \fi -\ifnum 0\ifxetex 1\fi\ifluatex 1\fi=0 % if pdftex +\ifPDFTeX \TeXXeTstate=1 \newcommand{\RL}[1]{\beginR #1\endR} \newcommand{\LR}[1]{\beginL #1\endL} diff --git a/data/templates/default.revealjs b/data/templates/default.revealjs --- a/data/templates/default.revealjs +++ b/data/templates/default.revealjs @@ -82,6 +82,10 @@ // Full list of configuration options available at: // https://revealjs.com/config/ Reveal.initialize({ +$if(center)$ + // Determines whether slide content should be vertically centered + center: $center$, +$endif$ $if(controls)$ // Display controls in the bottom right corner controls: $controls$, diff --git a/man/pandoc.1 b/man/pandoc.1 --- a/man/pandoc.1 +++ b/man/pandoc.1 @@ -1,7 +1,7 @@ '\" t -.\" Automatically generated by Pandoc 2.11.4 +.\" Automatically generated by Pandoc 2.12 .\" -.TH "Pandoc User\[cq]s Guide" "" "January 21, 2021" "pandoc 2.11.4" "" +.TH "Pandoc User\[cq]s Guide" "" "March 8, 2021" "pandoc 2.12" "" .hy .SH NAME pandoc - general markup converter @@ -172,13 +172,12 @@ When using LaTeX, the following packages need to be available (they are included with all recent versions of TeX Live): \f[C]amsfonts\f[R], \f[C]amsmath\f[R], \f[C]lm\f[R], \f[C]unicode-math\f[R], -\f[C]ifxetex\f[R], \f[C]ifluatex\f[R], \f[C]listings\f[R] (if the -\f[C]--listings\f[R] option is used), \f[C]fancyvrb\f[R], -\f[C]longtable\f[R], \f[C]booktabs\f[R], \f[C]graphicx\f[R] (if the -document contains images), \f[C]hyperref\f[R], \f[C]xcolor\f[R], -\f[C]ulem\f[R], \f[C]geometry\f[R] (with the \f[C]geometry\f[R] variable -set), \f[C]setspace\f[R] (with \f[C]linestretch\f[R]), and -\f[C]babel\f[R] (with \f[C]lang\f[R]). +\f[C]iftex\f[R], \f[C]listings\f[R] (if the \f[C]--listings\f[R] option +is used), \f[C]fancyvrb\f[R], \f[C]longtable\f[R], \f[C]booktabs\f[R], +\f[C]graphicx\f[R] (if the document contains images), +\f[C]hyperref\f[R], \f[C]xcolor\f[R], \f[C]ulem\f[R], \f[C]geometry\f[R] +(with the \f[C]geometry\f[R] variable set), \f[C]setspace\f[R] (with +\f[C]linestretch\f[R]), and \f[C]babel\f[R] (with \f[C]lang\f[R]). The use of \f[C]xelatex\f[R] or \f[C]lualatex\f[R] as the PDF engine requires \f[C]fontspec\f[R]. \f[C]lualatex\f[R] uses \f[C]selnolig\f[R]. @@ -458,16 +457,15 @@ of the XDG data directory (by default, \f[C]$HOME/.local/share\f[R], overridable by setting the \f[C]XDG_DATA_HOME\f[R] environment variable). -If that directory does not exist, \f[C]$HOME/.pandoc\f[R] will be used -(for backwards compatibility). -In Windows the default user data directory is +If that directory does not exist and \f[C]$HOME/.pandoc\f[R] exists, it +will be used (for backwards compatibility). +On Windows the default user data directory is \f[C]C:\[rs]Users\[rs]USERNAME\[rs]AppData\[rs]Roaming\[rs]pandoc\f[R]. You can find the default user data directory on your system by looking at the output of \f[C]pandoc --version\f[R]. -A \f[C]reference.odt\f[R], \f[C]reference.docx\f[R], \f[C]epub.css\f[R], -\f[C]templates\f[R], \f[C]slidy\f[R], \f[C]slideous\f[R], or -\f[C]s5\f[R] directory placed in this directory will override -pandoc\[cq]s normal defaults. +Data files placed in this directory (for example, +\f[C]reference.odt\f[R], \f[C]reference.docx\f[R], \f[C]epub.css\f[R], +\f[C]templates\f[R]) will override pandoc\[cq]s normal defaults. .TP \f[B]\f[CB]-d\f[B]\f[R] \f[I]FILE\f[R], \f[B]\f[CB]--defaults=\f[B]\f[R]\f[I]FILE\f[R] Specify a set of default option settings. @@ -732,9 +730,9 @@ To see the system default, use \f[C]pandoc --print-default-data-file=abbreviations\f[R]. The only use pandoc makes of this list is in the Markdown reader. -Strings ending in a period that are found in this list will be followed -by a nonbreaking space, so that the period will not produce -sentence-ending space in formats like LaTeX. +Strings found in this list will be followed by a nonbreaking space, and +the period will not produce sentence-ending space in formats like LaTeX. +The strings may not contain spaces. .SS General writer options .TP \f[B]\f[CB]-s\f[B]\f[R], \f[B]\f[CB]--standalone\f[B]\f[R] @@ -925,6 +923,11 @@ directory must be explicitly listed or it will not be searched. For example: \f[C]--resource-path=.:test\f[R] will search the working directory and the \f[C]test\f[R] subdirectory, in that order. +This option can be used repeatedly. +Search path components that come later on the command line will be +searched before those that come earlier, so +\f[C]--resource-path foo:bar --resource-path baz:bim\f[R] is equivalent +to \f[C]--resource-path baz:bim:foo:bar\f[R]. .TP \f[B]\f[CB]--request-header=\f[B]\f[R]\f[I]NAME\f[R]\f[B]\f[CB]:\f[B]\f[R]\f[I]VAL\f[R] Set the request header \f[I]NAME\f[R] to the value \f[I]VAL\f[R] when @@ -1614,6 +1617,11 @@ PandocPDFError T} T{ +44 +T}@T{ +PandocXMLError +T} +T{ 47 T}@T{ PandocPDFProgramNotFoundError @@ -1674,6 +1682,11 @@ PandocIpynbDecodingError T} T{ +94 +T}@T{ +PandocUnsupportedCharsetError +T} +T{ 97 T}@T{ PandocCouldNotFindDataFileError @@ -1773,8 +1786,11 @@ verbosity: INFO log-file: log.json -# citeproc, natbib, or biblatex +# citeproc, natbib, or biblatex. This only affects LaTeX +# output. If you want to use citeproc to format citations, +# you should also set \[aq]citeproc: true\[aq] (see above). cite-method: citeproc + # part, chapter, section, or default: top-level-division: chapter abbreviations: @@ -1875,6 +1891,38 @@ \f[R] .fi .PP +In fields that expect a file path (or list of file paths), the following +syntax may be used to interpolate environment variables: +.IP +.nf +\f[C] +csl: ${HOME}/mycsldir/special.csl +\f[R] +.fi +.PP +\f[C]${USERDATA}\f[R] may also be used; this will always resolve to the +user data directory that is current when the defaults file is parsed, +regardless of the setting of the environment variable +\f[C]USERDATA\f[R]. +.PP +\f[C]${.}\f[R] will resolve to the directory containing the default file +itself. +This allows you to refer to resources contained in that directory: +.IP +.nf +\f[C] +epub-cover-image: ${.}/cover.jpg +epub-metadata: ${.}/meta.xml +resource-path: +- . # the working directory from which pandoc is run +- ${.}/images # the images subdirectory of the directory + # containing this defaults file +\f[R] +.fi +.PP +This environment variable interpolation syntax \f[I]only\f[R] works in +fields that expect file paths. +.PP Default files can be placed in the \f[C]defaults\f[R] subdirectory of the user data directory and used from any directory. For example, one could create a file specifying defaults for writing @@ -2134,9 +2182,9 @@ \f[R] .fi .PP -(If a partial is not found in the directory of the template, it will -also be sought in the \f[C]templates\f[R] subdirectory of the user data -directory.) +(If a partial is not found in the directory of the template and the +template path is given as a relative path, it will also be sought in the +\f[C]templates\f[R] subdirectory of the user data directory.) .PP Partials may optionally be applied to variables using a colon: .IP @@ -3928,6 +3976,9 @@ \f[R] .fi .PP +Inline formatting (such as emphasis) is allowed in the content, but not +block-level formatting (such as block quotes or lists). +.PP This syntax is borrowed from reStructuredText. .SS Lists .SS Bullet lists @@ -5048,7 +5099,9 @@ .PP For display math, use \f[C]$$\f[R] delimiters. (In this case, the delimiters may be separated from the formula by -whitespace.) +whitespace. +However, there can be no blank lines betwen the opening and closing +\f[C]$$\f[R] delimiters.) .PP TeX math will be printed in all output formats. How it is rendered depends on the output format: @@ -6938,6 +6991,16 @@ \f[B]\f[CB]rights\f[B]\f[R] A string value. .TP +\f[B]\f[CB]belongs-to-collection\f[B]\f[R] +A string value. +identifies the name of a collection to which the EPUB Publication +belongs. +.TP +\f[B]\f[CB]group-position\f[B]\f[R] +The \f[C]group-position\f[R] field indicates the numeric position in +which the EPUB Publication belongs relative to other works belonging to +the same \f[C]belongs-to-collection\f[R] field. +.TP \f[B]\f[CB]cover-image\f[B]\f[R] A string value (path to cover image). .TP @@ -7453,6 +7516,20 @@ new default template with the name \f[C]default.NAME_OF_CUSTOM_WRITER.lua\f[R] to the \f[C]templates\f[R] subdirectory of your user data directory (see Templates). +.SH REPRODUCIBLE BUILDS +.PP +Some of the document formats pandoc targets (such as EPUB, docx, and +ODT) include build timestamps in the generated document. +That means that the files generated on successive builds will differ, +even if the source does not. +To avoid this, set the \f[C]SOURCE_DATE_EPOCH\f[R] environment variable, +and the timestamp will be taken from it instead of the current time. +\f[C]SOURCE_DATE_EPOCH\f[R] should contain an integer unix timestamp +(specifying the number of second since midnight UTC January 1, 1970). +.PP +Some document formats also include a unique identifier. +For EPUB, this can be set explicitly by setting the \f[C]identifier\f[R] +metadata field (see EPUB Metadata, above). .SH A NOTE ON SECURITY .PP If you use pandoc to convert user-contributed content in a web @@ -7495,4 +7572,4 @@ of contributors, see the file AUTHORS.md in the pandoc source code. .PP The Pandoc source code and all documentation may be downloaded -from . +from . diff --git a/man/pandoc.1.after b/man/pandoc.1.after --- a/man/pandoc.1.after +++ b/man/pandoc.1.after @@ -1,3 +1,3 @@ .PP The Pandoc source code and all documentation may be downloaded -from . +from . diff --git a/pandoc.cabal b/pandoc.cabal --- a/pandoc.cabal +++ b/pandoc.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: pandoc -version: 2.11.4 +version: 2.12 build-type: Simple license: GPL-2.0-or-later license-file: COPYING.md @@ -56,6 +56,8 @@ data/templates/default.icml data/templates/default.opml data/templates/default.latex + data/templates/default.bibtex + data/templates/default.biblatex data/templates/default.context data/templates/default.texinfo data/templates/default.jira @@ -394,9 +396,43 @@ Description: Build trypandoc cgi executable. Default: False +common common-options + default-language: Haskell2010 + build-depends: base >= 4.9 && < 5, + text >= 1.1.1.0 && < 1.3 + ghc-options: -Wall -fno-warn-unused-do-bind + -Wincomplete-record-updates + -Wnoncanonical-monad-instances + + if impl(ghc < 8.4) + hs-source-dirs: prelude + other-modules: Prelude + build-depends: base-compat >= 0.9 + other-extensions: NoImplicitPrelude + + if os(windows) + cpp-options: -D_WINDOWS + + -- Later: + -- -Wpartial-fields (currently used in Powerpoint writer) + -- -Wmissing-export-lists (currently some Odt modules violate this) + -- -Wredundant-constraints (problematic if we want to support older base) + if impl(ghc >= 8.2) + ghc-options: -Wcpp-undef + if impl(ghc >= 8.4) + ghc-options: -Wincomplete-uni-patterns + -Widentities + -fhide-source-paths + +common common-executable + import: common-options + build-depends: pandoc + ghc-options: -rtsopts -with-rtsopts=-K16m -threaded + + library - build-depends: base >= 4.9 && < 5, - Glob >= 0.7 && < 0.11, + import: common-options + build-depends: Glob >= 0.7 && < 0.11, HTTP >= 4000.0.5 && < 4000.4, HsYAML >= 0.2 && < 0.3, JuicyPixels >= 3.1.6.1 && < 3.4, @@ -404,13 +440,13 @@ aeson >= 0.7 && < 1.6, aeson-pretty >= 0.8.5 && < 0.9, attoparsec >= 0.12 && < 0.14, - base64-bytestring >= 0.1 && < 1.2, + base64-bytestring >= 0.1 && < 1.3, binary >= 0.7 && < 0.11, blaze-html >= 0.9 && < 0.10, blaze-markup >= 0.8 && < 0.9, bytestring >= 0.9 && < 0.12, case-insensitive >= 1.2 && < 1.3, - citeproc >= 0.3.0.5 && < 0.4, + citeproc >= 0.3.0.7 && < 0.4, commonmark >= 0.1.1.3 && < 0.2, commonmark-extensions >= 0.2.0.4 && < 0.3, commonmark-pandoc >= 0.2 && < 0.3, @@ -427,13 +463,14 @@ filepath >= 1.1 && < 1.5, haddock-library >= 1.8 && < 1.10, hslua >= 1.1 && < 1.4, + hslua-module-path >= 0.1.0 && < 0.2.0, hslua-module-system >= 0.2 && < 0.3, hslua-module-text >= 0.2.1 && < 0.4, http-client >= 0.4.30 && < 0.8, http-client-tls >= 0.2.4 && < 0.4, http-types >= 0.8 && < 0.13, ipynb >= 0.1 && < 0.2, - jira-wiki-markup >= 1.3.2 && < 1.4, + jira-wiki-markup >= 1.3.3 && < 1.4, mtl >= 2.2 && < 2.3, network >= 2.6, network-uri >= 2.6 && < 2.7, @@ -443,8 +480,8 @@ random >= 1 && < 1.2, safe >= 0.3 && < 0.4, scientific >= 0.3 && < 0.4, - skylighting >= 0.10.2 && < 0.11, - skylighting-core >= 0.10.2 && < 0.11, + skylighting >= 0.10.4 && < 0.11, + skylighting-core >= 0.10.4 && < 0.11, split >= 0.2 && < 0.3, syb >= 0.1 && < 0.8, tagsoup >= 0.14.6 && < 0.15, @@ -456,41 +493,18 @@ unicode-transforms >= 0.3 && < 0.4, unordered-containers >= 0.2 && < 0.3, xml >= 1.3.12 && < 1.4, + xml-conduit >= 1.7 && < 1.10, zip-archive >= 0.2.3.4 && < 0.5, zlib >= 0.5 && < 0.7 if os(windows) && arch(i386) build-depends: basement >= 0.0.10, foundation >= 0.0.23 -- basement 0.0.9 won't build on 32-bit windows. - if impl(ghc < 8.4) - hs-source-dirs: prelude - other-modules: Prelude - build-depends: base-compat >= 0.9 - if os(windows) - cpp-options: -D_WINDOWS - else + if !os(windows) build-depends: unix >= 2.4 && < 2.8 if flag(embed_data_files) cpp-options: -DEMBED_DATA_FILES other-modules: Text.Pandoc.Data - if os(windows) - cpp-options: -D_WINDOWS - ghc-options: -Wall -fno-warn-unused-do-bind - -Wincomplete-record-updates - -Wnoncanonical-monad-instances - -- Later: - -- -Wpartial-fields (currently used in Powerpoint writer) - -- -Wmissing-export-lists (currently some Odt modules violate this) - -- -Wredundant-constraints (problematic if we want to support older base) - if impl(ghc >= 8.2) - ghc-options: -Wcpp-undef - if impl(ghc >= 8.4) - ghc-options: -Wincomplete-uni-patterns - -Widentities - -fhide-source-paths - - default-language: Haskell2010 - other-extensions: NoImplicitPrelude hs-source-dirs: src exposed-modules: Text.Pandoc, @@ -504,7 +518,6 @@ Text.Pandoc.Readers, Text.Pandoc.Readers.HTML, Text.Pandoc.Readers.LaTeX, - Text.Pandoc.Readers.LaTeX.Types, Text.Pandoc.Readers.Markdown, Text.Pandoc.Readers.CommonMark, Text.Pandoc.Readers.Creole, @@ -613,9 +626,15 @@ Text.Pandoc.Readers.HTML.Table, Text.Pandoc.Readers.HTML.TagCategories, Text.Pandoc.Readers.HTML.Types, - Text.Pandoc.Readers.LaTeX.Parsing, + Text.Pandoc.Readers.LaTeX.Inline, + Text.Pandoc.Readers.LaTeX.Citation, Text.Pandoc.Readers.LaTeX.Lang, + Text.Pandoc.Readers.LaTeX.Macro, + Text.Pandoc.Readers.LaTeX.Math, + 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, @@ -645,7 +664,12 @@ Text.Pandoc.Writers.LaTeX.Caption, Text.Pandoc.Writers.LaTeX.Notes, Text.Pandoc.Writers.LaTeX.Table, + Text.Pandoc.Writers.LaTeX.Lang, Text.Pandoc.Writers.LaTeX.Types, + Text.Pandoc.Writers.LaTeX.Citation, + Text.Pandoc.Writers.LaTeX.Util, + Text.Pandoc.Writers.Markdown.Types, + Text.Pandoc.Writers.Markdown.Inline, Text.Pandoc.Writers.Roff, Text.Pandoc.Writers.Powerpoint.Presentation, Text.Pandoc.Writers.Powerpoint.Output, @@ -673,6 +697,10 @@ Text.Pandoc.Lua.PandocLua, Text.Pandoc.Lua.Util, Text.Pandoc.Lua.Walk, + Text.Pandoc.XML.Light, + Text.Pandoc.XML.Light.Types, + Text.Pandoc.XML.Light.Proc, + Text.Pandoc.XML.Light.Output, Text.Pandoc.CSS, Text.Pandoc.CSV, Text.Pandoc.RoffChar, @@ -691,91 +719,32 @@ buildable: True executable pandoc - build-depends: pandoc, base >= 4.8 && < 5 - if impl(ghc < 8.4) - hs-source-dirs: prelude - other-modules: Prelude - build-depends: base-compat >= 0.9 - default-language: Haskell2010 - other-extensions: NoImplicitPrelude + import: common-executable hs-source-dirs: app main-is: pandoc.hs buildable: True other-modules: Paths_pandoc - ghc-options: -rtsopts -with-rtsopts=-K16m -threaded - -Wall -fno-warn-unused-do-bind - -Wincomplete-record-updates - -Wnoncanonical-monad-instances - if impl(ghc >= 8.2) - ghc-options: -Wcpp-undef - if impl(ghc >= 8.4) - ghc-options: -Wincomplete-uni-patterns - -Widentities - -fhide-source-paths executable trypandoc + import: common-executable main-is: trypandoc.hs hs-source-dirs: trypandoc - default-language: Haskell2010 - other-extensions: NoImplicitPrelude if flag(trypandoc) - build-depends: base, aeson, pandoc, - text, wai-extra, wai >= 0.3, http-types + build-depends: aeson, http-types, wai >= 0.3, wai-extra >= 3.0.24 buildable: True else buildable: False - if impl(ghc < 8.4) - hs-source-dirs: prelude - other-modules: Prelude - build-depends: base-compat >= 0.9 - ghc-options: -rtsopts -with-rtsopts=-K16m -threaded - -Wall -fno-warn-unused-do-bind - -Wincomplete-record-updates - -Wnoncanonical-monad-instances - if impl(ghc >= 8.2) - ghc-options: -Wcpp-undef - if impl(ghc >= 8.4) - ghc-options: -Wincomplete-uni-patterns - -Widentities - -fhide-source-paths -benchmark weigh-pandoc - type: exitcode-stdio-1.0 - main-is: weigh-pandoc.hs - hs-source-dirs: benchmark - build-depends: pandoc, - base >= 4.8 && < 5, - mtl >= 2.2 && < 2.3, - text, - weigh >= 0.0 && < 0.1, - if impl(ghc < 8.4) - hs-source-dirs: prelude - other-modules: Prelude - build-depends: base-compat >= 0.9 - default-language: Haskell2010 - other-extensions: NoImplicitPrelude - ghc-options: -rtsopts -with-rtsopts=-K16m -threaded - -Wall -fno-warn-unused-do-bind - -Wincomplete-record-updates - -Wnoncanonical-monad-instances - if impl(ghc >= 8.2) - ghc-options: -Wcpp-undef - if impl(ghc >= 8.4) - ghc-options: -Wincomplete-uni-patterns - -Widentities - -fhide-source-paths - - test-suite test-pandoc + import: common-executable type: exitcode-stdio-1.0 main-is: test-pandoc.hs hs-source-dirs: test build-depends: pandoc, - base >= 4.8 && < 5, Diff >= 0.2 && < 0.5, Glob >= 0.7 && < 0.11, QuickCheck >= 2.4 && < 2.15, - base64-bytestring >= 0.1 && < 1.2, + base64-bytestring >= 0.1 && < 1.3, bytestring >= 0.9 && < 0.12, containers >= 0.4.2.1 && < 0.7, directory >= 1.2.3 && < 1.4, @@ -787,20 +756,15 @@ mtl >= 2.2 && < 2.3, pandoc-types >= 1.22 && < 1.23, process >= 1.2.3 && < 1.7, - tasty >= 0.11 && < 1.4, + tasty >= 0.11 && < 1.5, tasty-golden >= 2.3 && < 2.4, tasty-hunit >= 0.9 && < 0.11, tasty-lua >= 0.2 && < 0.3, tasty-quickcheck >= 0.8 && < 0.11, temporary >= 1.1 && < 1.4, - text >= 1.1.1.0 && < 1.3, time >= 1.5 && < 1.10, xml >= 1.3.12 && < 1.4, zip-archive >= 0.2.3.4 && < 0.5 - if impl(ghc < 8.4) - hs-source-dirs: prelude - other-modules: Prelude - build-depends: base-compat >= 0.9 other-modules: Tests.Old Tests.Command Tests.Helpers @@ -856,47 +820,15 @@ Tests.Writers.OOXML Tests.Writers.Ms Tests.Writers.AnnotatedTable - if os(windows) - cpp-options: -D_WINDOWS - default-language: Haskell2010 - other-extensions: NoImplicitPrelude - ghc-options: -rtsopts -with-rtsopts=-K16m -threaded - -Wall -fno-warn-unused-do-bind - -Wincomplete-record-updates - -Wnoncanonical-monad-instances - if impl(ghc >= 8.2) - ghc-options: -Wcpp-undef - if impl(ghc >= 8.4) - ghc-options: -Wincomplete-uni-patterns - -Widentities - -fhide-source-paths - benchmark benchmark-pandoc + import: common-executable type: exitcode-stdio-1.0 main-is: benchmark-pandoc.hs hs-source-dirs: benchmark - build-depends: pandoc, - base >= 4.8 && < 5, - bytestring, + build-depends: bytestring, containers, - criterion >= 1.0 && < 1.6, + tasty, + tasty-bench >= 0.2 && <= 0.3, mtl >= 2.2 && < 2.3, - text >= 1.1.1.0 && < 1.3, time - if impl(ghc < 8.4) - hs-source-dirs: prelude - other-modules: Prelude - build-depends: base-compat >= 0.9 - default-language: Haskell2010 - other-extensions: NoImplicitPrelude - ghc-options: -rtsopts -with-rtsopts=-K16m -threaded - -Wall -fno-warn-unused-do-bind - -Wincomplete-record-updates - -Wnoncanonical-monad-instances - if impl(ghc >= 8.2) - ghc-options: -Wcpp-undef - if impl(ghc >= 8.4) - ghc-options: -Wincomplete-uni-patterns - -Widentities - -fhide-source-paths 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,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -19,6 +20,7 @@ , Filter(..) , defaultOpts , parseOptions + , parseOptionsFromArgs , options , applyFilters ) where @@ -27,6 +29,7 @@ import Control.Monad.Trans ( MonadIO(..) ) import Control.Monad.Except (throwError) import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Lazy as BL import Data.Char (toLower) import Data.Maybe (fromMaybe, isJust, isNothing) @@ -44,10 +47,13 @@ import System.IO (nativeNewline, stdout) import qualified System.IO as IO (Newline (..)) import Text.Pandoc +import Text.Pandoc.Builder (setMeta) +import Text.Pandoc.MIME (getCharset) import Text.Pandoc.App.FormatHeuristics (formatFromFilePaths) import Text.Pandoc.App.Opt (Opt (..), LineEnding (..), defaultOpts, - IpynbOutput (..) ) -import Text.Pandoc.App.CommandLineOptions (parseOptions, options) + IpynbOutput (..)) +import Text.Pandoc.App.CommandLineOptions (parseOptions, parseOptionsFromArgs, + options) import Text.Pandoc.App.OutputSettings (OutputSettings (..), optToOutputSettings) import Text.Pandoc.BCP47 (Lang (..), parseBCP47) import Text.Pandoc.Filter (Filter (JSONFilter, LuaFilter), applyFilters) @@ -55,7 +61,7 @@ import Text.Pandoc.SelfContained (makeSelfContained) import Text.Pandoc.Shared (eastAsianLineBreakFilter, stripEmptyParagraphs, headerShift, isURI, tabFilter, uriPathToPath, filterIpynbOutput, - defaultUserDataDirs, tshow, findM) + defaultUserDataDir, tshow) import Text.Pandoc.Writers.Shared (lookupMetaString) import Text.Pandoc.Readers.Markdown (yamlToMeta) import qualified Text.Pandoc.UTF8 as UTF8 @@ -66,25 +72,29 @@ convertWithOpts :: Opt -> IO () convertWithOpts opts = do + datadir <- case optDataDir opts of + Nothing -> do + d <- defaultUserDataDir + exists <- doesDirectoryExist d + return $ if exists + then Just d + else Nothing + Just _ -> return $ optDataDir opts + let outputFile = fromMaybe "-" (optOutputFile opts) let filters = optFilters opts let verbosity = optVerbosity opts when (optDumpArgs opts) $ - do UTF8.hPutStrLn stdout outputFile - mapM_ (UTF8.hPutStrLn stdout) (fromMaybe ["-"] $ optInputFiles opts) + do UTF8.hPutStrLn stdout (T.pack outputFile) + mapM_ (UTF8.hPutStrLn stdout . T.pack) + (fromMaybe ["-"] $ optInputFiles opts) exitSuccess let sources = case optInputFiles opts of Just xs | not (optIgnoreArgs opts) -> xs _ -> ["-"] - datadir <- case optDataDir opts of - Nothing -> do - ds <- defaultUserDataDirs - findM doesDirectoryExist ds - Just _ -> return $ optDataDir opts - let runIO' :: PandocIO a -> IO a runIO' f = do (res, reports) <- runIOorExplode $ do @@ -269,12 +279,21 @@ report $ Deprecated "pandoc-citeproc filter" "Use --citeproc instead." + let cslMetadata = + maybe id (setMeta "csl") (optCSL opts) . + (case optBibliography opts of + [] -> id + xs -> setMeta "bibliography" xs) . + maybe id (setMeta "citation-abbreviations") + (optCitationAbbreviations opts) $ mempty + doc <- sourceToDoc sources >>= ( (if isJust (optExtractMedia opts) then fillMediaBag else return) >=> return . adjustMetadata (metadataFromFile <>) >=> return . adjustMetadata (<> optMetadata opts) + >=> return . adjustMetadata (<> cslMetadata) >=> applyTransforms transforms >=> applyFilters readerOpts filters [T.unpack format] >=> maybe return extractMedia (optExtractMedia opts) @@ -341,7 +360,18 @@ _ -> PandocAppError (tshow e)) readURI :: FilePath -> PandocIO Text -readURI src = UTF8.toText . fst <$> openURL (T.pack src) +readURI src = do + (bs, mt) <- openURL (T.pack src) + case mt >>= getCharset of + Just "UTF-8" -> return $ UTF8.toText bs + Just "ISO-8859-1" -> return $ T.pack $ B8.unpack bs + Just charset -> throwError $ PandocUnsupportedCharsetError charset + Nothing -> liftIO $ -- try first as UTF-8, then as latin1 + E.catch (return $! UTF8.toText bs) + (\case + TSE.DecodeError{} -> + return $ T.pack $ B8.unpack bs + e -> E.throwIO e) readFile' :: MonadIO m => FilePath -> m BL.ByteString readFile' "-" = liftIO BL.getContents @@ -352,6 +382,5 @@ writeFnBinary f = liftIO . BL.writeFile (UTF8.encodePath f) writerFn :: MonadIO m => IO.Newline -> FilePath -> Text -> m () --- TODO this implementation isn't maximally efficient: -writerFn eol "-" = liftIO . UTF8.putStrWith eol . T.unpack -writerFn eol f = liftIO . UTF8.writeFileWith eol f . T.unpack +writerFn eol "-" = liftIO . UTF8.putStrWith eol +writerFn eol f = liftIO . UTF8.writeFileWith eol f 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 @@ -17,6 +17,7 @@ -} module Text.Pandoc.App.CommandLineOptions ( parseOptions + , parseOptionsFromArgs , options , engines , lookupHighlightStyle @@ -47,12 +48,13 @@ import System.IO (stdout) import Text.DocTemplates (Context (..), ToContext (toVal), Val (..)) import Text.Pandoc +import Text.Pandoc.Builder (setMeta) import Text.Pandoc.App.Opt (Opt (..), LineEnding (..), IpynbOutput (..), - DefaultsState (..), addMeta, applyDefaults, + DefaultsState (..), applyDefaults, fullDefaultsPath) import Text.Pandoc.Filter (Filter (..)) import Text.Pandoc.Highlighting (highlightingStyles) -import Text.Pandoc.Shared (ordNub, elemText, safeStrRead, defaultUserDataDirs) +import Text.Pandoc.Shared (ordNub, elemText, safeStrRead, defaultUserDataDir) import Text.Printf #ifdef EMBED_DATA_FILES @@ -73,9 +75,13 @@ parseOptions options' defaults = do rawArgs <- map UTF8.decodeArg <$> getArgs prg <- getProgName + parseOptionsFromArgs options' defaults prg rawArgs +parseOptionsFromArgs + :: [OptDescr (Opt -> IO Opt)] -> Opt -> String -> [String] -> IO Opt +parseOptionsFromArgs options' defaults prg rawArgs = do let (actions, args, unrecognizedOpts, errors) = - getOpt' Permute options' rawArgs + getOpt' Permute options' (map UTF8.decodeArg rawArgs) let unknownOptionErrors = foldr (handleUnrecognizedOption . takeWhile (/= '=')) [] @@ -282,7 +288,8 @@ , Option "" ["resource-path"] (ReqArg (\arg opt -> return opt { optResourcePath = - splitSearchPath arg }) + splitSearchPath arg ++ + optResourcePath opt }) "SEARCHPATH") "" -- "Paths to search for images and other resources" @@ -807,10 +814,10 @@ map (\c -> ['-',c]) shorts ++ map ("--" ++) longs let allopts = unwords (concatMap optnames options) - UTF8.hPutStrLn stdout $ printf tpl allopts - (unwords readersNames) - (unwords writersNames) - (unwords $ map (T.unpack . fst) highlightingStyles) + 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 )) "" -- "Print bash completion script" @@ -849,7 +856,7 @@ else if extensionEnabled x allExts then '-' else ' ') : drop 4 (show x) - mapM_ (UTF8.hPutStrLn stdout . showExt) + mapM_ (UTF8.hPutStrLn stdout . T.pack . showExt) [ex | ex <- extList, extensionEnabled ex allExts] exitSuccess ) "FORMAT") @@ -863,14 +870,14 @@ , sShortname s `notElem` [T.pack "Alert", T.pack "Alert_indent"] ] - mapM_ (UTF8.hPutStrLn stdout) (sort langs) + mapM_ (UTF8.hPutStrLn stdout . T.pack) (sort langs) exitSuccess )) "" , Option "" ["list-highlight-styles"] (NoArg (\_ -> do - mapM_ (UTF8.hPutStrLn stdout . T.unpack . fst) highlightingStyles + mapM_ (UTF8.hPutStrLn stdout . fst) highlightingStyles exitSuccess )) "" @@ -888,7 +895,7 @@ | T.null t -> -- e.g. for docx, odt, json: E.throwIO $ PandocCouldNotFindDataFileError $ T.pack ("templates/default." ++ arg) - | otherwise -> write . T.unpack $ t + | otherwise -> write t Left e -> E.throwIO e exitSuccess) "FORMAT") @@ -934,12 +941,13 @@ (NoArg (\_ -> do prg <- getProgName - defaultDatadirs <- defaultUserDataDirs - UTF8.hPutStrLn stdout (prg ++ " " ++ T.unpack pandocVersion ++ - compileInfo ++ - "\nUser data directory: " ++ - intercalate " or " defaultDatadirs ++ - ('\n':copyrightMessage)) + defaultDatadir <- defaultUserDataDir + UTF8.hPutStrLn stdout + $ T.pack + $ prg ++ " " ++ T.unpack pandocVersion ++ + compileInfo ++ + "\nUser data directory: " ++ defaultDatadir ++ + ('\n':copyrightMessage) exitSuccess )) "" -- "Print version" @@ -947,7 +955,7 @@ (NoArg (\_ -> do prg <- getProgName - UTF8.hPutStr stdout (usageMessage prg options) + UTF8.hPutStr stdout (T.pack $ usageMessage prg options) exitSuccess )) "" -- "Show help" ] @@ -1008,12 +1016,12 @@ handleUnrecognizedOption x = (("Unknown option " ++ x ++ ".") :) -readersNames :: [String] -readersNames = sort (map (T.unpack . fst) (readers :: [(Text, Reader PandocIO)])) +readersNames :: [Text] +readersNames = sort (map fst (readers :: [(Text, Reader PandocIO)])) -writersNames :: [String] +writersNames :: [Text] writersNames = sort - ("pdf" : map (T.unpack . fst) (writers :: [(Text, Writer PandocIO)])) + ("pdf" : map fst (writers :: [(Text, Writer PandocIO)])) splitField :: String -> (String, String) splitField = second (tailDef "true") . break (`elemText` ":=") @@ -1045,6 +1053,27 @@ where go Nothing = Just $ toVal val go (Just (ListVal xs)) = Just $ ListVal $ xs ++ [toVal val] go (Just x) = Just $ ListVal [x, toVal val] + +addMeta :: String -> String -> Meta -> Meta +addMeta k v meta = + case lookupMeta k' meta of + Nothing -> setMeta k' v' meta + Just (MetaList xs) -> + setMeta k' (MetaList (xs ++ [v'])) meta + Just x -> setMeta k' (MetaList [x, v']) meta + where + v' = readMetaValue v + k' = T.pack k + +readMetaValue :: String -> MetaValue +readMetaValue s + | s == "true" = MetaBool True + | s == "True" = MetaBool True + | s == "TRUE" = MetaBool True + | s == "false" = MetaBool False + | s == "False" = MetaBool False + | s == "FALSE" = MetaBool False + | otherwise = MetaString $ T.pack s -- On Windows with ghc 8.6+, we need to rewrite paths -- beginning with \\ to \\?\UNC\. -- See #5127. 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 @@ -22,28 +22,29 @@ , IpynbOutput (..) , DefaultsState (..) , defaultOpts - , addMeta , applyDefaults , fullDefaultsPath ) where import Control.Monad.Except (MonadIO, liftIO, throwError, (>=>), foldM) import Control.Monad.State.Strict (StateT, modify, gets) -import System.FilePath ( addExtension, (), takeExtension ) +import System.FilePath ( addExtension, (), takeExtension, takeDirectory ) +import System.Directory ( canonicalizePath ) import Data.Char (isLower, toLower) import Data.Maybe (fromMaybe) import GHC.Generics hiding (Meta) -import Text.Pandoc.Builder (setMeta) import Text.Pandoc.Filter (Filter (..)) -import Text.Pandoc.Logging (Verbosity (WARNING)) +import Text.Pandoc.Logging (Verbosity (WARNING), LogMessage(..)) import Text.Pandoc.Options (TopLevelDivision (TopLevelDefault), TrackChanges (AcceptChanges), WrapOption (WrapAuto), HTMLMathMethod (PlainMath), ReferenceLocation (EndOfDocument), ObfuscationMethod (NoObfuscation), CiteMethod (Citeproc)) -import Text.Pandoc.Class (readFileLazy, fileExists, setVerbosity, PandocMonad) +import Text.Pandoc.Class (readFileLazy, fileExists, setVerbosity, report, + PandocMonad(lookupEnv), getUserDataDir) import Text.Pandoc.Error (PandocError (PandocParseError, PandocSomeError)) -import Text.Pandoc.Shared (camelCaseStrToHyphenated, defaultUserDataDirs, findM, ordNub) +import Text.Pandoc.Shared (camelCaseStrToHyphenated, defaultUserDataDir, + findM, ordNub) import qualified Text.Pandoc.Parsing as P import Text.Pandoc.Readers.Metadata (yamlMap) import Text.Pandoc.Class.PandocPure @@ -52,7 +53,7 @@ import Data.Default (def) import qualified Data.Text as T import qualified Data.Map as M -import Text.Pandoc.Definition (Meta(..), MetaValue(..), lookupMeta) +import Text.Pandoc.Definition (Meta(..), MetaValue(..)) import Data.Aeson (defaultOptions, Options(..)) import Data.Aeson.TH (deriveJSON) import Control.Applicative ((<|>)) @@ -156,6 +157,9 @@ , optNoCheckCertificate :: Bool -- ^ Disable certificate validation , optEol :: LineEnding -- ^ Style of line-endings to use , optStripComments :: Bool -- ^ Skip HTML comments + , optCSL :: Maybe FilePath -- ^ CSL stylesheet + , optBibliography :: [FilePath] -- ^ Bibliography files + , optCitationAbbreviations :: Maybe FilePath -- ^ Citation abbreviations } deriving (Generic, Show) instance FromYAML (Opt -> Opt) where @@ -175,17 +179,128 @@ dataDir <- case M.lookup "data-dir" opts of Nothing -> return Nothing Just v -> Just . unpack <$> parseYAML v - f <- parseOptions $ M.toList m + f <- parseOptions (M.toList m) case M.lookup "defaults" opts of Just v -> do g <- parseDefaults v dataDir - return $ g >=> f - Nothing -> return f + return $ g >=> f >=> resolveVarsInOpt + Nothing -> return $ f >=> resolveVarsInOpt where toText (Scalar _ (SStr s)) = s toText _ = "" parseYAML n = failAtNode n "Expected a mapping" +resolveVarsInOpt :: forall m. (PandocMonad m, MonadIO m) + => Opt -> StateT DefaultsState m Opt +resolveVarsInOpt + opt@Opt + { optTemplate = oTemplate + , optMetadataFiles = oMetadataFiles + , optOutputFile = oOutputFile + , optInputFiles = oInputFiles + , optSyntaxDefinitions = oSyntaxDefinitions + , optAbbreviations = oAbbreviations + , optReferenceDoc = oReferenceDoc + , optEpubMetadata = oEpubMetadata + , optEpubFonts = oEpubFonts + , optEpubCoverImage = oEpubCoverImage + , optLogFile = oLogFile + , optFilters = oFilters + , optDataDir = oDataDir + , optExtractMedia = oExtractMedia + , optCss = oCss + , optIncludeBeforeBody = oIncludeBeforeBody + , optIncludeAfterBody = oIncludeAfterBody + , optIncludeInHeader = oIncludeInHeader + , optResourcePath = oResourcePath + , optCSL = oCSL + , optBibliography = oBibliography + , optCitationAbbreviations = oCitationAbbreviations + } + = do + oTemplate' <- mapM resolveVars oTemplate + oMetadataFiles' <- mapM resolveVars oMetadataFiles + oOutputFile' <- mapM resolveVars oOutputFile + oInputFiles' <- mapM (mapM resolveVars) oInputFiles + oSyntaxDefinitions' <- mapM resolveVars oSyntaxDefinitions + oAbbreviations' <- mapM resolveVars oAbbreviations + oReferenceDoc' <- mapM resolveVars oReferenceDoc + oEpubMetadata' <- mapM resolveVars oEpubMetadata + oEpubFonts' <- mapM resolveVars oEpubFonts + oEpubCoverImage' <- mapM resolveVars oEpubCoverImage + oLogFile' <- mapM resolveVars oLogFile + oFilters' <- mapM resolveVarsInFilter oFilters + oDataDir' <- mapM resolveVars oDataDir + oExtractMedia' <- mapM resolveVars oExtractMedia + oCss' <- mapM resolveVars oCss + oIncludeBeforeBody' <- mapM resolveVars oIncludeBeforeBody + oIncludeAfterBody' <- mapM resolveVars oIncludeAfterBody + oIncludeInHeader' <- mapM resolveVars oIncludeInHeader + oResourcePath' <- mapM resolveVars oResourcePath + oCSL' <- mapM resolveVars oCSL + oBibliography' <- mapM resolveVars oBibliography + oCitationAbbreviations' <- mapM resolveVars oCitationAbbreviations + return opt{ optTemplate = oTemplate' + , optMetadataFiles = oMetadataFiles' + , optOutputFile = oOutputFile' + , optInputFiles = oInputFiles' + , optSyntaxDefinitions = oSyntaxDefinitions' + , optAbbreviations = oAbbreviations' + , optReferenceDoc = oReferenceDoc' + , optEpubMetadata = oEpubMetadata' + , optEpubFonts = oEpubFonts' + , optEpubCoverImage = oEpubCoverImage' + , optLogFile = oLogFile' + , optFilters = oFilters' + , optDataDir = oDataDir' + , optExtractMedia = oExtractMedia' + , optCss = oCss' + , optIncludeBeforeBody = oIncludeBeforeBody' + , optIncludeAfterBody = oIncludeAfterBody' + , optIncludeInHeader = oIncludeInHeader' + , optResourcePath = oResourcePath' + , optCSL = oCSL' + , optBibliography = oBibliography' + , optCitationAbbreviations = oCitationAbbreviations' + } + + where + resolveVars :: FilePath -> StateT DefaultsState m FilePath + resolveVars [] = return [] + resolveVars ('$':'{':xs) = + let (ys, zs) = break (=='}') xs + in if null zs + then return $ '$':'{':xs + else do + val <- lookupEnv' ys + (val ++) <$> resolveVars (drop 1 zs) + resolveVars (c:cs) = (c:) <$> resolveVars cs + lookupEnv' :: String -> StateT DefaultsState m String + lookupEnv' "." = do + mbCurDefaults <- gets curDefaults + maybe (return "") + (fmap takeDirectory . liftIO . canonicalizePath) + mbCurDefaults + lookupEnv' "USERDATA" = do + mbodatadir <- mapM resolveVars oDataDir + mbdatadir <- getUserDataDir + defdatadir <- liftIO defaultUserDataDir + return $ fromMaybe defdatadir (mbodatadir <|> mbdatadir) + lookupEnv' v = do + mbval <- fmap T.unpack <$> lookupEnv (T.pack v) + case mbval of + Nothing -> do + report $ EnvironmentVariableUndefined (T.pack v) + return mempty + Just x -> return x + resolveVarsInFilter (JSONFilter fp) = + JSONFilter <$> resolveVars fp + resolveVarsInFilter (LuaFilter fp) = + LuaFilter <$> resolveVars fp + resolveVarsInFilter CiteprocFilter = return CiteprocFilter + + + parseDefaults :: (PandocMonad m, MonadIO m) => Node Pos -> Maybe FilePath @@ -428,26 +543,18 @@ (parseYAML v >>= \x -> return (\o -> o{ optCss = optCss o <> [unpack x] })) "bibliography" -> - do let addItem x o = o{ optMetadata = - addMeta "bibliography" (T.unpack x) - (optMetadata o) } - (parseYAML v >>= \(xs :: [Text]) -> return $ \o -> - foldr addItem o xs) - <|> - (parseYAML v >>= \(x :: Text) -> return $ \o -> addItem x o) + (parseYAML v >>= \x -> return (\o -> + o{ optBibliography = optBibliography o <> + map unpack x })) + <|> + (parseYAML v >>= \x -> return (\o -> + o{ optBibliography = optBibliography o <> + [unpack x] })) "csl" -> - do let addItem x o = o{ optMetadata = - addMeta "csl" (T.unpack x) - (optMetadata o) } - (parseYAML v >>= \(xs :: [Text]) -> return $ \o -> - foldr addItem o xs) - <|> - (parseYAML v >>= \(x :: Text) -> return $ \o -> addItem x o) + parseYAML v >>= \x -> return (\o -> o{ optCSL = unpack <$> x }) "citation-abbreviations" -> - parseYAML v >>= \x -> - return (\o -> o{ optMetadata = - addMeta "citation-abbreviations" (T.unpack x) - (optMetadata o) }) + parseYAML v >>= \x -> return (\o -> o{ optCitationAbbreviations = + unpack <$> x }) "ipynb-output" -> parseYAML v >>= \x -> return (\o -> o{ optIpynbOutput = x }) "include-before-body" -> @@ -476,7 +583,8 @@ optIncludeInHeader o <> [unpack x] })) "resource-path" -> parseYAML v >>= \x -> - return (\o -> o{ optResourcePath = map unpack x }) + return (\o -> o{ optResourcePath = map unpack x <> + optResourcePath o }) "request-headers" -> parseYAML v >>= \x -> return (\o -> o{ optRequestHeaders = x }) @@ -562,6 +670,9 @@ , optNoCheckCertificate = False , optEol = Native , optStripComments = False + , optCSL = Nothing + , optBibliography = [] + , optCitationAbbreviations = Nothing } parseStringKey :: Node Pos -> Parser Text @@ -579,27 +690,6 @@ >>= fmap (Meta . flip P.runF def) yamlToMeta _ = return mempty -addMeta :: String -> String -> Meta -> Meta -addMeta k v meta = - case lookupMeta k' meta of - Nothing -> setMeta k' v' meta - Just (MetaList xs) -> - setMeta k' (MetaList (xs ++ [v'])) meta - Just x -> setMeta k' (MetaList [x, v']) meta - where - v' = readMetaValue v - k' = T.pack k - -readMetaValue :: String -> MetaValue -readMetaValue s - | s == "true" = MetaBool True - | s == "True" = MetaBool True - | s == "TRUE" = MetaBool True - | s == "false" = MetaBool False - | s == "False" = MetaBool False - | s == "FALSE" = MetaBool False - | otherwise = MetaString $ T.pack s - -- | Apply defaults from --defaults file. applyDefaults :: (PandocMonad m, MonadIO m) => Opt @@ -625,12 +715,9 @@ let fp = if null (takeExtension file) then addExtension file "yaml" else file - dataDirs <- liftIO defaultUserDataDirs - let fps = fp : case dataDir of - Nothing -> map ( ("defaults" fp)) - dataDirs - Just dd -> [dd "defaults" fp] - fromMaybe fp <$> findM fileExists fps + defaultDataDir <- liftIO defaultUserDataDir + let defaultFp = fromMaybe defaultDataDir dataDir "defaults" fp + fromMaybe fp <$> findM fileExists [fp, defaultFp] -- | In a list of lists, append another list in front of every list which -- starts with specific element. 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 @@ -59,8 +59,8 @@ let outputFile = fromMaybe "-" (optOutputFile opts) when (optDumpArgs opts) . liftIO $ do - UTF8.hPutStrLn stdout outputFile - mapM_ (UTF8.hPutStrLn stdout) (fromMaybe [] $ optInputFiles opts) + UTF8.hPutStrLn stdout (T.pack outputFile) + mapM_ (UTF8.hPutStrLn stdout . T.pack) (fromMaybe [] $ optInputFiles opts) exitSuccess epubMetadata <- traverse readUtf8File $ optEpubMetadata opts 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 @@ -68,8 +68,7 @@ pCSVUnquotedCell :: CSVOptions -> Parser Text pCSVUnquotedCell opts = T.pack <$> - many (satisfy (\c -> c /= csvDelim opts && c /= '\r' && c /= '\n' - && c /= csvQuote opts)) + many (satisfy (\c -> c /= csvDelim opts && c /= '\r' && c /= '\n')) pCSVDelim :: CSVOptions -> Parser () pCSVDelim opts = do 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 @@ -544,7 +544,7 @@ fixShortDOI x = let x' = extractText x in if "10/" `T.isPrefixOf` x' then TextVal $ T.drop 3 x' - -- see http://shortdoi.org + -- see https://shortdoi.org else TextVal x' tolink pref x = let x' = extractText x x'' = if "://" `T.isInfixOf` 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 @@ -52,6 +52,8 @@ import Data.List (foldl', intercalate, intersperse) import Safe (readMay) import Text.Printf (printf) +import Text.DocLayout (literal, hsep, nest, hang, Doc(..), + braces, ($$), cr) data Variant = Bibtex | Biblatex deriving (Show, Eq, Ord) @@ -77,10 +79,11 @@ -> Variant -- ^ bibtex or biblatex -> Maybe Lang -- ^ Language -> Reference Inlines -- ^ Reference to write - -> Text + -> Doc Text writeBibtexString opts variant mblang ref = - "@" <> bibtexType <> "{" <> unItemId (referenceId ref) <> ",\n " <> - renderFields fs <> "\n}\n" + "@" <> bibtexType <> "{" <> literal (unItemId (referenceId ref)) <> "," + $$ nest 2 (renderFields fs) + $$ "}" <> cr where bibtexType = @@ -115,7 +118,7 @@ "motion_picture" | variant == Biblatex -> "movie" "review" | variant == Biblatex -> "review" _ -> "misc" - + mbSubtype = case referenceType ref of "article-magazine" -> Just "magazine" @@ -149,7 +152,7 @@ , "type" , "entrysubtype" , "note" - , "language" + , "langid" , "abstract" , "keywords" ] @@ -202,12 +205,19 @@ [ (", " <>) <$> nameGiven name, nameDroppingParticle name ] - titlecase = case mblang of + mblang' = (parseLang <$> getVariableAsText "language") <|> mblang + + titlecase = case mblang' of Just (Lang "en" _) -> titlecase' Nothing -> titlecase' - _ -> id + _ -> + case variant of + Bibtex -> B.spanWith nullAttr + -- BibTex lacks a language field, so we wrap non-English + -- titles in {} to protect case. + Biblatex -> id - titlecase' = addTextCase mblang TitleCase . + titlecase' = addTextCase mblang' TitleCase . (\ils -> B.fromList (case B.toList ils of Str t : xs -> Str t : Walk.walk spanAroundCapitalizedWords xs @@ -224,10 +234,12 @@ toLaTeX x = case runPure (writeLaTeX opts $ doc (B.plain x)) of Left _ -> Nothing - Right t -> Just t + Right t -> Just $ hsep . map literal $ T.words t - renderField name = (\contents -> name <> " = {" <> contents <> "}") - <$> getContentsFor name + renderField :: Text -> Maybe (Doc Text) + renderField name = + (((literal name) <>) . hang 2 " = " . braces) + <$> getContentsFor name getVariable v = lookupVariable (toVariable v) ref @@ -241,10 +253,10 @@ Nothing -> case dateParts date of [DateParts (y1:_), DateParts (y2:_)] -> - Just (T.pack (printf "%04d" y1) <> "--" <> + Just $ literal (T.pack (printf "%04d" y1) <> "--" <> T.pack (printf "%04d" y2)) [DateParts (y1:_)] -> - Just (T.pack (printf "%04d" y1)) + Just $ literal (T.pack (printf "%04d" y1)) _ -> Nothing _ -> Nothing @@ -267,19 +279,19 @@ DateVal date -> case dateParts date of [DateParts (_:m1:_), DateParts (_:m2:_)] -> - Just (toMonth m1 <> "--" <> toMonth m2) - [DateParts (_:m1:_)] -> Just (toMonth m1) + Just $ literal (toMonth m1 <> "--" <> toMonth m2) + [DateParts (_:m1:_)] -> Just $ literal (toMonth m1) _ -> Nothing _ -> Nothing - getContentsFor :: Text -> Maybe Text + getContentsFor :: Text -> Maybe (Doc Text) getContentsFor "type" = getVariableAsText "genre" >>= \case "mathesis" -> Just "mastersthesis" "phdthesis" -> Just "phdthesis" _ -> Nothing - getContentsFor "entrysubtype" = mbSubtype + getContentsFor "entrysubtype" = literal <$> mbSubtype getContentsFor "journal" | bibtexType `elem` ["article", "periodical", "suppperiodical", "review"] = getVariable "container-title" >>= toLaTeX . valToInlines @@ -299,13 +311,15 @@ getContentsFor "urldate" = getVariable "accessed" >>= toLaTeX . valToInlines getContentsFor "year" = getVariable "issued" >>= getYear getContentsFor "month" = getVariable "issued" >>= getMonth + getContentsFor "pages" = getVariable "page" >>= toLaTeX . valToInlines + getContentsFor "langid" = getVariable "language" >>= toLaTeX . valToInlines getContentsFor "number" = (getVariable "number" <|> getVariable "collection-number" <|> getVariable "issue") >>= toLaTeX . valToInlines getContentsFor x = getVariable x >>= if isURL x - then Just . stringify . valToInlines + then Just . literal . stringify . valToInlines else toLaTeX . (if x == "title" then titlecase @@ -314,7 +328,7 @@ isURL x = x `elem` ["url","doi","issn","isbn"] - renderFields = T.intercalate ",\n " . mapMaybe renderField + renderFields = mconcat . intersperse ("," <> cr) . mapMaybe renderField defaultLang :: Lang defaultLang = Lang "en" (Just "US") @@ -563,10 +577,10 @@ eprint <- getRawField "eprint" let baseUrl = case T.toLower etype of - "arxiv" -> "http://arxiv.org/abs/" - "jstor" -> "http://www.jstor.org/stable/" - "pubmed" -> "http://www.ncbi.nlm.nih.gov/pubmed/" - "googlebooks" -> "http://books.google.com?id=" + "arxiv" -> "https://arxiv.org/abs/" + "jstor" -> "https://www.jstor.org/stable/" + "pubmed" -> "https://www.ncbi.nlm.nih.gov/pubmed/" + "googlebooks" -> "https://books.google.com?id=" _ -> "" if T.null baseUrl then mzero @@ -750,41 +764,10 @@ _ -> B.fromList $ Walk.query (:[]) bs adjustSpans :: Lang -> Inline -> Inline -adjustSpans lang (RawInline (Format "latex") s) - | s == "\\hyphen" || s == "\\hyphen " = Str "-" - | otherwise = parseRawLaTeX lang s +adjustSpans lang (Span ("",[],[("bibstring",s)]) _) = Str $ resolveKey' lang s adjustSpans _ SoftBreak = Space adjustSpans _ x = x -parseRawLaTeX :: Lang -> Text -> Inline -parseRawLaTeX lang t@(T.stripPrefix "\\" -> Just xs) = - case parseLaTeX lang contents of - Right [Para ys] -> f command ys - Right [Plain ys] -> f command ys - Right [] -> f command [] - _ -> RawInline (Format "latex") t - where (command', contents') = T.break (\c -> c =='{' || c =='\\') xs - command = T.strip command' - contents = T.drop 1 $ T.dropEnd 1 contents' - f "mkbibquote" ils = Span nullAttr [Quoted DoubleQuote ils] - f "mkbibemph" ils = Span nullAttr [Emph ils] - f "mkbibitalic" ils = Span nullAttr [Emph ils] - f "mkbibbold" ils = Span nullAttr [Strong ils] - f "mkbibparens" ils = Span nullAttr $ - [Str "("] ++ ils ++ [Str ")"] - f "mkbibbrackets" ils = Span nullAttr $ - [Str "["] ++ ils ++ [Str "]"] - -- ... both should be nestable & should work in year fields - f "autocap" ils = Span nullAttr ils - -- TODO: should work in year fields - f "textnormal" ils = Span ("",["nodecor"],[]) ils - f "bibstring" [Str s] = Str $ resolveKey' lang s - f "adddot" [] = Str "." - f "adddotspace" [] = Span nullAttr [Str ".", Space] - f "addabbrvspace" [] = Space - f _ ils = Span nullAttr ils -parseRawLaTeX _ t = RawInline (Format "latex") t - latex' :: Text -> Bib [Block] latex' t = do lang <- gets localeLang @@ -1060,14 +1043,14 @@ let dateparts = filter (\x -> x /= DateParts []) $ map toDateParts [(year',month',day'), (endyear',endmonth',endday')] - literal <- if null dateparts - then Just <$> getRawField (prefix <> "year") - else return Nothing + literal' <- if null dateparts + then Just <$> getRawField (prefix <> "year") + else return Nothing return $ Date { dateParts = dateparts , dateCirca = False , dateSeason = Nothing - , dateLiteral = literal } + , dateLiteral = literal' } getRawField :: Text -> Bib Text getRawField f = do 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 @@ -135,12 +135,13 @@ MetaMap _ -> TextVal mempty metaValueToDate :: MetaValue -> Date -metaValueToDate (MetaMap m) = - Date +metaValueToDate (MetaMap m) = fromMaybe + (Date { dateParts = dateparts , dateCirca = circa , dateSeason = season - , dateLiteral = literal } + , dateLiteral = literal }) + rawdate where dateparts = case M.lookup "date-parts" m of Just (MetaList xs) -> @@ -152,6 +153,7 @@ M.lookup "circa" m >>= metaValueToBool season = M.lookup "season" m >>= metaValueToInt literal = M.lookup "literal" m >>= metaValueToText + rawdate = M.lookup "raw" m >>= metaValueToText >>= rawDateEDTF metaValueToDate (MetaList xs) = Date{ dateParts = mapMaybe metaValueToDateParts xs , dateCirca = False 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 @@ -183,7 +183,7 @@ logOutput :: (PandocMonad m, MonadIO m) => LogMessage -> m () logOutput msg = liftIO $ do UTF8.hPutStr stderr $ - "[" ++ show (messageVerbosity msg) ++ "] " + "[" <> T.pack (show (messageVerbosity msg)) <> "] " alertIndent $ T.lines $ showLogMessage msg -- | Prints the list of lines to @stderr@, indenting every but the first @@ -191,10 +191,10 @@ alertIndent :: [Text] -> IO () alertIndent [] = return () alertIndent (l:ls) = do - UTF8.hPutStrLn stderr $ unpack l + UTF8.hPutStrLn stderr l mapM_ go ls where go l' = do UTF8.hPutStr stderr " " - UTF8.hPutStrLn stderr $ unpack l' + UTF8.hPutStrLn stderr l' -- | Extract media from the mediabag into a directory. extractMedia :: (PandocMonad m, MonadIO m) => FilePath -> Pandoc -> m Pandoc 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 @@ -51,6 +51,7 @@ , setTranslations , translateTerm , makeCanonical + , getTimestamp ) where import Codec.Archive.Zip @@ -59,7 +60,8 @@ import Data.Digest.Pure.SHA (sha1, showDigest) import Data.Maybe (fromMaybe) import Data.Time (UTCTime) -import Data.Time.Clock.POSIX (POSIXTime, utcTimeToPOSIXSeconds) +import Data.Time.Clock.POSIX (POSIXTime, utcTimeToPOSIXSeconds, + posixSecondsToUTCTime) import Data.Time.LocalTime (TimeZone, ZonedTime, utcToZonedTime) import Network.URI ( escapeURIString, nonStrictRelativeTo, unEscapeString, parseURIReference, isAllowedInURI, @@ -74,7 +76,7 @@ import Text.Pandoc.Logging import Text.Pandoc.MIME (MimeType, getMimeType, extensionFromMimeType) import Text.Pandoc.MediaBag (MediaBag, lookupMedia) -import Text.Pandoc.Shared (uriPathToPath) +import Text.Pandoc.Shared (uriPathToPath, safeRead) import Text.Pandoc.Translations (Term(..), Translations, lookupTerm, readTranslations) import Text.Pandoc.Walk (walkM) @@ -174,6 +176,21 @@ let level = messageVerbosity msg 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, 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 @@ -16,9 +16,10 @@ -} module Text.Pandoc.Error ( PandocError(..), + renderError, handleError) where -import Control.Exception (Exception) +import Control.Exception (Exception, displayException) import Data.Typeable (Typeable) import Data.Word (Word8) import Data.Text (Text) @@ -48,6 +49,7 @@ | PandocFailOnWarningError | PandocPDFProgramNotFoundError Text | PandocPDFError Text + | PandocXMLError Text Text | PandocFilterError Text Text | PandocLuaError Text | PandocCouldNotFindDataFileError Text @@ -58,6 +60,7 @@ | PandocMacroLoop Text | PandocUTF8DecodingError Text Int Word8 | PandocIpynbDecodingError Text + | PandocUnsupportedCharsetError Text | PandocUnknownReaderError Text | PandocUnknownWriterError Text | PandocUnsupportedExtensionError Text Text @@ -67,19 +70,17 @@ instance Exception PandocError --- | Handle PandocError by exiting with an error message. -handleError :: Either PandocError a -> IO a -handleError (Right r) = return r -handleError (Left e) = +renderError :: PandocError -> Text +renderError e = case e of - PandocIOError _ err' -> ioError err' - PandocHttpError u err' -> err 61 $ + PandocIOError _ err' -> T.pack $ displayException err' + PandocHttpError u err' -> "Could not fetch " <> u <> "\n" <> tshow err' - PandocShouldNeverHappenError s -> err 62 $ + PandocShouldNeverHappenError s -> "Something we thought was impossible happened!\n" <> "Please report this to pandoc's developers: " <> s - PandocSomeError s -> err 63 s - PandocParseError s -> err 64 s + PandocSomeError s -> s + PandocParseError s -> s PandocParsecError input err' -> let errPos = errorPos err' errLine = sourceLine errPos @@ -90,39 +91,43 @@ ,"\n", T.replicate (errColumn - 1) " " ,"^"] else "" - in err 65 $ "\nError at " <> tshow err' <> + in "\nError at " <> tshow err' <> -- if error comes from a chunk or included file, -- then we won't get the right text this way: if sourceName errPos == "source" then errorInFile else "" - PandocMakePDFError s -> err 66 s - PandocOptionError s -> err 6 s - PandocSyntaxMapError s -> err 67 s - PandocFailOnWarningError -> err 3 "Failing because there were warnings." - PandocPDFProgramNotFoundError pdfprog -> err 47 $ + PandocMakePDFError s -> s + PandocOptionError s -> s + PandocSyntaxMapError s -> s + PandocFailOnWarningError -> "Failing because there were warnings." + PandocPDFProgramNotFoundError pdfprog -> pdfprog <> " not found. Please select a different --pdf-engine or install " <> pdfprog - PandocPDFError logmsg -> err 43 $ "Error producing PDF.\n" <> logmsg - PandocFilterError filtername msg -> err 83 $ "Error running filter " <> + PandocPDFError logmsg -> "Error producing PDF.\n" <> logmsg + PandocXMLError fp logmsg -> "Invalid XML" <> + (if T.null fp then "" else " in " <> fp) <> ":\n" <> logmsg + PandocFilterError filtername msg -> "Error running filter " <> filtername <> ":\n" <> msg - PandocLuaError msg -> err 84 $ "Error running Lua:\n" <> msg - PandocCouldNotFindDataFileError fn -> err 97 $ + PandocLuaError msg -> "Error running Lua:\n" <> msg + PandocCouldNotFindDataFileError fn -> "Could not find data file " <> fn - PandocResourceNotFound fn -> err 99 $ + PandocResourceNotFound fn -> "File " <> fn <> " not found in resource path" - PandocTemplateError s -> err 5 $ "Error compiling template " <> s - PandocAppError s -> err 4 s - PandocEpubSubdirectoryError s -> err 31 $ + PandocTemplateError s -> "Error compiling template " <> s + PandocAppError s -> s + PandocEpubSubdirectoryError s -> "EPUB subdirectory name '" <> s <> "' contains illegal characters" - PandocMacroLoop s -> err 91 $ + PandocMacroLoop s -> "Loop encountered in expanding macro " <> s - PandocUTF8DecodingError f offset w -> err 92 $ + PandocUTF8DecodingError f offset w -> "UTF-8 decoding error in " <> f <> " at byte offset " <> tshow offset <> " (" <> T.pack (printf "%2x" w) <> ").\n" <> "The input must be a UTF-8 encoded text." - PandocIpynbDecodingError w -> err 93 $ + PandocIpynbDecodingError w -> "ipynb decoding error: " <> w - PandocUnknownReaderError r -> err 21 $ + PandocUnsupportedCharsetError charset -> + "Unsupported charset " <> charset + PandocUnknownReaderError r -> "Unknown input format " <> r <> case r of "doc" -> "\nPandoc can convert from DOCX, but not from DOC." <> @@ -130,7 +135,7 @@ " and convert that with pandoc." "pdf" -> "\nPandoc can convert to PDF, but not from PDF." _ -> "" - PandocUnknownWriterError w -> err 22 $ + PandocUnknownWriterError w -> "Unknown output format " <> w <> case w of "pdf" -> "To create a pdf using pandoc, use" <> @@ -139,16 +144,57 @@ ".pdf extension (-o filename.pdf)." "doc" -> "\nPandoc can convert to DOCX, but not to DOC." _ -> "" - PandocUnsupportedExtensionError ext f -> err 23 $ + PandocUnsupportedExtensionError ext f -> "The extension " <> ext <> " is not supported " <> "for " <> f - PandocCiteprocError e' -> err 24 $ + PandocCiteprocError e' -> prettyCiteprocError e' - PandocBibliographyError fp msg -> err 25 $ + PandocBibliographyError fp msg -> "Error reading bibliography file " <> fp <> ":\n" <> msg + +-- | Handle PandocError by exiting with an error message. +handleError :: Either PandocError a -> IO a +handleError (Right r) = return r +handleError (Left e) = + case e of + PandocIOError _ err' -> ioError err' + _ -> err exitCode (renderError e) + where + exitCode = + case e of + PandocIOError{} -> 1 + PandocHttpError{} -> 61 + PandocShouldNeverHappenError{} -> 62 + PandocSomeError{} -> 63 + PandocParseError{} -> 64 + PandocParsecError{} -> 65 + PandocMakePDFError{} -> 66 + PandocOptionError{} -> 6 + PandocSyntaxMapError{} -> 67 + PandocFailOnWarningError{} -> 3 + PandocPDFProgramNotFoundError{} -> 47 + PandocPDFError{} -> 43 + PandocXMLError{} -> 44 + PandocFilterError{} -> 83 + PandocLuaError{} -> 84 + PandocCouldNotFindDataFileError{} -> 97 + PandocResourceNotFound{} -> 99 + PandocTemplateError{} -> 5 + PandocAppError{} -> 4 + PandocEpubSubdirectoryError{} -> 31 + PandocMacroLoop{} -> 91 + PandocUTF8DecodingError{} -> 92 + PandocIpynbDecodingError{} -> 93 + PandocUnsupportedCharsetError{} -> 94 + PandocUnknownReaderError{} -> 21 + PandocUnknownWriterError{} -> 22 + PandocUnsupportedExtensionError{} -> 23 + PandocCiteprocError{} -> 24 + PandocBibliographyError{} -> 25 + err :: Int -> Text -> IO a err exitCode msg = do - UTF8.hPutStrLn stderr (T.unpack msg) + UTF8.hPutStrLn stderr msg exitWith $ ExitFailure exitCode return undefined 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 @@ -378,10 +378,10 @@ , Ext_raw_attribute , Ext_implicit_header_references , Ext_attributes - , Ext_fenced_code_attributes ] getDefaultExtensions "org" = extensionsFromList [Ext_citations, + Ext_task_lists, Ext_auto_identifiers] getDefaultExtensions "html" = extensionsFromList [Ext_auto_identifiers, @@ -509,7 +509,6 @@ , Ext_raw_attribute , Ext_implicit_header_references , Ext_attributes - , Ext_fenced_code_attributes , Ext_sourcepos ] getAll "commonmark_x" = getAll "commonmark" @@ -517,6 +516,7 @@ extensionsFromList [ Ext_citations , Ext_smart + , Ext_task_lists ] getAll "html" = autoIdExtensions <> extensionsFromList 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 @@ -44,8 +44,9 @@ import Text.Pandoc.Definition import Text.Pandoc.Options import qualified Text.Pandoc.UTF8 as UTF8 -import qualified Text.XML.Light as Xml +import Text.Pandoc.XML.Light hiding (Attr) import qualified Data.Text as T +import qualified Data.Text.Lazy as TL import qualified Data.Text.Encoding as TE import Control.Applicative import qualified Data.Attoparsec.ByteString.Char8 as A @@ -327,14 +328,15 @@ svgSize :: WriterOptions -> ByteString -> Maybe ImageSize svgSize opts img = do - doc <- Xml.parseXMLDoc $ UTF8.toString img + doc <- either (const mzero) return $ parseXMLElement + $ TL.fromStrict $ UTF8.toText img let viewboxSize = do - vb <- Xml.findAttrBy (== Xml.QName "viewBox" Nothing Nothing) doc - [_,_,w,h] <- mapM safeRead (T.words (T.pack vb)) + vb <- findAttrBy (== QName "viewBox" Nothing Nothing) doc + [_,_,w,h] <- mapM safeRead (T.words vb) return (w,h) let dpi = fromIntegral $ writerDpi opts let dirToInt dir = do - dim <- Xml.findAttrBy (== Xml.QName dir Nothing Nothing) doc >>= lengthToDim . T.pack + dim <- findAttrBy (== QName dir Nothing Nothing) doc >>= lengthToDim return $ inPixel opts dim w <- dirToInt "width" <|> (fst <$> viewboxSize) h <- dirToInt "height" <|> (snd <$> viewboxSize) 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 @@ -100,6 +100,7 @@ | FilterCompleted FilePath Integer | CiteprocWarning Text | ATXHeadingInLHS Int Text + | EnvironmentVariableUndefined Text deriving (Show, Eq, Data, Ord, Typeable, Generic) instance ToJSON LogMessage where @@ -229,6 +230,8 @@ ATXHeadingInLHS lvl contents -> ["level" .= lvl ,"contents" .= contents] + EnvironmentVariableUndefined var -> + ["variable" .= var ] showPos :: SourcePos -> Text showPos pos = Text.pack $ sn ++ "line " ++ @@ -345,6 +348,8 @@ if lvl < 3 then " Consider using --markdown-headings=setext." else "" + EnvironmentVariableUndefined var -> + "Undefined environment variable " <> var <> " in defaults file." messageVerbosity :: LogMessage -> Verbosity messageVerbosity msg = @@ -391,3 +396,4 @@ FilterCompleted{} -> INFO CiteprocWarning{} -> WARNING ATXHeadingInLHS{} -> WARNING + EnvironmentVariableUndefined{}-> WARNING diff --git a/src/Text/Pandoc/Lua/Init.hs b/src/Text/Pandoc/Lua/Init.hs --- a/src/Text/Pandoc/Lua/Init.hs +++ b/src/Text/Pandoc/Lua/Init.hs @@ -12,17 +12,18 @@ ( runLua ) where +import Control.Monad (when) import Control.Monad.Catch (try) import Control.Monad.Trans (MonadIO (..)) import Data.Data (Data, dataTypeConstrs, dataTypeOf, showConstr) import Foreign.Lua (Lua) import GHC.IO.Encoding (getForeignEncoding, setForeignEncoding, utf8) +import Text.Pandoc.Class.PandocMonad (readDataFile) import Text.Pandoc.Class.PandocIO (PandocIO) import Text.Pandoc.Error (PandocError) import Text.Pandoc.Lua.Packages (installPandocPackageSearcher) -import Text.Pandoc.Lua.PandocLua (PandocLua, liftPandocLua, - loadScriptFromDataDir, runPandocLua) - +import Text.Pandoc.Lua.PandocLua (PandocLua, liftPandocLua, runPandocLua) +import Text.Pandoc.Lua.Util (throwTopMessageAsError') import qualified Foreign.Lua as Lua import qualified Text.Pandoc.Definition as Pandoc import qualified Text.Pandoc.Lua.Module.Pandoc as ModulePandoc @@ -44,7 +45,7 @@ liftPandocLua Lua.openlibs installPandocPackageSearcher initPandocModule - loadScriptFromDataDir "init.lua" + loadInitScript "init.lua" where initPandocModule :: PandocLua () initPandocModule = do @@ -60,6 +61,15 @@ putConstructorsInRegistry -- assign module to global variable liftPandocLua $ Lua.setglobal "pandoc" + + loadInitScript :: FilePath -> PandocLua () + loadInitScript scriptFile = do + script <- readDataFile scriptFile + status <- liftPandocLua $ Lua.dostring script + when (status /= Lua.OK) . liftPandocLua $ + throwTopMessageAsError' + (("Couldn't load '" ++ scriptFile ++ "'.\n") ++) + -- | AST elements are marshaled via normal constructor functions in the -- @pandoc@ module. However, accessing Lua globals from Haskell is diff --git a/src/Text/Pandoc/Lua/Marshaling/AST.hs b/src/Text/Pandoc/Lua/Marshaling/AST.hs --- a/src/Text/Pandoc/Lua/Marshaling/AST.hs +++ b/src/Text/Pandoc/Lua/Marshaling/AST.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE LambdaCase #-} {- | Module : Text.Pandoc.Lua.Marshaling.AST @@ -17,6 +18,7 @@ ) where import Control.Applicative ((<|>)) +import Control.Monad ((<$!>)) import Foreign.Lua (Lua, Peekable, Pushable, StackIndex) import Text.Pandoc.Definition import Text.Pandoc.Error (PandocError) @@ -32,17 +34,16 @@ pushViaConstructor "Pandoc" blocks meta instance Peekable Pandoc where - peek idx = defineHowTo "get Pandoc value" $ do - blocks <- LuaUtil.rawField idx "blocks" - meta <- LuaUtil.rawField idx "meta" - return $ Pandoc meta blocks + peek idx = defineHowTo "get Pandoc value" $! Pandoc + <$!> LuaUtil.rawField idx "meta" + <*> LuaUtil.rawField idx "blocks" instance Pushable Meta where push (Meta mmap) = pushViaConstructor "Meta" mmap instance Peekable Meta where - peek idx = defineHowTo "get Meta value" $ - Meta <$> Lua.peek idx + peek idx = defineHowTo "get Meta value" $! + Meta <$!> Lua.peek idx instance Pushable MetaValue where push = pushMetaValue @@ -68,14 +69,13 @@ pushViaConstructor "Citation" cid mode prefix suffix noteNum hash instance Peekable Citation where - peek idx = do - id' <- LuaUtil.rawField idx "id" - prefix <- LuaUtil.rawField idx "prefix" - suffix <- LuaUtil.rawField idx "suffix" - mode <- LuaUtil.rawField idx "mode" - num <- LuaUtil.rawField idx "note_num" - hash <- LuaUtil.rawField idx "hash" - return $ Citation id' prefix suffix mode num hash + peek idx = Citation + <$!> LuaUtil.rawField idx "id" + <*> LuaUtil.rawField idx "prefix" + <*> LuaUtil.rawField idx "suffix" + <*> LuaUtil.rawField idx "mode" + <*> LuaUtil.rawField idx "note_num" + <*> LuaUtil.rawField idx "hash" instance Pushable Alignment where push = Lua.push . show @@ -90,7 +90,7 @@ instance Pushable Format where push (Format f) = Lua.push f instance Peekable Format where - peek idx = Format <$> Lua.peek idx + peek idx = Format <$!> Lua.peek idx instance Pushable ListNumberDelim where push = Lua.push . show @@ -130,26 +130,26 @@ elementContent = Lua.peek idx luatype <- Lua.ltype idx case luatype of - Lua.TypeBoolean -> MetaBool <$> Lua.peek idx - Lua.TypeString -> MetaString <$> Lua.peek idx + Lua.TypeBoolean -> MetaBool <$!> Lua.peek idx + Lua.TypeString -> MetaString <$!> Lua.peek idx Lua.TypeTable -> do tag <- try $ LuaUtil.getTag idx case tag of - Right "MetaBlocks" -> MetaBlocks <$> elementContent - Right "MetaBool" -> MetaBool <$> elementContent - Right "MetaMap" -> MetaMap <$> elementContent - Right "MetaInlines" -> MetaInlines <$> elementContent - Right "MetaList" -> MetaList <$> elementContent - Right "MetaString" -> MetaString <$> elementContent + Right "MetaBlocks" -> MetaBlocks <$!> elementContent + Right "MetaBool" -> MetaBool <$!> elementContent + Right "MetaMap" -> MetaMap <$!> elementContent + Right "MetaInlines" -> MetaInlines <$!> elementContent + Right "MetaList" -> MetaList <$!> elementContent + Right "MetaString" -> MetaString <$!> elementContent Right t -> Lua.throwMessage ("Unknown meta tag: " <> t) Left _ -> do -- no meta value tag given, try to guess. len <- Lua.rawlen idx if len <= 0 - then MetaMap <$> Lua.peek idx - else (MetaInlines <$> Lua.peek idx) - <|> (MetaBlocks <$> Lua.peek idx) - <|> (MetaList <$> Lua.peek idx) + then MetaMap <$!> Lua.peek idx + else (MetaInlines <$!> Lua.peek idx) + <|> (MetaBlocks <$!> Lua.peek idx) + <|> (MetaList <$!> Lua.peek idx) _ -> Lua.throwMessage "could not get meta value" -- | Push a block element to the top of the Lua stack. @@ -174,25 +174,25 @@ -- | Return the value at the given index as block if possible. peekBlock :: StackIndex -> Lua Block -peekBlock idx = defineHowTo "get Block value" $ do +peekBlock idx = defineHowTo "get Block value" $! do tag <- LuaUtil.getTag idx case tag of - "BlockQuote" -> BlockQuote <$> elementContent - "BulletList" -> BulletList <$> elementContent - "CodeBlock" -> withAttr CodeBlock <$> elementContent - "DefinitionList" -> DefinitionList <$> elementContent - "Div" -> withAttr Div <$> elementContent + "BlockQuote" -> BlockQuote <$!> elementContent + "BulletList" -> BulletList <$!> elementContent + "CodeBlock" -> withAttr CodeBlock <$!> elementContent + "DefinitionList" -> DefinitionList <$!> elementContent + "Div" -> withAttr Div <$!> elementContent "Header" -> (\(lvl, LuaAttr attr, lst) -> Header lvl attr lst) - <$> elementContent + <$!> elementContent "HorizontalRule" -> return HorizontalRule - "LineBlock" -> LineBlock <$> elementContent + "LineBlock" -> LineBlock <$!> elementContent "OrderedList" -> (\(LuaListAttributes lstAttr, lst) -> OrderedList lstAttr lst) - <$> elementContent + <$!> elementContent "Null" -> return Null - "Para" -> Para <$> elementContent - "Plain" -> Plain <$> elementContent - "RawBlock" -> uncurry RawBlock <$> elementContent + "Para" -> Para <$!> elementContent + "Plain" -> Plain <$!> elementContent + "RawBlock" -> uncurry RawBlock <$!> elementContent "Table" -> (\(attr, capt, colSpecs, thead, tbodies, tfoot) -> Table (fromLuaAttr attr) capt @@ -200,7 +200,7 @@ thead tbodies tfoot) - <$> elementContent + <$!> elementContent _ -> Lua.throwMessage ("Unknown block type: " <> tag) where -- Get the contents of an AST element. @@ -222,15 +222,14 @@ -- | Peek Caption element peekCaption :: StackIndex -> Lua Caption -peekCaption idx = do - short <- Lua.fromOptional <$> LuaUtil.rawField idx "short" - long <- LuaUtil.rawField idx "long" - return $ Caption short long +peekCaption idx = Caption + <$!> (Lua.fromOptional <$!> LuaUtil.rawField idx "short") + <*> LuaUtil.rawField idx "long" instance Peekable ColWidth where peek idx = do - width <- Lua.fromOptional <$> Lua.peek idx - return $ maybe ColWidthDefault ColWidth width + width <- Lua.fromOptional <$!> Lua.peek idx + return $! maybe ColWidthDefault ColWidth width instance Pushable ColWidth where push = \case @@ -252,12 +251,11 @@ LuaUtil.addField "body" body instance Peekable TableBody where - peek idx = do - attr <- LuaUtil.rawField idx "attr" - rowHeadColumns <- LuaUtil.rawField idx "row_head_columns" - head' <- LuaUtil.rawField idx "head" - body <- LuaUtil.rawField idx "body" - return $ TableBody attr (RowHeadColumns rowHeadColumns) head' body + peek idx = TableBody + <$!> LuaUtil.rawField idx "attr" + <*> (RowHeadColumns <$!> LuaUtil.rawField idx "row_head_columns") + <*> LuaUtil.rawField idx "head" + <*> LuaUtil.rawField idx "body" instance Pushable TableHead where push (TableHead attr rows) = Lua.push (attr, rows) @@ -287,13 +285,12 @@ LuaUtil.addField "contents" contents peekCell :: StackIndex -> Lua Cell -peekCell idx = do - attr <- fromLuaAttr <$> LuaUtil.rawField idx "attr" - align <- LuaUtil.rawField idx "alignment" - rowSpan <- LuaUtil.rawField idx "row_span" - colSpan <- LuaUtil.rawField idx "col_span" - contents <- LuaUtil.rawField idx "contents" - return $ Cell attr align (RowSpan rowSpan) (ColSpan colSpan) contents +peekCell idx = Cell + <$!> (fromLuaAttr <$!> LuaUtil.rawField idx "attr") + <*> LuaUtil.rawField idx "alignment" + <*> (RowSpan <$!> LuaUtil.rawField idx "row_span") + <*> (ColSpan <$!> LuaUtil.rawField idx "col_span") + <*> LuaUtil.rawField idx "contents" -- | Push an inline element to the top of the lua stack. pushInline :: Inline -> Lua () @@ -324,28 +321,29 @@ peekInline idx = defineHowTo "get Inline value" $ do tag <- LuaUtil.getTag idx case tag of - "Cite" -> uncurry Cite <$> elementContent - "Code" -> withAttr Code <$> elementContent - "Emph" -> Emph <$> elementContent - "Underline" -> Underline <$> elementContent - "Image" -> (\(LuaAttr attr, lst, tgt) -> Image attr lst tgt) - <$> elementContent - "Link" -> (\(LuaAttr attr, lst, tgt) -> Link attr lst tgt) - <$> elementContent + "Cite" -> uncurry Cite <$!> elementContent + "Code" -> withAttr Code <$!> elementContent + "Emph" -> Emph <$!> elementContent + "Underline" -> Underline <$!> elementContent + "Image" -> (\(LuaAttr !attr, !lst, !tgt) -> Image attr lst tgt) + <$!> elementContent + "Link" -> (\(LuaAttr !attr, !lst, !tgt) -> Link attr lst tgt) + <$!> elementContent "LineBreak" -> return LineBreak - "Note" -> Note <$> elementContent - "Math" -> uncurry Math <$> elementContent - "Quoted" -> uncurry Quoted <$> elementContent - "RawInline" -> uncurry RawInline <$> elementContent - "SmallCaps" -> SmallCaps <$> elementContent + "Note" -> Note <$!> elementContent + "Math" -> uncurry Math <$!> elementContent + "Quoted" -> uncurry Quoted <$!> elementContent + "RawInline" -> uncurry RawInline <$!> elementContent + "SmallCaps" -> SmallCaps <$!> elementContent "SoftBreak" -> return SoftBreak "Space" -> return Space - "Span" -> withAttr Span <$> elementContent - "Str" -> Str <$> elementContent - "Strikeout" -> Strikeout <$> elementContent - "Strong" -> Strong <$> elementContent - "Subscript" -> Subscript <$> elementContent - "Superscript"-> Superscript <$> elementContent + "Span" -> withAttr Span <$!> elementContent + -- strict to Lua string is copied before gc + "Str" -> Str <$!> elementContent + "Strikeout" -> Strikeout <$!> elementContent + "Strong" -> Strong <$!> elementContent + "Subscript" -> Subscript <$!> elementContent + "Superscript"-> Superscript <$!> elementContent _ -> Lua.throwMessage ("Unknown inline type: " <> tag) where -- Get the contents of an AST element. @@ -366,7 +364,7 @@ pushViaConstructor "Attr" id' classes kv instance Peekable LuaAttr where - peek idx = defineHowTo "get Attr value" (LuaAttr <$> Lua.peek idx) + peek idx = defineHowTo "get Attr value" $! (LuaAttr <$!> Lua.peek idx) -- | Wrapper for ListAttributes newtype LuaListAttributes = LuaListAttributes ListAttributes diff --git a/src/Text/Pandoc/Lua/Module/MediaBag.hs b/src/Text/Pandoc/Lua/Module/MediaBag.hs --- a/src/Text/Pandoc/Lua/Module/MediaBag.hs +++ b/src/Text/Pandoc/Lua/Module/MediaBag.hs @@ -13,6 +13,7 @@ ( pushModule ) where +import Prelude hiding (lookup) import Control.Monad (zipWithM_) import Foreign.Lua (Lua, NumResults, Optional) import Text.Pandoc.Class.CommonState (CommonState (..)) @@ -36,10 +37,10 @@ liftPandocLua Lua.newtable addFunction "delete" delete addFunction "empty" empty - addFunction "insert" insertMediaFn + addFunction "insert" insert addFunction "items" items - addFunction "lookup" lookupMediaFn - addFunction "list" mediaDirectoryFn + addFunction "lookup" lookup + addFunction "list" list addFunction "fetch" fetch return 1 @@ -53,11 +54,11 @@ empty = 0 <$ modifyCommonState (\st -> st { stMediaBag = mempty }) -- | Insert a new item into the media bag. -insertMediaFn :: FilePath - -> Optional MimeType - -> BL.ByteString - -> PandocLua NumResults -insertMediaFn fp optionalMime contents = do +insert :: FilePath + -> Optional MimeType + -> BL.ByteString + -> PandocLua NumResults +insert fp optionalMime contents = do mb <- getMediaBag setMediaBag $ MB.insertMedia fp (Lua.fromOptional optionalMime) contents mb return (Lua.NumResults 0) @@ -66,9 +67,9 @@ items :: PandocLua NumResults items = getMediaBag >>= liftPandocLua . pushIterator -lookupMediaFn :: FilePath - -> PandocLua NumResults -lookupMediaFn fp = do +lookup :: FilePath + -> PandocLua NumResults +lookup fp = do res <- MB.lookupMedia fp <$> getMediaBag liftPandocLua $ case res of Nothing -> 1 <$ Lua.pushnil @@ -77,8 +78,8 @@ Lua.push contents return 2 -mediaDirectoryFn :: PandocLua NumResults -mediaDirectoryFn = do +list :: PandocLua NumResults +list = do dirContents <- MB.mediaDirectory <$> getMediaBag liftPandocLua $ do Lua.newtable diff --git a/src/Text/Pandoc/Lua/Module/Pandoc.hs b/src/Text/Pandoc/Lua/Module/Pandoc.hs --- a/src/Text/Pandoc/Lua/Module/Pandoc.hs +++ b/src/Text/Pandoc/Lua/Module/Pandoc.hs @@ -14,6 +14,7 @@ ( pushModule ) where +import Prelude hiding (read) import Control.Monad (when) import Control.Monad.Except (throwError) import Data.Default (Default (..)) @@ -25,7 +26,7 @@ import Text.Pandoc.Lua.Filter (walkInlines, walkBlocks, LuaFilter, SingletonsList (..)) import Text.Pandoc.Lua.Marshaling () import Text.Pandoc.Lua.PandocLua (PandocLua, addFunction, liftPandocLua, - loadScriptFromDataDir) + loadDefaultModule) import Text.Pandoc.Walk (Walkable) import Text.Pandoc.Options (ReaderOptions (readerExtensions)) import Text.Pandoc.Process (pipeProcess) @@ -38,15 +39,15 @@ import qualified Text.Pandoc.Lua.Util as LuaUtil import Text.Pandoc.Error --- | Push the "pandoc" on the lua stack. Requires the `list` module to be --- loaded. +-- | Push the "pandoc" package to the Lua stack. Requires the `List` +-- module to be loadable. pushModule :: PandocLua NumResults pushModule = do - loadScriptFromDataDir "pandoc.lua" - addFunction "read" readDoc - addFunction "pipe" pipeFn - addFunction "walk_block" walkBlock - addFunction "walk_inline" walkInline + loadDefaultModule "pandoc" + addFunction "read" read + addFunction "pipe" pipe + addFunction "walk_block" walk_block + addFunction "walk_inline" walk_inline return 1 walkElement :: (Walkable (SingletonsList Inline) a, @@ -54,14 +55,14 @@ => a -> LuaFilter -> PandocLua a walkElement x f = liftPandocLua $ walkInlines f x >>= walkBlocks f -walkInline :: Inline -> LuaFilter -> PandocLua Inline -walkInline = walkElement +walk_inline :: Inline -> LuaFilter -> PandocLua Inline +walk_inline = walkElement -walkBlock :: Block -> LuaFilter -> PandocLua Block -walkBlock = walkElement +walk_block :: Block -> LuaFilter -> PandocLua Block +walk_block = walkElement -readDoc :: T.Text -> Optional T.Text -> PandocLua NumResults -readDoc content formatSpecOrNil = liftPandocLua $ do +read :: T.Text -> Optional T.Text -> PandocLua NumResults +read content formatSpecOrNil = liftPandocLua $ do let formatSpec = fromMaybe "markdown" (Lua.fromOptional formatSpecOrNil) res <- Lua.liftIO . runIO $ getReader formatSpec >>= \(rdr,es) -> @@ -79,11 +80,11 @@ Left e -> Lua.raiseError $ show e -- | Pipes input through a command. -pipeFn :: String - -> [String] - -> BL.ByteString - -> PandocLua NumResults -pipeFn command args input = liftPandocLua $ do +pipe :: String -- ^ path to executable + -> [String] -- ^ list of arguments + -> BL.ByteString -- ^ input passed to process via stdin + -> PandocLua NumResults +pipe command args input = liftPandocLua $ do (ec, output) <- Lua.liftIO $ pipeProcess Nothing command args input case ec of ExitSuccess -> 1 <$ Lua.push output diff --git a/src/Text/Pandoc/Lua/Packages.hs b/src/Text/Pandoc/Lua/Packages.hs --- a/src/Text/Pandoc/Lua/Packages.hs +++ b/src/Text/Pandoc/Lua/Packages.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE ScopedTypeVariables #-} {- | Module : Text.Pandoc.Lua.Packages Copyright : Copyright © 2017-2021 Albert Krewinkel @@ -15,15 +12,12 @@ ( installPandocPackageSearcher ) where -import Control.Monad.Catch (try) import Control.Monad (forM_) -import Data.ByteString (ByteString) -import Foreign.Lua (Lua, NumResults) -import Text.Pandoc.Error (PandocError) -import Text.Pandoc.Class.PandocMonad (readDataFile) -import Text.Pandoc.Lua.PandocLua (PandocLua, liftPandocLua) +import Foreign.Lua (NumResults) +import Text.Pandoc.Lua.PandocLua (PandocLua, liftPandocLua, loadDefaultModule) import qualified Foreign.Lua as Lua +import qualified Foreign.Lua.Module.Path as Path import qualified Foreign.Lua.Module.Text as Text import qualified Text.Pandoc.Lua.Module.Pandoc as Pandoc import qualified Text.Pandoc.Lua.Module.MediaBag as MediaBag @@ -50,28 +44,17 @@ case pkgName of "pandoc" -> pushWrappedHsFun Pandoc.pushModule "pandoc.mediabag" -> pushWrappedHsFun MediaBag.pushModule + "pandoc.path" -> pushWrappedHsFun Path.pushModule "pandoc.system" -> pushWrappedHsFun System.pushModule "pandoc.types" -> pushWrappedHsFun Types.pushModule "pandoc.utils" -> pushWrappedHsFun Utils.pushModule "text" -> pushWrappedHsFun Text.pushModule - _ -> searchPureLuaLoader + "pandoc.List" -> pushWrappedHsFun (loadDefaultModule pkgName) + _ -> reportPandocSearcherFailure where pushWrappedHsFun f = liftPandocLua $ do Lua.pushHaskellFunction f return 1 - searchPureLuaLoader = do - let filename = pkgName ++ ".lua" - try (readDataFile filename) >>= \case - Right script -> pushWrappedHsFun (loadStringAsPackage pkgName script) - Left (_ :: PandocError) -> liftPandocLua $ do - Lua.push ("\n\tno file '" ++ filename ++ "' in pandoc's datadir") - return (1 :: NumResults) - -loadStringAsPackage :: String -> ByteString -> Lua NumResults -loadStringAsPackage pkgName script = do - status <- Lua.dostring script - if status == Lua.OK - then return (1 :: NumResults) - else do - msg <- Lua.popValue - Lua.raiseError ("Error while loading `" <> pkgName <> "`.\n" <> msg) + reportPandocSearcherFailure = liftPandocLua $ do + Lua.push ("\n\t" <> pkgName <> "is not one of pandoc's default packages") + return (1 :: NumResults) diff --git a/src/Text/Pandoc/Lua/PandocLua.hs b/src/Text/Pandoc/Lua/PandocLua.hs --- a/src/Text/Pandoc/Lua/PandocLua.hs +++ b/src/Text/Pandoc/Lua/PandocLua.hs @@ -23,24 +23,23 @@ , runPandocLua , liftPandocLua , addFunction - , loadScriptFromDataDir + , loadDefaultModule ) where -import Control.Monad (when) import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow) import Control.Monad.Except (MonadError (catchError, throwError)) import Control.Monad.IO.Class (MonadIO (liftIO)) import Foreign.Lua (Lua (..), NumResults, Pushable, ToHaskellFunction) import Text.Pandoc.Class.PandocIO (PandocIO) -import Text.Pandoc.Class.PandocMonad (PandocMonad (..), readDataFile) -import Text.Pandoc.Error (PandocError) +import Text.Pandoc.Class.PandocMonad (PandocMonad (..), readDefaultDataFile) +import Text.Pandoc.Error (PandocError (PandocLuaError)) import Text.Pandoc.Lua.Global (Global (..), setGlobals) import Text.Pandoc.Lua.ErrorConversion (errorConversion) import qualified Control.Monad.Catch as Catch +import qualified Data.Text as T import qualified Foreign.Lua as Lua import qualified Text.Pandoc.Class.IO as IO -import qualified Text.Pandoc.Lua.Util as LuaUtil -- | Type providing access to both, pandoc and Lua operations. newtype PandocLua a = PandocLua { unPandocLua :: Lua a } @@ -86,14 +85,22 @@ Lua.pushHaskellFunction fn Lua.rawset (-3) --- | Load a file from pandoc's data directory. -loadScriptFromDataDir :: FilePath -> PandocLua () -loadScriptFromDataDir scriptFile = do - script <- readDataFile scriptFile +-- | Load a pure Lua module included with pandoc. Leaves the result on +-- the stack and returns @NumResults 1@. +-- +-- The script is loaded from the default data directory. We do not load +-- from data directories supplied via command line, as this could cause +-- scripts to be executed even though they had not been passed explicitly. +loadDefaultModule :: String -> PandocLua NumResults +loadDefaultModule name = do + script <- readDefaultDataFile (name <> ".lua") status <- liftPandocLua $ Lua.dostring script - when (status /= Lua.OK) . liftPandocLua $ - LuaUtil.throwTopMessageAsError' - (("Couldn't load '" ++ scriptFile ++ "'.\n") ++) + if status == Lua.OK + then return (1 :: NumResults) + else do + msg <- liftPandocLua Lua.popValue + let err = "Error while loading `" <> name <> "`.\n" <> msg + throwError $ PandocLuaError (T.pack err) -- | Global variables which should always be set. defaultGlobals :: PandocIO [Global] 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 @@ -10,8 +10,13 @@ Mime type lookup. -} -module Text.Pandoc.MIME ( MimeType, getMimeType, getMimeTypeDef, - extensionFromMimeType, mediaCategory ) where +module Text.Pandoc.MIME ( + MimeType, + getMimeType, + getMimeTypeDef, + getCharset, + extensionFromMimeType, + mediaCategory ) where import Data.List (isPrefixOf, isSuffixOf) import qualified Data.Map as M import qualified Data.Text as T @@ -53,6 +58,14 @@ mimeTypes :: M.Map T.Text MimeType mimeTypes = M.fromList mimeTypesList + +-- | Get the charset from a mime type, if one is present. +getCharset :: MimeType -> Maybe T.Text +getCharset mt = + let (_,y) = T.breakOn "charset=" mt + in if T.null y + then Nothing + else Just $ T.toUpper $ T.takeWhile (/= ';') $ T.drop 8 y -- | Collection of common mime types. -- Except for first entry, list borrowed from 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 @@ -43,6 +43,7 @@ import Text.Pandoc.Error (PandocError (PandocPDFProgramNotFoundError)) import Text.Pandoc.MIME (getMimeType) import Text.Pandoc.Options (HTMLMathMethod (..), WriterOptions (..)) +import Text.Pandoc.Extensions (disableExtension, Extension(Ext_smart)) import Text.Pandoc.Process (pipeProcess) import System.Process (readProcessWithExitCode) import Text.Pandoc.Shared (inDirectory, stringify, tshow) @@ -114,7 +115,10 @@ runIOorExplode $ do putCommonState commonState doc' <- handleImages opts tmpdir doc - source <- writer opts doc' + source <- writer opts{ writerExtensions = -- disable use of quote + -- ligatures to avoid bad ligatures like ?` + disableExtension Ext_smart + (writerExtensions opts) } doc' res <- case baseProg of "context" -> context2pdf verbosity program pdfargs tmpdir source "tectonic" -> tectonic2pdf verbosity program pdfargs tmpdir source @@ -266,7 +270,7 @@ | isAscii c = T.singleton c | otherwise = T.pack $ c : " (U+" ++ printf "%04X" (ord c) ++ ")" let addCodePoint = T.concatMap toCodePoint - let warnings = [ addCodePoint (T.pack $ utf8ToString (BC.drop 19 l)) + let warnings = [ addCodePoint (utf8ToText (BC.drop 19 l)) | l <- ls , isMissingCharacterWarning l ] @@ -310,7 +314,7 @@ env <- liftIO getEnvironment when (verbosity >= INFO) $ liftIO $ showVerboseInfo (Just tmpDir) program programArgs env - (utf8ToString sourceBL) + (utf8ToText sourceBL) (exit, out) <- liftIO $ E.catch (pipeProcess (Just env) program programArgs sourceBL) (handlePDFProgramNotFound program) @@ -381,7 +385,7 @@ (pipeProcess (Just env'') program programArgs BL.empty) (handlePDFProgramNotFound program) when (verbosity >= INFO) $ liftIO $ do - UTF8.hPutStrLn stderr $ "[makePDF] Run #" ++ show runNumber + UTF8.hPutStrLn stderr $ "[makePDF] Run #" <> tshow runNumber BL.hPutStr stderr out UTF8.hPutStr stderr "\n" if runNumber < numRuns @@ -401,7 +405,7 @@ generic2pdf verbosity program args source = do env' <- getEnvironment when (verbosity >= INFO) $ - showVerboseInfo Nothing program args env' (T.unpack source) + showVerboseInfo Nothing program args env' source (exit, out) <- E.catch (pipeProcess (Just env') program args (BL.fromStrict $ UTF8.fromText source)) @@ -490,19 +494,20 @@ -> String -> [String] -> [(String, String)] - -> String + -> Text -> IO () showVerboseInfo mbTmpDir program programArgs env source = do case mbTmpDir of Just tmpDir -> do UTF8.hPutStrLn stderr "[makePDF] temp dir:" - UTF8.hPutStrLn stderr tmpDir + UTF8.hPutStrLn stderr (T.pack tmpDir) Nothing -> return () UTF8.hPutStrLn stderr "[makePDF] Command line:" - UTF8.hPutStrLn stderr $ program ++ " " ++ unwords (map show programArgs) + UTF8.hPutStrLn stderr $ + T.pack program <> " " <> T.pack (unwords (map show programArgs)) UTF8.hPutStr stderr "\n" UTF8.hPutStrLn stderr "[makePDF] Environment:" - mapM_ (UTF8.hPutStrLn stderr . show) env + mapM_ (UTF8.hPutStrLn stderr . tshow) env UTF8.hPutStr stderr "\n" UTF8.hPutStrLn stderr "[makePDF] Source:" UTF8.hPutStrLn stderr source @@ -513,8 +518,8 @@ E.throwIO $ PandocPDFProgramNotFoundError $ T.pack program | otherwise = E.throwIO e -utf8ToString :: ByteString -> String -utf8ToString lbs = +utf8ToText :: ByteString -> Text +utf8ToText lbs = case decodeUtf8' lbs of - Left _ -> BC.unpack lbs -- if decoding fails, treat as latin1 - Right t -> TL.unpack t + Left _ -> T.pack $ BC.unpack lbs -- if decoding fails, treat as latin1 + Right t -> TL.toStrict t 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 @@ -1148,7 +1148,7 @@ => ParserT Text ParserState Identity a -> Text -> IO () -testStringWith parser str = UTF8.putStrLn $ show $ +testStringWith parser str = UTF8.putStrLn $ tshow $ readWith parser defaultParserState str -- | Parsing options. 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 @@ -12,7 +12,7 @@ -} module Text.Pandoc.Readers.DocBook ( readDocBook ) where import Control.Monad.State.Strict -import Data.Char (isSpace, toUpper) +import Data.Char (isSpace, isLetter) import Data.Default import Data.Either (rights) import Data.Foldable (asum) @@ -21,14 +21,17 @@ import Data.Maybe (fromMaybe,mapMaybe) import Data.Text (Text) 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.Error (PandocError(..)) import Text.Pandoc.Builder import Text.Pandoc.Class.PandocMonad (PandocMonad, report) import Text.Pandoc.Options import Text.Pandoc.Logging (LogMessage(..)) import Text.Pandoc.Shared (crFilter, safeRead, extractSpaces) import Text.TeXMath (readMathML, writeTeX) -import Text.XML.Light +import Text.Pandoc.XML.Light {- @@ -206,7 +209,7 @@ [x] info - A wrapper for information about a component or other block. (DocBook v5) [x] informalequation - A displayed mathematical equation without a title [x] informalexample - A displayed example without a title -[ ] informalfigure - A untitled figure +[x] informalfigure - An untitled figure [ ] informaltable - A table without a title [ ] initializer - The initializer for a FieldSynopsis [x] inlineequation - A mathematical equation or expression occurring inline @@ -537,22 +540,26 @@ readDocBook :: PandocMonad m => ReaderOptions -> Text -> m Pandoc readDocBook _ inp = do - let tree = normalizeTree . parseXML . handleInstructions $ crFilter inp + tree <- either (throwError . PandocXMLError "") return $ + parseXMLContents + (TL.fromStrict . handleInstructions $ crFilter inp) (bs, st') <- flip runStateT (def{ dbContent = tree }) $ mapM parseBlock tree return $ Pandoc (dbMeta st') (toList . mconcat $ bs) --- We treat specially (issue #1236), converting it --- to
, since xml-light doesn't parse the instruction correctly. --- Other xml instructions are simply removed from the input stream. +-- We treat certain processing instructions by converting them to tags +-- beginning "pi-". handleInstructions :: Text -> Text -handleInstructions = T.pack . handleInstructions' . T.unpack - -handleInstructions' :: String -> String -handleInstructions' ('<':'?':'a':'s':'c':'i':'i':'d':'o':'c':'-':'b':'r':'?':'>':xs) = '<':'b':'r':'/':'>': handleInstructions' xs -handleInstructions' xs = case break (=='<') xs of - (ys, []) -> ys - ([], '<':zs) -> '<' : handleInstructions' zs - (ys, zs) -> ys ++ handleInstructions' zs +handleInstructions t = + let (x,y) = T.breakOn "" y + in (if T.takeWhile (\c -> isLetter c || c == '-') + (T.drop 2 w) `elem` ["asciidoc-br", "dbfo"] + then x <> " T.drop 2 w <> "/>" + else x <> w <> T.take 2 z) <> + handleInstructions (T.drop 2 z) getFigure :: PandocMonad m => Element -> DB m Blocks getFigure e = do @@ -565,32 +572,14 @@ modify $ \st -> st{ dbFigureTitle = mempty, dbFigureId = mempty } return res --- normalize input, consolidating adjacent Text and CRef elements -normalizeTree :: [Content] -> [Content] -normalizeTree = everywhere (mkT go) - where go :: [Content] -> [Content] - go (Text (CData CDataRaw _ _):xs) = xs - go (Text (CData CDataText s1 z):Text (CData CDataText s2 _):xs) = - Text (CData CDataText (s1 ++ s2) z):xs - go (Text (CData CDataText s1 z):CRef r:xs) = - Text (CData CDataText (s1 ++ convertEntity r) z):xs - go (CRef r:Text (CData CDataText s1 z):xs) = - Text (CData CDataText (convertEntity r ++ s1) z):xs - go (CRef r1:CRef r2:xs) = - Text (CData CDataText (convertEntity r1 ++ convertEntity r2) Nothing):xs - go xs = xs - -convertEntity :: String -> String -convertEntity e = Data.Maybe.fromMaybe (map toUpper e) (lookupEntity e) - -- convenience function to get an attribute value, defaulting to "" -attrValue :: String -> Element -> Text +attrValue :: Text -> Element -> Text attrValue attr elt = - maybe "" T.pack (lookupAttrBy (\x -> qName x == attr) (elAttribs elt)) + fromMaybe "" (lookupAttrBy (\x -> qName x == attr) (elAttribs elt)) -- convenience function named :: Text -> Element -> Bool -named s e = qName (elName e) == T.unpack s +named s e = qName (elName e) == s -- @@ -627,7 +616,7 @@ isBlockElement (Elem e) = qName (elName e) `elem` blockTags isBlockElement _ = False -blockTags :: [String] +blockTags :: [Text] blockTags = [ "abstract" , "ackno" @@ -669,6 +658,7 @@ , "index" , "info" , "informalexample" + , "informalfigure" , "informaltable" , "itemizedlist" , "linegroup" @@ -713,7 +703,7 @@ , "variablelist" ] ++ admonitionTags -admonitionTags :: [String] +admonitionTags :: [Text] admonitionTags = ["important","caution","note","tip","warning"] -- Trim leading and trailing newline characters @@ -771,10 +761,10 @@ parseBlock :: PandocMonad m => Content -> DB m Blocks parseBlock (Text (CData CDataRaw _ _)) = return mempty -- DOCTYPE -parseBlock (Text (CData _ s _)) = if all isSpace s +parseBlock (Text (CData _ s _)) = if T.all isSpace s then return mempty - else return $ plain $ trimInlines $ text $ T.pack s -parseBlock (CRef x) = return $ plain $ str $ T.toUpper $ T.pack x + else return $ plain $ trimInlines $ text s +parseBlock (CRef x) = return $ plain $ str $ T.toUpper x parseBlock (Elem e) = case qName (elName e) of "toc" -> skip -- skip TOC, since in pandoc it's autogenerated @@ -829,7 +819,7 @@ "refsect2" -> sect 2 "refsect3" -> sect 3 "refsection" -> gets dbSectionLevel >>= sect . (+1) - l | l `elem` admonitionTags -> parseAdmonition $ T.pack l + l | l `elem` admonitionTags -> parseAdmonition l "area" -> skip "areaset" -> skip "areaspec" -> skip @@ -855,6 +845,7 @@ "variablelist" -> definitionList <$> deflistitems "procedure" -> bulletList <$> steps "figure" -> getFigure e + "informalfigure" -> getFigure e "mediaobject" -> para <$> getMediaobject e "caption" -> skip "info" -> addMetadataFromElement e @@ -890,7 +881,11 @@ "subtitle" -> return mempty -- handled in parent element _ -> skip >> getBlocks e where skip = do - lift $ report $ IgnoredElement $ T.pack $ qName (elName e) + let qn = qName $ elName e + let name = if "pi-" `T.isPrefixOf` qn + then " qn <> "?>" + else qn + lift $ report $ IgnoredElement name return mempty codeBlockWithLang = do @@ -898,7 +893,7 @@ "" -> [] x -> [x] return $ codeBlockWith (attrValue "id" e, classes', []) - $ trimNl $ T.pack $ strContentRecursive e + $ trimNl $ strContentRecursive e parseBlockquote = do attrib <- case filterChild (named "attribution") e of Nothing -> return mempty @@ -952,7 +947,7 @@ w <- findAttr (unqual "colwidth") c n <- safeRead $ "0" <> T.filter (\x -> (x >= '0' && x <= '9') - || x == '.') (T.pack w) + || x == '.') w if n > 0 then Just n else Nothing let numrows = case bodyrows of [] -> 0 @@ -962,7 +957,7 @@ cs -> map toAlignment cs let parseWidth s = safeRead (T.filter (\x -> (x >= '0' && x <= '9') || x == '.') s) - let textWidth = case filterChild (named "?dbfo") e of + let textWidth = case filterChild (named "pi-dbfo") e of Just d -> case attrValue "table-width" d of "" -> 1.0 w -> fromMaybe 100.0 (parseWidth w) / 100.0 @@ -1035,12 +1030,12 @@ x <- parseMixed container rs return $ p <> b <> x -parseRow :: PandocMonad m => [String] -> Element -> DB m [Cell] +parseRow :: PandocMonad m => [Text] -> Element -> DB m [Cell] parseRow cn = do let isEntry x = named "entry" x || named "td" x || named "th" x mapM (parseEntry cn) . filterChildren isEntry -parseEntry :: PandocMonad m => [String] -> Element -> DB m Cell +parseEntry :: PandocMonad m => [Text] -> Element -> DB m Cell parseEntry cn el = do let colDistance sa ea = do let iStrt = elemIndex sa cn @@ -1062,7 +1057,7 @@ getInlines e' = trimInlines . mconcat <$> mapM parseInline (elContent e') -strContentRecursive :: Element -> String +strContentRecursive :: Element -> Text strContentRecursive = strContent . (\e' -> e'{ elContent = map elementToStr $ elContent e' }) @@ -1071,9 +1066,9 @@ elementToStr x = x parseInline :: PandocMonad m => Content -> DB m Inlines -parseInline (Text (CData _ s _)) = return $ text $ T.pack s +parseInline (Text (CData _ s _)) = return $ text s parseInline (CRef ref) = - return $ text $ maybe (T.toUpper $ T.pack ref) T.pack $ lookupEntity ref + return $ text $ maybe (T.toUpper ref) T.pack $ lookupEntity (T.unpack ref) parseInline (Elem e) = case qName (elName e) of "anchor" -> do @@ -1125,7 +1120,7 @@ "userinput" -> codeWithLang "systemitem" -> codeWithLang "varargs" -> return $ code "(...)" - "keycap" -> return (str $ T.pack $ strContent e) + "keycap" -> return (str $ strContent e) "keycombo" -> keycombo <$> mapM parseInline (elContent e) "menuchoice" -> menuchoice <$> @@ -1137,17 +1132,17 @@ let title = case attrValue "endterm" e of "" -> maybe "???" xrefTitleByElem (findElementById linkend content) - endterm -> maybe "???" (T.pack . strContent) + endterm -> maybe "???" strContent (findElementById endterm content) return $ link ("#" <> linkend) "" (text title) - "email" -> return $ link ("mailto:" <> T.pack (strContent e)) "" - $ str $ T.pack $ strContent e - "uri" -> return $ link (T.pack $ strContent e) "" $ str $ T.pack $ strContent e + "email" -> return $ link ("mailto:" <> strContent e) "" + $ str $ strContent e + "uri" -> return $ link (strContent e) "" $ str $ strContent e "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 - Just h -> T.pack h + Just h -> h _ -> "#" <> attrValue "linkend" e let ils' = if ils == mempty then str href else ils let attr = (attrValue "id" e, T.words $ attrValue "role" e, []) @@ -1163,12 +1158,15 @@ "title" -> return mempty "affiliation" -> skip -- Note: this isn't a real docbook tag; it's what we convert - -- to in handleInstructions, above. A kludge to - -- work around xml-light's inability to parse an instruction. - "br" -> return linebreak + -- to in handleInstructions, above. + "pi-asciidoc-br" -> return linebreak _ -> skip >> innerInlines id where skip = do - lift $ report $ IgnoredElement $ T.pack $ qName (elName e) + let qn = qName $ elName e + let name = if "pi-" `T.isPrefixOf` qn + then " qn <> "?>" + else qn + lift $ report $ IgnoredElement name return mempty innerInlines f = extractSpaces f . mconcat <$> @@ -1177,7 +1175,7 @@ let classes' = case attrValue "language" e of "" -> [] l -> [l] - return $ codeWith (attrValue "id" e,classes',[]) $ T.pack $ strContentRecursive e + return $ codeWith (attrValue "id" e,classes',[]) $ strContentRecursive e simpleList = mconcat . intersperse (str "," <> space) <$> mapM getInlines (filterChildren (named "member") e) segmentedList = do @@ -1218,10 +1216,10 @@ "sect5" -> descendantContent "title" el "cmdsynopsis" -> descendantContent "command" el "funcsynopsis" -> descendantContent "function" el - _ -> T.pack $ qName (elName el) ++ "_title" + _ -> qName (elName el) <> "_title" where xrefLabel = attrValue "xreflabel" el - descendantContent name = maybe "???" (T.pack . strContent) + descendantContent name = maybe "???" strContent . filterElementName (\n -> qName n == name) -- | Extract a math equation from an element @@ -1242,7 +1240,7 @@ mathMLEquations :: [Text] mathMLEquations = map writeTeX $ rights $ readMath (\x -> qName (elName x) == "math" && qPrefix (elName x) == Just "mml") - (readMathML . T.pack . showElement) + (readMathML . showElement) latexEquations :: [Text] latexEquations = readMath (\x -> qName (elName x) == "mathphrase") @@ -1256,8 +1254,8 @@ -- | Get the actual text stored in a CData block. 'showContent' -- returns the text still surrounded by the [[CDATA]] tags. showVerbatimCData :: Content -> Text -showVerbatimCData (Text (CData _ d _)) = T.pack d -showVerbatimCData c = T.pack $ showContent c +showVerbatimCData (Text (CData _ d _)) = d +showVerbatimCData c = showContent c -- | Set the prefix of a name to 'Nothing' 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 @@ -63,6 +63,7 @@ import Data.List import qualified Data.Map as M import qualified Data.Text as T +import Data.Text (Text) import Data.Maybe import System.FilePath import Text.Pandoc.Readers.Docx.Util @@ -72,8 +73,7 @@ import Text.TeXMath (Exp) import Text.TeXMath.Readers.OMML (readOMML) import Text.TeXMath.Unicode.Fonts (Font (..), getUnicode, textToFont) -import Text.XML.Light -import qualified Text.XML.Light.Cursor as XMLC +import Text.Pandoc.XML.Light data ReaderEnv = ReaderEnv { envNotes :: Notes , envComments :: Comments @@ -127,37 +127,23 @@ in concatMapM handler xs -unwrap :: NameSpaces -> Content -> [Content] -unwrap ns (Elem element) +unwrapElement :: NameSpaces -> Element -> [Element] +unwrapElement ns element | isElem ns "w" "sdt" element , Just sdtContent <- findChildByName ns "w" "sdtContent" element - = concatMap (unwrap ns . Elem) (elChildren sdtContent) + = concatMap (unwrapElement ns) (elChildren sdtContent) | isElem ns "w" "smartTag" element - = concatMap (unwrap ns . Elem) (elChildren element) -unwrap _ content = [content] - -unwrapChild :: NameSpaces -> Content -> Content -unwrapChild ns (Elem element) = - Elem $ element { elContent = concatMap (unwrap ns) (elContent element) } -unwrapChild _ content = content + = concatMap (unwrapElement ns) (elChildren element) + | otherwise + = [element{ elContent = concatMap (unwrapContent ns) (elContent element) }] -walkDocument' :: NameSpaces -> XMLC.Cursor -> XMLC.Cursor -walkDocument' ns cur = - let modifiedCur = XMLC.modifyContent (unwrapChild ns) cur - in - case XMLC.nextDF modifiedCur of - Just cur' -> walkDocument' ns cur' - Nothing -> XMLC.root modifiedCur +unwrapContent :: NameSpaces -> Content -> [Content] +unwrapContent ns (Elem element) = map Elem $ unwrapElement ns element +unwrapContent _ content = [content] -walkDocument :: NameSpaces -> Element -> Maybe Element +walkDocument :: NameSpaces -> Element -> Element walkDocument ns element = - let cur = XMLC.fromContent (Elem element) - cur' = walkDocument' ns cur - in - case XMLC.toTree cur' of - Elem element' -> Just element' - _ -> Nothing - + element{ elContent = concatMap (unwrapContent ns) (elContent element) } newtype Docx = Docx Document deriving Show @@ -343,10 +329,16 @@ Right doc -> Right (Docx doc, stateWarnings st) Left e -> Left e +parseXMLFromEntry :: Entry -> Maybe Element +parseXMLFromEntry entry = + case parseXMLElement (UTF8.toTextLazy (fromEntry entry)) of + Left _ -> Nothing + Right el -> Just el + getDocumentXmlPath :: Archive -> Maybe FilePath getDocumentXmlPath zf = do entry <- findEntryByPath "_rels/.rels" zf - relsElem <- (parseXMLDoc . UTF8.toStringLazy . fromEntry) entry + relsElem <- parseXMLFromEntry entry let rels = filterChildrenName (\n -> qName n == "Relationship") relsElem rel <- find (\e -> findAttr (QName "Type" Nothing Nothing) e == Just "http://schemas.openxmlformats.org/officeDocument/2006/relationships/officeDocument") @@ -354,18 +346,18 @@ fp <- findAttr (QName "Target" Nothing Nothing) rel -- sometimes there will be a leading slash, which windows seems to -- have trouble with. - return $ case fp of + return $ case T.unpack fp of '/' : fp' -> fp' - _ -> fp + fp' -> fp' archiveToDocument :: Archive -> D Document archiveToDocument zf = do docPath <- asks envDocXmlPath entry <- maybeToD $ findEntryByPath docPath zf - docElem <- maybeToD $ (parseXMLDoc . UTF8.toStringLazy . fromEntry) entry + docElem <- maybeToD $ parseXMLFromEntry entry let namespaces = elemToNameSpaces docElem bodyElem <- maybeToD $ findChildByName namespaces "w" "body" docElem - let bodyElem' = fromMaybe bodyElem (walkDocument namespaces bodyElem) + let bodyElem' = walkDocument namespaces bodyElem body <- elemToBody namespaces bodyElem' return $ Document namespaces body @@ -401,23 +393,24 @@ archiveToNotes :: Archive -> Notes archiveToNotes zf = let fnElem = findEntryByPath "word/footnotes.xml" zf - >>= (parseXMLDoc . UTF8.toStringLazy . fromEntry) + >>= parseXMLFromEntry enElem = findEntryByPath "word/endnotes.xml" zf - >>= (parseXMLDoc . UTF8.toStringLazy . fromEntry) - fn_namespaces = maybe [] elemToNameSpaces fnElem - en_namespaces = maybe [] elemToNameSpaces enElem - ns = unionBy (\x y -> fst x == fst y) fn_namespaces en_namespaces - fn = fnElem >>= walkDocument ns >>= elemToNotes ns "footnote" - en = enElem >>= walkDocument ns >>= elemToNotes ns "endnote" + >>= parseXMLFromEntry + fn_namespaces = maybe mempty elemToNameSpaces fnElem + en_namespaces = maybe mempty elemToNameSpaces enElem + ns = M.union fn_namespaces en_namespaces + fn = fnElem >>= elemToNotes ns "footnote" . walkDocument ns + en = enElem >>= elemToNotes ns "endnote" . walkDocument ns in Notes ns fn en archiveToComments :: Archive -> Comments archiveToComments zf = let cmtsElem = findEntryByPath "word/comments.xml" zf - >>= (parseXMLDoc . UTF8.toStringLazy . fromEntry) - cmts_namespaces = maybe [] elemToNameSpaces cmtsElem - cmts = elemToComments cmts_namespaces <$> (cmtsElem >>= walkDocument cmts_namespaces) + >>= parseXMLFromEntry + cmts_namespaces = maybe mempty elemToNameSpaces cmtsElem + cmts = elemToComments cmts_namespaces . walkDocument cmts_namespaces <$> + cmtsElem in case cmts of Just c -> Comments cmts_namespaces c @@ -436,8 +429,8 @@ relElemToRelationship :: DocumentLocation -> Element -> Maybe Relationship relElemToRelationship relType element | qName (elName element) == "Relationship" = do - relId <- findAttrText (QName "Id" Nothing Nothing) element - target <- findAttrText (QName "Target" Nothing Nothing) element + relId <- findAttr (QName "Id" Nothing Nothing) element + target <- findAttr (QName "Target" Nothing Nothing) element return $ Relationship relType relId target relElemToRelationship _ _ = Nothing @@ -445,7 +438,7 @@ filePathToRelationships ar docXmlPath fp | Just relType <- filePathToRelType fp docXmlPath , Just entry <- findEntryByPath fp ar - , Just relElems <- (parseXMLDoc . UTF8.toStringLazy . fromEntry) entry = + , Just relElems <- parseXMLFromEntry entry = mapMaybe (relElemToRelationship relType) $ elChildren relElems filePathToRelationships _ _ _ = [] @@ -478,10 +471,10 @@ loElemToLevelOverride :: NameSpaces -> Element -> Maybe LevelOverride loElemToLevelOverride ns element | isElem ns "w" "lvlOverride" element = do - ilvl <- findAttrTextByName ns "w" "ilvl" element + ilvl <- findAttrByName ns "w" "ilvl" element let startOverride = findChildByName ns "w" "startOverride" element >>= findAttrByName ns "w" "val" - >>= (\s -> listToMaybe (map fst (reads s :: [(Integer, String)]))) + >>= stringToInteger lvl = findChildByName ns "w" "lvl" element >>= levelElemToLevel ns return $ LevelOverride ilvl startOverride lvl @@ -490,9 +483,9 @@ numElemToNum :: NameSpaces -> Element -> Maybe Numb numElemToNum ns element | isElem ns "w" "num" element = do - numId <- findAttrTextByName ns "w" "numId" element + numId <- findAttrByName ns "w" "numId" element absNumId <- findChildByName ns "w" "abstractNumId" element - >>= findAttrTextByName ns "w" "val" + >>= findAttrByName ns "w" "val" let lvlOverrides = mapMaybe (loElemToLevelOverride ns) (findChildrenByName ns "w" "lvlOverride" element) @@ -502,7 +495,7 @@ absNumElemToAbsNum :: NameSpaces -> Element -> Maybe AbstractNumb absNumElemToAbsNum ns element | isElem ns "w" "abstractNum" element = do - absNumId <- findAttrTextByName ns "w" "abstractNumId" element + absNumId <- findAttrByName ns "w" "abstractNumId" element let levelElems = findChildrenByName ns "w" "lvl" element levels = mapMaybe (levelElemToLevel ns) levelElems return $ AbstractNumb absNumId levels @@ -511,23 +504,23 @@ levelElemToLevel :: NameSpaces -> Element -> Maybe Level levelElemToLevel ns element | isElem ns "w" "lvl" element = do - ilvl <- findAttrTextByName ns "w" "ilvl" element + ilvl <- findAttrByName ns "w" "ilvl" element fmt <- findChildByName ns "w" "numFmt" element - >>= findAttrTextByName ns "w" "val" + >>= findAttrByName ns "w" "val" txt <- findChildByName ns "w" "lvlText" element - >>= findAttrTextByName ns "w" "val" + >>= findAttrByName ns "w" "val" let start = findChildByName ns "w" "start" element >>= findAttrByName ns "w" "val" - >>= (\s -> listToMaybe (map fst (reads s :: [(Integer, String)]))) + >>= stringToInteger return (Level ilvl fmt txt start) levelElemToLevel _ _ = Nothing archiveToNumbering' :: Archive -> Maybe Numbering archiveToNumbering' zf = case findEntryByPath "word/numbering.xml" zf of - Nothing -> Just $ Numbering [] [] [] + Nothing -> Just $ Numbering mempty [] [] Just entry -> do - numberingElem <- (parseXMLDoc . UTF8.toStringLazy . fromEntry) entry + numberingElem <- parseXMLFromEntry entry let namespaces = elemToNameSpaces numberingElem numElems = findChildrenByName namespaces "w" "num" numberingElem absNumElems = findChildrenByName namespaces "w" "abstractNum" numberingElem @@ -537,13 +530,13 @@ archiveToNumbering :: Archive -> Numbering archiveToNumbering archive = - fromMaybe (Numbering [] [] []) (archiveToNumbering' archive) + fromMaybe (Numbering mempty [] []) (archiveToNumbering' archive) -elemToNotes :: NameSpaces -> String -> Element -> Maybe (M.Map T.Text Element) +elemToNotes :: NameSpaces -> Text -> Element -> Maybe (M.Map T.Text Element) elemToNotes ns notetype element | isElem ns "w" (notetype <> "s") element = let pairs = mapMaybe - (\e -> findAttrTextByName ns "w" "id" e >>= + (\e -> findAttrByName ns "w" "id" e >>= (\a -> Just (a, e))) (findChildrenByName ns "w" notetype element) in @@ -555,7 +548,7 @@ elemToComments ns element | isElem ns "w" "comments" element = let pairs = mapMaybe - (\e -> findAttrTextByName ns "w" "id" e >>= + (\e -> findAttrByName ns "w" "id" e >>= (\a -> Just (a, e))) (findChildrenByName ns "w" "comment" element) in @@ -615,12 +608,12 @@ stringToInteger , hangingParIndent = findAttrByName ns "w" "hanging" element >>= - stringToInteger} + stringToInteger } elemToParIndentation _ _ = Nothing -testBitMask :: String -> Int -> Bool +testBitMask :: Text -> Int -> Bool testBitMask bitMaskS n = - case (reads ("0x" ++ bitMaskS) :: [(Int, String)]) of + case (reads ("0x" ++ T.unpack bitMaskS) :: [(Int, String)]) of [] -> False ((n', _) : _) -> (n' .|. n) /= 0 @@ -635,7 +628,7 @@ | isElem ns "w" "p" element , (c:_) <- findChildrenByName ns "m" "oMathPara" element = do - expsLst <- eitherToD $ readOMML $ T.pack $ showElement c + expsLst <- eitherToD $ readOMML $ showElement c return $ OMathPara expsLst elemToBodyPart ns element | isElem ns "w" "p" element @@ -659,7 +652,7 @@ | isElem ns "w" "tbl" element = do let caption' = findChildByName ns "w" "tblPr" element >>= findChildByName ns "w" "tblCaption" - >>= findAttrTextByName ns "w" "val" + >>= findAttrByName ns "w" "val" caption = fromMaybe "" caption' grid' = case findChildByName ns "w" "tblGrid" element of Just g -> elemToTblGrid ns g @@ -698,8 +691,8 @@ getTitleAndAlt ns element = let mbDocPr = findChildByName ns "wp" "inline" element >>= findChildByName ns "wp" "docPr" - title = fromMaybe "" (mbDocPr >>= findAttrTextByName ns "" "title") - alt = fromMaybe "" (mbDocPr >>= findAttrTextByName ns "" "descr") + title = fromMaybe "" (mbDocPr >>= findAttrByName ns "" "title") + alt = fromMaybe "" (mbDocPr >>= findAttrByName ns "" "descr") in (title, alt) elemToParPart :: NameSpaces -> Element -> D ParPart @@ -711,7 +704,7 @@ = let (title, alt) = getTitleAndAlt ns drawingElem a_ns = "http://schemas.openxmlformats.org/drawingml/2006/main" drawing = findElement (QName "blip" (Just a_ns) (Just "a")) picElem - >>= findAttrTextByName ns "r" "embed" + >>= findAttrByName ns "r" "embed" in case drawing of Just s -> expandDrawingId s >>= (\(fp, bs) -> return $ Drawing fp title alt bs $ elemToExtent drawingElem) @@ -721,7 +714,7 @@ | isElem ns "w" "r" element , Just _ <- findChildByName ns "w" "pict" element = let drawing = findElement (elemName ns "v" "imagedata") element - >>= findAttrTextByName ns "r" "id" + >>= findAttrByName ns "r" "id" in case drawing of -- Todo: check out title and attr for deprecated format. @@ -790,7 +783,7 @@ fldCharState <- gets stateFldCharState case fldCharState of FldCharOpen -> do - info <- eitherToD $ parseFieldInfo $ T.pack $ strContent instrText + info <- eitherToD $ parseFieldInfo $ strContent instrText modify $ \st -> st{stateFldCharState = FldCharFieldInfo info} return NullParPart _ -> return NullParPart @@ -811,48 +804,48 @@ return $ ChangedRuns change runs elemToParPart ns element | isElem ns "w" "bookmarkStart" element - , Just bmId <- findAttrTextByName ns "w" "id" element - , Just bmName <- findAttrTextByName ns "w" "name" element = + , Just bmId <- findAttrByName ns "w" "id" element + , Just bmName <- findAttrByName ns "w" "name" element = return $ BookMark bmId bmName elemToParPart ns element | isElem ns "w" "hyperlink" element - , Just relId <- findAttrTextByName ns "r" "id" element = do + , Just relId <- findAttrByName ns "r" "id" element = do location <- asks envLocation runs <- mapD (elemToRun ns) (elChildren element) rels <- asks envRelationships case lookupRelationship location relId rels of Just target -> - case findAttrTextByName ns "w" "anchor" element of + case findAttrByName ns "w" "anchor" element of Just anchor -> return $ ExternalHyperLink (target <> "#" <> anchor) runs Nothing -> return $ ExternalHyperLink target runs Nothing -> return $ ExternalHyperLink "" runs elemToParPart ns element | isElem ns "w" "hyperlink" element - , Just anchor <- findAttrTextByName ns "w" "anchor" element = do + , Just anchor <- findAttrByName ns "w" "anchor" element = do runs <- mapD (elemToRun ns) (elChildren element) return $ InternalHyperLink anchor runs elemToParPart ns element | isElem ns "w" "commentRangeStart" element - , Just cmtId <- findAttrTextByName ns "w" "id" element = do + , Just cmtId <- findAttrByName ns "w" "id" element = do (Comments _ commentMap) <- asks envComments case M.lookup cmtId commentMap of Just cmtElem -> elemToCommentStart ns cmtElem Nothing -> throwError WrongElem elemToParPart ns element | isElem ns "w" "commentRangeEnd" element - , Just cmtId <- findAttrTextByName ns "w" "id" element = + , Just cmtId <- findAttrByName ns "w" "id" element = return $ CommentEnd cmtId elemToParPart ns element | isElem ns "m" "oMath" element = - fmap PlainOMath (eitherToD $ readOMML $ T.pack $ showElement element) + fmap PlainOMath (eitherToD $ readOMML $ showElement element) elemToParPart _ _ = throwError WrongElem elemToCommentStart :: NameSpaces -> Element -> D ParPart elemToCommentStart ns element | isElem ns "w" "comment" element - , Just cmtId <- findAttrTextByName ns "w" "id" element - , Just cmtAuthor <- findAttrTextByName ns "w" "author" element - , cmtDate <- findAttrTextByName ns "w" "date" element = do + , Just cmtId <- findAttrByName ns "w" "id" element + , Just cmtAuthor <- findAttrByName ns "w" "author" element + , cmtDate <- findAttrByName ns "w" "date" element = do bps <- mapD (elemToBodyPart ns) (elChildren element) return $ CommentStart cmtId cmtAuthor cmtDate bps elemToCommentStart _ _ = throwError WrongElem @@ -871,7 +864,7 @@ where wp_ns = "http://schemas.openxmlformats.org/drawingml/2006/wordprocessingDrawing" getDim at = findElement (QName "extent" (Just wp_ns) (Just "wp")) drawingElem - >>= findAttr (QName at Nothing Nothing) >>= safeRead . T.pack + >>= findAttr (QName at Nothing Nothing) >>= safeRead childElemToRun :: NameSpaces -> Element -> D Run @@ -882,7 +875,7 @@ = let (title, alt) = getTitleAndAlt ns element a_ns = "http://schemas.openxmlformats.org/drawingml/2006/main" drawing = findElement (QName "blip" (Just a_ns) (Just "a")) picElem - >>= findAttrText (QName "embed" (lookup "r" ns) (Just "r")) + >>= findAttr (QName "embed" (M.lookup "r" ns) (Just "r")) in case drawing of Just s -> expandDrawingId s >>= @@ -895,7 +888,7 @@ = return InlineChart childElemToRun ns element | isElem ns "w" "footnoteReference" element - , Just fnId <- findAttrTextByName ns "w" "id" element = do + , Just fnId <- findAttrByName ns "w" "id" element = do notes <- asks envNotes case lookupFootnote fnId notes of Just e -> do bps <- local (\r -> r {envLocation=InFootnote}) $ mapD (elemToBodyPart ns) (elChildren e) @@ -903,7 +896,7 @@ Nothing -> return $ Footnote [] childElemToRun ns element | isElem ns "w" "endnoteReference" element - , Just enId <- findAttrTextByName ns "w" "id" element = do + , Just enId <- findAttrByName ns "w" "id" element = do notes <- asks envNotes case lookupEndnote enId notes of Just e -> do bps <- local (\r -> r {envLocation=InEndnote}) $ mapD (elemToBodyPart ns) (elChildren e) @@ -956,15 +949,15 @@ getTrackedChange :: NameSpaces -> Element -> Maybe TrackedChange getTrackedChange ns element | isElem ns "w" "ins" element || isElem ns "w" "moveTo" element - , Just cId <- findAttrTextByName ns "w" "id" element - , Just cAuthor <- findAttrTextByName ns "w" "author" element - , mcDate <- findAttrTextByName ns "w" "date" element = + , Just cId <- findAttrByName ns "w" "id" element + , Just cAuthor <- findAttrByName ns "w" "author" element + , mcDate <- findAttrByName ns "w" "date" element = Just $ TrackedChange Insertion (ChangeInfo cId cAuthor mcDate) getTrackedChange ns element | isElem ns "w" "del" element || isElem ns "w" "moveFrom" element - , Just cId <- findAttrTextByName ns "w" "id" element - , Just cAuthor <- findAttrTextByName ns "w" "author" element - , mcDate <- findAttrTextByName ns "w" "date" element = + , Just cId <- findAttrByName ns "w" "id" element + , Just cAuthor <- findAttrByName ns "w" "author" element + , mcDate <- findAttrByName ns "w" "date" element = Just $ TrackedChange Deletion (ChangeInfo cId cAuthor mcDate) getTrackedChange _ _ = Nothing @@ -973,7 +966,7 @@ | Just pPr <- findChildByName ns "w" "pPr" element = let style = mapMaybe - (fmap ParaStyleId . findAttrTextByName ns "w" "val") + (fmap ParaStyleId . findAttrByName ns "w" "val") (findChildrenByName ns "w" "pStyle" pPr) in ParagraphStyle {pStyle = mapMaybe (`M.lookup` sty) style @@ -1005,7 +998,7 @@ charStyles <- asks envCharStyles let parentSty = findChildByName ns "w" "rStyle" rPr >>= - findAttrTextByName ns "w" "val" >>= + findAttrByName ns "w" "val" >>= flip M.lookup charStyles . CharStyleId return $ elemToRunStyle ns element parentSty elemToRunStyleD _ _ = return defaultRunStyle @@ -1015,7 +1008,7 @@ | isElem ns "w" "t" element || isElem ns "w" "delText" element || isElem ns "m" "t" element = do - let str = T.pack $ strContent element + let str = strContent element font <- asks envFont case font of Nothing -> return $ TextRun str @@ -1037,14 +1030,14 @@ getSymChar ns element | Just s <- lowerFromPrivate <$> getCodepoint , Just font <- getFont = - case readLitChar ("\\x" ++ s) of + case readLitChar ("\\x" ++ T.unpack s) of [(char, _)] -> TextRun . maybe "" T.singleton $ getUnicode font char _ -> TextRun "" where getCodepoint = findAttrByName ns "w" "char" element - getFont = textToFont . T.pack =<< findAttrByName ns "w" "font" element - lowerFromPrivate ('F':xs) = '0':xs - lowerFromPrivate xs = xs + getFont = textToFont =<< findAttrByName ns "w" "font" element + lowerFromPrivate t | "F" `T.isPrefixOf` t = "0" <> T.drop 1 t + | otherwise = t getSymChar _ _ = TextRun "" elemToRunElems :: NameSpaces -> Element -> D [RunElem] @@ -1054,8 +1047,9 @@ let qualName = elemName ns "w" let font = do fontElem <- findElement (qualName "rFonts") element - textToFont . T.pack =<< - foldr ((<|>) . (flip findAttr fontElem . qualName)) Nothing ["ascii", "hAnsi"] + textToFont =<< + foldr ((<|>) . (flip findAttr fontElem . qualName)) + Nothing ["ascii", "hAnsi"] local (setFont font) (mapD (elemToRunElem ns) (elChildren element)) elemToRunElems _ _ = throwError WrongElem diff --git a/src/Text/Pandoc/Readers/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 @@ -48,11 +48,13 @@ import Data.String (IsString(..)) import qualified Data.Map as M import qualified Data.Text as T +import qualified Data.Text.Read +import Data.Text (Text) import Data.Maybe import Data.Coerce import Text.Pandoc.Readers.Docx.Util import qualified Text.Pandoc.UTF8 as UTF8 -import Text.XML.Light +import Text.Pandoc.XML.Light newtype CharStyleId = CharStyleId T.Text deriving (Show, Eq, Ord, IsString, FromStyleId) @@ -108,7 +110,7 @@ , isRTL :: Maybe Bool , isForceCTL :: Maybe Bool , rVertAlign :: Maybe VertAlign - , rUnderline :: Maybe String + , rUnderline :: Maybe Text , rParentStyle :: Maybe CharStyle } deriving Show @@ -135,19 +137,22 @@ , rParentStyle = Nothing } -archiveToStyles' :: (Ord k1, Ord k2, ElemToStyle a1, ElemToStyle a2) => - (a1 -> k1) -> (a2 -> k2) -> Archive -> (M.Map k1 a1, M.Map k2 a2) +archiveToStyles' + :: (Ord k1, Ord k2, ElemToStyle a1, ElemToStyle a2) + => (a1 -> k1) -> (a2 -> k2) -> Archive -> (M.Map k1 a1, M.Map k2 a2) archiveToStyles' conv1 conv2 zf = - let stylesElem = findEntryByPath "word/styles.xml" zf >>= - (parseXMLDoc . UTF8.toStringLazy . fromEntry) - in - case stylesElem of - Nothing -> (M.empty, M.empty) - Just styElem -> - let namespaces = elemToNameSpaces styElem - in - ( M.fromList $ map (\r -> (conv1 r, r)) $ buildBasedOnList namespaces styElem Nothing, - M.fromList $ map (\p -> (conv2 p, p)) $ buildBasedOnList namespaces styElem Nothing) + case findEntryByPath "word/styles.xml" zf of + Nothing -> (M.empty, M.empty) + Just entry -> + case parseXMLElement . UTF8.toTextLazy . fromEntry $ entry of + Left _ -> (M.empty, M.empty) + Right styElem -> + let namespaces = elemToNameSpaces styElem + in + ( M.fromList $ map (\r -> (conv1 r, r)) $ + buildBasedOnList namespaces styElem Nothing, + M.fromList $ map (\p -> (conv2 p, p)) $ + buildBasedOnList namespaces styElem Nothing) isBasedOnStyle :: (ElemToStyle a, FromStyleId (StyleId a)) => NameSpaces -> Element -> Maybe a -> Bool isBasedOnStyle ns element parentStyle @@ -155,7 +160,7 @@ , Just styleType <- findAttrByName ns "w" "type" element , styleType == cStyleType parentStyle , Just basedOnVal <- findChildByName ns "w" "basedOn" element >>= - findAttrTextByName ns "w" "val" + findAttrByName ns "w" "val" , Just ps <- parentStyle = basedOnVal == fromStyleId (getStyleId ps) | isElem ns "w" "style" element , Just styleType <- findAttrByName ns "w" "type" element @@ -165,7 +170,7 @@ | otherwise = False class HasStyleId a => ElemToStyle a where - cStyleType :: Maybe a -> String + cStyleType :: Maybe a -> Text elemToStyle :: NameSpaces -> Element -> Maybe a -> Maybe a class FromStyleId (StyleId a) => HasStyleId a where @@ -222,8 +227,10 @@ stys -> stys ++ concatMap (buildBasedOnList ns element . Just) stys -stringToInteger :: String -> Maybe Integer -stringToInteger s = listToMaybe $ map fst (reads s :: [(Integer, String)]) +stringToInteger :: Text -> Maybe Integer +stringToInteger s = case Data.Text.Read.decimal s of + Right (x,_) -> Just x + Left _ -> Nothing checkOnOff :: NameSpaces -> Element -> QName -> Maybe Bool checkOnOff ns rPr tag @@ -243,7 +250,7 @@ elemToCharStyle :: NameSpaces -> Element -> Maybe CharStyle -> Maybe CharStyle elemToCharStyle ns element parentStyle - = CharStyle <$> (CharStyleId <$> findAttrTextByName ns "w" "styleId" element) + = CharStyle <$> (CharStyleId <$> findAttrByName ns "w" "styleId" element) <*> getElementStyleName ns element <*> Just (elemToRunStyle ns element parentStyle) @@ -277,7 +284,7 @@ getHeaderLevel :: NameSpaces -> Element -> Maybe (ParaStyleName, Int) getHeaderLevel ns element | Just styleName <- getElementStyleName ns element - , Just n <- stringToInteger . T.unpack =<< + , Just n <- stringToInteger =<< (T.stripPrefix "heading " . T.toLower $ fromStyleName styleName) , n > 0 = Just (styleName, fromInteger n) @@ -285,8 +292,8 @@ getElementStyleName :: Coercible T.Text a => NameSpaces -> Element -> Maybe a getElementStyleName ns el = coerce <$> - ((findChildByName ns "w" "name" el >>= findAttrTextByName ns "w" "val") - <|> findAttrTextByName ns "w" "styleId" el) + ((findChildByName ns "w" "name" el >>= findAttrByName ns "w" "val") + <|> findAttrByName ns "w" "styleId" el) getNumInfo :: NameSpaces -> Element -> Maybe (T.Text, T.Text) getNumInfo ns element = do @@ -294,15 +301,15 @@ findChildByName ns "w" "numPr" lvl = fromMaybe "0" (numPr >>= findChildByName ns "w" "ilvl" >>= - findAttrTextByName ns "w" "val") + findAttrByName ns "w" "val") numId <- numPr >>= findChildByName ns "w" "numId" >>= - findAttrTextByName ns "w" "val" + findAttrByName ns "w" "val" return (numId, lvl) elemToParStyleData :: NameSpaces -> Element -> Maybe ParStyle -> Maybe ParStyle elemToParStyleData ns element parentStyle - | Just styleId <- findAttrTextByName ns "w" "styleId" element + | Just styleId <- findAttrByName ns "w" "styleId" element , Just styleName <- getElementStyleName ns element = Just $ ParStyle { 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 @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Readers.Docx.StyleMaps Copyright : © 2014-2020 Jesse Rosenthal , @@ -18,51 +19,45 @@ , elemToNameSpaces , findChildByName , findChildrenByName - , findAttrText , findAttrByName - , findAttrTextByName ) where -import Data.Maybe (mapMaybe) import qualified Data.Text as T -import Text.XML.Light +import Data.Text (Text) +import Text.Pandoc.XML.Light +import qualified Data.Map as M -type NameSpaces = [(String, String)] +type NameSpaces = M.Map Text Text elemToNameSpaces :: Element -> NameSpaces -elemToNameSpaces = mapMaybe attrToNSPair . elAttribs - -attrToNSPair :: Attr -> Maybe (String, String) -attrToNSPair (Attr (QName s _ (Just "xmlns")) val) = Just (s, val) -attrToNSPair _ = Nothing +elemToNameSpaces = foldr (\(Attr qn val) -> + case qn of + QName s _ (Just "xmlns") -> M.insert s val + _ -> id) mempty . elAttribs -elemName :: NameSpaces -> String -> String -> QName +elemName :: NameSpaces -> Text -> Text -> QName elemName ns prefix name = - QName name (lookup prefix ns) (if null prefix then Nothing else Just prefix) + QName name (M.lookup prefix ns) + (if T.null prefix then Nothing else Just prefix) -isElem :: NameSpaces -> String -> String -> Element -> Bool +isElem :: NameSpaces -> Text -> Text -> Element -> Bool isElem ns prefix name element = - let ns' = ns ++ elemToNameSpaces element + let ns' = ns <> elemToNameSpaces element in qName (elName element) == name && - qURI (elName element) == lookup prefix ns' + qURI (elName element) == M.lookup prefix ns' -findChildByName :: NameSpaces -> String -> String -> Element -> Maybe Element +findChildByName :: NameSpaces -> Text -> Text -> Element -> Maybe Element findChildByName ns pref name el = - let ns' = ns ++ elemToNameSpaces el + let ns' = ns <> elemToNameSpaces el in findChild (elemName ns' pref name) el -findChildrenByName :: NameSpaces -> String -> String -> Element -> [Element] +findChildrenByName :: NameSpaces -> Text -> Text -> Element -> [Element] findChildrenByName ns pref name el = - let ns' = ns ++ elemToNameSpaces el + let ns' = ns <> elemToNameSpaces el in findChildren (elemName ns' pref name) el -findAttrText :: QName -> Element -> Maybe T.Text -findAttrText x = fmap T.pack . findAttr x - -findAttrByName :: NameSpaces -> String -> String -> Element -> Maybe String +findAttrByName :: NameSpaces -> Text -> Text -> Element -> Maybe Text findAttrByName ns pref name el = - let ns' = ns ++ elemToNameSpaces el + let ns' = ns <> elemToNameSpaces el in findAttr (elemName ns' pref name) el -findAttrTextByName :: NameSpaces -> String -> String -> Element -> Maybe T.Text -findAttrTextByName a b c = fmap T.pack . findAttrByName a b c 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 @@ -17,14 +17,14 @@ (readEPUB) where -import Codec.Archive.Zip (Archive (..), Entry, findEntryByPath, fromEntry, +import Codec.Archive.Zip (Archive (..), Entry(..), findEntryByPath, fromEntry, toArchiveOrFail) import Control.DeepSeq (NFData, deepseq) import Control.Monad (guard, liftM, liftM2, mplus) import Control.Monad.Except (throwError) import qualified Data.ByteString.Lazy as BL (ByteString) -import Data.List (isInfixOf) import qualified Data.Text as T +import Data.Text (Text) import qualified Data.Map as M (Map, elems, fromList, lookup) import Data.Maybe (mapMaybe) import qualified Data.Text.Lazy as TL @@ -40,12 +40,12 @@ import Text.Pandoc.MIME (MimeType) import Text.Pandoc.Options (ReaderOptions (..)) import Text.Pandoc.Readers.HTML (readHtml) -import Text.Pandoc.Shared (addMetaField, collapseFilePath, escapeURI) -import qualified Text.Pandoc.UTF8 as UTF8 (toStringLazy) +import Text.Pandoc.Shared (addMetaField, collapseFilePath, escapeURI, tshow) +import qualified Text.Pandoc.UTF8 as UTF8 (toTextLazy) import Text.Pandoc.Walk (query, walk) -import Text.XML.Light +import Text.Pandoc.XML.Light -type Items = M.Map String (FilePath, MimeType) +type Items = M.Map Text (FilePath, MimeType) readEPUB :: PandocMonad m => ReaderOptions -> BL.ByteString -> m Pandoc readEPUB opts bytes = case toArchiveOrFail bytes of @@ -125,26 +125,27 @@ imageMimes :: [MimeType] imageMimes = ["image/gif", "image/jpeg", "image/png"] -type CoverId = String +type CoverId = Text type CoverImage = FilePath -parseManifest :: (PandocMonad m) => Element -> Maybe CoverId -> m (Maybe CoverImage, Items) +parseManifest :: (PandocMonad m) + => Element -> Maybe CoverId -> m (Maybe CoverImage, Items) parseManifest content coverId = do manifest <- findElementE (dfName "manifest") content let items = findChildren (dfName "item") manifest r <- mapM parseItem items let cover = findAttr (emptyName "href") =<< filterChild findCover manifest - return (cover `mplus` coverId, M.fromList r) + return (T.unpack <$> (cover `mplus` coverId), M.fromList r) where - findCover e = maybe False (isInfixOf "cover-image") + findCover e = maybe False (T.isInfixOf "cover-image") (findAttr (emptyName "properties") e) || Just True == liftM2 (==) coverId (findAttr (emptyName "id") e) parseItem e = do uid <- findAttrE (emptyName "id") e href <- findAttrE (emptyName "href") e mime <- findAttrE (emptyName "media-type") e - return (uid, (href, T.pack mime)) + return (uid, (T.unpack href, mime)) parseSpine :: PandocMonad m => Items -> Element -> m [(FilePath, MimeType)] parseSpine is e = do @@ -172,25 +173,25 @@ -- http://www.idpf.org/epub/30/spec/epub30-publications.html#sec-metadata-elem parseMetaItem :: Element -> Meta -> Meta parseMetaItem e@(stripNamespace . elName -> field) meta = - addMetaField (renameMeta field) (B.str $ T.pack $ strContent e) meta + addMetaField (renameMeta field) (B.str $ strContent e) meta -renameMeta :: String -> T.Text +renameMeta :: Text -> Text renameMeta "creator" = "author" -renameMeta s = T.pack s +renameMeta s = s getManifest :: PandocMonad m => Archive -> m (String, Element) getManifest archive = do metaEntry <- findEntryByPathE ("META-INF" "container.xml") archive - docElem <- (parseXMLDocE . UTF8.toStringLazy . fromEntry) metaEntry + docElem <- parseXMLDocE metaEntry let namespaces = mapMaybe attrToNSPair (elAttribs docElem) ns <- mkE "xmlns not in namespaces" (lookup "xmlns" namespaces) as <- fmap (map attrToPair . elAttribs) (findElementE (QName "rootfile" (Just ns) Nothing) docElem) - manifestFile <- mkE "Root not found" (lookup "full-path" as) + manifestFile <- T.unpack <$> mkE "Root not found" (lookup "full-path" as) let rootdir = dropFileName manifestFile --mime <- lookup "media-type" as manifest <- findEntryByPathE manifestFile archive - (rootdir,) <$> (parseXMLDocE . UTF8.toStringLazy . fromEntry $ manifest) + (rootdir,) <$> parseXMLDocE manifest -- Fixup @@ -200,7 +201,8 @@ . walk (fixBlockIRs filename) . walk (fixInlineIRs filename) where - (root, T.unpack . escapeURI . T.pack -> filename) = splitFileName pathToFile + (root, T.unpack . escapeURI . T.pack -> filename) = + splitFileName pathToFile fixInlineIRs :: String -> Inline -> Inline fixInlineIRs s (Span as v) = @@ -213,7 +215,7 @@ Link (fixAttrs s as) is t fixInlineIRs _ v = v -prependHash :: [T.Text] -> Inline -> Inline +prependHash :: [Text] -> Inline -> Inline prependHash ps l@(Link attr is (url, tit)) | or [s `T.isPrefixOf` url | s <- ps] = Link attr is ("#" <> url, tit) @@ -230,16 +232,17 @@ fixBlockIRs _ b = b fixAttrs :: FilePath -> B.Attr -> B.Attr -fixAttrs s (ident, cs, kvs) = (addHash s ident, filter (not . T.null) cs, removeEPUBAttrs kvs) +fixAttrs s (ident, cs, kvs) = + (addHash s ident, filter (not . T.null) cs, removeEPUBAttrs kvs) -addHash :: String -> T.Text -> T.Text +addHash :: FilePath -> Text -> Text addHash _ "" = "" addHash s ident = T.pack (takeFileName s) <> "#" <> ident -removeEPUBAttrs :: [(T.Text, T.Text)] -> [(T.Text, T.Text)] +removeEPUBAttrs :: [(Text, Text)] -> [(Text, Text)] removeEPUBAttrs kvs = filter (not . isEPUBAttr) kvs -isEPUBAttr :: (T.Text, a) -> Bool +isEPUBAttr :: (Text, a) -> Bool isEPUBAttr (k, _) = "epub:" `T.isPrefixOf` k -- Library @@ -256,39 +259,44 @@ -- Utility -stripNamespace :: QName -> String +stripNamespace :: QName -> Text stripNamespace (QName v _ _) = v -attrToNSPair :: Attr -> Maybe (String, String) +attrToNSPair :: Attr -> Maybe (Text, Text) attrToNSPair (Attr (QName "xmlns" _ _) val) = Just ("xmlns", val) attrToNSPair _ = Nothing -attrToPair :: Attr -> (String, String) +attrToPair :: Attr -> (Text, Text) attrToPair (Attr (QName name _ _) val) = (name, val) -defaultNameSpace :: Maybe String +defaultNameSpace :: Maybe Text defaultNameSpace = Just "http://www.idpf.org/2007/opf" -dfName :: String -> QName +dfName :: Text -> QName dfName s = QName s defaultNameSpace Nothing -emptyName :: String -> QName +emptyName :: Text -> QName emptyName s = QName s Nothing Nothing -- Convert Maybe interface to Either -findAttrE :: PandocMonad m => QName -> Element -> m String +findAttrE :: PandocMonad m => QName -> Element -> m Text findAttrE q e = mkE "findAttr" $ findAttr q e findEntryByPathE :: PandocMonad m => FilePath -> Archive -> m Entry findEntryByPathE (normalise . unEscapeString -> path) a = - mkE ("No entry on path: " ++ path) $ findEntryByPath path a + mkE ("No entry on path: " <> T.pack path) $ findEntryByPath path a -parseXMLDocE :: PandocMonad m => String -> m Element -parseXMLDocE doc = mkE "Unable to parse XML doc" $ parseXMLDoc doc +parseXMLDocE :: PandocMonad m => Entry -> m Element +parseXMLDocE entry = + either (throwError . PandocXMLError fp) return $ parseXMLElement doc + where + doc = UTF8.toTextLazy . fromEntry $ entry + fp = T.pack $ eRelativePath entry findElementE :: PandocMonad m => QName -> Element -> m Element -findElementE e x = mkE ("Unable to find element: " ++ show e) $ findElement e x +findElementE e x = + mkE ("Unable to find element: " <> tshow e) $ findElement e x -mkE :: PandocMonad m => String -> Maybe a -> m a -mkE s = maybe (throwError . PandocParseError $ T.pack s) return +mkE :: PandocMonad m => Text -> Maybe a -> m a +mkE s = maybe (throwError . PandocParseError $ s) return 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 @@ -25,13 +25,13 @@ module Text.Pandoc.Readers.FB2 ( readFB2 ) where import Control.Monad.Except (throwError) import Control.Monad.State.Strict -import Data.ByteString.Lazy.Char8 ( pack ) import Data.ByteString.Base64.Lazy import Data.Functor import Data.List (intersperse) import qualified Data.Map as M import Data.Text (Text) import qualified Data.Text as T +import qualified Data.Text.Lazy as TL import Data.Default import Data.Maybe import Text.HTML.TagSoup.Entity (lookupEntity) @@ -41,7 +41,8 @@ import Text.Pandoc.Logging import Text.Pandoc.Options import Text.Pandoc.Shared (crFilter) -import Text.XML.Light +import Text.Pandoc.XML.Light +import qualified Text.Pandoc.UTF8 as UTF8 type FB2 m = StateT FB2State m @@ -64,10 +65,10 @@ readFB2 :: PandocMonad m => ReaderOptions -> Text -> m Pandoc readFB2 _ inp = - case parseXMLDoc $ crFilter inp of - Nothing -> throwError $ PandocParseError "Not an XML document" - Just e -> do - (bs, st) <- runStateT (parseRootElement e) def + case parseXMLElement $ TL.fromStrict $ crFilter inp of + Left msg -> throwError $ PandocXMLError "" msg + Right el -> do + (bs, st) <- runStateT (parseRootElement el) def let authors = if null $ fb2Authors st then id else setMeta "author" (map text $ reverse $ fb2Authors st) @@ -83,12 +84,12 @@ Just ('#', xs) -> xs _ -> t -convertEntity :: String -> Text -convertEntity e = maybe (T.toUpper $ T.pack e) T.pack $ lookupEntity e +convertEntity :: Text -> Text +convertEntity e = maybe (T.toUpper e) T.pack $ lookupEntity (T.unpack e) parseInline :: PandocMonad m => Content -> FB2 m Inlines parseInline (Elem e) = - case T.pack $ qName $ elName e of + case qName $ elName e of "strong" -> strong <$> parseStyleType e "emphasis" -> emph <$> parseStyleType e "style" -> parseNamedStyle e @@ -96,12 +97,12 @@ "strikethrough" -> strikeout <$> parseStyleType e "sub" -> subscript <$> parseStyleType e "sup" -> superscript <$> parseStyleType e - "code" -> pure $ code $ T.pack $ strContent e + "code" -> pure $ code $ strContent e "image" -> parseInlineImageElement e name -> do report $ IgnoredElement name pure mempty -parseInline (Text x) = pure $ text $ T.pack $ cdData x +parseInline (Text x) = pure $ text $ cdData x parseInline (CRef r) = pure $ str $ convertEntity r parseSubtitle :: PandocMonad m => Element -> FB2 m Blocks @@ -111,7 +112,7 @@ parseRootElement :: PandocMonad m => Element -> FB2 m Blocks parseRootElement e = - case T.pack $ qName $ elName e of + case qName $ elName e of "FictionBook" -> do -- Parse notes before parsing the rest of the content. case filterChild isNotesBody e of @@ -144,7 +145,7 @@ Just sectionId -> do content <- mconcat <$> mapM parseSectionChild (dropTitle $ elChildren e) oldNotes <- gets fb2Notes - modify $ \s -> s { fb2Notes = M.insert ("#" <> T.pack sectionId) content oldNotes } + modify $ \s -> s { fb2Notes = M.insert ("#" <> sectionId) content oldNotes } pure () where isTitle x = qName (elName x) == "title" @@ -156,7 +157,7 @@ -- | Parse a child of @\@ element. parseFictionBookChild :: PandocMonad m => Element -> FB2 m Blocks parseFictionBookChild e = - case T.pack $ qName $ elName e of + case qName $ elName e of "stylesheet" -> pure mempty -- stylesheet is ignored "description" -> mempty <$ mapM_ parseDescriptionChild (elChildren e) "body" -> if isNotesBody e @@ -168,7 +169,7 @@ -- | Parse a child of @\@ element. parseDescriptionChild :: PandocMonad m => Element -> FB2 m () parseDescriptionChild e = - case T.pack $ qName $ elName e of + case qName $ elName e of "title-info" -> mapM_ parseTitleInfoChild (elChildren e) "src-title-info" -> pure () -- ignore "document-info" -> pure () @@ -182,7 +183,7 @@ -- | Parse a child of @\@ element. parseBodyChild :: PandocMonad m => Element -> FB2 m Blocks parseBodyChild e = - case T.pack $ qName $ elName e of + case qName $ elName e of "image" -> parseImageElement e "title" -> header <$> gets fb2SectionLevel <*> parseTitleType (elContent e) "epigraph" -> parseEpigraph e @@ -196,7 +197,10 @@ (Nothing, _) -> report $ IgnoredElement "binary without id attribute" (Just _, Nothing) -> report $ IgnoredElement "binary without content-type attribute" - (Just filename, contentType) -> insertMedia filename (T.pack <$> contentType) (decodeLenient (pack (strContent e))) + (Just filename, contentType) -> + insertMedia (T.unpack filename) contentType + (decodeLenient + (UTF8.fromTextLazy . TL.fromStrict . strContent $ e)) -- * Type parsers @@ -206,13 +210,13 @@ parseAuthorChild :: PandocMonad m => Element -> FB2 m (Maybe Text) parseAuthorChild e = - case T.pack $ qName $ elName e of - "first-name" -> pure $ Just $ T.pack $ strContent e - "middle-name" -> pure $ Just $ T.pack $ strContent e - "last-name" -> pure $ Just $ T.pack $ strContent e - "nickname" -> pure $ Just $ T.pack $ strContent e - "home-page" -> pure $ Just $ T.pack $ strContent e - "email" -> pure $ Just $ T.pack $ strContent e + case qName $ elName e of + "first-name" -> pure $ Just $ strContent e + "middle-name" -> pure $ Just $ strContent e + "last-name" -> pure $ Just $ strContent e + "nickname" -> pure $ Just $ strContent e + "home-page" -> pure $ Just $ strContent e + "email" -> pure $ Just $ strContent e name -> do report $ IgnoredElement $ name <> " in author" pure Nothing @@ -236,13 +240,13 @@ parseImageElement :: PandocMonad m => Element -> FB2 m Blocks parseImageElement e = case href of - Just src -> pure $ para $ imageWith (imgId, [], []) (removeHash $ T.pack src) title alt + Just src -> pure $ para $ imageWith (imgId, [], []) (removeHash src) title alt Nothing -> do report $ IgnoredElement " image without href" pure mempty - where alt = maybe mempty (str . T.pack) $ findAttr (unqual "alt") e - title = maybe "" T.pack $ findAttr (unqual "title") e - imgId = maybe "" T.pack $ findAttr (unqual "id") e + where alt = maybe mempty str $ findAttr (unqual "alt") e + title = fromMaybe "" $ findAttr (unqual "title") e + imgId = fromMaybe "" $ findAttr (unqual "id") e href = findAttr (QName "href" (Just "http://www.w3.org/1999/xlink") Nothing) e -- | Parse @pType@ @@ -256,7 +260,7 @@ -- | Parse @citeType@ child parseCiteChild :: PandocMonad m => Element -> FB2 m Blocks parseCiteChild e = - case T.pack $ qName $ elName e of + case qName $ elName e of "p" -> para <$> parsePType e "poem" -> parsePoem e "empty-line" -> pure horizontalRule @@ -271,13 +275,13 @@ parsePoemChild :: PandocMonad m => Element -> FB2 m Blocks parsePoemChild e = - case T.pack $ qName $ elName e of + case qName $ elName e of "title" -> parseTitle e "subtitle" -> parseSubtitle e "epigraph" -> parseEpigraph e "stanza" -> parseStanza e "text-author" -> para <$> parsePType e - "date" -> pure $ para $ text $ T.pack $ strContent e + "date" -> pure $ para $ text $ strContent e name -> report (UnexpectedXmlElement name "poem") $> mempty parseStanza :: PandocMonad m => Element -> FB2 m Blocks @@ -290,7 +294,7 @@ parseStanzaChild :: PandocMonad m => Element -> FB2 m Blocks parseStanzaChild e = - case T.pack $ qName $ elName e of + case qName $ elName e of "title" -> parseTitle e "subtitle" -> parseSubtitle e "v" -> lineBlock . (:[]) <$> parsePType e @@ -300,11 +304,11 @@ parseEpigraph :: PandocMonad m => Element -> FB2 m Blocks parseEpigraph e = divWith (divId, ["epigraph"], []) . mconcat <$> mapM parseEpigraphChild (elChildren e) - where divId = maybe "" T.pack $ findAttr (unqual "id") e + where divId = fromMaybe "" $ findAttr (unqual "id") e parseEpigraphChild :: PandocMonad m => Element -> FB2 m Blocks parseEpigraphChild e = - case T.pack $ qName $ elName e of + case qName $ elName e of "p" -> para <$> parsePType e "poem" -> parsePoem e "cite" -> parseCite e @@ -318,7 +322,7 @@ parseAnnotationChild :: PandocMonad m => Element -> FB2 m Blocks parseAnnotationChild e = - case T.pack $ qName $ elName e of + case qName $ elName e of "p" -> para <$> parsePType e "poem" -> parsePoem e "cite" -> parseCite e @@ -332,14 +336,14 @@ parseSection e = do n <- gets fb2SectionLevel modify $ \st -> st{ fb2SectionLevel = n + 1 } - let sectionId = maybe "" T.pack $ findAttr (unqual "id") e + let sectionId = fromMaybe "" $ findAttr (unqual "id") e bs <- divWith (sectionId, ["section"], []) . mconcat <$> mapM parseSectionChild (elChildren e) modify $ \st -> st{ fb2SectionLevel = n } pure bs parseSectionChild :: PandocMonad m => Element -> FB2 m Blocks parseSectionChild e = - case T.pack $ qName $ elName e of + case qName $ elName e of "title" -> parseBodyChild e "epigraph" -> parseEpigraph e "image" -> parseImageElement e @@ -361,16 +365,16 @@ parseNamedStyle :: PandocMonad m => Element -> FB2 m Inlines parseNamedStyle e = do content <- mconcat <$> mapM parseNamedStyleChild (elContent e) - let lang = maybeToList $ ("lang",) . T.pack <$> findAttr (QName "lang" Nothing (Just "xml")) e + let lang = maybeToList $ ("lang",) <$> findAttr (QName "lang" Nothing (Just "xml")) e case findAttr (unqual "name") e of - Just name -> pure $ spanWith ("", [T.pack name], lang) content + Just name -> pure $ spanWith ("", [name], lang) content Nothing -> do report $ IgnoredElement "link without required name" pure mempty parseNamedStyleChild :: PandocMonad m => Content -> FB2 m Inlines parseNamedStyleChild (Elem e) = - case T.pack $ qName (elName e) of + case qName (elName e) of "strong" -> strong <$> parseStyleType e "emphasis" -> emph <$> parseStyleType e "style" -> parseNamedStyle e @@ -378,7 +382,7 @@ "strikethrough" -> strikeout <$> parseStyleType e "sub" -> subscript <$> parseStyleType e "sup" -> superscript <$> parseStyleType e - "code" -> pure $ code $ T.pack $ strContent e + "code" -> pure $ code $ strContent e "image" -> parseInlineImageElement e name -> do report $ IgnoredElement $ name <> " in style" @@ -390,7 +394,7 @@ parseLinkType e = do content <- mconcat <$> mapM parseStyleLinkType (elContent e) notes <- gets fb2Notes - case T.pack <$> findAttr (QName "href" (Just "http://www.w3.org/1999/xlink") Nothing) e of + case findAttr (QName "href" (Just "http://www.w3.org/1999/xlink") Nothing) e of Just href -> case findAttr (QName "type" Nothing Nothing) e of Just "note" -> case M.lookup href notes of Nothing -> pure $ link href "" content @@ -417,15 +421,14 @@ -- | Parse @title-infoType@ parseTitleInfoChild :: PandocMonad m => Element -> FB2 m () parseTitleInfoChild e = - case T.pack $ qName (elName e) of + case qName (elName e) of "genre" -> pure () "author" -> parseAuthor e >>= \author -> modify (\st -> st {fb2Authors = author:fb2Authors st}) - "book-title" -> modify (setMeta "title" (text $ T.pack $ strContent e)) + "book-title" -> modify (setMeta "title" (text $ strContent e)) "annotation" -> parseAnnotation e >>= modify . setMeta "abstract" "keywords" -> modify (setMeta "keywords" (map (MetaString . trim) $ T.splitOn "," - $ T.pack $ strContent e)) - "date" -> modify (setMeta "date" (text $ T.pack $ strContent e)) + "date" -> modify (setMeta "date" (text $ strContent e)) "coverpage" -> parseCoverPage e "lang" -> pure () "src-lang" -> pure () @@ -439,7 +442,7 @@ Just img -> case href of Just src -> modify (setMeta "cover-image" (MetaString $ removeHash src)) Nothing -> pure () - where href = T.pack <$> findAttr (QName "href" (Just "http://www.w3.org/1999/xlink") Nothing) img + where href = findAttr (QName "href" (Just "http://www.w3.org/1999/xlink") Nothing) img Nothing -> pure () -- | Parse @inlineImageType@ element @@ -452,5 +455,5 @@ Nothing -> do report $ IgnoredElement "inline image without href" pure mempty - where alt = maybe mempty (str . T.pack) $ findAttr (unqual "alt") e - href = T.pack <$> findAttr (QName "href" (Just "http://www.w3.org/1999/xlink") Nothing) e + where alt = maybe mempty str $ findAttr (unqual "alt") e + href = findAttr (QName "href" (Just "http://www.w3.org/1999/xlink") Nothing) 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 @@ -19,14 +19,13 @@ , htmlInBalanced , isInlineTag , isBlockTag - , NamedTag(..) , isTextTag , isCommentTag ) where import Control.Applicative ((<|>)) import Control.Monad (guard, msum, mzero, unless, void) -import Control.Monad.Except (throwError) +import Control.Monad.Except (throwError, catchError) import Control.Monad.Reader (ask, asks, lift, local, runReaderT) import Data.ByteString.Base64 (encode) import Data.Char (isAlphaNum, isLetter) @@ -158,32 +157,64 @@ return mempty block :: PandocMonad m => TagParser m Blocks -block = do - res <- choice - [ eSection - , eSwitch B.para block - , mempty <$ eFootnote - , mempty <$ eTOC - , mempty <$ eTitlePage - , pPara - , pHeader - , pBlockQuote - , pCodeBlock - , pList - , pHrule - , pTable block - , pHtml - , pHead - , pBody - , pLineBlock - , pDiv - , pPlain - , pFigure - , pIframe - , pRawHtmlBlock - ] - trace (T.take 60 $ tshow $ B.toList res) - return res +block = ((do + tag <- lookAhead (pSatisfy isBlockTag) + exts <- getOption readerExtensions + case tag of + TagOpen name attr -> + let type' = fromMaybe "" $ + lookup "type" attr <|> lookup "epub:type" attr + epubExts = extensionEnabled Ext_epub_html_exts exts + in + case name of + _ | name `elem` sectioningContent + , epubExts + , "chapter" `T.isInfixOf` type' + -> eSection + _ | epubExts + , type' `elem` ["footnote", "rearnote"] + -> mempty <$ eFootnote + _ | epubExts + , type' == "toc" + -> mempty <$ eTOC + _ | "titlepage" `T.isInfixOf` type' + , name `elem` ("section" : groupingContent) + -> mempty <$ eTitlePage + "p" -> pPara + "h1" -> pHeader + "h2" -> pHeader + "h3" -> pHeader + "h4" -> pHeader + "h5" -> pHeader + "h6" -> pHeader + "blockquote" -> pBlockQuote + "pre" -> pCodeBlock + "ul" -> pBulletList + "ol" -> pOrderedList + "dl" -> pDefinitionList + "table" -> pTable block + "hr" -> pHrule + "html" -> pHtml + "head" -> pHead + "body" -> pBody + "div" + | extensionEnabled Ext_line_blocks exts + , Just "line-block" <- lookup "class" attr + -> pLineBlock + | otherwise + -> pDiv + "section" -> pDiv + "main" -> pDiv + "figure" -> pFigure + "iframe" -> pIframe + "style" -> pRawHtmlBlock + "textarea" -> pRawHtmlBlock + "switch" + | epubExts + -> eSwitch B.para block + _ -> mzero + _ -> mzero) <|> pPlain <|> pRawHtmlBlock) >>= \res -> + res <$ trace (T.take 60 $ tshow $ B.toList res) namespaces :: PandocMonad m => [(Text, TagParser m Inlines)] namespaces = [(mathMLNamespace, pMath True)] @@ -256,9 +287,6 @@ guard $ (lookup "type" attr <|> lookup "epub:type" attr) == Just "toc" void (pInTags tag block) -pList :: PandocMonad m => TagParser m Blocks -pList = pBulletList <|> pOrderedList <|> pDefinitionList - pBulletList :: PandocMonad m => TagParser m Blocks pBulletList = try $ do pSatisfy (matchTagOpen "ul" []) @@ -369,13 +397,15 @@ B.toList ils return $ B.lineBlock lns +isDivLike :: Text -> Bool +isDivLike "div" = True +isDivLike "section" = True +isDivLike "main" = True +isDivLike _ = False + pDiv :: PandocMonad m => TagParser m Blocks pDiv = try $ do guardEnabled Ext_native_divs - let isDivLike "div" = True - isDivLike "section" = True - isDivLike "main" = True - isDivLike _ = False TagOpen tag attr' <- lookAhead $ pSatisfy $ tagOpen isDivLike (const True) let (ident, classes, kvs) = toAttr attr' contents <- pInTags tag block @@ -393,11 +423,17 @@ tag <- pSatisfy (tagOpen (=="iframe") (isJust . lookup "src")) pCloses "iframe" <|> eof url <- canonicalizeUrl $ fromAttrib "src" tag - (bs, _) <- openURL url - let inp = UTF8.toText bs - opts <- readerOpts <$> getState - Pandoc _ contents <- readHtml opts inp - return $ B.divWith ("",["iframe"],[]) $ B.fromList contents + if T.null url + then ignore $ renderTags' [tag, TagClose "iframe"] + else catchError + (do (bs, _) <- openURL url + let inp = UTF8.toText bs + opts <- readerOpts <$> getState + Pandoc _ contents <- readHtml opts inp + return $ B.divWith ("",["iframe"],[]) $ B.fromList contents) + (\e -> do + logMessage $ CouldNotFetchResource url (renderError e) + ignore $ renderTags' [tag, TagClose "iframe"]) pRawHtmlBlock :: PandocMonad m => TagParser m Blocks pRawHtmlBlock = do @@ -538,31 +574,47 @@ tagToText _ = "" inline :: PandocMonad m => TagParser m Inlines -inline = choice - [ eNoteref - , eSwitch id inline - , pTagText - , pQ - , pEmph - , pStrong - , pSuperscript - , pSubscript - , pSpanLike - , pSmall - , pStrikeout - , pUnderline - , pLineBreak - , pLink - , pImage - , pSvg - , pBdo - , pCode - , pCodeWithClass [("samp","sample"),("var","variable")] - , pSpan - , pMath False - , pScriptMath - , pRawHtmlInline - ] +inline = pTagText <|> do + tag <- lookAhead (pSatisfy isInlineTag) + exts <- getOption readerExtensions + case tag of + TagOpen name attr -> + case name of + "a" | extensionEnabled Ext_epub_html_exts exts + , Just "noteref" <- lookup "type" attr <|> lookup "epub:type" attr + , Just ('#',_) <- lookup "href" attr >>= T.uncons + -> eNoteref + | otherwise -> pLink + "switch" -> eSwitch id inline + "q" -> pQ + "em" -> pEmph + "i" -> pEmph + "strong" -> pStrong + "b" -> pStrong + "sup" -> pSuperscript + "sub" -> pSubscript + "small" -> pSmall + "s" -> pStrikeout + "strike" -> pStrikeout + "del" -> pStrikeout + "u" -> pUnderline + "ins" -> pUnderline + "br" -> pLineBreak + "img" -> pImage + "svg" -> pSvg + "bdo" -> pBdo + "code" -> pCode + "samp" -> pCodeWithClass "samp" "sample" + "var" -> pCodeWithClass "var" "variable" + "span" -> pSpan + "math" -> pMath False + "script" + | Just x <- lookup "type" attr + , "math/tex" `T.isPrefixOf` x -> pScriptMath + _ | name `elem` htmlSpanLikeElements -> pSpanLike + _ -> pRawHtmlInline + TagText _ -> pTagText + _ -> pRawHtmlInline pSelfClosing :: PandocMonad m => (Text -> Bool) -> ([Attribute Text] -> Bool) @@ -573,27 +625,25 @@ return open pQ :: PandocMonad m => TagParser m Inlines -pQ = choice $ map try [citedQuote, normalQuote] - where citedQuote = do - tag <- pSatisfy $ tagOpenLit "q" (any ((=="cite") . fst)) - - url <- canonicalizeUrl $ fromAttrib "cite" tag - let uid = fromMaybe (fromAttrib "name" tag) $ - maybeFromAttrib "id" tag - let cls = T.words $ fromAttrib "class" tag - - makeQuote $ B.spanWith (uid, cls, [("cite", escapeURI url)]) - normalQuote = do - pSatisfy $ tagOpenLit "q" (const True) - makeQuote id - makeQuote wrapper = do - ctx <- asks quoteContext - let (constructor, innerContext) = case ctx of - InDoubleQuote -> (B.singleQuoted, InSingleQuote) - _ -> (B.doubleQuoted, InDoubleQuote) - - content <- withQuoteContext innerContext (mconcat <$> manyTill inline (pCloses "q")) - return $ extractSpaces (constructor . wrapper) content +pQ = do + TagOpen _ attrs <- pSatisfy $ tagOpenLit "q" (const True) + case lookup "cite" attrs of + Just url -> do + let uid = fromMaybe mempty $ + lookup "name" attrs <> lookup "id" attrs + let cls = maybe [] T.words $ lookup "class" attrs + url' <- canonicalizeUrl url + makeQuote $ B.spanWith (uid, cls, [("cite", escapeURI url')]) + Nothing -> makeQuote id + where + makeQuote wrapper = do + ctx <- asks quoteContext + let (constructor, innerContext) = case ctx of + InDoubleQuote -> (B.singleQuoted, InSingleQuote) + _ -> (B.doubleQuoted, InDoubleQuote) + content <- withQuoteContext innerContext + (mconcat <$> manyTill inline (pCloses "q")) + return $ extractSpaces (constructor . wrapper) content pEmph :: PandocMonad m => TagParser m Inlines pEmph = pInlinesInTags "em" B.emph <|> pInlinesInTags "i" B.emph @@ -684,13 +734,12 @@ UTF8.toText (encode $ UTF8.fromText rawText) return $ B.imageWith (ident,cls,[]) svgData mempty mempty -pCodeWithClass :: PandocMonad m => [(T.Text,Text)] -> TagParser m Inlines -pCodeWithClass elemToClass = try $ do - let tagTest = flip elem . fmap fst $ elemToClass - TagOpen open attr' <- pSatisfy $ tagOpen tagTest (const True) +pCodeWithClass :: PandocMonad m => Text -> Text -> TagParser m Inlines +pCodeWithClass name class' = try $ do + TagOpen open attr' <- pSatisfy $ tagOpen (== name) (const True) result <- manyTill pAny (pCloses open) let (ids,cs,kvs) = toAttr attr' - cs' = maybe cs (:cs) . lookup open $ elemToClass + cs' = class' : cs return . B.codeWith (ids,cs',kvs) . T.unwords . T.lines . innerText $ result @@ -881,27 +930,21 @@ then return B.softbreak else return B.space -class NamedTag a where - getTagName :: a -> Maybe Text - -instance NamedTag (Tag Text) where - getTagName (TagOpen t _) = Just t - getTagName (TagClose t) = Just t - getTagName _ = Nothing - -instance NamedTag (Tag String) where - getTagName (TagOpen t _) = Just (T.pack t) - getTagName (TagClose t) = Just (T.pack t) - getTagName _ = Nothing +getTagName :: Tag Text -> Maybe Text +getTagName (TagOpen t _) = Just t +getTagName (TagClose t) = Just t +getTagName _ = Nothing -isInlineTag :: NamedTag (Tag a) => Tag a -> Bool +isInlineTag :: Tag Text -> Bool isInlineTag t = - isCommentTag t || case getTagName t of - Nothing -> False - Just x -> x `Set.notMember` blockTags || - T.take 1 x == "?" -- processing instr. + isCommentTag t || + case getTagName t of + Nothing -> False + Just "script" -> "math/tex" `T.isPrefixOf` fromAttrib "type" t + Just x -> x `Set.notMember` blockTags || + T.take 1 x == "?" -- processing instr. -isBlockTag :: NamedTag (Tag a) => Tag a -> Bool +isBlockTag :: Tag Text -> Bool isBlockTag t = isBlockTagName || isTagComment t where isBlockTagName = case getTagName t of @@ -912,10 +955,10 @@ || x `Set.member` eitherBlockOrInline Nothing -> False -isTextTag :: Tag a -> Bool +isTextTag :: Tag Text -> Bool isTextTag = tagText (const True) -isCommentTag :: Tag a -> Bool +isCommentTag :: Tag Text -> Bool isCommentTag = tagComment (const True) --- parsers for use in markdown, textile readers @@ -964,7 +1007,7 @@ go n (t:ts') = (t :) <$> go n ts' go _ [] = mzero -hasTagWarning :: [Tag a] -> Bool +hasTagWarning :: [Tag Text] -> Bool hasTagWarning (TagWarning _:_) = True hasTagWarning _ = False 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,9 @@ module Text.Pandoc.Readers.JATS ( readJATS ) where import Control.Monad.State.Strict -import Data.Char (isDigit, isSpace, toUpper) +import Control.Monad.Except (throwError) +import Text.Pandoc.Error (PandocError(..)) +import Data.Char (isDigit, isSpace) import Data.Default import Data.Generics import Data.List (foldl', intersperse) @@ -22,13 +24,14 @@ import Data.Maybe (maybeToList, fromMaybe) 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.Builder import Text.Pandoc.Class.PandocMonad (PandocMonad) import Text.Pandoc.Options import Text.Pandoc.Shared (crFilter, safeRead, extractSpaces) import Text.TeXMath (readMathML, writeTeX) -import Text.XML.Light +import Text.Pandoc.XML.Light import qualified Data.Set as S (fromList, member) import Data.Set ((\\)) @@ -51,40 +54,22 @@ readJATS :: PandocMonad m => ReaderOptions -> Text -> m Pandoc readJATS _ inp = do - let tree = normalizeTree . parseXML - $ T.unpack $ crFilter inp + tree <- either (throwError . PandocXMLError "") return $ + parseXMLContents (TL.fromStrict $ crFilter inp) (bs, st') <- flip runStateT (def{ jatsContent = tree }) $ mapM parseBlock tree return $ Pandoc (jatsMeta st') (toList . mconcat $ bs) --- normalize input, consolidating adjacent Text and CRef elements -normalizeTree :: [Content] -> [Content] -normalizeTree = everywhere (mkT go) - where go :: [Content] -> [Content] - go (Text (CData CDataRaw _ _):xs) = xs - go (Text (CData CDataText s1 z):Text (CData CDataText s2 _):xs) = - Text (CData CDataText (s1 ++ s2) z):xs - go (Text (CData CDataText s1 z):CRef r:xs) = - Text (CData CDataText (s1 ++ convertEntity r) z):xs - go (CRef r:Text (CData CDataText s1 z):xs) = - Text (CData CDataText (convertEntity r ++ s1) z):xs - go (CRef r1:CRef r2:xs) = - Text (CData CDataText (convertEntity r1 ++ convertEntity r2) Nothing):xs - go xs = xs - -convertEntity :: String -> String -convertEntity e = Data.Maybe.fromMaybe (map toUpper e) (lookupEntity e) - -- convenience function to get an attribute value, defaulting to "" -attrValue :: String -> Element -> Text +attrValue :: Text -> Element -> Text attrValue attr = fromMaybe "" . maybeAttrValue attr -maybeAttrValue :: String -> Element -> Maybe Text +maybeAttrValue :: Text -> Element -> Maybe Text maybeAttrValue attr elt = - T.pack <$> lookupAttrBy (\x -> qName x == attr) (elAttribs elt) + lookupAttrBy (\x -> qName x == attr) (elAttribs elt) -- convenience function -named :: String -> Element -> Bool +named :: Text -> Element -> Bool named s e = qName (elName e) == s -- @@ -150,10 +135,10 @@ parseBlock :: PandocMonad m => Content -> JATS m Blocks parseBlock (Text (CData CDataRaw _ _)) = return mempty -- DOCTYPE -parseBlock (Text (CData _ s _)) = if all isSpace s +parseBlock (Text (CData _ s _)) = if T.all isSpace s then return mempty - else return $ plain $ trimInlines $ text $ T.pack s -parseBlock (CRef x) = return $ plain $ str $ T.toUpper $ T.pack x + else return $ plain $ trimInlines $ text s +parseBlock (CRef x) = return $ plain $ str $ T.toUpper x parseBlock (Elem e) = case qName (elName e) of "p" -> parseMixed para (elContent e) @@ -202,7 +187,7 @@ "" -> [] x -> [x] return $ codeBlockWith (attrValue "id" e, classes', []) - $ trimNl $ textContentRecursive e + $ trimNl $ strContentRecursive e parseBlockquote = do attrib <- case filterChild (named "attribution") e of Nothing -> return mempty @@ -266,7 +251,7 @@ Just "center" -> AlignCenter _ -> AlignDefault let toWidth c = do - w <- findAttrText (unqual "colwidth") c + w <- findAttr (unqual "colwidth") c n <- safeRead $ "0" <> T.filter (\x -> isDigit x || x == '.') w if n > 0 then Just n else Nothing let numrows = foldl' max 0 $ map length bodyrows @@ -437,16 +422,10 @@ Nothing -> return $ Map.insert "id" (toMetaValue refId) mempty -- TODO handle mixed-citation -findAttrText :: QName -> Element -> Maybe Text -findAttrText x = fmap T.pack . findAttr x - textContent :: Element -> Text -textContent = T.pack . strContent - -textContentRecursive :: Element -> Text -textContentRecursive = T.pack . strContentRecursive +textContent = strContent -strContentRecursive :: Element -> String +strContentRecursive :: Element -> Text strContentRecursive = strContent . (\e' -> e'{ elContent = map elementToStr $ elContent e' }) @@ -455,9 +434,9 @@ elementToStr x = x parseInline :: PandocMonad m => Content -> JATS m Inlines -parseInline (Text (CData _ s _)) = return $ text $ T.pack s -parseInline (CRef ref) = - return . text . maybe (T.toUpper $ T.pack ref) T.pack $ lookupEntity ref +parseInline (Text (CData _ s _)) = return $ text s +parseInline (CRef ref) = return $ maybe (text $ T.toUpper ref) (text . T.pack) + $ lookupEntity (T.unpack ref) parseInline (Elem e) = case qName (elName e) of "italic" -> innerInlines emph @@ -502,9 +481,9 @@ else linkWith attr ("#" <> rid) "" ils "ext-link" -> do ils <- innerInlines id - let title = fromMaybe "" $ findAttrText (QName "title" (Just "http://www.w3.org/1999/xlink") Nothing) e + let title = fromMaybe "" $ findAttr (QName "title" (Just "http://www.w3.org/1999/xlink") Nothing) e let href = case findAttr (QName "href" (Just "http://www.w3.org/1999/xlink") Nothing) e of - Just h -> T.pack h + Just h -> h _ -> "#" <> attrValue "rid" e let ils' = if ils == mempty then str href else ils let attr = (attrValue "id" e, [], []) @@ -524,7 +503,7 @@ where innerInlines f = extractSpaces f . mconcat <$> mapM parseInline (elContent e) mathML x = - case readMathML . T.pack . showElement $ everywhere (mkT removePrefix) x of + case readMathML . showElement $ everywhere (mkT removePrefix) x of Left _ -> mempty Right m -> writeTeX m formula constructor = do @@ -542,4 +521,4 @@ let classes' = case attrValue "language" e of "" -> [] l -> [l] - return $ codeWith (attrValue "id" e,classes',[]) $ textContentRecursive e + return $ codeWith (attrValue "id" e,classes',[]) $ strContentRecursive e 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 @@ -1,2434 +1,1263 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE ViewPatterns #-} -{- | - Module : Text.Pandoc.Readers.LaTeX - Copyright : Copyright (C) 2006-2021 John MacFarlane - License : GNU GPL, version 2 or above - - Maintainer : John MacFarlane - Stability : alpha - Portability : portable - -Conversion of LaTeX to 'Pandoc' document. - --} -module Text.Pandoc.Readers.LaTeX ( readLaTeX, - applyMacros, - rawLaTeXInline, - rawLaTeXBlock, - inlineCommand, - tokenize, - untokenize - ) where - -import Control.Applicative (many, optional, (<|>)) -import Control.Monad -import Control.Monad.Except (throwError) -import Data.Char (isDigit, isLetter, toUpper, chr) -import Data.Default -import Data.Functor (($>)) -import Data.List (intercalate) -import qualified Data.Map as M -import Data.Maybe (fromMaybe, maybeToList) -import qualified Data.Set as Set -import qualified Data.Sequence as Seq -import Data.Text (Text) -import qualified Data.Text as T -import System.FilePath (addExtension, replaceExtension, takeExtension) -import Text.Pandoc.BCP47 (Lang (..), renderLang) -import Text.Pandoc.Builder -import Text.Pandoc.Class.PandocPure (PandocPure) -import Text.Pandoc.Class.PandocMonad (PandocMonad (..), getResourcePath, - readFileFromDirs, report, setResourcePath, - setTranslations, translateTerm) -import Text.Pandoc.Error (PandocError (PandocParseError, PandocParsecError)) -import Text.Pandoc.Highlighting (fromListingsLanguage, 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 (ExpansionPoint (..), Macro (..), - ArgSpec (..), Tok (..), TokType (..)) -import Text.Pandoc.Readers.LaTeX.Parsing -import Text.Pandoc.Readers.LaTeX.Lang (polyglossiaLangToBCP47, - babelLangToBCP47) -import Text.Pandoc.Readers.LaTeX.SIunitx -import Text.Pandoc.Shared -import qualified Text.Pandoc.Translations as Translations -import Text.Pandoc.Walk -import qualified Text.Pandoc.Builder as B -import qualified Data.Text.Normalize as Normalize -import Safe - --- for debugging: --- import Text.Pandoc.Extensions (getDefaultExtensions) --- import Text.Pandoc.Class.PandocIO (runIOorExplode, PandocIO) --- import Debug.Trace (traceShowId) - --- | Parse LaTeX from string and return 'Pandoc' document. -readLaTeX :: PandocMonad m - => ReaderOptions -- ^ Reader options - -> Text -- ^ String to parse (assumes @'\n'@ line endings) - -> m Pandoc -readLaTeX opts ltx = do - parsed <- runParserT parseLaTeX def{ sOptions = opts } "source" - (tokenize "source" (crFilter ltx)) - case parsed of - Right result -> return result - Left e -> throwError $ PandocParsecError ltx e - -parseLaTeX :: PandocMonad m => LP m Pandoc -parseLaTeX = do - bs <- blocks - eof - st <- getState - let meta = sMeta st - let doc' = doc bs - let headerLevel (Header n _ _) = [n] - headerLevel _ = [] -#if MIN_VERSION_safe(0,3,18) - let bottomLevel = minimumBound 1 $ query headerLevel doc' -#else - let bottomLevel = minimumDef 1 $ query headerLevel doc' -#endif - let adjustHeaders m (Header n attr ils) = Header (n+m) attr ils - adjustHeaders _ x = x - let (Pandoc _ bs') = - -- handle the case where you have \part or \chapter - (if bottomLevel < 1 - then walk (adjustHeaders (1 - bottomLevel)) - else id) $ - walk (resolveRefs (sLabels st)) doc' - return $ Pandoc meta bs' - -resolveRefs :: M.Map Text [Inline] -> Inline -> Inline -resolveRefs labels x@(Link (ident,classes,kvs) _ _) = - case (lookup "reference-type" kvs, - lookup "reference" kvs) of - (Just "ref", Just lab) -> - case M.lookup lab labels of - Just txt -> Link (ident,classes,kvs) txt ("#" <> lab, "") - Nothing -> x - _ -> x -resolveRefs _ x = x - - --- testParser :: LP PandocIO a -> Text -> IO a --- testParser p t = do --- res <- runIOorExplode (runParserT p defaultLaTeXState{ --- sOptions = def{ readerExtensions = --- enableExtension Ext_raw_tex $ --- getDefaultExtensions "latex" }} "source" (tokenize "source" t)) --- case res of --- Left e -> error (show e) --- Right r -> return r - - -rawLaTeXBlock :: (PandocMonad m, HasMacros s, HasReaderOptions s) - => ParserT Text s m Text -rawLaTeXBlock = do - lookAhead (try (char '\\' >> letter)) - inp <- getInput - let toks = tokenize "source" inp - snd <$> (rawLaTeXParser toks False (macroDef (const mempty)) blocks - <|> rawLaTeXParser toks True - (do choice (map controlSeq - ["include", "input", "subfile", "usepackage"]) - skipMany opt - braced - return mempty) blocks - <|> rawLaTeXParser toks True - (environment <|> blockCommand) - (mconcat <$> many (block <|> beginOrEndCommand))) - --- See #4667 for motivation; sometimes people write macros --- that just evaluate to a begin or end command, which blockCommand --- won't accept. -beginOrEndCommand :: PandocMonad m => LP m Blocks -beginOrEndCommand = try $ do - Tok _ (CtrlSeq name) txt <- anyControlSeq - guard $ name == "begin" || name == "end" - (envname, rawargs) <- withRaw braced - if M.member (untokenize envname) - (inlineEnvironments :: M.Map Text (LP PandocPure Inlines)) - then mzero - else return $ rawBlock "latex" - (txt <> untokenize rawargs) - -rawLaTeXInline :: (PandocMonad m, HasMacros s, HasReaderOptions s) - => ParserT Text s m Text -rawLaTeXInline = do - lookAhead (try (char '\\' >> letter)) - inp <- getInput - let toks = tokenize "source" inp - raw <- snd <$> - ( rawLaTeXParser toks True - (mempty <$ (controlSeq "input" >> skipMany opt >> braced)) - inlines - <|> rawLaTeXParser toks True (inlineEnvironment <|> inlineCommand') - inlines - ) - finalbraces <- mconcat <$> many (try (string "{}")) -- see #5439 - return $ raw <> T.pack finalbraces - -inlineCommand :: PandocMonad m => ParserT Text ParserState m Inlines -inlineCommand = do - lookAhead (try (char '\\' >> letter)) - inp <- getInput - let toks = tokenize "source" inp - fst <$> rawLaTeXParser toks True (inlineEnvironment <|> inlineCommand') - inlines - --- inline elements: - -word :: PandocMonad m => LP m Inlines -word = str . untoken <$> satisfyTok isWordTok - -regularSymbol :: PandocMonad m => LP m Inlines -regularSymbol = str . untoken <$> satisfyTok isRegularSymbol - where isRegularSymbol (Tok _ Symbol t) = not $ T.any isSpecial t - isRegularSymbol _ = False - isSpecial c = c `Set.member` specialChars - -inlineGroup :: PandocMonad m => LP m Inlines -inlineGroup = do - ils <- grouped inline - if null ils - then return mempty - else return $ spanWith nullAttr ils - -- we need the span so we can detitlecase bibtex entries; - -- we need to know when something is {C}apitalized - -doLHSverb :: PandocMonad m => LP m Inlines -doLHSverb = - codeWith ("",["haskell"],[]) . untokenize - <$> manyTill (satisfyTok (not . isNewlineTok)) (symbol '|') - -mkImage :: PandocMonad m => [(Text, Text)] -> Text -> LP m Inlines -mkImage options (T.unpack -> src) = do - let replaceTextwidth (k,v) = - case numUnit v of - Just (num, "\\textwidth") -> (k, showFl (num * 100) <> "%") - _ -> (k, v) - let kvs = map replaceTextwidth - $ filter (\(k,_) -> k `elem` ["width", "height"]) options - let attr = ("",[], kvs) - let alt = str "image" - defaultExt <- getOption readerDefaultImageExtension - let exts' = [".pdf", ".png", ".jpg", ".mps", ".jpeg", ".jbig2", ".jb2"] - let exts = exts' ++ map (map toUpper) exts' - let findFile s [] = return s - findFile s (e:es) = do - let s' = addExtension s e - exists <- fileExists s' - if exists - then return s' - else findFile s es - src' <- case takeExtension src of - "" | not (T.null defaultExt) -> return $ addExtension src $ T.unpack defaultExt - | otherwise -> findFile src exts - _ -> return src - return $ imageWith attr (T.pack src') "" alt - -doxspace :: PandocMonad m => LP m Inlines -doxspace = - (space <$ lookAhead (satisfyTok startsWithLetter)) <|> return mempty - where startsWithLetter (Tok _ Word t) = - case T.uncons t of - Just (c, _) | isLetter c -> True - _ -> False - startsWithLetter _ = False - - -lit :: Text -> LP m Inlines -lit = pure . str - -removeDoubleQuotes :: Text -> Text -removeDoubleQuotes t = - Data.Maybe.fromMaybe t $ T.stripPrefix "\"" t >>= T.stripSuffix "\"" - -doubleQuote :: PandocMonad m => LP m Inlines -doubleQuote = - quoted' doubleQuoted (try $ count 2 $ symbol '`') - (void $ try $ count 2 $ symbol '\'') - <|> quoted' doubleQuoted ((:[]) <$> symbol '“') (void $ symbol '”') - -- the following is used by babel for localized quotes: - <|> quoted' doubleQuoted (try $ sequence [symbol '"', symbol '`']) - (void $ try $ sequence [symbol '"', symbol '\'']) - -singleQuote :: PandocMonad m => LP m Inlines -singleQuote = - quoted' singleQuoted ((:[]) <$> symbol '`') - (try $ symbol '\'' >> - notFollowedBy (satisfyTok startsWithLetter)) - <|> quoted' singleQuoted ((:[]) <$> symbol '‘') - (try $ symbol '’' >> - notFollowedBy (satisfyTok startsWithLetter)) - where startsWithLetter (Tok _ Word t) = - case T.uncons t of - Just (c, _) | isLetter c -> True - _ -> False - startsWithLetter _ = False - -quoted' :: PandocMonad m - => (Inlines -> Inlines) - -> LP m [Tok] - -> LP m () - -> LP m Inlines -quoted' f starter ender = do - startchs <- untokenize <$> starter - smart <- extensionEnabled Ext_smart <$> getOption readerExtensions - if smart - then do - ils <- many (notFollowedBy ender >> inline) - (ender >> return (f (mconcat ils))) <|> - (<> mconcat ils) <$> - lit (case startchs of - "``" -> "“" - "`" -> "‘" - cs -> cs) - else lit startchs - -enquote :: PandocMonad m => Bool -> Maybe Text -> LP m Inlines -enquote starred mblang = do - skipopts - let lang = mblang >>= babelLangToBCP47 - let langspan = case lang of - Nothing -> id - Just l -> spanWith ("",[],[("lang", renderLang l)]) - quoteContext <- sQuoteContext <$> getState - if starred || quoteContext == InDoubleQuote - then singleQuoted . langspan <$> withQuoteContext InSingleQuote tok - else doubleQuoted . langspan <$> withQuoteContext InDoubleQuote tok - -blockquote :: PandocMonad m => Bool -> Maybe Text -> LP m Blocks -blockquote cvariant mblang = do - citepar <- if cvariant - then (\xs -> para (cite xs mempty)) - <$> cites NormalCitation False - else option mempty $ para <$> bracketed inline - let lang = mblang >>= babelLangToBCP47 - let langdiv = case lang of - Nothing -> id - Just l -> divWith ("",[],[("lang", renderLang l)]) - _closingPunct <- option mempty $ bracketed inline -- currently ignored - bs <- grouped block - optional $ symbolIn (".:;?!" :: [Char]) -- currently ignored - return $ blockQuote . langdiv $ (bs <> citepar) - -doAcronym :: PandocMonad m => Text -> LP m Inlines -doAcronym form = do - acro <- braced - return . mconcat $ [spanWith ("",[],[("acronym-label", untokenize acro), - ("acronym-form", "singular+" <> form)]) - $ str $ untokenize acro] - -doAcronymPlural :: PandocMonad m => Text -> LP m Inlines -doAcronymPlural form = do - acro <- braced - plural <- lit "s" - return . mconcat $ [spanWith ("",[],[("acronym-label", untokenize acro), - ("acronym-form", "plural+" <> form)]) $ - mconcat [str $ untokenize acro, plural]] - -doverb :: PandocMonad m => LP m Inlines -doverb = do - Tok _ Symbol t <- anySymbol - marker <- case T.uncons t of - Just (c, ts) | T.null ts -> return c - _ -> mzero - withVerbatimMode $ - code . untokenize <$> - manyTill (notFollowedBy newlineTok >> verbTok marker) (symbol marker) - -verbTok :: PandocMonad m => Char -> LP m Tok -verbTok stopchar = do - t@(Tok pos toktype txt) <- anyTok - case T.findIndex (== stopchar) txt of - Nothing -> return t - Just i -> do - let (t1, t2) = T.splitAt i txt - inp <- getInput - setInput $ Tok (incSourceColumn pos i) Symbol (T.singleton stopchar) - : totoks (incSourceColumn pos (i + 1)) (T.drop 1 t2) ++ inp - return $ Tok pos toktype t1 - -listingsLanguage :: [(Text, Text)] -> Maybe Text -listingsLanguage opts = - case lookup "language" opts of - Nothing -> Nothing - Just l -> fromListingsLanguage l `mplus` Just l - -dolstinline :: PandocMonad m => LP m Inlines -dolstinline = do - options <- option [] keyvals - let classes = maybeToList $ listingsLanguage options - doinlinecode classes - -domintinline :: PandocMonad m => LP m Inlines -domintinline = do - skipopts - cls <- untokenize <$> braced - doinlinecode [cls] - -doinlinecode :: PandocMonad m => [Text] -> LP m Inlines -doinlinecode classes = do - Tok _ Symbol t <- anySymbol - marker <- case T.uncons t of - Just (c, ts) | T.null ts -> return c - _ -> mzero - let stopchar = if marker == '{' then '}' else marker - withVerbatimMode $ - codeWith ("",classes,[]) . T.map nlToSpace . untokenize <$> - manyTill (verbTok stopchar) (symbol stopchar) - -nlToSpace :: Char -> Char -nlToSpace '\n' = ' ' -nlToSpace x = x - -mathDisplay :: Text -> Inlines -mathDisplay = displayMath . trimMath - -mathInline :: Text -> Inlines -mathInline = math . trimMath - -dollarsMath :: PandocMonad m => LP m Inlines -dollarsMath = do - symbol '$' - display <- option False (True <$ symbol '$') - (do contents <- try $ untokenize <$> pDollarsMath 0 - if display - then mathDisplay contents <$ symbol '$' - else return $ mathInline contents) - <|> (guard display >> return (mathInline "")) - --- Int is number of embedded groupings -pDollarsMath :: PandocMonad m => Int -> LP m [Tok] -pDollarsMath n = do - tk@(Tok _ toktype t) <- anyTok - case toktype of - Symbol | t == "$" - , n == 0 -> return [] - | t == "\\" -> do - tk' <- anyTok - (tk :) . (tk' :) <$> pDollarsMath n - | t == "{" -> (tk :) <$> pDollarsMath (n+1) - | t == "}" -> - if n > 0 - then (tk :) <$> pDollarsMath (n-1) - else mzero - _ -> (tk :) <$> pDollarsMath n - --- citations - -addPrefix :: [Inline] -> [Citation] -> [Citation] -addPrefix p (k:ks) = k {citationPrefix = p ++ citationPrefix k} : ks -addPrefix _ _ = [] - -addSuffix :: [Inline] -> [Citation] -> [Citation] -addSuffix s ks@(_:_) = - let k = last ks - in init ks ++ [k {citationSuffix = citationSuffix k ++ s}] -addSuffix _ _ = [] - -simpleCiteArgs :: PandocMonad m => LP m [Citation] -simpleCiteArgs = try $ do - first <- optionMaybe $ toList <$> opt - second <- optionMaybe $ toList <$> opt - keys <- try $ bgroup *> manyTill citationLabel egroup - let (pre, suf) = case (first , second ) of - (Just s , Nothing) -> (mempty, s ) - (Just s , Just t ) -> (s , t ) - _ -> (mempty, mempty) - conv k = Citation { citationId = k - , citationPrefix = [] - , citationSuffix = [] - , citationMode = NormalCitation - , citationHash = 0 - , citationNoteNum = 0 - } - return $ addPrefix pre $ addSuffix suf $ map conv keys - -citationLabel :: PandocMonad m => LP m Text -citationLabel = do - sp - untokenize <$> - (many1 (satisfyTok isWordTok <|> symbolIn bibtexKeyChar) - <* sp - <* optional (symbol ',') - <* sp) - where bibtexKeyChar = ".:;?!`'()/*@_+=-&[]" :: [Char] - -cites :: PandocMonad m => CitationMode -> Bool -> LP m [Citation] -cites mode multi = try $ do - cits <- if multi - then do - multiprenote <- optionMaybe $ toList <$> paropt - multipostnote <- optionMaybe $ toList <$> paropt - let (pre, suf) = case (multiprenote, multipostnote) of - (Just s , Nothing) -> (mempty, s) - (Nothing , Just t) -> (mempty, t) - (Just s , Just t ) -> (s, t) - _ -> (mempty, mempty) - tempCits <- many1 simpleCiteArgs - case tempCits of - (k:ks) -> case ks of - (_:_) -> return $ (addMprenote pre k : init ks) ++ - [addMpostnote suf (last ks)] - _ -> return [addMprenote pre (addMpostnote suf k)] - _ -> return [[]] - else count 1 simpleCiteArgs - let cs = concat cits - return $ case mode of - AuthorInText -> case cs of - (c:rest) -> c {citationMode = mode} : rest - [] -> [] - _ -> map (\a -> a {citationMode = mode}) cs - where mprenote (k:ks) = (k:ks) ++ [Space] - mprenote _ = mempty - mpostnote (k:ks) = [Str ",", Space] ++ (k:ks) - mpostnote _ = mempty - addMprenote mpn (k:ks) = - let mpnfinal = case citationPrefix k of - (_:_) -> mprenote mpn - _ -> mpn - in addPrefix mpnfinal (k:ks) - addMprenote _ _ = [] - addMpostnote = addSuffix . mpostnote - -citation :: PandocMonad m => Text -> CitationMode -> Bool -> LP m Inlines -citation name mode multi = do - (c,raw) <- withRaw $ cites mode multi - return $ cite c (rawInline "latex" $ "\\" <> name <> untokenize raw) - -handleCitationPart :: Inlines -> [Citation] -handleCitationPart ils = - let isCite Cite{} = True - isCite _ = False - (pref, rest) = break isCite (toList ils) - in case rest of - (Cite cs _:suff) -> addPrefix pref $ addSuffix suff cs - _ -> [] - -complexNatbibCitation :: PandocMonad m => CitationMode -> LP m Inlines -complexNatbibCitation mode = try $ do - (cs, raw) <- - withRaw $ concat <$> do - bgroup - items <- mconcat <$> - many1 (notFollowedBy (symbol ';') >> inline) - `sepBy1` symbol ';' - egroup - return $ map handleCitationPart items - case cs of - [] -> mzero - (c:cits) -> return $ cite (c{ citationMode = mode }:cits) - (rawInline "latex" $ "\\citetext" <> untokenize raw) - -inNote :: Inlines -> Inlines -inNote ils = - note $ para $ ils <> str "." - -inlineCommand' :: PandocMonad m => LP m Inlines -inlineCommand' = try $ do - Tok _ (CtrlSeq name) cmd <- anyControlSeq - guard $ name /= "begin" && name /= "end" && name /= "and" - star <- option "" ("*" <$ symbol '*' <* sp) - overlay <- option "" overlaySpecification - let name' = name <> star <> overlay - let names = ordNub [name', name] -- check non-starred as fallback - let raw = do - guard $ isInlineCommand name || not (isBlockCommand name) - rawcommand <- getRawCommand name (cmd <> star) - (guardEnabled Ext_raw_tex >> return (rawInline "latex" rawcommand)) - <|> ignore rawcommand - lookupListDefault raw names inlineCommands - - -tok :: PandocMonad m => LP m Inlines -tok = try $ spaces >> grouped inline <|> inlineCommand' <|> singleChar' - where singleChar' = do - Tok _ _ t <- singleChar - return $ str t - -opt :: PandocMonad m => LP m Inlines -opt = do - toks <- try (sp *> bracketedToks <* sp) - -- now parse the toks as inlines - st <- getState - parsed <- runParserT (mconcat <$> many inline) st "bracketed option" toks - case parsed of - Right result -> return result - Left e -> throwError $ PandocParsecError (untokenize toks) e - -paropt :: PandocMonad m => LP m Inlines -paropt = parenWrapped inline - -inBrackets :: Inlines -> Inlines -inBrackets x = str "[" <> x <> str "]" - -unescapeURL :: Text -> Text -unescapeURL = T.concat . go . T.splitOn "\\" - where - isEscapable c = c `elemText` "#$%&~_^\\{}" - go (x:xs) = x : map unescapeInterior xs - go [] = [] - unescapeInterior t - | Just (c, _) <- T.uncons t - , isEscapable c = t - | otherwise = "\\" <> t - -mathEnvWith :: PandocMonad m - => (Inlines -> a) -> Maybe Text -> Text -> LP m a -mathEnvWith f innerEnv name = f . mathDisplay . inner <$> mathEnv name - where inner x = case innerEnv of - Nothing -> x - Just y -> "\\begin{" <> y <> "}\n" <> x <> - "\\end{" <> y <> "}" - -mathEnv :: PandocMonad m => Text -> LP m Text -mathEnv name = do - skipopts - optional blankline - res <- manyTill anyTok (end_ name) - return $ stripTrailingNewlines $ untokenize res - -inlineEnvironment :: PandocMonad m => LP m Inlines -inlineEnvironment = try $ do - controlSeq "begin" - name <- untokenize <$> braced - M.findWithDefault mzero name inlineEnvironments - -inlineEnvironments :: PandocMonad m => M.Map Text (LP m Inlines) -inlineEnvironments = M.fromList [ - ("displaymath", mathEnvWith id Nothing "displaymath") - , ("math", math <$> mathEnv "math") - , ("equation", mathEnvWith id Nothing "equation") - , ("equation*", mathEnvWith id Nothing "equation*") - , ("gather", mathEnvWith id (Just "gathered") "gather") - , ("gather*", mathEnvWith id (Just "gathered") "gather*") - , ("multline", mathEnvWith id (Just "gathered") "multline") - , ("multline*", mathEnvWith id (Just "gathered") "multline*") - , ("eqnarray", mathEnvWith id (Just "aligned") "eqnarray") - , ("eqnarray*", mathEnvWith id (Just "aligned") "eqnarray*") - , ("align", mathEnvWith id (Just "aligned") "align") - , ("align*", mathEnvWith id (Just "aligned") "align*") - , ("alignat", mathEnvWith id (Just "aligned") "alignat") - , ("alignat*", mathEnvWith id (Just "aligned") "alignat*") - , ("dmath", mathEnvWith id Nothing "dmath") - , ("dmath*", mathEnvWith id Nothing "dmath*") - , ("dgroup", mathEnvWith id (Just "aligned") "dgroup") - , ("dgroup*", mathEnvWith id (Just "aligned") "dgroup*") - , ("darray", mathEnvWith id (Just "aligned") "darray") - , ("darray*", mathEnvWith id (Just "aligned") "darray*") - ] - -inlineCommands :: PandocMonad m => M.Map Text (LP m Inlines) -inlineCommands = M.union inlineLanguageCommands $ M.fromList - [ ("emph", extractSpaces emph <$> tok) - , ("textit", extractSpaces emph <$> tok) - , ("textsl", extractSpaces emph <$> tok) - , ("textsc", extractSpaces smallcaps <$> tok) - , ("textsf", extractSpaces (spanWith ("",["sans-serif"],[])) <$> tok) - , ("textmd", extractSpaces (spanWith ("",["medium"],[])) <$> tok) - , ("textrm", extractSpaces (spanWith ("",["roman"],[])) <$> tok) - , ("textup", extractSpaces (spanWith ("",["upright"],[])) <$> tok) - , ("texttt", ttfamily) - , ("sout", extractSpaces strikeout <$> tok) - , ("alert", skipopts >> spanWith ("",["alert"],[]) <$> tok) -- beamer - , ("lq", return (str "‘")) - , ("rq", return (str "’")) - , ("textquoteleft", return (str "‘")) - , ("textquoteright", return (str "’")) - , ("textquotedblleft", return (str "“")) - , ("textquotedblright", return (str "”")) - , ("textsuperscript", extractSpaces superscript <$> tok) - , ("textsubscript", extractSpaces subscript <$> tok) - , ("textbackslash", lit "\\") - , ("backslash", lit "\\") - , ("slash", lit "/") - , ("textbf", extractSpaces strong <$> tok) - , ("textnormal", extractSpaces (spanWith ("",["nodecor"],[])) <$> tok) - , ("underline", underline <$> tok) - , ("ldots", lit "…") - , ("vdots", lit "\8942") - , ("dots", lit "…") - , ("mdots", lit "…") - , ("sim", lit "~") - , ("sep", lit ",") - , ("label", rawInlineOr "label" dolabel) - , ("ref", rawInlineOr "ref" $ doref "ref") - , ("cref", rawInlineOr "cref" $ doref "ref") -- from cleveref.sty - , ("vref", rawInlineOr "vref" $ doref "ref+page") -- from varioref.sty - , ("eqref", rawInlineOr "eqref" $ doref "eqref") -- from amsmath.sty - , ("mbox", rawInlineOr "mbox" $ processHBox <$> tok) - , ("hbox", rawInlineOr "hbox" $ processHBox <$> tok) - , ("lettrine", rawInlineOr "lettrine" lettrine) - , ("(", mathInline . untokenize <$> manyTill anyTok (controlSeq ")")) - , ("[", mathDisplay . untokenize <$> manyTill anyTok (controlSeq "]")) - , ("ensuremath", mathInline . untokenize <$> braced) - , ("texorpdfstring", const <$> tok <*> tok) - , ("P", lit "¶") - , ("S", lit "§") - , ("$", lit "$") - , ("%", lit "%") - , ("&", lit "&") - , ("#", lit "#") - , ("_", lit "_") - , ("{", lit "{") - , ("}", lit "}") - , ("qed", lit "\a0\x25FB") - -- old TeX commands - , ("em", extractSpaces emph <$> inlines) - , ("it", extractSpaces emph <$> inlines) - , ("sl", extractSpaces emph <$> inlines) - , ("bf", extractSpaces strong <$> inlines) - , ("tt", code . stringify . toList <$> inlines) - , ("rm", inlines) - , ("itshape", extractSpaces emph <$> inlines) - , ("slshape", extractSpaces emph <$> inlines) - , ("scshape", extractSpaces smallcaps <$> inlines) - , ("bfseries", extractSpaces strong <$> inlines) - , ("MakeUppercase", makeUppercase <$> tok) - , ("MakeTextUppercase", makeUppercase <$> tok) -- textcase - , ("uppercase", makeUppercase <$> tok) - , ("MakeLowercase", makeLowercase <$> tok) - , ("MakeTextLowercase", makeLowercase <$> tok) - , ("lowercase", makeLowercase <$> tok) - , ("/", pure mempty) -- italic correction - , ("aa", lit "å") - , ("AA", lit "Å") - , ("ss", lit "ß") - , ("o", lit "ø") - , ("O", lit "Ø") - , ("L", lit "Ł") - , ("l", lit "ł") - , ("ae", lit "æ") - , ("AE", lit "Æ") - , ("oe", lit "œ") - , ("OE", lit "Œ") - , ("pounds", lit "£") - , ("euro", lit "€") - , ("copyright", lit "©") - , ("textasciicircum", lit "^") - , ("textasciitilde", lit "~") - , ("H", accent '\779' Nothing) -- hungarumlaut - , ("`", accent '\768' (Just '`')) -- grave - , ("'", accent '\769' (Just '\'')) -- acute - , ("^", accent '\770' (Just '^')) -- circ - , ("~", accent '\771' (Just '~')) -- tilde - , ("\"", accent '\776' Nothing) -- umlaut - , (".", accent '\775' Nothing) -- dot - , ("=", accent '\772' Nothing) -- macron - , ("|", accent '\781' Nothing) -- vertical line above - , ("b", accent '\817' Nothing) -- macron below - , ("c", accent '\807' Nothing) -- cedilla - , ("G", accent '\783' Nothing) -- doublegrave - , ("h", accent '\777' Nothing) -- hookabove - , ("d", accent '\803' Nothing) -- dotbelow - , ("f", accent '\785' Nothing) -- inverted breve - , ("r", accent '\778' Nothing) -- ringabove - , ("t", accent '\865' Nothing) -- double inverted breve - , ("U", accent '\782' Nothing) -- double vertical line above - , ("v", accent '\780' Nothing) -- hacek - , ("u", accent '\774' Nothing) -- breve - , ("k", accent '\808' Nothing) -- ogonek - , ("textogonekcentered", accent '\808' Nothing) -- ogonek - , ("i", lit "ı") -- dotless i - , ("j", lit "ȷ") -- dotless j - , ("newtie", accent '\785' Nothing) -- inverted breve - , ("textcircled", accent '\8413' Nothing) -- combining circle - , ("\\", linebreak <$ (do inTableCell <- sInTableCell <$> getState - guard $ not inTableCell - optional opt - spaces)) - , (",", lit "\8198") - , ("@", pure mempty) - , (" ", lit "\160") - , ("ps", pure $ str "PS." <> space) - , ("TeX", lit "TeX") - , ("LaTeX", lit "LaTeX") - , ("bar", lit "|") - , ("textless", lit "<") - , ("textgreater", lit ">") - , ("thanks", skipopts >> note <$> grouped block) - , ("footnote", skipopts >> note <$> grouped block) - , ("passthrough", tok) -- \passthrough macro used by latex writer - -- for listings - , ("verb", doverb) - , ("lstinline", dolstinline) - , ("mintinline", domintinline) - , ("Verb", doverb) - , ("url", (\url -> link url "" (str url)) . unescapeURL . untokenize <$> - bracedUrl) - , ("nolinkurl", code . unescapeURL . untokenize <$> bracedUrl) - , ("href", do url <- bracedUrl - sp - link (unescapeURL $ untokenize url) "" <$> tok) - , ("includegraphics", do options <- option [] keyvals - src <- braced - mkImage options . unescapeURL . removeDoubleQuotes $ - untokenize src) - , ("enquote*", enquote True Nothing) - , ("enquote", enquote False Nothing) - -- foreignquote is supposed to use native quote marks - , ("foreignquote*", braced >>= enquote True . Just . untokenize) - , ("foreignquote", braced >>= enquote False . Just . untokenize) - -- hypehnquote uses regular quotes - , ("hyphenquote*", braced >>= enquote True . Just . untokenize) - , ("hyphenquote", braced >>= enquote False . Just . untokenize) - , ("figurename", doTerm Translations.Figure) - , ("prefacename", doTerm Translations.Preface) - , ("refname", doTerm Translations.References) - , ("bibname", doTerm Translations.Bibliography) - , ("chaptername", doTerm Translations.Chapter) - , ("partname", doTerm Translations.Part) - , ("contentsname", doTerm Translations.Contents) - , ("listfigurename", doTerm Translations.ListOfFigures) - , ("listtablename", doTerm Translations.ListOfTables) - , ("indexname", doTerm Translations.Index) - , ("abstractname", doTerm Translations.Abstract) - , ("tablename", doTerm Translations.Table) - , ("enclname", doTerm Translations.Encl) - , ("ccname", doTerm Translations.Cc) - , ("headtoname", doTerm Translations.To) - , ("pagename", doTerm Translations.Page) - , ("seename", doTerm Translations.See) - , ("seealsoname", doTerm Translations.SeeAlso) - , ("proofname", doTerm Translations.Proof) - , ("glossaryname", doTerm Translations.Glossary) - , ("lstlistingname", doTerm Translations.Listing) - , ("cite", citation "cite" NormalCitation False) - , ("Cite", citation "Cite" NormalCitation False) - , ("citep", citation "citep" NormalCitation False) - , ("citep*", citation "citep*" NormalCitation False) - , ("citeal", citation "citeal" NormalCitation False) - , ("citealp", citation "citealp" NormalCitation False) - , ("citealp*", citation "citealp*" NormalCitation False) - , ("autocite", citation "autocite" NormalCitation False) - , ("smartcite", citation "smartcite" NormalCitation False) - , ("footcite", inNote <$> citation "footcite" NormalCitation False) - , ("parencite", citation "parencite" NormalCitation False) - , ("supercite", citation "supercite" NormalCitation False) - , ("footcitetext", inNote <$> citation "footcitetext" NormalCitation False) - , ("citeyearpar", citation "citeyearpar" SuppressAuthor False) - , ("citeyear", citation "citeyear" SuppressAuthor False) - , ("autocite*", citation "autocite*" SuppressAuthor False) - , ("cite*", citation "cite*" SuppressAuthor False) - , ("parencite*", citation "parencite*" SuppressAuthor False) - , ("textcite", citation "textcite" AuthorInText False) - , ("citet", citation "citet" AuthorInText False) - , ("citet*", citation "citet*" AuthorInText False) - , ("citealt", citation "citealt" AuthorInText False) - , ("citealt*", citation "citealt*" AuthorInText False) - , ("textcites", citation "textcites" AuthorInText True) - , ("cites", citation "cites" NormalCitation True) - , ("autocites", citation "autocites" NormalCitation True) - , ("footcites", inNote <$> citation "footcites" NormalCitation True) - , ("parencites", citation "parencites" NormalCitation True) - , ("supercites", citation "supercites" NormalCitation True) - , ("footcitetexts", inNote <$> citation "footcitetexts" NormalCitation True) - , ("Autocite", citation "Autocite" NormalCitation False) - , ("Smartcite", citation "Smartcite" NormalCitation False) - , ("Footcite", inNote <$> citation "Footcite" NormalCitation False) - , ("Parencite", citation "Parencite" NormalCitation False) - , ("Supercite", citation "Supercite" NormalCitation False) - , ("Footcitetext", inNote <$> citation "Footcitetext" NormalCitation False) - , ("Citeyearpar", citation "Citeyearpar" SuppressAuthor False) - , ("Citeyear", citation "Citeyear" SuppressAuthor False) - , ("Autocite*", citation "Autocite*" SuppressAuthor False) - , ("Cite*", citation "Cite*" SuppressAuthor False) - , ("Parencite*", citation "Parencite*" SuppressAuthor False) - , ("Textcite", citation "Textcite" AuthorInText False) - , ("Textcites", citation "Textcites" AuthorInText True) - , ("Cites", citation "Cites" NormalCitation True) - , ("Autocites", citation "Autocites" NormalCitation True) - , ("Footcites", inNote <$> citation "Footcites" NormalCitation True) - , ("Parencites", citation "Parencites" NormalCitation True) - , ("Supercites", citation "Supercites" NormalCitation True) - , ("Footcitetexts", inNote <$> citation "Footcitetexts" NormalCitation True) - , ("citetext", complexNatbibCitation NormalCitation) - , ("citeauthor", (try (tok *> sp *> controlSeq "citetext") *> - complexNatbibCitation AuthorInText) - <|> citation "citeauthor" AuthorInText False) - , ("nocite", mempty <$ (citation "nocite" NormalCitation False >>= - addMeta "nocite")) - , ("hyperlink", hyperlink) - , ("hypertarget", hypertargetInline) - -- glossaries package - , ("gls", doAcronym "short") - , ("Gls", doAcronym "short") - , ("glsdesc", doAcronym "long") - , ("Glsdesc", doAcronym "long") - , ("GLSdesc", doAcronym "long") - , ("acrlong", doAcronym "long") - , ("Acrlong", doAcronym "long") - , ("acrfull", doAcronym "full") - , ("Acrfull", doAcronym "full") - , ("acrshort", doAcronym "abbrv") - , ("Acrshort", doAcronym "abbrv") - , ("glspl", doAcronymPlural "short") - , ("Glspl", doAcronymPlural "short") - , ("glsdescplural", doAcronymPlural "long") - , ("Glsdescplural", doAcronymPlural "long") - , ("GLSdescplural", doAcronymPlural "long") - -- acronyms package - , ("ac", doAcronym "short") - , ("acf", doAcronym "full") - , ("acs", doAcronym "abbrv") - , ("acl", doAcronym "long") - , ("acp", doAcronymPlural "short") - , ("acfp", doAcronymPlural "full") - , ("acsp", doAcronymPlural "abbrv") - , ("aclp", doAcronymPlural "long") - , ("Ac", doAcronym "short") - , ("Acf", doAcronym "full") - , ("Acs", doAcronym "abbrv") - , ("Acl", doAcronym "long") - , ("Acp", doAcronymPlural "short") - , ("Acfp", doAcronymPlural "full") - , ("Acsp", doAcronymPlural "abbrv") - , ("Aclp", doAcronymPlural "long") - -- siuntix - , ("si", skipopts *> dosi tok) - , ("SI", doSI tok) - , ("SIrange", doSIrange True tok) - , ("numrange", doSIrange False tok) - , ("numlist", doSInumlist) - , ("num", doSInum) - , ("ang", doSIang) - -- hyphenat - , ("bshyp", lit "\\\173") - , ("fshyp", lit "/\173") - , ("dothyp", lit ".\173") - , ("colonhyp", lit ":\173") - , ("hyp", lit "-") - , ("nohyphens", tok) - , ("textnhtt", ttfamily) - , ("nhttfamily", ttfamily) - -- LaTeX colors - , ("textcolor", coloredInline "color") - , ("colorbox", coloredInline "background-color") - -- fontawesome - , ("faCheck", lit "\10003") - , ("faClose", lit "\10007") - -- xspace - , ("xspace", doxspace) - -- etoolbox - , ("ifstrequal", ifstrequal) - , ("newtoggle", braced >>= newToggle) - , ("toggletrue", braced >>= setToggle True) - , ("togglefalse", braced >>= setToggle False) - , ("iftoggle", try $ ifToggle >> inline) - -- biblatex misc - , ("RN", romanNumeralUpper) - , ("Rn", romanNumeralLower) - -- babel - , ("foreignlanguage", foreignlanguage) - -- include - , ("input", rawInlineOr "input" $ include "input") - -- soul package - , ("ul", underline <$> tok) - -- ulem package - , ("uline", underline <$> tok) - -- plain tex stuff that should just be passed through as raw tex - , ("ifdim", ifdim) - ] - -accent :: PandocMonad m => Char -> Maybe Char -> LP m Inlines -accent combiningAccent fallBack = try $ do - ils <- tok - case toList ils of - (Str (T.uncons -> Just (x, xs)) : ys) -> return $ fromList $ - -- try to normalize to the combined character: - Str (Normalize.normalize Normalize.NFC - (T.pack [x, combiningAccent]) <> xs) : ys - [Space] -> return $ str $ T.singleton $ fromMaybe combiningAccent fallBack - [] -> return $ str $ T.singleton $ fromMaybe combiningAccent fallBack - _ -> return ils - - -lettrine :: PandocMonad m => LP m Inlines -lettrine = do - optional opt - x <- tok - y <- tok - return $ extractSpaces (spanWith ("",["lettrine"],[])) x <> smallcaps y - -ifdim :: PandocMonad m => LP m Inlines -ifdim = do - contents <- manyTill anyTok (controlSeq "fi") - return $ rawInline "latex" $ "\\ifdim" <> untokenize contents <> "\\fi" - -makeUppercase :: Inlines -> Inlines -makeUppercase = fromList . walk (alterStr T.toUpper) . toList - -makeLowercase :: Inlines -> Inlines -makeLowercase = fromList . walk (alterStr T.toLower) . toList - -alterStr :: (Text -> Text) -> Inline -> Inline -alterStr f (Str xs) = Str (f xs) -alterStr _ x = x - -foreignlanguage :: PandocMonad m => LP m Inlines -foreignlanguage = do - babelLang <- untokenize <$> braced - case babelLangToBCP47 babelLang of - Just lang -> spanWith ("", [], [("lang", renderLang lang)]) <$> tok - _ -> tok - -inlineLanguageCommands :: PandocMonad m => M.Map Text (LP m Inlines) -inlineLanguageCommands = M.fromList $ mk <$> M.toList polyglossiaLangToBCP47 - where - mk (polyglossia, bcp47Func) = - ("text" <> polyglossia, inlineLanguage bcp47Func) - -inlineLanguage :: PandocMonad m => (Text -> Lang) -> LP m Inlines -inlineLanguage bcp47Func = do - o <- option "" $ T.filter (\c -> c /= '[' && c /= ']') - <$> rawopt - let lang = renderLang $ bcp47Func o - extractSpaces (spanWith ("", [], [("lang", lang)])) <$> tok - -hyperlink :: PandocMonad m => LP m Inlines -hyperlink = try $ do - src <- untokenize <$> braced - lab <- tok - return $ link ("#" <> src) "" lab - -hypertargetBlock :: PandocMonad m => LP m Blocks -hypertargetBlock = try $ do - ref <- untokenize <$> braced - bs <- grouped block - case toList bs of - [Header 1 (ident,_,_) _] | ident == ref -> return bs - _ -> return $ divWith (ref, [], []) bs - -hypertargetInline :: PandocMonad m => LP m Inlines -hypertargetInline = try $ do - ref <- untokenize <$> braced - ils <- grouped inline - return $ spanWith (ref, [], []) ils - -romanNumeralUpper :: (PandocMonad m) => LP m Inlines -romanNumeralUpper = - str . toRomanNumeral <$> romanNumeralArg - -romanNumeralLower :: (PandocMonad m) => LP m Inlines -romanNumeralLower = - str . T.toLower . toRomanNumeral <$> romanNumeralArg - -romanNumeralArg :: (PandocMonad m) => LP m Int -romanNumeralArg = spaces *> (parser <|> inBraces) - where - inBraces = do - symbol '{' - spaces - res <- parser - spaces - symbol '}' - return res - parser = do - Tok _ Word s <- satisfyTok isWordTok - let (digits, rest) = T.span isDigit s - unless (T.null rest) $ - Prelude.fail "Non-digits in argument to \\Rn or \\RN" - safeRead digits - -newToggle :: (Monoid a, PandocMonad m) => [Tok] -> LP m a -newToggle name = do - updateState $ \st -> - st{ sToggles = M.insert (untokenize name) False (sToggles st) } - return mempty - -setToggle :: (Monoid a, PandocMonad m) => Bool -> [Tok] -> LP m a -setToggle on name = do - updateState $ \st -> - st{ sToggles = M.adjust (const on) (untokenize name) (sToggles st) } - return mempty - -ifToggle :: PandocMonad m => LP m () -ifToggle = do - name <- braced - spaces - yes <- braced - spaces - no <- braced - toggles <- sToggles <$> getState - inp <- getInput - let name' = untokenize name - case M.lookup name' toggles of - Just True -> setInput (yes ++ inp) - Just False -> setInput (no ++ inp) - Nothing -> do - pos <- getPosition - report $ UndefinedToggle name' pos - return () - -doTerm :: PandocMonad m => Translations.Term -> LP m Inlines -doTerm term = str <$> translateTerm term - -ifstrequal :: (PandocMonad m, Monoid a) => LP m a -ifstrequal = do - str1 <- tok - str2 <- tok - ifequal <- braced - ifnotequal <- braced - if str1 == str2 - then getInput >>= setInput . (ifequal ++) - else getInput >>= setInput . (ifnotequal ++) - return mempty - -coloredInline :: PandocMonad m => Text -> LP m Inlines -coloredInline stylename = do - skipopts - color <- braced - spanWith ("",[],[("style",stylename <> ": " <> untokenize color)]) <$> tok - -ttfamily :: PandocMonad m => LP m Inlines -ttfamily = code . stringify . toList <$> tok - -rawInlineOr :: PandocMonad m => Text -> LP m Inlines -> LP m Inlines -rawInlineOr name' fallback = do - parseRaw <- extensionEnabled Ext_raw_tex <$> getOption readerExtensions - if parseRaw - then rawInline "latex" <$> getRawCommand name' ("\\" <> name') - else fallback - -processHBox :: Inlines -> Inlines -processHBox = walk convert - where - convert Space = Str $ T.singleton $ chr 160 -- non-breakable space - convert SoftBreak = Str $ T.singleton $ chr 160 -- non-breakable space - convert LineBreak = Str "" - convert x = x - -isBlockCommand :: Text -> Bool -isBlockCommand s = - s `M.member` (blockCommands :: M.Map Text (LP PandocPure Blocks)) - || s `Set.member` treatAsBlock - -treatAsBlock :: Set.Set Text -treatAsBlock = Set.fromList - [ "special", "pdfannot", "pdfstringdef" - , "bibliographystyle" - , "maketitle", "makeindex", "makeglossary" - , "addcontentsline", "addtocontents", "addtocounter" - -- \ignore{} is used conventionally in literate haskell for definitions - -- that are to be processed by the compiler but not printed. - , "ignore" - , "hyperdef" - , "markboth", "markright", "markleft" - , "hspace", "vspace" - , "newpage" - , "clearpage" - , "pagebreak" - , "titleformat" - , "listoffigures" - , "listoftables" - , "write" - ] - -isInlineCommand :: Text -> Bool -isInlineCommand s = - s `M.member` (inlineCommands :: M.Map Text (LP PandocPure Inlines)) - || s `Set.member` treatAsInline - -treatAsInline :: Set.Set Text -treatAsInline = Set.fromList - [ "index" - , "hspace" - , "vspace" - , "noindent" - , "newpage" - , "clearpage" - , "pagebreak" - ] - -label :: PandocMonad m => LP m () -label = do - controlSeq "label" - t <- braced - updateState $ \st -> st{ sLastLabel = Just $ untokenize t } - -dolabel :: PandocMonad m => LP m Inlines -dolabel = do - v <- braced - let refstr = untokenize v - updateState $ \st -> - st{ sLastLabel = Just refstr } - return $ spanWith (refstr,[],[("label", refstr)]) - $ inBrackets $ str $ untokenize v - -doref :: PandocMonad m => Text -> LP m Inlines -doref cls = do - v <- braced - let refstr = untokenize v - return $ linkWith ("",[],[ ("reference-type", cls) - , ("reference", refstr)]) - ("#" <> refstr) - "" - (inBrackets $ str refstr) - -lookupListDefault :: (Ord k) => v -> [k] -> M.Map k v -> v -lookupListDefault d = (fromMaybe d .) . lookupList - where lookupList l m = msum $ map (`M.lookup` m) l - -inline :: PandocMonad m => LP m Inlines -inline = (mempty <$ comment) - <|> (space <$ whitespace) - <|> (softbreak <$ endline) - <|> word - <|> macroDef (rawInline "latex") - <|> inlineCommand' - <|> inlineEnvironment - <|> inlineGroup - <|> (symbol '-' *> - option (str "-") (symbol '-' *> - option (str "–") (str "—" <$ symbol '-'))) - <|> doubleQuote - <|> singleQuote - <|> (str "”" <$ try (symbol '\'' >> symbol '\'')) - <|> (str "”" <$ symbol '”') - <|> (str "’" <$ symbol '\'') - <|> (str "’" <$ symbol '’') - <|> (str "\160" <$ symbol '~') - <|> dollarsMath - <|> (guardEnabled Ext_literate_haskell *> symbol '|' *> doLHSverb) - <|> (str . T.singleton <$> primEscape) - <|> regularSymbol - <|> (do res <- symbolIn "#^'`\"[]&" - pos <- getPosition - let s = untoken res - report $ ParsingUnescaped s pos - return $ str s) - -inlines :: PandocMonad m => LP m Inlines -inlines = mconcat <$> many inline - --- block elements: - -preamble :: PandocMonad m => LP m Blocks -preamble = mconcat <$> many preambleBlock - where preambleBlock = (mempty <$ spaces1) - <|> macroDef (rawBlock "latex") - <|> filecontents - <|> (mempty <$ blockCommand) - <|> (mempty <$ braced) - <|> (do notFollowedBy (begin_ "document") - anyTok - return mempty) - -rule :: PandocMonad m => LP m Blocks -rule = do - skipopts - width <- T.takeWhile (\c -> isDigit c || c == '.') . stringify <$> tok - _thickness <- tok - -- 0-width rules are used to fix spacing issues: - case safeRead width of - Just (0 :: Double) -> return mempty - _ -> return horizontalRule - -paragraph :: PandocMonad m => LP m Blocks -paragraph = do - x <- trimInlines . mconcat <$> many1 inline - if x == mempty - then return mempty - else return $ para x - -rawBlockOr :: PandocMonad m => Text -> LP m Blocks -> LP m Blocks -rawBlockOr name fallback = do - -- if raw_tex allowed, don't process - parseRaw <- extensionEnabled Ext_raw_tex <$> getOption readerExtensions - if parseRaw - then rawBlock "latex" <$> getRawCommand name ("\\" <> name) - else fallback - -doSubfile :: PandocMonad m => LP m Blocks -doSubfile = do - skipMany opt - f <- T.unpack . removeDoubleQuotes . T.strip . untokenize <$> braced - oldToks <- getInput - setInput [] - insertIncluded ".tex" f - bs <- blocks - eof - setInput oldToks - return bs - -include :: (PandocMonad m, Monoid a) => Text -> LP m a -include name = do - skipMany opt - fs <- map (T.unpack . removeDoubleQuotes . T.strip) . T.splitOn "," . - untokenize <$> braced - let defaultExt | name == "usepackage" = ".sty" - | otherwise = ".tex" - mapM_ (insertIncluded defaultExt) fs - return mempty - -readFileFromTexinputs :: PandocMonad m => FilePath -> LP m (Maybe Text) -readFileFromTexinputs fp = do - fileContentsMap <- sFileContents <$> getState - case M.lookup (T.pack fp) fileContentsMap of - Just t -> return (Just t) - Nothing -> do - dirs <- map T.unpack . splitTextBy (==':') . fromMaybe "." - <$> lookupEnv "TEXINPUTS" - readFileFromDirs dirs fp - -insertIncluded :: PandocMonad m - => FilePath - -> FilePath - -> LP m () -insertIncluded defaultExtension f' = do - let f = case takeExtension f' of - ".tex" -> f' - ".sty" -> f' - _ -> addExtension f' defaultExtension - pos <- getPosition - containers <- getIncludeFiles <$> getState - when (T.pack f `elem` containers) $ - throwError $ PandocParseError $ T.pack $ "Include file loop at " ++ show pos - updateState $ addIncludeFile $ T.pack f - mbcontents <- readFileFromTexinputs f - contents <- case mbcontents of - Just s -> return s - Nothing -> do - report $ CouldNotLoadIncludeFile (T.pack f) pos - return "" - getInput >>= setInput . (tokenize f contents ++) - updateState dropLatestIncludeFile - -addMeta :: PandocMonad m => ToMetaValue a => Text -> a -> LP m () -addMeta field val = updateState $ \st -> - st{ sMeta = addMetaField field val $ sMeta st } - -authors :: PandocMonad m => LP m () -authors = try $ do - bgroup - let oneAuthor = blocksToInlines' . B.toList . mconcat <$> many1 block - auths <- sepBy oneAuthor (controlSeq "and") - egroup - addMeta "author" (map trimInlines auths) - -macroDef :: (PandocMonad m, Monoid a) => (Text -> a) -> LP m a -macroDef constructor = do - (_, s) <- withRaw (commandDef <|> environmentDef) - (constructor (untokenize s) <$ - guardDisabled Ext_latex_macros) - <|> return mempty - where commandDef = do - (name, macro') <- newcommand <|> letmacro <|> defmacro - guardDisabled Ext_latex_macros <|> - updateState (\s -> s{ sMacros = M.insert name macro' (sMacros s) }) - environmentDef = do - mbenv <- newenvironment - case mbenv of - Nothing -> return () - Just (name, macro1, macro2) -> - guardDisabled Ext_latex_macros <|> - do updateState $ \s -> s{ sMacros = - M.insert name macro1 (sMacros s) } - updateState $ \s -> s{ sMacros = - M.insert ("end" <> name) macro2 (sMacros s) } - -- @\newenvironment{envname}[n-args][default]{begin}{end}@ - -- is equivalent to - -- @\newcommand{\envname}[n-args][default]{begin}@ - -- @\newcommand{\endenvname}@ - -letmacro :: PandocMonad m => LP m (Text, Macro) -letmacro = do - controlSeq "let" - (name, contents) <- withVerbatimMode $ do - Tok _ (CtrlSeq name) _ <- anyControlSeq - optional $ symbol '=' - spaces - -- we first parse in verbatim mode, and then expand macros, - -- because we don't want \let\foo\bar to turn into - -- \let\foo hello if we have previously \def\bar{hello} - contents <- bracedOrToken - return (name, contents) - contents' <- doMacros' 0 contents - return (name, Macro ExpandWhenDefined [] Nothing contents') - -defmacro :: PandocMonad m => LP m (Text, Macro) -defmacro = try $ - -- we use withVerbatimMode, because macros are to be expanded - -- at point of use, not point of definition - withVerbatimMode $ do - controlSeq "def" - Tok _ (CtrlSeq name) _ <- anyControlSeq - argspecs <- many (argspecArg <|> argspecPattern) - contents <- bracedOrToken - return (name, Macro ExpandWhenUsed argspecs Nothing contents) - -argspecArg :: PandocMonad m => LP m ArgSpec -argspecArg = do - Tok _ (Arg i) _ <- satisfyTok isArgTok - return $ ArgNum i - -argspecPattern :: PandocMonad m => LP m ArgSpec -argspecPattern = - Pattern <$> many1 (satisfyTok (\(Tok _ toktype' txt) -> - (toktype' == Symbol || toktype' == Word) && - (txt /= "{" && txt /= "\\" && txt /= "}"))) - -newcommand :: PandocMonad m => LP m (Text, Macro) -newcommand = do - pos <- getPosition - Tok _ (CtrlSeq mtype) _ <- controlSeq "newcommand" <|> - controlSeq "renewcommand" <|> - controlSeq "providecommand" <|> - controlSeq "DeclareMathOperator" <|> - controlSeq "DeclareRobustCommand" - withVerbatimMode $ do - Tok _ (CtrlSeq name) txt <- do - optional (symbol '*') - anyControlSeq <|> - (symbol '{' *> spaces *> anyControlSeq <* spaces <* symbol '}') - spaces - numargs <- option 0 $ try bracketedNum - let argspecs = map ArgNum [1..numargs] - spaces - optarg <- option Nothing $ Just <$> try bracketedToks - spaces - contents' <- bracedOrToken - let contents = - case mtype of - "DeclareMathOperator" -> - Tok pos (CtrlSeq "mathop") "\\mathop" - : Tok pos Symbol "{" - : Tok pos (CtrlSeq "mathrm") "\\mathrm" - : Tok pos Symbol "{" - : (contents' ++ - [ Tok pos Symbol "}", Tok pos Symbol "}" ]) - _ -> contents' - macros <- sMacros <$> getState - case M.lookup name macros of - Just macro - | mtype == "newcommand" -> do - report $ MacroAlreadyDefined txt pos - return (name, macro) - | mtype == "providecommand" -> return (name, macro) - _ -> return (name, Macro ExpandWhenUsed argspecs optarg contents) - -newenvironment :: PandocMonad m => LP m (Maybe (Text, Macro, Macro)) -newenvironment = do - pos <- getPosition - Tok _ (CtrlSeq mtype) _ <- controlSeq "newenvironment" <|> - controlSeq "renewenvironment" <|> - controlSeq "provideenvironment" - withVerbatimMode $ do - optional $ symbol '*' - spaces - name <- untokenize <$> braced - spaces - numargs <- option 0 $ try bracketedNum - spaces - optarg <- option Nothing $ Just <$> try bracketedToks - let argspecs = map (\i -> ArgNum i) [1..numargs] - startcontents <- spaces >> bracedOrToken - endcontents <- spaces >> bracedOrToken - macros <- sMacros <$> getState - case M.lookup name macros of - Just _ - | mtype == "newenvironment" -> do - report $ MacroAlreadyDefined name pos - return Nothing - | mtype == "provideenvironment" -> - return Nothing - _ -> return $ Just (name, - Macro ExpandWhenUsed argspecs optarg startcontents, - Macro ExpandWhenUsed [] Nothing endcontents) - -bracketedNum :: PandocMonad m => LP m Int -bracketedNum = do - ds <- untokenize <$> bracketedToks - case safeRead ds of - Just i -> return i - _ -> return 0 - -setCaption :: PandocMonad m => LP m () -setCaption = try $ do - skipopts - ils <- tok - optional $ try $ spaces *> label - updateState $ \st -> st{ sCaption = Just ils } - -looseItem :: PandocMonad m => LP m Blocks -looseItem = do - inListItem <- sInListItem <$> getState - guard $ not inListItem - skipopts - return mempty - -epigraph :: PandocMonad m => LP m Blocks -epigraph = do - p1 <- grouped block - p2 <- grouped block - return $ divWith ("", ["epigraph"], []) (p1 <> p2) - -resetCaption :: PandocMonad m => LP m () -resetCaption = updateState $ \st -> st{ sCaption = Nothing - , sLastLabel = Nothing } - -section :: PandocMonad m => Attr -> Int -> LP m Blocks -section (ident, classes, kvs) lvl = do - skipopts - contents <- grouped inline - lab <- option ident $ - try (spaces >> controlSeq "label" - >> spaces >> untokenize <$> braced) - when (lvl == 0) $ - updateState $ \st -> st{ sHasChapters = True } - unless ("unnumbered" `elem` classes) $ do - hn <- sLastHeaderNum <$> getState - hasChapters <- sHasChapters <$> getState - let lvl' = lvl + if hasChapters then 1 else 0 - let num = incrementDottedNum lvl' hn - updateState $ \st -> st{ sLastHeaderNum = num - , sLabels = M.insert lab - [Str (renderDottedNum num)] - (sLabels st) } - attr' <- registerHeader (lab, classes, kvs) contents - return $ headerWith attr' lvl contents - -blockCommand :: PandocMonad m => LP m Blocks -blockCommand = try $ do - Tok _ (CtrlSeq name) txt <- anyControlSeq - guard $ name /= "begin" && name /= "end" && name /= "and" - star <- option "" ("*" <$ symbol '*' <* sp) - let name' = name <> star - let names = ordNub [name', name] - let rawDefiniteBlock = do - guard $ isBlockCommand name - rawcontents <- getRawCommand name (txt <> star) - (guardEnabled Ext_raw_tex >> return (rawBlock "latex" rawcontents)) - <|> ignore rawcontents - -- heuristic: if it could be either block or inline, we - -- treat it if block if we have a sequence of block - -- commands followed by a newline. But we stop if we - -- hit a \startXXX, since this might start a raw ConTeXt - -- environment (this is important because this parser is - -- used by the Markdown reader). - let startCommand = try $ do - Tok _ (CtrlSeq n) _ <- anyControlSeq - guard $ "start" `T.isPrefixOf` n - let rawMaybeBlock = try $ do - guard $ not $ isInlineCommand name - rawcontents <- getRawCommand name (txt <> star) - curr <- (guardEnabled Ext_raw_tex >> - return (rawBlock "latex" rawcontents)) - <|> ignore rawcontents - rest <- many $ notFollowedBy startCommand *> blockCommand - lookAhead $ blankline <|> startCommand - return $ curr <> mconcat rest - let raw = rawDefiniteBlock <|> rawMaybeBlock - lookupListDefault raw names blockCommands - -closing :: PandocMonad m => LP m Blocks -closing = do - contents <- tok - st <- getState - let extractInlines (MetaBlocks [Plain ys]) = ys - extractInlines (MetaBlocks [Para ys ]) = ys - extractInlines _ = [] - let sigs = case lookupMeta "author" (sMeta st) of - Just (MetaList xs) -> - para $ trimInlines $ fromList $ - intercalate [LineBreak] $ map extractInlines xs - _ -> mempty - return $ para (trimInlines contents) <> sigs - -parbox :: PandocMonad m => LP m Blocks -parbox = try $ do - skipopts - braced -- size - oldInTableCell <- sInTableCell <$> getState - -- see #5711 - updateState $ \st -> st{ sInTableCell = False } - res <- grouped block - updateState $ \st -> st{ sInTableCell = oldInTableCell } - return res - -blockCommands :: PandocMonad m => M.Map Text (LP m Blocks) -blockCommands = M.fromList - [ ("par", mempty <$ skipopts) - , ("parbox", parbox) - , ("title", mempty <$ (skipopts *> - (grouped inline >>= addMeta "title") - <|> (grouped block >>= addMeta "title"))) - , ("subtitle", mempty <$ (skipopts *> tok >>= addMeta "subtitle")) - , ("author", mempty <$ (skipopts *> authors)) - -- -- in letter class, temp. store address & sig as title, author - , ("address", mempty <$ (skipopts *> tok >>= addMeta "address")) - , ("signature", mempty <$ (skipopts *> authors)) - , ("date", mempty <$ (skipopts *> tok >>= addMeta "date")) - , ("newtheorem", newtheorem) - , ("theoremstyle", theoremstyle) - -- KOMA-Script metadata commands - , ("extratitle", mempty <$ (skipopts *> tok >>= addMeta "extratitle")) - , ("frontispiece", mempty <$ (skipopts *> tok >>= addMeta "frontispiece")) - , ("titlehead", mempty <$ (skipopts *> tok >>= addMeta "titlehead")) - , ("subject", mempty <$ (skipopts *> tok >>= addMeta "subject")) - , ("publishers", mempty <$ (skipopts *> tok >>= addMeta "publishers")) - , ("uppertitleback", mempty <$ (skipopts *> tok >>= addMeta "uppertitleback")) - , ("lowertitleback", mempty <$ (skipopts *> tok >>= addMeta "lowertitleback")) - , ("dedication", mempty <$ (skipopts *> tok >>= addMeta "dedication")) - -- sectioning - , ("part", section nullAttr (-1)) - , ("part*", section nullAttr (-1)) - , ("chapter", section nullAttr 0) - , ("chapter*", section ("",["unnumbered"],[]) 0) - , ("section", section nullAttr 1) - , ("section*", section ("",["unnumbered"],[]) 1) - , ("subsection", section nullAttr 2) - , ("subsection*", section ("",["unnumbered"],[]) 2) - , ("subsubsection", section nullAttr 3) - , ("subsubsection*", section ("",["unnumbered"],[]) 3) - , ("paragraph", section nullAttr 4) - , ("paragraph*", section ("",["unnumbered"],[]) 4) - , ("subparagraph", section nullAttr 5) - , ("subparagraph*", section ("",["unnumbered"],[]) 5) - -- beamer slides - , ("frametitle", section nullAttr 3) - , ("framesubtitle", section nullAttr 4) - -- letters - , ("opening", para . trimInlines <$> (skipopts *> tok)) - , ("closing", skipopts *> closing) - -- memoir - , ("plainbreak", braced >> pure horizontalRule) - , ("plainbreak*", braced >> pure horizontalRule) - , ("fancybreak", braced >> pure horizontalRule) - , ("fancybreak*", braced >> pure horizontalRule) - , ("plainfancybreak", braced >> braced >> braced >> pure horizontalRule) - , ("plainfancybreak*", braced >> braced >> braced >> pure horizontalRule) - , ("pfbreak", pure horizontalRule) - , ("pfbreak*", pure horizontalRule) - -- - , ("hrule", pure horizontalRule) - , ("strut", pure mempty) - , ("rule", rule) - , ("item", looseItem) - , ("documentclass", skipopts *> braced *> preamble) - , ("centerline", para . trimInlines <$> (skipopts *> tok)) - , ("caption", mempty <$ setCaption) - , ("bibliography", mempty <$ (skipopts *> braced >>= - addMeta "bibliography" . splitBibs . untokenize)) - , ("addbibresource", mempty <$ (skipopts *> braced >>= - addMeta "bibliography" . splitBibs . untokenize)) - , ("endinput", mempty <$ skipMany anyTok) - -- includes - , ("lstinputlisting", inputListing) - , ("inputminted", inputMinted) - , ("graphicspath", graphicsPath) - -- polyglossia - , ("setdefaultlanguage", setDefaultLanguage) - , ("setmainlanguage", setDefaultLanguage) - -- hyperlink - , ("hypertarget", hypertargetBlock) - -- LaTeX colors - , ("textcolor", coloredBlock "color") - , ("colorbox", coloredBlock "background-color") - -- csquotes - , ("blockquote", blockquote False Nothing) - , ("blockcquote", blockquote True Nothing) - , ("foreignblockquote", braced >>= blockquote False . Just . untokenize) - , ("foreignblockcquote", braced >>= blockquote True . Just . untokenize) - , ("hyphenblockquote", braced >>= blockquote False . Just . untokenize) - , ("hyphenblockcquote", braced >>= blockquote True . Just . untokenize) - -- include - , ("include", rawBlockOr "include" $ include "include") - , ("input", rawBlockOr "input" $ include "input") - , ("subfile", rawBlockOr "subfile" doSubfile) - , ("usepackage", rawBlockOr "usepackage" $ include "usepackage") - -- preamble - , ("PackageError", mempty <$ (braced >> braced >> braced)) - -- epigraph package - , ("epigraph", epigraph) - ] - - -environments :: PandocMonad m => M.Map Text (LP m Blocks) -environments = M.fromList - [ ("document", env "document" blocks <* skipMany anyTok) - , ("abstract", mempty <$ (env "abstract" blocks >>= addMeta "abstract")) - , ("sloppypar", env "sloppypar" blocks) - , ("letter", env "letter" letterContents) - , ("minipage", env "minipage" $ - skipopts *> spaces *> optional braced *> spaces *> blocks) - , ("figure", env "figure" $ skipopts *> figure) - , ("subfigure", env "subfigure" $ skipopts *> tok *> figure) - , ("center", divWith ("", ["center"], []) <$> env "center" blocks) - , ("longtable", env "longtable" $ - resetCaption *> simpTable "longtable" False >>= addTableCaption) - , ("table", env "table" $ - skipopts *> resetCaption *> blocks >>= addTableCaption) - , ("tabular*", env "tabular*" $ simpTable "tabular*" True) - , ("tabularx", env "tabularx" $ simpTable "tabularx" True) - , ("tabular", env "tabular" $ simpTable "tabular" False) - , ("quote", blockQuote <$> env "quote" blocks) - , ("quotation", blockQuote <$> env "quotation" blocks) - , ("verse", blockQuote <$> env "verse" blocks) - , ("itemize", bulletList <$> listenv "itemize" (many item)) - , ("description", definitionList <$> listenv "description" (many descItem)) - , ("enumerate", orderedList') - , ("alltt", alltt <$> env "alltt" blocks) - , ("code", guardEnabled Ext_literate_haskell *> - (codeBlockWith ("",["haskell","literate"],[]) <$> verbEnv "code")) - , ("comment", mempty <$ verbEnv "comment") - , ("verbatim", codeBlock <$> verbEnv "verbatim") - , ("Verbatim", fancyverbEnv "Verbatim") - , ("BVerbatim", fancyverbEnv "BVerbatim") - , ("lstlisting", do attr <- parseListingsOptions <$> option [] keyvals - codeBlockWith attr <$> verbEnv "lstlisting") - , ("minted", minted) - , ("obeylines", obeylines) - , ("tikzpicture", rawVerbEnv "tikzpicture") - , ("tikzcd", rawVerbEnv "tikzcd") - , ("lilypond", rawVerbEnv "lilypond") - , ("ly", rawVerbEnv "ly") - -- amsthm - , ("proof", proof) - -- etoolbox - , ("ifstrequal", ifstrequal) - , ("newtoggle", braced >>= newToggle) - , ("toggletrue", braced >>= setToggle True) - , ("togglefalse", braced >>= setToggle False) - , ("iftoggle", try $ ifToggle >> block) - ] - -filecontents :: PandocMonad m => LP m Blocks -filecontents = try $ do - controlSeq "begin" - name <- untokenize <$> braced - guard $ name == "filecontents" || name == "filecontents*" - skipopts - fp <- untokenize <$> braced - txt <- verbEnv name - updateState $ \st -> - st{ sFileContents = M.insert fp txt (sFileContents st) } - return mempty - -theoremstyle :: PandocMonad m => LP m Blocks -theoremstyle = do - stylename <- untokenize <$> braced - let mbstyle = case stylename of - "plain" -> Just PlainStyle - "definition" -> Just DefinitionStyle - "remark" -> Just RemarkStyle - _ -> Nothing - case mbstyle of - Nothing -> return () - Just sty -> updateState $ \s -> s{ sLastTheoremStyle = sty } - return mempty - -newtheorem :: PandocMonad m => LP m Blocks -newtheorem = do - number <- option True (False <$ symbol '*' <* sp) - name <- untokenize <$> braced - sp - series <- option Nothing $ Just . untokenize <$> bracketedToks - sp - showName <- tok - sp - syncTo <- option Nothing $ Just . untokenize <$> bracketedToks - sty <- sLastTheoremStyle <$> getState - let spec = TheoremSpec { theoremName = showName - , theoremStyle = sty - , theoremSeries = series - , theoremSyncTo = syncTo - , theoremNumber = number - , theoremLastNum = DottedNum [0] } - tmap <- sTheoremMap <$> getState - updateState $ \s -> s{ sTheoremMap = - M.insert name spec tmap } - return mempty - -proof :: PandocMonad m => LP m Blocks -proof = do - title <- option (B.text "Proof") opt - bs <- env "proof" blocks - return $ - B.divWith ("", ["proof"], []) $ - addQed $ addTitle (B.emph (title <> ".")) bs - -addTitle :: Inlines -> Blocks -> Blocks -addTitle ils bs = - case B.toList bs of - (Para xs : rest) - -> B.fromList (Para (B.toList ils ++ (Space : xs)) : rest) - _ -> B.para ils <> bs - -addQed :: Blocks -> Blocks -addQed bs = - case Seq.viewr (B.unMany bs) of - s Seq.:> Para ils - -> B.Many (s Seq.|> Para (ils ++ B.toList qedSign)) - _ -> bs <> B.para qedSign - where - qedSign = B.str "\xa0\x25FB" - -environment :: PandocMonad m => LP m Blocks -environment = try $ do - controlSeq "begin" - name <- untokenize <$> braced - M.findWithDefault mzero name environments <|> - theoremEnvironment name <|> - if M.member name (inlineEnvironments - :: M.Map Text (LP PandocPure Inlines)) - then mzero - else try (rawEnv name) <|> rawVerbEnv name - -theoremEnvironment :: PandocMonad m => Text -> LP m Blocks -theoremEnvironment name = do - tmap <- sTheoremMap <$> getState - case M.lookup name tmap of - Nothing -> mzero - Just tspec -> do - optTitle <- option mempty $ (\x -> space <> "(" <> x <> ")") <$> opt - mblabel <- option Nothing $ Just . untokenize <$> - try (spaces >> controlSeq "label" >> spaces >> braced) - bs <- env name blocks - number <- - if theoremNumber tspec - then do - let name' = fromMaybe name $ theoremSeries tspec - num <- getNextNumber - (maybe (DottedNum [0]) theoremLastNum . - M.lookup name' . sTheoremMap) - updateState $ \s -> - s{ sTheoremMap = - M.adjust - (\spec -> spec{ theoremLastNum = num }) - name' - (sTheoremMap s) - } - - case mblabel of - Just ident -> - updateState $ \s -> - s{ sLabels = M.insert ident - (B.toList $ - theoremName tspec <> "\160" <> - str (renderDottedNum num)) (sLabels s) } - Nothing -> return () - return $ space <> B.text (renderDottedNum num) - else return mempty - let titleEmph = case theoremStyle tspec of - PlainStyle -> B.strong - DefinitionStyle -> B.strong - RemarkStyle -> B.emph - let title = titleEmph (theoremName tspec <> number) - <> optTitle <> "." <> space - return $ divWith (fromMaybe "" mblabel, [name], []) $ addTitle title - $ case theoremStyle tspec of - PlainStyle -> walk italicize bs - _ -> bs - -italicize :: Block -> Block -italicize x@(Para [Image{}]) = x -- see #6925 -italicize (Para ils) = Para [Emph ils] -italicize (Plain ils) = Plain [Emph ils] -italicize x = x - -env :: PandocMonad m => Text -> LP m a -> LP m a -env name p = p <* end_ name - -rawEnv :: PandocMonad m => Text -> LP m Blocks -rawEnv name = do - exts <- getOption readerExtensions - let parseRaw = extensionEnabled Ext_raw_tex exts - rawOptions <- mconcat <$> many rawopt - let beginCommand = "\\begin{" <> name <> "}" <> rawOptions - pos1 <- getPosition - (bs, raw) <- withRaw $ env name blocks - if parseRaw - then return $ rawBlock "latex" - $ beginCommand <> untokenize raw - else do - report $ SkippedContent beginCommand pos1 - pos2 <- getPosition - report $ SkippedContent ("\\end{" <> name <> "}") pos2 - return $ divWith ("",[name],[]) bs - -rawVerbEnv :: PandocMonad m => Text -> LP m Blocks -rawVerbEnv name = do - pos <- getPosition - (_, raw) <- withRaw $ verbEnv name - let raw' = "\\begin{" <> name <> "}" <> untokenize raw - exts <- getOption readerExtensions - let parseRaw = extensionEnabled Ext_raw_tex exts - if parseRaw - then return $ rawBlock "latex" raw' - else do - report $ SkippedContent raw' pos - return mempty - -fancyverbEnv :: PandocMonad m => Text -> LP m Blocks -fancyverbEnv name = do - options <- option [] keyvals - let kvs = [ (if k == "firstnumber" - then "startFrom" - else k, v) | (k,v) <- options ] - let classes = [ "numberLines" | - lookup "numbers" options == Just "left" ] - let attr = ("",classes,kvs) - codeBlockWith attr <$> verbEnv name - -obeylines :: PandocMonad m => LP m Blocks -obeylines = - para . fromList . removeLeadingTrailingBreaks . - walk softBreakToHard . toList <$> env "obeylines" inlines - where softBreakToHard SoftBreak = LineBreak - softBreakToHard x = x - removeLeadingTrailingBreaks = reverse . dropWhile isLineBreak . - reverse . dropWhile isLineBreak - isLineBreak LineBreak = True - isLineBreak _ = False - -minted :: PandocMonad m => LP m Blocks -minted = do - attr <- mintedAttr - codeBlockWith attr <$> verbEnv "minted" - -mintedAttr :: PandocMonad m => LP m Attr -mintedAttr = do - options <- option [] keyvals - lang <- untokenize <$> braced - let kvs = [ (if k == "firstnumber" - then "startFrom" - else k, v) | (k,v) <- options ] - let classes = [ lang | not (T.null lang) ] ++ - [ "numberLines" | - lookup "linenos" options == Just "true" ] - return ("",classes,kvs) - -inputMinted :: PandocMonad m => LP m Blocks -inputMinted = do - pos <- getPosition - attr <- mintedAttr - f <- T.filter (/='"') . untokenize <$> braced - mbCode <- readFileFromTexinputs (T.unpack f) - rawcode <- case mbCode of - Just s -> return s - Nothing -> do - report $ CouldNotLoadIncludeFile f pos - return "" - return $ B.codeBlockWith attr rawcode - -letterContents :: PandocMonad m => LP m Blocks -letterContents = do - bs <- blocks - st <- getState - -- add signature (author) and address (title) - let addr = case lookupMeta "address" (sMeta st) of - Just (MetaBlocks [Plain xs]) -> - para $ trimInlines $ fromList xs - _ -> mempty - return $ addr <> bs -- sig added by \closing - -figure :: PandocMonad m => LP m Blocks -figure = try $ do - resetCaption - blocks >>= addImageCaption - -addImageCaption :: PandocMonad m => Blocks -> LP m Blocks -addImageCaption = walkM go - where go (Image attr@(_, cls, kvs) alt (src,tit)) - | not ("fig:" `T.isPrefixOf` tit) = do - st <- getState - let (alt', tit') = case sCaption st of - Just ils -> (toList ils, "fig:" <> tit) - Nothing -> (alt, tit) - attr' = case sLastLabel st 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) } - return $ Image attr' alt' (src, tit') - go x = return x - -coloredBlock :: PandocMonad m => Text -> LP m Blocks -coloredBlock stylename = try $ do - skipopts - color <- braced - notFollowedBy (grouped inline) - let constructor = divWith ("",[],[("style",stylename <> ": " <> untokenize color)]) - constructor <$> grouped block - -graphicsPath :: PandocMonad m => LP m Blocks -graphicsPath = do - ps <- map (T.unpack . untokenize) <$> - (bgroup *> spaces *> manyTill (braced <* spaces) egroup) - getResourcePath >>= setResourcePath . (<> ps) - return mempty - -splitBibs :: Text -> [Inlines] -splitBibs = map (str . T.pack . flip replaceExtension "bib" . T.unpack . trim) . splitTextBy (==',') - -alltt :: Blocks -> Blocks -alltt = walk strToCode - where strToCode (Str s) = Code nullAttr s - strToCode Space = RawInline (Format "latex") "\\ " - strToCode SoftBreak = LineBreak - strToCode x = x - -parseListingsOptions :: [(Text, Text)] -> Attr -parseListingsOptions options = - let kvs = [ (if k == "firstnumber" - then "startFrom" - else k, v) | (k,v) <- options ] - classes = [ "numberLines" | - lookup "numbers" options == Just "left" ] - ++ maybeToList (listingsLanguage options) - in (fromMaybe "" (lookup "label" options), classes, kvs) - -inputListing :: PandocMonad m => LP m Blocks -inputListing = do - pos <- getPosition - options <- option [] keyvals - f <- T.filter (/='"') . untokenize <$> braced - mbCode <- readFileFromTexinputs (T.unpack f) - codeLines <- case mbCode of - Just s -> return $ T.lines s - Nothing -> do - report $ CouldNotLoadIncludeFile f pos - return [] - let (ident,classes,kvs) = parseListingsOptions options - let classes' = - (case listingsLanguage options of - Nothing -> (take 1 (languagesByExtension (T.pack $ takeExtension $ T.unpack f)) <>) - Just _ -> id) classes - let firstline = fromMaybe 1 $ lookup "firstline" options >>= safeRead - let lastline = fromMaybe (length codeLines) $ - lookup "lastline" options >>= safeRead - let codeContents = T.intercalate "\n" $ take (1 + lastline - firstline) $ - drop (firstline - 1) codeLines - return $ codeBlockWith (ident,classes',kvs) codeContents - --- lists - -item :: PandocMonad m => LP m Blocks -item = void blocks *> controlSeq "item" *> skipopts *> blocks - -descItem :: PandocMonad m => LP m (Inlines, [Blocks]) -descItem = do - blocks -- skip blocks before item - controlSeq "item" - sp - ils <- opt - bs <- blocks - return (ils, [bs]) - -listenv :: PandocMonad m => Text -> LP m a -> LP m a -listenv name p = try $ do - oldInListItem <- sInListItem `fmap` getState - updateState $ \st -> st{ sInListItem = True } - res <- env name p - updateState $ \st -> st{ sInListItem = oldInListItem } - return res - -orderedList' :: PandocMonad m => LP m Blocks -orderedList' = try $ do - spaces - let markerSpec = do - symbol '[' - ts <- untokenize <$> manyTill anyTok (symbol ']') - case runParser anyOrderedListMarker def "option" ts of - Right r -> return r - Left _ -> do - pos <- getPosition - report $ SkippedContent ("[" <> ts <> "]") pos - return (1, DefaultStyle, DefaultDelim) - (_, style, delim) <- option (1, DefaultStyle, DefaultDelim) markerSpec - spaces - optional $ try $ controlSeq "setlength" - *> grouped (count 1 $ controlSeq "itemindent") - *> braced - spaces - start <- option 1 $ try $ do pos <- getPosition - controlSeq "setcounter" - ctr <- untokenize <$> braced - guard $ "enum" `T.isPrefixOf` ctr - guard $ T.all (`elem` ['i','v']) (T.drop 4 ctr) - sp - num <- untokenize <$> braced - case safeRead num of - Just i -> return (i + 1 :: Int) - Nothing -> do - report $ SkippedContent - ("\\setcounter{" <> ctr <> - "}{" <> num <> "}") pos - return 1 - bs <- listenv "enumerate" (many item) - return $ orderedListWith (start, style, delim) bs - --- tables - -hline :: PandocMonad m => LP m () -hline = try $ do - spaces - controlSeq "hline" <|> - -- booktabs rules: - controlSeq "toprule" <|> - controlSeq "bottomrule" <|> - controlSeq "midrule" <|> - controlSeq "endhead" <|> - controlSeq "endfirsthead" - spaces - optional opt - return () - -lbreak :: PandocMonad m => LP m Tok -lbreak = (controlSeq "\\" <|> controlSeq "tabularnewline") - <* skipopts <* spaces - -amp :: PandocMonad m => LP m Tok -amp = symbol '&' - --- Split a Word into individual Symbols (for parseAligns) -splitWordTok :: PandocMonad m => LP m () -splitWordTok = do - inp <- getInput - case inp of - (Tok spos Word t : rest) -> - setInput $ map (Tok spos Symbol . T.singleton) (T.unpack t) <> rest - _ -> return () - -parseAligns :: PandocMonad m => LP m [(Alignment, ColWidth, ([Tok], [Tok]))] -parseAligns = try $ do - let maybeBar = skipMany - (try $ sp *> (() <$ symbol '|' <|> () <$ (symbol '@' >> braced))) - let cAlign = AlignCenter <$ symbol 'c' - let lAlign = AlignLeft <$ symbol 'l' - let rAlign = AlignRight <$ symbol 'r' - let parAlign = AlignLeft <$ symbol 'p' - -- aligns from tabularx - let xAlign = AlignLeft <$ symbol 'X' - let mAlign = AlignLeft <$ symbol 'm' - let bAlign = AlignLeft <$ symbol 'b' - let alignChar = splitWordTok *> ( cAlign <|> lAlign <|> rAlign <|> parAlign - <|> xAlign <|> mAlign <|> bAlign ) - let alignPrefix = symbol '>' >> braced - let alignSuffix = symbol '<' >> braced - let colWidth = try $ do - symbol '{' - ds <- trim . untokenize <$> manyTill anyTok (controlSeq "linewidth") - spaces - symbol '}' - return $ safeRead ds - let alignSpec = do - pref <- option [] alignPrefix - spaces - al <- alignChar - width <- colWidth <|> option Nothing (do s <- untokenize <$> braced - pos <- getPosition - report $ SkippedContent s pos - return Nothing) - spaces - suff <- option [] alignSuffix - return (al, width, (pref, suff)) - let starAlign = do -- '*{2}{r}' == 'rr', we just expand like a macro - symbol '*' - spaces - ds <- trim . untokenize <$> braced - spaces - spec <- braced - case safeRead ds of - Just n -> - getInput >>= setInput . (mconcat (replicate n spec) ++) - Nothing -> Prelude.fail $ "Could not parse " <> T.unpack ds <> " as number" - bgroup - spaces - maybeBar - aligns' <- many $ try $ spaces >> optional starAlign >> - (alignSpec <* maybeBar) - spaces - egroup - spaces - return $ map toSpec aligns' - where - toColWidth (Just w) | w > 0 = ColWidth w - toColWidth _ = ColWidthDefault - toSpec (x, y, z) = (x, toColWidth y, z) - --- N.B. this parser returns a Row that may have erroneous empty cells --- in it. See the note above fixTableHead for details. -parseTableRow :: PandocMonad m - => Text -- ^ table environment name - -> [([Tok], [Tok])] -- ^ pref/suffixes - -> LP m Row -parseTableRow envname prefsufs = do - notFollowedBy (spaces *> end_ envname) - -- add prefixes and suffixes in token stream: - let celltoks (pref, suff) = do - prefpos <- getPosition - contents <- mconcat <$> - many ( snd <$> withRaw (controlSeq "parbox" >> parbox) -- #5711 - <|> - snd <$> withRaw (inlineEnvironment <|> dollarsMath) - <|> - (do notFollowedBy - (() <$ amp <|> () <$ lbreak <|> end_ envname) - count 1 anyTok) ) - - suffpos <- getPosition - option [] (count 1 amp) - return $ map (setpos prefpos) pref ++ contents ++ map (setpos suffpos) suff - rawcells <- mapM celltoks prefsufs - oldInput <- getInput - cells <- mapM (\ts -> setInput ts >> parseTableCell) rawcells - setInput oldInput - spaces - return $ Row nullAttr cells - -parseTableCell :: PandocMonad m => LP m Cell -parseTableCell = do - spaces - updateState $ \st -> st{ sInTableCell = True } - cell' <- multicolumnCell - <|> multirowCell - <|> parseSimpleCell - <|> parseEmptyCell - updateState $ \st -> st{ sInTableCell = False } - spaces - return cell' - where - -- The parsing of empty cells is important in LaTeX, especially when dealing - -- with multirow/multicolumn. See #6603. - parseEmptyCell = spaces $> emptyCell - -cellAlignment :: PandocMonad m => LP m Alignment -cellAlignment = skipMany (symbol '|') *> alignment <* skipMany (symbol '|') - where - alignment = do - c <- untoken <$> singleChar - return $ case c of - "l" -> AlignLeft - "r" -> AlignRight - "c" -> AlignCenter - "*" -> AlignDefault - _ -> AlignDefault - -plainify :: Blocks -> Blocks -plainify bs = case toList bs of - [Para ils] -> plain (fromList ils) - _ -> bs - -multirowCell :: PandocMonad m => LP m Cell -multirowCell = controlSeq "multirow" >> do - -- Full prototype for \multirow macro is: - -- \multirow[vpos]{nrows}[bigstruts]{width}[vmove]{text} - -- However, everything except `nrows` and `text` make - -- sense in the context of the Pandoc AST - _ <- optional $ symbol '[' *> cellAlignment <* symbol ']' -- vertical position - nrows <- fmap (fromMaybe 1 . safeRead . untokenize) braced - _ <- optional $ symbol '[' *> manyTill anyTok (symbol ']') -- bigstrut-related - _ <- symbol '{' *> manyTill anyTok (symbol '}') -- Cell width - _ <- optional $ symbol '[' *> manyTill anyTok (symbol ']') -- Length used for fine-tuning - content <- symbol '{' *> (plainify <$> blocks) <* symbol '}' - return $ cell AlignDefault (RowSpan nrows) (ColSpan 1) content - -multicolumnCell :: PandocMonad m => LP m Cell -multicolumnCell = controlSeq "multicolumn" >> do - span' <- fmap (fromMaybe 1 . safeRead . untokenize) braced - alignment <- symbol '{' *> cellAlignment <* symbol '}' - - let singleCell = do - content <- plainify <$> blocks - return $ cell alignment (RowSpan 1) (ColSpan span') content - - -- Two possible contents: either a \multirow cell, or content. - -- E.g. \multicol{1}{c}{\multirow{2}{1em}{content}} - -- Note that a \multirow cell can be nested in a \multicolumn, - -- but not the other way around. See #6603 - let nestedCell = do - (Cell _ _ (RowSpan rs) _ bs) <- multirowCell - return $ cell - alignment - (RowSpan rs) - (ColSpan span') - (fromList bs) - - symbol '{' *> (nestedCell <|> singleCell) <* symbol '}' - --- Parse a simple cell, i.e. not multirow/multicol -parseSimpleCell :: PandocMonad m => LP m Cell -parseSimpleCell = simpleCell <$> (plainify <$> blocks) - --- LaTeX tables are stored with empty cells underneath multirow cells --- denoting the grid spaces taken up by them. More specifically, if a --- cell spans m rows, then it will overwrite all the cells in the --- columns it spans for (m-1) rows underneath it, requiring padding --- cells in these places. These padding cells need to be removed for --- proper table reading. See #6603. --- --- These fixTable functions do not otherwise fix up malformed --- input tables: that is left to the table builder. -fixTableHead :: TableHead -> TableHead -fixTableHead (TableHead attr rows) = TableHead attr rows' - where - rows' = fixTableRows rows - -fixTableBody :: TableBody -> TableBody -fixTableBody (TableBody attr rhc th tb) - = TableBody attr rhc th' tb' - where - th' = fixTableRows th - tb' = fixTableRows tb - -fixTableRows :: [Row] -> [Row] -fixTableRows = fixTableRows' $ repeat Nothing - where - fixTableRows' oldHang (Row attr cells : rs) - = let (newHang, cells') = fixTableRow oldHang cells - rs' = fixTableRows' newHang rs - in Row attr cells' : rs' - fixTableRows' _ [] = [] - --- The overhang is represented as Just (relative cell dimensions) or --- Nothing for an empty grid space. -fixTableRow :: [Maybe (ColSpan, RowSpan)] -> [Cell] -> ([Maybe (ColSpan, RowSpan)], [Cell]) -fixTableRow oldHang cells - -- If there's overhang, drop cells until their total width meets the - -- width of the occupied grid spaces (or we run out) - | (n, prefHang, restHang) <- splitHang oldHang - , n > 0 - = let cells' = dropToWidth getCellW n cells - (restHang', cells'') = fixTableRow restHang cells' - in (prefHang restHang', cells'') - -- Otherwise record the overhang of a pending cell and fix the rest - -- of the row - | c@(Cell _ _ h w _):cells' <- cells - = let h' = max 1 h - w' = max 1 w - oldHang' = dropToWidth getHangW w' oldHang - (newHang, cells'') = fixTableRow oldHang' cells' - in (toHang w' h' <> newHang, c : cells'') - | otherwise - = (oldHang, []) - where - getCellW (Cell _ _ _ w _) = w - getHangW = maybe 1 fst - getCS (ColSpan n) = n - - toHang c r - | r > 1 = [Just (c, r)] - | otherwise = replicate (getCS c) Nothing - - -- Take the prefix of the overhang list representing filled grid - -- spaces. Also return the remainder and the length of this prefix. - splitHang = splitHang' 0 id - - splitHang' !n l (Just (c, r):xs) - = splitHang' (n + c) (l . (toHang c (r-1) ++)) xs - splitHang' n l xs = (n, l, xs) - - -- Drop list items until the total width of the dropped items - -- exceeds the passed width. - dropToWidth _ n l | n < 1 = l - dropToWidth wproj n (c:cs) = dropToWidth wproj (n - wproj c) cs - dropToWidth _ _ [] = [] - -simpTable :: PandocMonad m => Text -> Bool -> LP m Blocks -simpTable envname hasWidthParameter = try $ do - when hasWidthParameter $ () <$ (spaces >> tok) - skipopts - colspecs <- parseAligns - let (aligns, widths, prefsufs) = unzip3 colspecs - optional $ controlSeq "caption" *> setCaption - spaces - optional label - spaces - optional lbreak - spaces - skipMany hline - spaces - header' <- option [] . try . fmap (:[]) $ - parseTableRow envname prefsufs <* lbreak <* many1 hline - spaces - rows <- sepEndBy (parseTableRow envname prefsufs) - (lbreak <* optional (skipMany hline)) - spaces - optional $ controlSeq "caption" *> setCaption - spaces - optional label - spaces - optional lbreak - spaces - lookAhead $ controlSeq "end" -- make sure we're at end - let th = fixTableHead $ TableHead nullAttr header' - let tbs = [fixTableBody $ TableBody nullAttr 0 [] rows] - let tf = TableFoot nullAttr [] - return $ table emptyCaption (zip aligns widths) th tbs tf - -addTableCaption :: PandocMonad m => Blocks -> LP m Blocks -addTableCaption = walkM go - where go (Table attr c spec th tb tf) = do - st <- getState - let mblabel = sLastLabel st - capt <- case (sCaption st, mblabel) of - (Just ils, Nothing) -> return $ caption Nothing (plain ils) - (Just ils, 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 - let attr' = case (attr, mblabel) of - ((_,classes,kvs), Just ident) -> - (ident,classes,kvs) - _ -> attr - return $ addAttrDiv attr' $ Table nullAttr capt spec th tb tf - go x = return x - --- TODO: For now we add a Div to contain table attributes, since --- most writers don't do anything yet with attributes on Table. --- This can be removed when that changes. -addAttrDiv :: Attr -> Block -> Block -addAttrDiv ("",[],[]) b = b -addAttrDiv attr b = Div attr [b] - -block :: PandocMonad m => LP m Blocks -block = do - res <- (mempty <$ spaces1) - <|> environment - <|> macroDef (rawBlock "latex") - <|> blockCommand - <|> paragraph - <|> grouped block - trace (T.take 60 $ tshow $ B.toList res) - return res - -blocks :: PandocMonad m => LP m Blocks -blocks = mconcat <$> many block - -setDefaultLanguage :: PandocMonad m => LP m Blocks -setDefaultLanguage = do - o <- option "" $ T.filter (\c -> c /= '[' && c /= ']') - <$> rawopt - polylang <- untokenize <$> braced - case M.lookup polylang polyglossiaLangToBCP47 of - Nothing -> return mempty -- TODO mzero? warning? - Just langFunc -> do - let l = langFunc o - setTranslations l - updateState $ setMeta "lang" $ str (renderLang l) - return mempty +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} +{- | + Module : Text.Pandoc.Readers.LaTeX + Copyright : Copyright (C) 2006-2021 John MacFarlane + License : GNU GPL, version 2 or above + + Maintainer : John MacFarlane + Stability : alpha + Portability : portable + +Conversion of LaTeX to 'Pandoc' document. + +-} +module Text.Pandoc.Readers.LaTeX ( readLaTeX, + applyMacros, + rawLaTeXInline, + rawLaTeXBlock, + inlineCommand + ) where + +import Control.Applicative (many, optional, (<|>)) +import Control.Monad +import Control.Monad.Except (throwError) +import Data.Char (isDigit, isLetter, toUpper, chr) +import Data.Default +import Data.List (intercalate) +import qualified Data.Map as M +import Data.Maybe (fromMaybe, maybeToList) +import qualified Data.Set as Set +import Data.Text (Text) +import qualified Data.Text as T +import System.FilePath (addExtension, replaceExtension, takeExtension) +import Text.Pandoc.BCP47 (renderLang) +import Text.Pandoc.Builder as B +import Text.Pandoc.Class.PandocPure (PandocPure) +import Text.Pandoc.Class.PandocMonad (PandocMonad (..), getResourcePath, + readFileFromDirs, report, + setResourcePath) +import Text.Pandoc.Error (PandocError (PandocParseError, PandocParsecError)) +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.Readers.LaTeX.Parsing +import Text.Pandoc.Readers.LaTeX.Citation (citationCommands, cites) +import Text.Pandoc.Readers.LaTeX.Math (dollarsMath, inlineEnvironments, + inlineEnvironment, + mathDisplay, mathInline, + newtheorem, theoremstyle, proof, + theoremEnvironment) +import Text.Pandoc.Readers.LaTeX.Table (tableEnvironments) +import Text.Pandoc.Readers.LaTeX.Macro (macroDef) +import Text.Pandoc.Readers.LaTeX.Lang (inlineLanguageCommands, + enquoteCommands, + babelLangToBCP47, setDefaultLanguage) +import Text.Pandoc.Readers.LaTeX.SIunitx (siunitxCommands) +import Text.Pandoc.Readers.LaTeX.Inline (acronymCommands, refCommands, + nameCommands, charCommands, + accentCommands, + biblatexInlineCommands, + verbCommands, rawInlineOr, + listingsLanguage) +import Text.Pandoc.Shared +import Text.Pandoc.Walk +import Safe + +-- for debugging: +-- import Text.Pandoc.Extensions (getDefaultExtensions) +-- import Text.Pandoc.Class.PandocIO (runIOorExplode, PandocIO) +-- import Debug.Trace (traceShowId) + +-- | Parse LaTeX from string and return 'Pandoc' document. +readLaTeX :: PandocMonad m + => ReaderOptions -- ^ Reader options + -> Text -- ^ String to parse (assumes @'\n'@ line endings) + -> m Pandoc +readLaTeX opts ltx = do + parsed <- runParserT parseLaTeX def{ sOptions = opts } "source" + (tokenize "source" (crFilter ltx)) + case parsed of + Right result -> return result + Left e -> throwError $ PandocParsecError ltx e + +parseLaTeX :: PandocMonad m => LP m Pandoc +parseLaTeX = do + bs <- blocks + eof + st <- getState + let meta = sMeta st + let doc' = doc bs + let headerLevel (Header n _ _) = [n] + headerLevel _ = [] +#if MIN_VERSION_safe(0,3,18) + let bottomLevel = minimumBound 1 $ query headerLevel doc' +#else + let bottomLevel = minimumDef 1 $ query headerLevel doc' +#endif + let adjustHeaders m (Header n attr ils) = Header (n+m) attr ils + adjustHeaders _ x = x + let (Pandoc _ bs') = + -- handle the case where you have \part or \chapter + (if bottomLevel < 1 + then walk (adjustHeaders (1 - bottomLevel)) + else id) $ + walk (resolveRefs (sLabels st)) doc' + return $ Pandoc meta bs' + +resolveRefs :: M.Map Text [Inline] -> Inline -> Inline +resolveRefs labels x@(Link (ident,classes,kvs) _ _) = + case (lookup "reference-type" kvs, + lookup "reference" kvs) of + (Just "ref", Just lab) -> + case M.lookup lab labels of + Just txt -> Link (ident,classes,kvs) txt ("#" <> lab, "") + Nothing -> x + _ -> x +resolveRefs _ x = x + + +-- testParser :: LP PandocIO a -> Text -> IO a +-- testParser p t = do +-- res <- runIOorExplode (runParserT p defaultLaTeXState{ +-- sOptions = def{ readerExtensions = +-- enableExtension Ext_raw_tex $ +-- getDefaultExtensions "latex" }} "source" (tokenize "source" t)) +-- case res of +-- Left e -> error (show e) +-- Right r -> return r + + +rawLaTeXBlock :: (PandocMonad m, HasMacros s, HasReaderOptions s) + => ParserT Text s m Text +rawLaTeXBlock = do + lookAhead (try (char '\\' >> letter)) + inp <- getInput + let toks = tokenize "source" inp + snd <$> (rawLaTeXParser toks False (macroDef (const mempty)) blocks + <|> rawLaTeXParser toks True + (do choice (map controlSeq + ["include", "input", "subfile", "usepackage"]) + skipMany opt + braced + return mempty) blocks + <|> rawLaTeXParser toks True + (environment <|> blockCommand) + (mconcat <$> many (block <|> beginOrEndCommand))) + +-- See #4667 for motivation; sometimes people write macros +-- that just evaluate to a begin or end command, which blockCommand +-- won't accept. +beginOrEndCommand :: PandocMonad m => LP m Blocks +beginOrEndCommand = try $ do + Tok _ (CtrlSeq name) txt <- anyControlSeq + guard $ name == "begin" || name == "end" + (envname, rawargs) <- withRaw braced + if M.member (untokenize envname) + (inlineEnvironments :: M.Map Text (LP PandocPure Inlines)) + then mzero + else return $ rawBlock "latex" + (txt <> untokenize rawargs) + +rawLaTeXInline :: (PandocMonad m, HasMacros s, HasReaderOptions s) + => ParserT Text s m Text +rawLaTeXInline = do + lookAhead (try (char '\\' >> letter)) + inp <- getInput + let toks = tokenize "source" inp + raw <- snd <$> + ( rawLaTeXParser toks True + (mempty <$ (controlSeq "input" >> skipMany rawopt >> braced)) + inlines + <|> rawLaTeXParser toks True (inlineEnvironment <|> inlineCommand') + inlines + ) + finalbraces <- mconcat <$> many (try (string "{}")) -- see #5439 + return $ raw <> T.pack finalbraces + +inlineCommand :: PandocMonad m => ParserT Text ParserState m Inlines +inlineCommand = do + lookAhead (try (char '\\' >> letter)) + inp <- getInput + let toks = tokenize "source" inp + fst <$> rawLaTeXParser toks True (inlineEnvironment <|> inlineCommand') + inlines + +-- inline elements: + +word :: PandocMonad m => LP m Inlines +word = str . untoken <$> satisfyTok isWordTok + +inlineGroup :: PandocMonad m => LP m Inlines +inlineGroup = do + ils <- grouped inline + if null ils + then return mempty + else return $ spanWith nullAttr ils + -- we need the span so we can detitlecase bibtex entries; + -- we need to know when something is {C}apitalized + +doLHSverb :: PandocMonad m => LP m Inlines +doLHSverb = + codeWith ("",["haskell"],[]) . untokenize + <$> manyTill (satisfyTok (not . isNewlineTok)) (symbol '|') + +mkImage :: PandocMonad m => [(Text, Text)] -> Text -> LP m Inlines +mkImage options (T.unpack -> src) = do + let replaceTextwidth (k,v) = + case numUnit v of + Just (num, "\\textwidth") -> (k, showFl (num * 100) <> "%") + _ -> (k, v) + let kvs = map replaceTextwidth + $ filter (\(k,_) -> k `elem` ["width", "height"]) options + let attr = ("",[], kvs) + let alt = str "image" + defaultExt <- getOption readerDefaultImageExtension + let exts' = [".pdf", ".png", ".jpg", ".mps", ".jpeg", ".jbig2", ".jb2"] + let exts = exts' ++ map (map toUpper) exts' + let findFile s [] = return s + findFile s (e:es) = do + let s' = addExtension s e + exists <- fileExists s' + if exists + then return s' + else findFile s es + src' <- case takeExtension src of + "" | not (T.null defaultExt) -> return $ addExtension src $ T.unpack defaultExt + | otherwise -> findFile src exts + _ -> return src + return $ imageWith attr (T.pack src') "" alt + +doxspace :: PandocMonad m => LP m Inlines +doxspace = + (space <$ lookAhead (satisfyTok startsWithLetter)) <|> return mempty + where startsWithLetter (Tok _ Word t) = + case T.uncons t of + Just (c, _) | isLetter c -> True + _ -> False + startsWithLetter _ = False + + +removeDoubleQuotes :: Text -> Text +removeDoubleQuotes t = + Data.Maybe.fromMaybe t $ T.stripPrefix "\"" t >>= T.stripSuffix "\"" + +doubleQuote :: PandocMonad m => LP m Inlines +doubleQuote = + quoted' doubleQuoted (try $ count 2 $ symbol '`') + (void $ try $ count 2 $ symbol '\'') + <|> quoted' doubleQuoted ((:[]) <$> symbol '“') (void $ symbol '”') + -- the following is used by babel for localized quotes: + <|> quoted' doubleQuoted (try $ sequence [symbol '"', symbol '`']) + (void $ try $ sequence [symbol '"', symbol '\'']) + +singleQuote :: PandocMonad m => LP m Inlines +singleQuote = + quoted' singleQuoted ((:[]) <$> symbol '`') + (try $ symbol '\'' >> + notFollowedBy (satisfyTok startsWithLetter)) + <|> quoted' singleQuoted ((:[]) <$> symbol '‘') + (try $ symbol '’' >> + notFollowedBy (satisfyTok startsWithLetter)) + where startsWithLetter (Tok _ Word t) = + case T.uncons t of + Just (c, _) | isLetter c -> True + _ -> False + startsWithLetter _ = False + +quoted' :: PandocMonad m + => (Inlines -> Inlines) + -> LP m [Tok] + -> LP m () + -> LP m Inlines +quoted' f starter ender = do + startchs <- untokenize <$> starter + smart <- extensionEnabled Ext_smart <$> getOption readerExtensions + if smart + then do + ils <- many (notFollowedBy ender >> inline) + (ender >> return (f (mconcat ils))) <|> + (<> mconcat ils) <$> + lit (case startchs of + "``" -> "“" + "`" -> "‘" + cs -> cs) + else lit startchs + +lit :: Text -> LP m Inlines +lit = pure . str + +blockquote :: PandocMonad m => Bool -> Maybe Text -> LP m Blocks +blockquote cvariant mblang = do + citepar <- if cvariant + then (\xs -> para (cite xs mempty)) + <$> cites inline NormalCitation False + else option mempty $ para <$> bracketed inline + let lang = mblang >>= babelLangToBCP47 + let langdiv = case lang of + Nothing -> id + Just l -> divWith ("",[],[("lang", renderLang l)]) + _closingPunct <- option mempty $ bracketed inline -- currently ignored + bs <- grouped block + optional $ symbolIn (".:;?!" :: [Char]) -- currently ignored + return $ blockQuote . langdiv $ (bs <> citepar) + +inlineCommand' :: PandocMonad m => LP m Inlines +inlineCommand' = try $ do + Tok _ (CtrlSeq name) cmd <- anyControlSeq + guard $ name /= "begin" && name /= "end" && name /= "and" + star <- option "" ("*" <$ symbol '*' <* sp) + overlay <- option "" overlaySpecification + let name' = name <> star <> overlay + let names = ordNub [name', name] -- check non-starred as fallback + let raw = do + guard $ isInlineCommand name || not (isBlockCommand name) + rawcommand <- getRawCommand name (cmd <> star) + (guardEnabled Ext_raw_tex >> return (rawInline "latex" rawcommand)) + <|> ignore rawcommand + lookupListDefault raw names inlineCommands + +tok :: PandocMonad m => LP m Inlines +tok = tokWith inline + +unescapeURL :: Text -> Text +unescapeURL = T.concat . go . T.splitOn "\\" + where + isEscapable c = c `elemText` "#$%&~_^\\{}" + go (x:xs) = x : map unescapeInterior xs + go [] = [] + unescapeInterior t + | Just (c, _) <- T.uncons t + , isEscapable c = t + | otherwise = "\\" <> t + +inlineCommands :: PandocMonad m => M.Map Text (LP m Inlines) +inlineCommands = M.unions + [ accentCommands tok + , citationCommands inline + , siunitxCommands tok + , acronymCommands + , refCommands + , nameCommands + , verbCommands + , charCommands + , enquoteCommands tok + , inlineLanguageCommands tok + , biblatexInlineCommands tok + , rest ] + where + rest = M.fromList + [ ("emph", extractSpaces emph <$> tok) + , ("textit", extractSpaces emph <$> tok) + , ("textsl", extractSpaces emph <$> tok) + , ("textsc", extractSpaces smallcaps <$> tok) + , ("textsf", extractSpaces (spanWith ("",["sans-serif"],[])) <$> tok) + , ("textmd", extractSpaces (spanWith ("",["medium"],[])) <$> tok) + , ("textrm", extractSpaces (spanWith ("",["roman"],[])) <$> tok) + , ("textup", extractSpaces (spanWith ("",["upright"],[])) <$> tok) + , ("texttt", ttfamily) + , ("sout", extractSpaces strikeout <$> tok) + , ("alert", skipopts >> spanWith ("",["alert"],[]) <$> tok) -- beamer + , ("textsuperscript", extractSpaces superscript <$> tok) + , ("textsubscript", extractSpaces subscript <$> tok) + , ("textbf", extractSpaces strong <$> tok) + , ("textnormal", extractSpaces (spanWith ("",["nodecor"],[])) <$> tok) + , ("underline", underline <$> tok) + , ("mbox", rawInlineOr "mbox" $ processHBox <$> tok) + , ("hbox", rawInlineOr "hbox" $ processHBox <$> tok) + , ("lettrine", rawInlineOr "lettrine" lettrine) + , ("(", mathInline . untokenize <$> manyTill anyTok (controlSeq ")")) + , ("[", mathDisplay . untokenize <$> manyTill anyTok (controlSeq "]")) + , ("ensuremath", mathInline . untokenize <$> braced) + , ("texorpdfstring", const <$> tok <*> tok) + -- old TeX commands + , ("em", extractSpaces emph <$> inlines) + , ("it", extractSpaces emph <$> inlines) + , ("sl", extractSpaces emph <$> inlines) + , ("bf", extractSpaces strong <$> inlines) + , ("tt", code . stringify . toList <$> inlines) + , ("rm", inlines) + , ("itshape", extractSpaces emph <$> inlines) + , ("slshape", extractSpaces emph <$> inlines) + , ("scshape", extractSpaces smallcaps <$> inlines) + , ("bfseries", extractSpaces strong <$> inlines) + , ("MakeUppercase", makeUppercase <$> tok) + , ("MakeTextUppercase", makeUppercase <$> tok) -- textcase + , ("uppercase", makeUppercase <$> tok) + , ("MakeLowercase", makeLowercase <$> tok) + , ("MakeTextLowercase", makeLowercase <$> tok) + , ("lowercase", makeLowercase <$> tok) + , ("thanks", skipopts >> note <$> grouped block) + , ("footnote", skipopts >> note <$> grouped block) + , ("passthrough", tok) -- \passthrough macro used by latex writer + -- for listings + , ("includegraphics", do options <- option [] keyvals + src <- braced + mkImage options . + unescapeURL . + removeDoubleQuotes $ untokenize src) + -- hyperref + , ("url", (\url -> link url "" (str url)) . unescapeURL . untokenize <$> + bracedUrl) + , ("nolinkurl", code . unescapeURL . untokenize <$> bracedUrl) + , ("href", do url <- bracedUrl + sp + link (unescapeURL $ untokenize url) "" <$> tok) + , ("hyperlink", hyperlink) + , ("hyperref", hyperref) + , ("hypertarget", hypertargetInline) + -- hyphenat + , ("nohyphens", tok) + , ("textnhtt", ttfamily) + , ("nhttfamily", ttfamily) + -- LaTeX colors + , ("textcolor", coloredInline "color") + , ("colorbox", coloredInline "background-color") + -- xspace + , ("xspace", doxspace) + -- etoolbox + , ("ifstrequal", ifstrequal) + , ("newtoggle", braced >>= newToggle) + , ("toggletrue", braced >>= setToggle True) + , ("togglefalse", braced >>= setToggle False) + , ("iftoggle", try $ ifToggle >> inline) + -- include + , ("input", rawInlineOr "input" $ include "input") + -- soul package + , ("ul", underline <$> tok) + -- ulem package + , ("uline", underline <$> tok) + -- plain tex stuff that should just be passed through as raw tex + , ("ifdim", ifdim) + ] + +lettrine :: PandocMonad m => LP m Inlines +lettrine = do + optional rawopt + x <- tok + y <- tok + return $ extractSpaces (spanWith ("",["lettrine"],[])) x <> smallcaps y + +ifdim :: PandocMonad m => LP m Inlines +ifdim = do + contents <- manyTill anyTok (controlSeq "fi") + return $ rawInline "latex" $ "\\ifdim" <> untokenize contents <> "\\fi" + +makeUppercase :: Inlines -> Inlines +makeUppercase = fromList . walk (alterStr T.toUpper) . toList + +makeLowercase :: Inlines -> Inlines +makeLowercase = fromList . walk (alterStr T.toLower) . toList + +alterStr :: (Text -> Text) -> Inline -> Inline +alterStr f (Str xs) = Str (f xs) +alterStr _ x = x + +hyperlink :: PandocMonad m => LP m Inlines +hyperlink = try $ do + src <- untokenize <$> braced + lab <- tok + return $ link ("#" <> src) "" lab + +hyperref :: PandocMonad m => LP m Inlines +hyperref = try $ do + url <- (("#" <>) . untokenize <$> try (sp *> bracketedToks <* sp)) + <|> untokenize <$> (bracedUrl <* bracedUrl <* bracedUrl) + link url "" <$> tok + +hypertargetBlock :: PandocMonad m => LP m Blocks +hypertargetBlock = try $ do + ref <- untokenize <$> braced + bs <- grouped block + case toList bs of + [Header 1 (ident,_,_) _] | ident == ref -> return bs + _ -> return $ divWith (ref, [], []) bs + +hypertargetInline :: PandocMonad m => LP m Inlines +hypertargetInline = try $ do + ref <- untokenize <$> braced + ils <- grouped inline + return $ spanWith (ref, [], []) ils + +newToggle :: (Monoid a, PandocMonad m) => [Tok] -> LP m a +newToggle name = do + updateState $ \st -> + st{ sToggles = M.insert (untokenize name) False (sToggles st) } + return mempty + +setToggle :: (Monoid a, PandocMonad m) => Bool -> [Tok] -> LP m a +setToggle on name = do + updateState $ \st -> + st{ sToggles = M.adjust (const on) (untokenize name) (sToggles st) } + return mempty + +ifToggle :: PandocMonad m => LP m () +ifToggle = do + name <- braced + spaces + yes <- braced + spaces + no <- braced + toggles <- sToggles <$> getState + inp <- getInput + let name' = untokenize name + case M.lookup name' toggles of + Just True -> setInput (yes ++ inp) + Just False -> setInput (no ++ inp) + Nothing -> do + pos <- getPosition + report $ UndefinedToggle name' pos + return () + +ifstrequal :: (PandocMonad m, Monoid a) => LP m a +ifstrequal = do + str1 <- tok + str2 <- tok + ifequal <- braced + ifnotequal <- braced + if str1 == str2 + then getInput >>= setInput . (ifequal ++) + else getInput >>= setInput . (ifnotequal ++) + return mempty + +coloredInline :: PandocMonad m => Text -> LP m Inlines +coloredInline stylename = do + skipopts + color <- braced + spanWith ("",[],[("style",stylename <> ": " <> untokenize color)]) <$> tok + +ttfamily :: PandocMonad m => LP m Inlines +ttfamily = code . stringify . toList <$> tok + +processHBox :: Inlines -> Inlines +processHBox = walk convert + where + convert Space = Str $ T.singleton $ chr 160 -- non-breakable space + convert SoftBreak = Str $ T.singleton $ chr 160 -- non-breakable space + convert LineBreak = Str "" + convert x = x + +isBlockCommand :: Text -> Bool +isBlockCommand s = + s `M.member` (blockCommands :: M.Map Text (LP PandocPure Blocks)) + || s `Set.member` treatAsBlock + +treatAsBlock :: Set.Set Text +treatAsBlock = Set.fromList + [ "special", "pdfannot", "pdfstringdef" + , "bibliographystyle" + , "maketitle", "makeindex", "makeglossary" + , "addcontentsline", "addtocontents", "addtocounter" + -- \ignore{} is used conventionally in literate haskell for definitions + -- that are to be processed by the compiler but not printed. + , "ignore" + , "hyperdef" + , "markboth", "markright", "markleft" + , "hspace", "vspace" + , "newpage" + , "clearpage" + , "pagebreak" + , "titleformat" + , "listoffigures" + , "listoftables" + , "write" + ] + +isInlineCommand :: Text -> Bool +isInlineCommand s = + s `M.member` (inlineCommands :: M.Map Text (LP PandocPure Inlines)) + || s `Set.member` treatAsInline + +treatAsInline :: Set.Set Text +treatAsInline = Set.fromList + [ "index" + , "hspace" + , "vspace" + , "noindent" + , "newpage" + , "clearpage" + , "pagebreak" + ] + +lookupListDefault :: (Ord k) => v -> [k] -> M.Map k v -> v +lookupListDefault d = (fromMaybe d .) . lookupList + where lookupList l m = msum $ map (`M.lookup` m) l + +inline :: PandocMonad m => LP m Inlines +inline = do + Tok pos toktype t <- lookAhead anyTok + let symbolAsString = str . untoken <$> anySymbol + let unescapedSymbolAsString = + do s <- untoken <$> anySymbol + report $ ParsingUnescaped s pos + return $ str s + case toktype of + Comment -> mempty <$ comment + Spaces -> space <$ whitespace + Newline -> softbreak <$ endline + Word -> word + Esc1 -> str . T.singleton <$> primEscape + Esc2 -> str . T.singleton <$> primEscape + Symbol -> + case t of + "-" -> symbol '-' *> + option (str "-") (symbol '-' *> + option (str "–") (str "—" <$ symbol '-')) + "'" -> symbol '\'' *> + option (str "’") (str "”" <$ symbol '\'') + "~" -> str "\160" <$ symbol '~' + "`" -> doubleQuote <|> singleQuote <|> symbolAsString + "\"" -> doubleQuote <|> singleQuote <|> symbolAsString + "“" -> doubleQuote <|> symbolAsString + "‘" -> singleQuote <|> symbolAsString + "$" -> dollarsMath <|> unescapedSymbolAsString + "|" -> (guardEnabled Ext_literate_haskell *> + symbol '|' *> doLHSverb) <|> symbolAsString + "{" -> inlineGroup + "#" -> unescapedSymbolAsString + "&" -> unescapedSymbolAsString + "_" -> unescapedSymbolAsString + "^" -> unescapedSymbolAsString + "\\" -> mzero + "}" -> mzero + _ -> symbolAsString + CtrlSeq _ -> macroDef (rawInline "latex") + <|> inlineCommand' + <|> inlineEnvironment + <|> inlineGroup + _ -> mzero + +inlines :: PandocMonad m => LP m Inlines +inlines = mconcat <$> many inline + +opt :: PandocMonad m => LP m Inlines +opt = do + toks <- try (sp *> bracketedToks <* sp) + -- now parse the toks as inlines + st <- getState + parsed <- runParserT (mconcat <$> many inline) st "bracketed option" toks + case parsed of + Right result -> return result + Left e -> throwError $ PandocParsecError (untokenize toks) e + +-- block elements: + +preamble :: PandocMonad m => LP m Blocks +preamble = mconcat <$> many preambleBlock + where preambleBlock = (mempty <$ spaces1) + <|> macroDef (rawBlock "latex") + <|> filecontents + <|> (mempty <$ blockCommand) + <|> (mempty <$ braced) + <|> (do notFollowedBy (begin_ "document") + anyTok + return mempty) + +rule :: PandocMonad m => LP m Blocks +rule = do + skipopts + width <- T.takeWhile (\c -> isDigit c || c == '.') . stringify <$> tok + _thickness <- tok + -- 0-width rules are used to fix spacing issues: + case safeRead width of + Just (0 :: Double) -> return mempty + _ -> return horizontalRule + +paragraph :: PandocMonad m => LP m Blocks +paragraph = do + x <- trimInlines . mconcat <$> many1 inline + if x == mempty + then return mempty + else return $ para x + +rawBlockOr :: PandocMonad m => Text -> LP m Blocks -> LP m Blocks +rawBlockOr name fallback = do + -- if raw_tex allowed, don't process + parseRaw <- extensionEnabled Ext_raw_tex <$> getOption readerExtensions + if parseRaw + then rawBlock "latex" <$> getRawCommand name ("\\" <> name) + else fallback + +doSubfile :: PandocMonad m => LP m Blocks +doSubfile = do + skipMany opt + f <- T.unpack . removeDoubleQuotes . T.strip . untokenize <$> braced + oldToks <- getInput + setInput [] + insertIncluded ".tex" f + bs <- blocks + eof + setInput oldToks + return bs + +include :: (PandocMonad m, Monoid a) => Text -> LP m a +include name = do + skipMany opt + fs <- map (T.unpack . removeDoubleQuotes . T.strip) . T.splitOn "," . + untokenize <$> braced + let defaultExt | name == "usepackage" = ".sty" + | otherwise = ".tex" + mapM_ (insertIncluded defaultExt) fs + return mempty + +readFileFromTexinputs :: PandocMonad m => FilePath -> LP m (Maybe Text) +readFileFromTexinputs fp = do + fileContentsMap <- sFileContents <$> getState + case M.lookup (T.pack fp) fileContentsMap of + Just t -> return (Just t) + Nothing -> do + dirs <- map T.unpack . splitTextBy (==':') . fromMaybe "." + <$> lookupEnv "TEXINPUTS" + readFileFromDirs dirs fp + +insertIncluded :: PandocMonad m + => FilePath + -> FilePath + -> LP m () +insertIncluded defaultExtension f' = do + let f = case takeExtension f' of + ".tex" -> f' + ".sty" -> f' + _ -> addExtension f' defaultExtension + pos <- getPosition + containers <- getIncludeFiles <$> getState + when (T.pack f `elem` containers) $ + throwError $ PandocParseError $ T.pack $ "Include file loop at " ++ show pos + updateState $ addIncludeFile $ T.pack f + mbcontents <- readFileFromTexinputs f + contents <- case mbcontents of + Just s -> return s + Nothing -> do + report $ CouldNotLoadIncludeFile (T.pack f) pos + return "" + getInput >>= setInput . (tokenize f contents ++) + updateState dropLatestIncludeFile + +authors :: PandocMonad m => LP m () +authors = try $ do + bgroup + let oneAuthor = blocksToInlines' . B.toList . mconcat <$> many1 block + auths <- sepBy oneAuthor (controlSeq "and") + egroup + addMeta "author" (map trimInlines auths) + +looseItem :: PandocMonad m => LP m Blocks +looseItem = do + inListItem <- sInListItem <$> getState + guard $ not inListItem + skipopts + return mempty + +epigraph :: PandocMonad m => LP m Blocks +epigraph = do + p1 <- grouped block + p2 <- grouped block + return $ divWith ("", ["epigraph"], []) (p1 <> p2) + +section :: PandocMonad m => Attr -> Int -> LP m Blocks +section (ident, classes, kvs) lvl = do + skipopts + contents <- grouped inline + lab <- option ident $ + try (spaces >> controlSeq "label" + >> spaces >> untokenize <$> braced) + when (lvl == 0) $ + updateState $ \st -> st{ sHasChapters = True } + unless ("unnumbered" `elem` classes) $ do + hn <- sLastHeaderNum <$> getState + hasChapters <- sHasChapters <$> getState + let lvl' = lvl + if hasChapters then 1 else 0 + let num = incrementDottedNum lvl' hn + updateState $ \st -> st{ sLastHeaderNum = num + , sLabels = M.insert lab + [Str (renderDottedNum num)] + (sLabels st) } + attr' <- registerHeader (lab, classes, kvs) contents + return $ headerWith attr' lvl contents + +blockCommand :: PandocMonad m => LP m Blocks +blockCommand = try $ do + Tok _ (CtrlSeq name) txt <- anyControlSeq + guard $ name /= "begin" && name /= "end" && name /= "and" + star <- option "" ("*" <$ symbol '*' <* sp) + let name' = name <> star + let names = ordNub [name', name] + let rawDefiniteBlock = do + guard $ isBlockCommand name + rawcontents <- getRawCommand name (txt <> star) + (guardEnabled Ext_raw_tex >> return (rawBlock "latex" rawcontents)) + <|> ignore rawcontents + -- heuristic: if it could be either block or inline, we + -- treat it if block if we have a sequence of block + -- commands followed by a newline. But we stop if we + -- hit a \startXXX, since this might start a raw ConTeXt + -- environment (this is important because this parser is + -- used by the Markdown reader). + let startCommand = try $ do + Tok _ (CtrlSeq n) _ <- anyControlSeq + guard $ "start" `T.isPrefixOf` n + let rawMaybeBlock = try $ do + guard $ not $ isInlineCommand name + rawcontents <- getRawCommand name (txt <> star) + curr <- (guardEnabled Ext_raw_tex >> + return (rawBlock "latex" rawcontents)) + <|> ignore rawcontents + rest <- many $ notFollowedBy startCommand *> blockCommand + lookAhead $ blankline <|> startCommand + return $ curr <> mconcat rest + let raw = rawDefiniteBlock <|> rawMaybeBlock + lookupListDefault raw names blockCommands + +closing :: PandocMonad m => LP m Blocks +closing = do + contents <- tok + st <- getState + let extractInlines (MetaBlocks [Plain ys]) = ys + extractInlines (MetaBlocks [Para ys ]) = ys + extractInlines _ = [] + let sigs = case lookupMeta "author" (sMeta st) of + Just (MetaList xs) -> + para $ trimInlines $ fromList $ + intercalate [LineBreak] $ map extractInlines xs + _ -> mempty + return $ para (trimInlines contents) <> sigs + +parbox :: PandocMonad m => LP m Blocks +parbox = try $ do + skipopts + braced -- size + oldInTableCell <- sInTableCell <$> getState + -- see #5711 + updateState $ \st -> st{ sInTableCell = False } + res <- grouped block + updateState $ \st -> st{ sInTableCell = oldInTableCell } + return res + +blockCommands :: PandocMonad m => M.Map Text (LP m Blocks) +blockCommands = M.fromList + [ ("par", mempty <$ skipopts) + , ("parbox", parbox) + , ("title", mempty <$ (skipopts *> + (grouped inline >>= addMeta "title") + <|> (grouped block >>= addMeta "title"))) + , ("subtitle", mempty <$ (skipopts *> tok >>= addMeta "subtitle")) + , ("author", mempty <$ (skipopts *> authors)) + -- -- in letter class, temp. store address & sig as title, author + , ("address", mempty <$ (skipopts *> tok >>= addMeta "address")) + , ("signature", mempty <$ (skipopts *> authors)) + , ("date", mempty <$ (skipopts *> tok >>= addMeta "date")) + , ("newtheorem", newtheorem inline) + , ("theoremstyle", theoremstyle) + -- KOMA-Script metadata commands + , ("extratitle", mempty <$ (skipopts *> tok >>= addMeta "extratitle")) + , ("frontispiece", mempty <$ (skipopts *> tok >>= addMeta "frontispiece")) + , ("titlehead", mempty <$ (skipopts *> tok >>= addMeta "titlehead")) + , ("subject", mempty <$ (skipopts *> tok >>= addMeta "subject")) + , ("publishers", mempty <$ (skipopts *> tok >>= addMeta "publishers")) + , ("uppertitleback", mempty <$ (skipopts *> tok >>= addMeta "uppertitleback")) + , ("lowertitleback", mempty <$ (skipopts *> tok >>= addMeta "lowertitleback")) + , ("dedication", mempty <$ (skipopts *> tok >>= addMeta "dedication")) + -- sectioning + , ("part", section nullAttr (-1)) + , ("part*", section nullAttr (-1)) + , ("chapter", section nullAttr 0) + , ("chapter*", section ("",["unnumbered"],[]) 0) + , ("section", section nullAttr 1) + , ("section*", section ("",["unnumbered"],[]) 1) + , ("subsection", section nullAttr 2) + , ("subsection*", section ("",["unnumbered"],[]) 2) + , ("subsubsection", section nullAttr 3) + , ("subsubsection*", section ("",["unnumbered"],[]) 3) + , ("paragraph", section nullAttr 4) + , ("paragraph*", section ("",["unnumbered"],[]) 4) + , ("subparagraph", section nullAttr 5) + , ("subparagraph*", section ("",["unnumbered"],[]) 5) + -- beamer slides + , ("frametitle", section nullAttr 3) + , ("framesubtitle", section nullAttr 4) + -- letters + , ("opening", para . trimInlines <$> (skipopts *> tok)) + , ("closing", skipopts *> closing) + -- memoir + , ("plainbreak", braced >> pure horizontalRule) + , ("plainbreak*", braced >> pure horizontalRule) + , ("fancybreak", braced >> pure horizontalRule) + , ("fancybreak*", braced >> pure horizontalRule) + , ("plainfancybreak", braced >> braced >> braced >> pure horizontalRule) + , ("plainfancybreak*", braced >> braced >> braced >> pure horizontalRule) + , ("pfbreak", pure horizontalRule) + , ("pfbreak*", pure horizontalRule) + -- + , ("hrule", pure horizontalRule) + , ("strut", pure mempty) + , ("rule", rule) + , ("item", looseItem) + , ("documentclass", skipopts *> braced *> preamble) + , ("centerline", para . trimInlines <$> (skipopts *> tok)) + , ("caption", mempty <$ setCaption inline) + , ("bibliography", mempty <$ (skipopts *> braced >>= + addMeta "bibliography" . splitBibs . untokenize)) + , ("addbibresource", mempty <$ (skipopts *> braced >>= + addMeta "bibliography" . splitBibs . untokenize)) + , ("endinput", mempty <$ skipMany anyTok) + -- includes + , ("lstinputlisting", inputListing) + , ("inputminted", inputMinted) + , ("graphicspath", graphicsPath) + -- polyglossia + , ("setdefaultlanguage", setDefaultLanguage) + , ("setmainlanguage", setDefaultLanguage) + -- hyperlink + , ("hypertarget", hypertargetBlock) + -- LaTeX colors + , ("textcolor", coloredBlock "color") + , ("colorbox", coloredBlock "background-color") + -- csquotes + , ("blockquote", blockquote False Nothing) + , ("blockcquote", blockquote True Nothing) + , ("foreignblockquote", braced >>= blockquote False . Just . untokenize) + , ("foreignblockcquote", braced >>= blockquote True . Just . untokenize) + , ("hyphenblockquote", braced >>= blockquote False . Just . untokenize) + , ("hyphenblockcquote", braced >>= blockquote True . Just . untokenize) + -- include + , ("include", rawBlockOr "include" $ include "include") + , ("input", rawBlockOr "input" $ include "input") + , ("subfile", rawBlockOr "subfile" doSubfile) + , ("usepackage", rawBlockOr "usepackage" $ include "usepackage") + -- preamble + , ("PackageError", mempty <$ (braced >> braced >> braced)) + -- epigraph package + , ("epigraph", epigraph) + ] + + +environments :: PandocMonad m => M.Map Text (LP m Blocks) +environments = M.union (tableEnvironments blocks inline) $ + M.fromList + [ ("document", env "document" blocks <* skipMany anyTok) + , ("abstract", mempty <$ (env "abstract" blocks >>= addMeta "abstract")) + , ("sloppypar", env "sloppypar" blocks) + , ("letter", env "letter" letterContents) + , ("minipage", env "minipage" $ + skipopts *> spaces *> optional braced *> spaces *> blocks) + , ("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) + , ("verse", blockQuote <$> env "verse" blocks) + , ("itemize", bulletList <$> listenv "itemize" (many item)) + , ("description", definitionList <$> listenv "description" (many descItem)) + , ("enumerate", orderedList') + , ("alltt", alltt <$> env "alltt" blocks) + , ("code", guardEnabled Ext_literate_haskell *> + (codeBlockWith ("",["haskell","literate"],[]) <$> verbEnv "code")) + , ("comment", mempty <$ verbEnv "comment") + , ("verbatim", codeBlock <$> verbEnv "verbatim") + , ("Verbatim", fancyverbEnv "Verbatim") + , ("BVerbatim", fancyverbEnv "BVerbatim") + , ("lstlisting", do attr <- parseListingsOptions <$> option [] keyvals + codeBlockWith attr <$> verbEnv "lstlisting") + , ("minted", minted) + , ("obeylines", obeylines) + , ("tikzpicture", rawVerbEnv "tikzpicture") + , ("tikzcd", rawVerbEnv "tikzcd") + , ("lilypond", rawVerbEnv "lilypond") + , ("ly", rawVerbEnv "ly") + -- amsthm + , ("proof", proof blocks opt) + -- etoolbox + , ("ifstrequal", ifstrequal) + , ("newtoggle", braced >>= newToggle) + , ("toggletrue", braced >>= setToggle True) + , ("togglefalse", braced >>= setToggle False) + , ("iftoggle", try $ ifToggle >> block) + ] + +filecontents :: PandocMonad m => LP m Blocks +filecontents = try $ do + controlSeq "begin" + name <- untokenize <$> braced + guard $ name == "filecontents" || name == "filecontents*" + skipopts + fp <- untokenize <$> braced + txt <- verbEnv name + updateState $ \st -> + st{ sFileContents = M.insert fp txt (sFileContents st) } + return mempty + +environment :: PandocMonad m => LP m Blocks +environment = try $ do + controlSeq "begin" + name <- untokenize <$> braced + M.findWithDefault mzero name environments <|> + theoremEnvironment blocks opt name <|> + if M.member name (inlineEnvironments + :: M.Map Text (LP PandocPure Inlines)) + then mzero + else try (rawEnv name) <|> rawVerbEnv name + +rawEnv :: PandocMonad m => Text -> LP m Blocks +rawEnv name = do + exts <- getOption readerExtensions + let parseRaw = extensionEnabled Ext_raw_tex exts + rawOptions <- mconcat <$> many rawopt + let beginCommand = "\\begin{" <> name <> "}" <> rawOptions + pos1 <- getPosition + if parseRaw + then do + (_, raw) <- withRaw $ env name blocks + return $ rawBlock "latex" + $ beginCommand <> untokenize raw + else do + bs <- env name blocks + report $ SkippedContent beginCommand pos1 + pos2 <- getPosition + report $ SkippedContent ("\\end{" <> name <> "}") pos2 + return $ divWith ("",[name],[]) bs + +rawVerbEnv :: PandocMonad m => Text -> LP m Blocks +rawVerbEnv name = do + pos <- getPosition + (_, raw) <- withRaw $ verbEnv name + let raw' = "\\begin{" <> name <> "}" <> untokenize raw + exts <- getOption readerExtensions + let parseRaw = extensionEnabled Ext_raw_tex exts + if parseRaw + then return $ rawBlock "latex" raw' + else do + report $ SkippedContent raw' pos + return mempty + +fancyverbEnv :: PandocMonad m => Text -> LP m Blocks +fancyverbEnv name = do + options <- option [] keyvals + let kvs = [ (if k == "firstnumber" + then "startFrom" + else k, v) | (k,v) <- options ] + let classes = [ "numberLines" | + lookup "numbers" options == Just "left" ] + let attr = ("",classes,kvs) + codeBlockWith attr <$> verbEnv name + +obeylines :: PandocMonad m => LP m Blocks +obeylines = + para . fromList . removeLeadingTrailingBreaks . + walk softBreakToHard . toList <$> env "obeylines" inlines + where softBreakToHard SoftBreak = LineBreak + softBreakToHard x = x + removeLeadingTrailingBreaks = reverse . dropWhile isLineBreak . + reverse . dropWhile isLineBreak + isLineBreak LineBreak = True + isLineBreak _ = False + +minted :: PandocMonad m => LP m Blocks +minted = do + attr <- mintedAttr + codeBlockWith attr <$> verbEnv "minted" + +mintedAttr :: PandocMonad m => LP m Attr +mintedAttr = do + options <- option [] keyvals + lang <- untokenize <$> braced + let kvs = [ (if k == "firstnumber" + then "startFrom" + else k, v) | (k,v) <- options ] + let classes = [ lang | not (T.null lang) ] ++ + [ "numberLines" | + lookup "linenos" options == Just "true" ] + return ("",classes,kvs) + +inputMinted :: PandocMonad m => LP m Blocks +inputMinted = do + pos <- getPosition + attr <- mintedAttr + f <- T.filter (/='"') . untokenize <$> braced + mbCode <- readFileFromTexinputs (T.unpack f) + rawcode <- case mbCode of + Just s -> return s + Nothing -> do + report $ CouldNotLoadIncludeFile f pos + return "" + return $ B.codeBlockWith attr rawcode + +letterContents :: PandocMonad m => LP m Blocks +letterContents = do + bs <- blocks + st <- getState + -- add signature (author) and address (title) + let addr = case lookupMeta "address" (sMeta st) of + Just (MetaBlocks [Plain xs]) -> + para $ trimInlines $ fromList xs + _ -> mempty + return $ addr <> bs -- sig added by \closing + +figure :: PandocMonad m => LP m Blocks +figure = try $ do + resetCaption + blocks >>= addImageCaption + +addImageCaption :: PandocMonad m => Blocks -> LP m Blocks +addImageCaption = walkM go + where go (Image attr@(_, cls, kvs) alt (src,tit)) + | not ("fig:" `T.isPrefixOf` tit) = do + st <- getState + let (alt', tit') = case sCaption st of + Just ils -> (toList ils, "fig:" <> tit) + Nothing -> (alt, tit) + attr' = case sLastLabel st 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) } + return $ Image attr' alt' (src, tit') + go x = return x + +coloredBlock :: PandocMonad m => Text -> LP m Blocks +coloredBlock stylename = try $ do + skipopts + color <- braced + notFollowedBy (grouped inline) + let constructor = divWith ("",[],[("style",stylename <> ": " <> untokenize color)]) + constructor <$> grouped block + +graphicsPath :: PandocMonad m => LP m Blocks +graphicsPath = do + ps <- map (T.unpack . untokenize) <$> + (bgroup *> spaces *> manyTill (braced <* spaces) egroup) + getResourcePath >>= setResourcePath . (<> ps) + return mempty + +splitBibs :: Text -> [Inlines] +splitBibs = map (str . T.pack . flip replaceExtension "bib" . T.unpack . trim) . splitTextBy (==',') + +alltt :: Blocks -> Blocks +alltt = walk strToCode + where strToCode (Str s) = Code nullAttr s + strToCode Space = RawInline (Format "latex") "\\ " + strToCode SoftBreak = LineBreak + strToCode x = x + +parseListingsOptions :: [(Text, Text)] -> Attr +parseListingsOptions options = + let kvs = [ (if k == "firstnumber" + then "startFrom" + else k, v) | (k,v) <- options ] + classes = [ "numberLines" | + lookup "numbers" options == Just "left" ] + ++ maybeToList (listingsLanguage options) + in (fromMaybe "" (lookup "label" options), classes, kvs) + +inputListing :: PandocMonad m => LP m Blocks +inputListing = do + pos <- getPosition + options <- option [] keyvals + f <- T.filter (/='"') . untokenize <$> braced + mbCode <- readFileFromTexinputs (T.unpack f) + codeLines <- case mbCode of + Just s -> return $ T.lines s + Nothing -> do + report $ CouldNotLoadIncludeFile f pos + return [] + let (ident,classes,kvs) = parseListingsOptions options + let classes' = + (case listingsLanguage options of + Nothing -> (take 1 (languagesByExtension (T.pack $ takeExtension $ T.unpack f)) <>) + Just _ -> id) classes + let firstline = fromMaybe 1 $ lookup "firstline" options >>= safeRead + let lastline = fromMaybe (length codeLines) $ + lookup "lastline" options >>= safeRead + let codeContents = T.intercalate "\n" $ take (1 + lastline - firstline) $ + drop (firstline - 1) codeLines + return $ codeBlockWith (ident,classes',kvs) codeContents + +-- lists + +item :: PandocMonad m => LP m Blocks +item = void blocks *> controlSeq "item" *> skipopts *> blocks + +descItem :: PandocMonad m => LP m (Inlines, [Blocks]) +descItem = do + blocks -- skip blocks before item + controlSeq "item" + sp + ils <- opt + bs <- blocks + return (ils, [bs]) + +listenv :: PandocMonad m => Text -> LP m a -> LP m a +listenv name p = try $ do + oldInListItem <- sInListItem `fmap` getState + updateState $ \st -> st{ sInListItem = True } + res <- env name p + updateState $ \st -> st{ sInListItem = oldInListItem } + return res + +orderedList' :: PandocMonad m => LP m Blocks +orderedList' = try $ do + spaces + let markerSpec = do + symbol '[' + ts <- untokenize <$> manyTill anyTok (symbol ']') + case runParser anyOrderedListMarker def "option" ts of + Right r -> return r + Left _ -> do + pos <- getPosition + report $ SkippedContent ("[" <> ts <> "]") pos + return (1, DefaultStyle, DefaultDelim) + (_, style, delim) <- option (1, DefaultStyle, DefaultDelim) markerSpec + spaces + optional $ try $ controlSeq "setlength" + *> grouped (count 1 $ controlSeq "itemindent") + *> braced + spaces + start <- option 1 $ try $ do pos <- getPosition + controlSeq "setcounter" + ctr <- untokenize <$> braced + guard $ "enum" `T.isPrefixOf` ctr + guard $ T.all (`elem` ['i','v']) (T.drop 4 ctr) + sp + num <- untokenize <$> braced + case safeRead num of + Just i -> return (i + 1 :: Int) + Nothing -> do + report $ SkippedContent + ("\\setcounter{" <> ctr <> + "}{" <> num <> "}") pos + return 1 + bs <- listenv "enumerate" (many item) + return $ orderedListWith (start, style, delim) bs + +block :: PandocMonad m => LP m Blocks +block = do + Tok _ toktype _ <- lookAhead anyTok + res <- (case toktype of + Newline -> mempty <$ spaces1 + Spaces -> mempty <$ spaces1 + Comment -> mempty <$ spaces1 + Word -> paragraph + CtrlSeq "begin" -> environment + CtrlSeq _ -> macroDef (rawBlock "latex") + <|> blockCommand + _ -> mzero) + <|> paragraph + <|> grouped block + trace (T.take 60 $ tshow $ B.toList res) + return res + +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 new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/Readers/LaTeX/Citation.hs @@ -0,0 +1,210 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +module Text.Pandoc.Readers.LaTeX.Citation + ( citationCommands + , cites + ) +where + +import Text.Pandoc.Class +import Text.Pandoc.Readers.LaTeX.Parsing +import Text.Pandoc.Builder as B +import qualified Data.Map as M +import Data.Text (Text) +import Control.Applicative ((<|>), optional, many) +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, (<|>)) + +citationCommands :: PandocMonad m => LP m Inlines -> M.Map Text (LP m Inlines) +citationCommands inline = + let citation = citationWith inline + tok = spaces *> grouped inline + in M.fromList + [ ("cite", citation "cite" NormalCitation False) + , ("Cite", citation "Cite" NormalCitation False) + , ("citep", citation "citep" NormalCitation False) + , ("citep*", citation "citep*" NormalCitation False) + , ("citeal", citation "citeal" NormalCitation False) + , ("citealp", citation "citealp" NormalCitation False) + , ("citealp*", citation "citealp*" NormalCitation False) + , ("autocite", citation "autocite" NormalCitation False) + , ("smartcite", citation "smartcite" NormalCitation False) + , ("footcite", inNote <$> citation "footcite" NormalCitation False) + , ("parencite", citation "parencite" NormalCitation False) + , ("supercite", citation "supercite" NormalCitation False) + , ("footcitetext", inNote <$> citation "footcitetext" NormalCitation False) + , ("citeyearpar", citation "citeyearpar" SuppressAuthor False) + , ("citeyear", citation "citeyear" SuppressAuthor False) + , ("autocite*", citation "autocite*" SuppressAuthor False) + , ("cite*", citation "cite*" SuppressAuthor False) + , ("parencite*", citation "parencite*" SuppressAuthor False) + , ("textcite", citation "textcite" AuthorInText False) + , ("citet", citation "citet" AuthorInText False) + , ("citet*", citation "citet*" AuthorInText False) + , ("citealt", citation "citealt" AuthorInText False) + , ("citealt*", citation "citealt*" AuthorInText False) + , ("textcites", citation "textcites" AuthorInText True) + , ("cites", citation "cites" NormalCitation True) + , ("autocites", citation "autocites" NormalCitation True) + , ("footcites", inNote <$> citation "footcites" NormalCitation True) + , ("parencites", citation "parencites" NormalCitation True) + , ("supercites", citation "supercites" NormalCitation True) + , ("footcitetexts", inNote <$> citation "footcitetexts" NormalCitation True) + , ("Autocite", citation "Autocite" NormalCitation False) + , ("Smartcite", citation "Smartcite" NormalCitation False) + , ("Footcite", inNote <$> citation "Footcite" NormalCitation False) + , ("Parencite", citation "Parencite" NormalCitation False) + , ("Supercite", citation "Supercite" NormalCitation False) + , ("Footcitetext", inNote <$> citation "Footcitetext" NormalCitation False) + , ("Citeyearpar", citation "Citeyearpar" SuppressAuthor False) + , ("Citeyear", citation "Citeyear" SuppressAuthor False) + , ("Autocite*", citation "Autocite*" SuppressAuthor False) + , ("Cite*", citation "Cite*" SuppressAuthor False) + , ("Parencite*", citation "Parencite*" SuppressAuthor False) + , ("Textcite", citation "Textcite" AuthorInText False) + , ("Textcites", citation "Textcites" AuthorInText True) + , ("Cites", citation "Cites" NormalCitation True) + , ("Autocites", citation "Autocites" NormalCitation True) + , ("Footcites", inNote <$> citation "Footcites" NormalCitation True) + , ("Parencites", citation "Parencites" NormalCitation True) + , ("Supercites", citation "Supercites" NormalCitation True) + , ("Footcitetexts", inNote <$> citation "Footcitetexts" NormalCitation True) + , ("citetext", complexNatbibCitation inline NormalCitation) + , ("citeauthor", (try (tok *> sp *> controlSeq "citetext") *> + complexNatbibCitation inline AuthorInText) + <|> citation "citeauthor" AuthorInText False) + , ("nocite", mempty <$ (citation "nocite" NormalCitation False >>= + addMeta "nocite")) + ] + +-- citations + +addPrefix :: [Inline] -> [Citation] -> [Citation] +addPrefix p (k:ks) = k {citationPrefix = p ++ citationPrefix k} : ks +addPrefix _ _ = [] + +addSuffix :: [Inline] -> [Citation] -> [Citation] +addSuffix s ks@(_:_) = + let k = last ks + in init ks ++ [k {citationSuffix = citationSuffix k ++ s}] +addSuffix _ _ = [] + +simpleCiteArgs :: forall m . PandocMonad m => LP m Inlines -> LP m [Citation] +simpleCiteArgs inline = try $ do + first <- optionMaybe $ toList <$> opt + second <- optionMaybe $ toList <$> opt + keys <- try $ bgroup *> manyTill citationLabel egroup + let (pre, suf) = case (first , second ) of + (Just s , Nothing) -> (mempty, s ) + (Just s , Just t ) -> (s , t ) + _ -> (mempty, mempty) + conv k = Citation { citationId = k + , citationPrefix = [] + , citationSuffix = [] + , citationMode = NormalCitation + , citationHash = 0 + , citationNoteNum = 0 + } + return $ addPrefix pre $ addSuffix suf $ map conv keys + where + opt :: PandocMonad m => LP m Inlines + opt = do + toks <- try (sp *> bracketedToks <* sp) + -- now parse the toks as inlines + st <- getState + parsed <- lift $ + runParserT (mconcat <$> many inline) st "bracketed option" toks + case parsed of + Right result -> return result + Left e -> throwError $ PandocParsecError (untokenize toks) e + + + +citationLabel :: PandocMonad m => LP m Text +citationLabel = do + sp + untokenize <$> + (many1 (satisfyTok isWordTok <|> symbolIn bibtexKeyChar) + <* sp + <* optional (symbol ',') + <* sp) + where bibtexKeyChar = ".:;?!`'()/*@_+=-&[]" :: [Char] + +cites :: PandocMonad m + => LP m Inlines -> CitationMode -> Bool -> LP m [Citation] +cites inline mode multi = try $ do + let paropt = parenWrapped inline + cits <- if multi + then do + multiprenote <- optionMaybe $ toList <$> paropt + multipostnote <- optionMaybe $ toList <$> paropt + let (pre, suf) = case (multiprenote, multipostnote) of + (Just s , Nothing) -> (mempty, s) + (Nothing , Just t) -> (mempty, t) + (Just s , Just t ) -> (s, t) + _ -> (mempty, mempty) + tempCits <- many1 $ simpleCiteArgs inline + case tempCits of + (k:ks) -> case ks of + (_:_) -> return $ (addMprenote pre k : init ks) ++ + [addMpostnote suf (last ks)] + _ -> return [addMprenote pre (addMpostnote suf k)] + _ -> return [[]] + else count 1 $ simpleCiteArgs inline + let cs = concat cits + return $ case mode of + AuthorInText -> case cs of + (c:rest) -> c {citationMode = mode} : rest + [] -> [] + _ -> map (\a -> a {citationMode = mode}) cs + where mprenote (k:ks) = (k:ks) ++ [Space] + mprenote _ = mempty + mpostnote (k:ks) = [Str ",", Space] ++ (k:ks) + mpostnote _ = mempty + addMprenote mpn (k:ks) = + let mpnfinal = case citationPrefix k of + (_:_) -> mprenote mpn + _ -> mpn + in addPrefix mpnfinal (k:ks) + addMprenote _ _ = [] + addMpostnote = addSuffix . mpostnote + +citationWith :: PandocMonad m + => LP m Inlines -> Text -> CitationMode -> Bool -> LP m Inlines +citationWith inline name mode multi = do + (c,raw) <- withRaw $ cites inline mode multi + return $ cite c (rawInline "latex" $ "\\" <> name <> untokenize raw) + +handleCitationPart :: Inlines -> [Citation] +handleCitationPart ils = + let isCite Cite{} = True + isCite _ = False + (pref, rest) = break isCite (toList ils) + in case rest of + (Cite cs _:suff) -> addPrefix pref $ addSuffix suff cs + _ -> [] + +complexNatbibCitation :: PandocMonad m + => LP m Inlines -> CitationMode -> LP m Inlines +complexNatbibCitation inline mode = try $ do + (cs, raw) <- + withRaw $ concat <$> do + bgroup + items <- mconcat <$> + many1 (notFollowedBy (symbol ';') >> inline) + `sepBy1` symbol ';' + egroup + return $ map handleCitationPart items + case cs of + [] -> mzero + (c:cits) -> return $ cite (c{ citationMode = mode }:cits) + (rawInline "latex" $ "\\citetext" <> untokenize raw) + +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 new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/Readers/LaTeX/Inline.hs @@ -0,0 +1,397 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} +{- | + Module : Text.Pandoc.Readers.LaTeX.Inline + Copyright : Copyright (C) 2006-2021 John MacFarlane + License : GNU GPL, version 2 or above + + Maintainer : John MacFarlane + Stability : alpha + Portability : portable +-} +module Text.Pandoc.Readers.LaTeX.Inline + ( acronymCommands + , verbCommands + , charCommands + , accentCommands + , nameCommands + , biblatexInlineCommands + , refCommands + , rawInlineOr + , listingsLanguage + ) +where + +import qualified Data.Map as M +import Data.Text (Text) +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 Control.Applicative (optional, (<|>)) +import Control.Monad (guard, mzero, mplus, unless) +import Text.Pandoc.Class.PandocMonad (PandocMonad (..), translateTerm) +import Text.Pandoc.Readers.LaTeX.Parsing +import Text.Pandoc.Extensions (extensionEnabled, Extension(..)) +import Text.Pandoc.Parsing (getOption, updateState, getState, notFollowedBy, + manyTill, getInput, setInput, incSourceColumn, + option, many1, try) +import Data.Char (isDigit) +import Text.Pandoc.Highlighting (fromListingsLanguage,) +import Data.Maybe (maybeToList, fromMaybe) +import Text.Pandoc.Options (ReaderOptions(..)) +import qualified Data.Text.Normalize as Normalize +import qualified Text.Pandoc.Translations as Translations + +rawInlineOr :: PandocMonad m => Text -> LP m Inlines -> LP m Inlines +rawInlineOr name' fallback = do + parseRaw <- extensionEnabled Ext_raw_tex <$> getOption readerExtensions + if parseRaw + then rawInline "latex" <$> getRawCommand name' ("\\" <> name') + else fallback + +dolabel :: PandocMonad m => LP m Inlines +dolabel = do + v <- braced + let refstr = untokenize v + updateState $ \st -> + st{ sLastLabel = Just refstr } + return $ spanWith (refstr,[],[("label", refstr)]) + $ inBrackets $ str $ untokenize v + +doref :: PandocMonad m => Text -> LP m Inlines +doref cls = do + v <- braced + let refstr = untokenize v + return $ linkWith ("",[],[ ("reference-type", cls) + , ("reference", refstr)]) + ("#" <> refstr) + "" + (inBrackets $ str refstr) + +inBrackets :: Inlines -> Inlines +inBrackets x = str "[" <> x <> str "]" + +doTerm :: PandocMonad m => Translations.Term -> LP m Inlines +doTerm term = str <$> translateTerm term + +lit :: Text -> LP m Inlines +lit = pure . str + +doverb :: PandocMonad m => LP m Inlines +doverb = do + Tok _ Symbol t <- anySymbol + marker <- case T.uncons t of + Just (c, ts) | T.null ts -> return c + _ -> mzero + withVerbatimMode $ + code . untokenize <$> + manyTill (notFollowedBy newlineTok >> verbTok marker) (symbol marker) + +verbTok :: PandocMonad m => Char -> LP m Tok +verbTok stopchar = do + t@(Tok pos toktype txt) <- anyTok + case T.findIndex (== stopchar) txt of + Nothing -> return t + Just i -> do + let (t1, t2) = T.splitAt i txt + inp <- getInput + setInput $ Tok (incSourceColumn pos i) Symbol (T.singleton stopchar) + : totoks (incSourceColumn pos (i + 1)) (T.drop 1 t2) ++ inp + return $ Tok pos toktype t1 + +listingsLanguage :: [(Text, Text)] -> Maybe Text +listingsLanguage opts = + case lookup "language" opts of + Nothing -> Nothing + Just l -> fromListingsLanguage l `mplus` Just l + +dolstinline :: PandocMonad m => LP m Inlines +dolstinline = do + options <- option [] keyvals + let classes = maybeToList $ listingsLanguage options + doinlinecode classes + +domintinline :: PandocMonad m => LP m Inlines +domintinline = do + skipopts + cls <- untokenize <$> braced + doinlinecode [cls] + +doinlinecode :: PandocMonad m => [Text] -> LP m Inlines +doinlinecode classes = do + Tok _ Symbol t <- anySymbol + marker <- case T.uncons t of + Just (c, ts) | T.null ts -> return c + _ -> mzero + let stopchar = if marker == '{' then '}' else marker + withVerbatimMode $ + codeWith ("",classes,[]) . T.map nlToSpace . untokenize <$> + manyTill (verbTok stopchar) (symbol stopchar) + +nlToSpace :: Char -> Char +nlToSpace '\n' = ' ' +nlToSpace x = x + +romanNumeralUpper :: (PandocMonad m) => LP m Inlines +romanNumeralUpper = + str . toRomanNumeral <$> romanNumeralArg + +romanNumeralLower :: (PandocMonad m) => LP m Inlines +romanNumeralLower = + str . T.toLower . toRomanNumeral <$> romanNumeralArg + +romanNumeralArg :: (PandocMonad m) => LP m Int +romanNumeralArg = spaces *> (parser <|> inBraces) + where + inBraces = do + symbol '{' + spaces + res <- parser + spaces + symbol '}' + return res + parser = do + s <- untokenize <$> many1 (satisfyTok isWordTok) + let (digits, rest) = T.span isDigit s + unless (T.null rest) $ + Prelude.fail "Non-digits in argument to \\Rn or \\RN" + safeRead digits + +accentWith :: PandocMonad m + => LP m Inlines -> Char -> Maybe Char -> LP m Inlines +accentWith tok combiningAccent fallBack = try $ do + ils <- tok + case toList ils of + (Str (T.uncons -> Just (x, xs)) : ys) -> return $ fromList $ + -- try to normalize to the combined character: + Str (Normalize.normalize Normalize.NFC + (T.pack [x, combiningAccent]) <> xs) : ys + [Space] -> return $ str $ T.singleton + $ fromMaybe combiningAccent fallBack + [] -> return $ str $ T.singleton + $ fromMaybe combiningAccent fallBack + _ -> return ils + + +verbCommands :: PandocMonad m => M.Map Text (LP m Inlines) +verbCommands = M.fromList + [ ("verb", doverb) + , ("lstinline", dolstinline) + , ("mintinline", domintinline) + , ("Verb", doverb) + ] + +accentCommands :: PandocMonad m => LP m Inlines -> M.Map Text (LP m Inlines) +accentCommands tok = + let accent = accentWith tok + in M.fromList + [ ("aa", lit "å") + , ("AA", lit "Å") + , ("ss", lit "ß") + , ("o", lit "ø") + , ("O", lit "Ø") + , ("L", lit "Ł") + , ("l", lit "ł") + , ("ae", lit "æ") + , ("AE", lit "Æ") + , ("oe", lit "œ") + , ("OE", lit "Œ") + , ("pounds", lit "£") + , ("euro", lit "€") + , ("copyright", lit "©") + , ("textasciicircum", lit "^") + , ("textasciitilde", lit "~") + , ("H", accent '\779' Nothing) -- hungarumlaut + , ("`", accent '\768' (Just '`')) -- grave + , ("'", accent '\769' (Just '\'')) -- acute + , ("^", accent '\770' (Just '^')) -- circ + , ("~", accent '\771' (Just '~')) -- tilde + , ("\"", accent '\776' Nothing) -- umlaut + , (".", accent '\775' Nothing) -- dot + , ("=", accent '\772' Nothing) -- macron + , ("|", accent '\781' Nothing) -- vertical line above + , ("b", accent '\817' Nothing) -- macron below + , ("c", accent '\807' Nothing) -- cedilla + , ("G", accent '\783' Nothing) -- doublegrave + , ("h", accent '\777' Nothing) -- hookabove + , ("d", accent '\803' Nothing) -- dotbelow + , ("f", accent '\785' Nothing) -- inverted breve + , ("r", accent '\778' Nothing) -- ringabove + , ("t", accent '\865' Nothing) -- double inverted breve + , ("U", accent '\782' Nothing) -- double vertical line above + , ("v", accent '\780' Nothing) -- hacek + , ("u", accent '\774' Nothing) -- breve + , ("k", accent '\808' Nothing) -- ogonek + , ("textogonekcentered", accent '\808' Nothing) -- ogonek + , ("i", lit "ı") -- dotless i + , ("j", lit "ȷ") -- dotless j + , ("newtie", accent '\785' Nothing) -- inverted breve + , ("textcircled", accent '\8413' Nothing) -- combining circle + ] + +charCommands :: PandocMonad m => M.Map Text (LP m Inlines) +charCommands = M.fromList + [ ("ldots", lit "…") + , ("vdots", lit "\8942") + , ("dots", lit "…") + , ("mdots", lit "…") + , ("sim", lit "~") + , ("sep", lit ",") + , ("P", lit "¶") + , ("S", lit "§") + , ("$", lit "$") + , ("%", lit "%") + , ("&", lit "&") + , ("#", lit "#") + , ("_", lit "_") + , ("{", lit "{") + , ("}", lit "}") + , ("qed", lit "\a0\x25FB") + , ("lq", return (str "‘")) + , ("rq", return (str "’")) + , ("textquoteleft", return (str "‘")) + , ("textquoteright", return (str "’")) + , ("textquotedblleft", return (str "“")) + , ("textquotedblright", return (str "”")) + , ("/", pure mempty) -- italic correction + , ("\\", linebreak <$ (do inTableCell <- sInTableCell <$> getState + guard $ not inTableCell + optional rawopt + spaces)) + , (",", lit "\8198") + , ("@", pure mempty) + , (" ", lit "\160") + , ("ps", pure $ str "PS." <> space) + , ("TeX", lit "TeX") + , ("LaTeX", lit "LaTeX") + , ("bar", lit "|") + , ("textless", lit "<") + , ("textgreater", lit ">") + , ("textbackslash", lit "\\") + , ("backslash", lit "\\") + , ("slash", lit "/") + -- fontawesome + , ("faCheck", lit "\10003") + , ("faClose", lit "\10007") + -- hyphenat + , ("bshyp", lit "\\\173") + , ("fshyp", lit "/\173") + , ("dothyp", lit ".\173") + , ("colonhyp", lit ":\173") + , ("hyp", lit "-") + ] + +biblatexInlineCommands :: PandocMonad m + => LP m Inlines -> M.Map Text (LP m Inlines) +biblatexInlineCommands tok = M.fromList + -- biblatex misc + [ ("RN", romanNumeralUpper) + , ("Rn", romanNumeralLower) + , ("mkbibquote", spanWith nullAttr . doubleQuoted <$> tok) + , ("mkbibemph", spanWith nullAttr . emph <$> tok) + , ("mkbibitalic", spanWith nullAttr . emph <$> tok) + , ("mkbibbold", spanWith nullAttr . strong <$> tok) + , ("mkbibparens", + spanWith nullAttr . (\x -> str "(" <> x <> str ")") <$> tok) + , ("mkbibbrackets", + spanWith nullAttr . (\x -> str "[" <> x <> str "]") <$> tok) + , ("autocap", spanWith nullAttr <$> tok) + , ("textnormal", spanWith ("",["nodecor"],[]) <$> tok) + , ("bibstring", + (\x -> spanWith ("",[],[("bibstring",x)]) (str x)) . untokenize + <$> braced) + , ("adddot", pure (str ".")) + , ("adddotspace", pure (spanWith nullAttr (str "." <> space))) + , ("addabbrvspace", pure space) + , ("hyphen", pure (str "-")) + ] + +nameCommands :: PandocMonad m => M.Map Text (LP m Inlines) +nameCommands = M.fromList + [ ("figurename", doTerm Translations.Figure) + , ("prefacename", doTerm Translations.Preface) + , ("refname", doTerm Translations.References) + , ("bibname", doTerm Translations.Bibliography) + , ("chaptername", doTerm Translations.Chapter) + , ("partname", doTerm Translations.Part) + , ("contentsname", doTerm Translations.Contents) + , ("listfigurename", doTerm Translations.ListOfFigures) + , ("listtablename", doTerm Translations.ListOfTables) + , ("indexname", doTerm Translations.Index) + , ("abstractname", doTerm Translations.Abstract) + , ("tablename", doTerm Translations.Table) + , ("enclname", doTerm Translations.Encl) + , ("ccname", doTerm Translations.Cc) + , ("headtoname", doTerm Translations.To) + , ("pagename", doTerm Translations.Page) + , ("seename", doTerm Translations.See) + , ("seealsoname", doTerm Translations.SeeAlso) + , ("proofname", doTerm Translations.Proof) + , ("glossaryname", doTerm Translations.Glossary) + , ("lstlistingname", doTerm Translations.Listing) + ] + +refCommands :: PandocMonad m => M.Map Text (LP m Inlines) +refCommands = M.fromList + [ ("label", rawInlineOr "label" dolabel) + , ("ref", rawInlineOr "ref" $ doref "ref") + , ("cref", rawInlineOr "cref" $ doref "ref") -- from cleveref.sty + , ("vref", rawInlineOr "vref" $ doref "ref+page") -- from varioref.sty + , ("eqref", rawInlineOr "eqref" $ doref "eqref") -- from amsmath.sty + ] + +acronymCommands :: PandocMonad m => M.Map Text (LP m Inlines) +acronymCommands = M.fromList + -- glossaries package + [ ("gls", doAcronym "short") + , ("Gls", doAcronym "short") + , ("glsdesc", doAcronym "long") + , ("Glsdesc", doAcronym "long") + , ("GLSdesc", doAcronym "long") + , ("acrlong", doAcronym "long") + , ("Acrlong", doAcronym "long") + , ("acrfull", doAcronym "full") + , ("Acrfull", doAcronym "full") + , ("acrshort", doAcronym "abbrv") + , ("Acrshort", doAcronym "abbrv") + , ("glspl", doAcronymPlural "short") + , ("Glspl", doAcronymPlural "short") + , ("glsdescplural", doAcronymPlural "long") + , ("Glsdescplural", doAcronymPlural "long") + , ("GLSdescplural", doAcronymPlural "long") + -- acronyms package + , ("ac", doAcronym "short") + , ("acf", doAcronym "full") + , ("acs", doAcronym "abbrv") + , ("acl", doAcronym "long") + , ("acp", doAcronymPlural "short") + , ("acfp", doAcronymPlural "full") + , ("acsp", doAcronymPlural "abbrv") + , ("aclp", doAcronymPlural "long") + , ("Ac", doAcronym "short") + , ("Acf", doAcronym "full") + , ("Acs", doAcronym "abbrv") + , ("Acl", doAcronym "long") + , ("Acp", doAcronymPlural "short") + , ("Acfp", doAcronymPlural "full") + , ("Acsp", doAcronymPlural "abbrv") + , ("Aclp", doAcronymPlural "long") + ] + +doAcronym :: PandocMonad m => Text -> LP m Inlines +doAcronym form = do + acro <- braced + return . mconcat $ [spanWith ("",[],[("acronym-label", untokenize acro), + ("acronym-form", "singular+" <> form)]) + $ str $ untokenize acro] + +doAcronymPlural :: PandocMonad m => Text -> LP m Inlines +doAcronymPlural form = do + acro <- braced + let plural = str "s" + 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 @@ -12,13 +12,89 @@ BCP47 'Lang'. -} module Text.Pandoc.Readers.LaTeX.Lang - ( polyglossiaLangToBCP47 + ( setDefaultLanguage + , polyglossiaLangToBCP47 , babelLangToBCP47 + , enquoteCommands + , inlineLanguageCommands ) where import qualified Data.Map as M +import Data.Text (Text) import qualified Data.Text as T -import Text.Pandoc.BCP47 (Lang(..)) +import Text.Pandoc.Shared (extractSpaces) +import Text.Pandoc.BCP47 (Lang(..), renderLang) +import Text.Pandoc.Class (PandocMonad(..), setTranslations) +import Text.Pandoc.Readers.LaTeX.Parsing +import Text.Pandoc.Parsing (updateState, option, getState, QuoteContext(..), + withQuoteContext) +import Text.Pandoc.Builder (Blocks, Inlines, setMeta, str, spanWith, + singleQuoted, doubleQuoted) + +enquote :: PandocMonad m + => LP m Inlines + -> Bool -> Maybe Text -> LP m Inlines +enquote tok starred mblang = do + skipopts + let lang = mblang >>= babelLangToBCP47 + let langspan = case lang of + Nothing -> id + Just l -> spanWith ("",[],[("lang", renderLang l)]) + quoteContext <- sQuoteContext <$> getState + if starred || quoteContext == InDoubleQuote + then singleQuoted . langspan <$> withQuoteContext InSingleQuote tok + else doubleQuoted . langspan <$> withQuoteContext InDoubleQuote tok + +enquoteCommands :: PandocMonad m + => LP m Inlines -> M.Map Text (LP m Inlines) +enquoteCommands tok = M.fromList + [ ("enquote*", enquote tok True Nothing) + , ("enquote", enquote tok False Nothing) + -- foreignquote is supposed to use native quote marks + , ("foreignquote*", braced >>= enquote tok True . Just . untokenize) + , ("foreignquote", braced >>= enquote tok False . Just . untokenize) + -- hypehnquote uses regular quotes + , ("hyphenquote*", braced >>= enquote tok True . Just . untokenize) + , ("hyphenquote", braced >>= enquote tok False . Just . untokenize) + ] + +foreignlanguage :: PandocMonad m => LP m Inlines -> LP m Inlines +foreignlanguage tok = do + babelLang <- untokenize <$> braced + case babelLangToBCP47 babelLang of + Just lang -> spanWith ("", [], [("lang", renderLang lang)]) <$> tok + _ -> tok + +inlineLanguageCommands :: PandocMonad m + => LP m Inlines -> M.Map Text (LP m Inlines) +inlineLanguageCommands tok = + M.fromList $ + ("foreignlanguage", foreignlanguage tok) : + (mk <$> M.toList polyglossiaLangToBCP47) + where + mk (polyglossia, bcp47Func) = + ("text" <> polyglossia, inlineLanguage tok bcp47Func) + +inlineLanguage :: PandocMonad m + => LP m Inlines -> (Text -> Lang) -> LP m Inlines +inlineLanguage tok bcp47Func = do + o <- option "" $ T.filter (\c -> c /= '[' && c /= ']') + <$> rawopt + let lang = renderLang $ bcp47Func o + extractSpaces (spanWith ("", [], [("lang", lang)])) <$> tok + +setDefaultLanguage :: PandocMonad m => LP m Blocks +setDefaultLanguage = do + o <- option "" $ T.filter (\c -> c /= '[' && c /= ']') + <$> rawopt + polylang <- untokenize <$> braced + case M.lookup polylang polyglossiaLangToBCP47 of + Nothing -> return mempty -- TODO mzero? warning? + Just langFunc -> do + let l = langFunc o + setTranslations l + updateState $ setMeta "lang" $ str (renderLang l) + return mempty polyglossiaLangToBCP47 :: M.Map T.Text (T.Text -> Lang) polyglossiaLangToBCP47 = M.fromList diff --git a/src/Text/Pandoc/Readers/LaTeX/Macro.hs b/src/Text/Pandoc/Readers/LaTeX/Macro.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/Readers/LaTeX/Macro.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE OverloadedStrings #-} +module Text.Pandoc.Readers.LaTeX.Macro + ( macroDef + ) +where +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.Class +import Text.Pandoc.Shared (safeRead) +import Text.Pandoc.Parsing hiding (blankline, mathDisplay, mathInline, + optional, space, spaces, withRaw, (<|>)) +import Control.Applicative ((<|>), optional) +import qualified Data.Map as M +import Data.Text (Text) + +macroDef :: (PandocMonad m, Monoid a) => (Text -> a) -> LP m a +macroDef constructor = do + (_, s) <- withRaw (commandDef <|> environmentDef) + (constructor (untokenize s) <$ + guardDisabled Ext_latex_macros) + <|> return mempty + where commandDef = do + (name, macro') <- newcommand <|> letmacro <|> defmacro + guardDisabled Ext_latex_macros <|> + updateState (\s -> s{ sMacros = M.insert name macro' (sMacros s) }) + environmentDef = do + mbenv <- newenvironment + case mbenv of + Nothing -> return () + Just (name, macro1, macro2) -> + guardDisabled Ext_latex_macros <|> + do updateState $ \s -> s{ sMacros = + M.insert name macro1 (sMacros s) } + updateState $ \s -> s{ sMacros = + M.insert ("end" <> name) macro2 (sMacros s) } + -- @\newenvironment{envname}[n-args][default]{begin}{end}@ + -- is equivalent to + -- @\newcommand{\envname}[n-args][default]{begin}@ + -- @\newcommand{\endenvname}@ + +letmacro :: PandocMonad m => LP m (Text, Macro) +letmacro = do + controlSeq "let" + (name, contents) <- withVerbatimMode $ do + Tok _ (CtrlSeq name) _ <- anyControlSeq + optional $ symbol '=' + spaces + -- we first parse in verbatim mode, and then expand macros, + -- because we don't want \let\foo\bar to turn into + -- \let\foo hello if we have previously \def\bar{hello} + contents <- bracedOrToken + return (name, contents) + contents' <- doMacros' 0 contents + return (name, Macro ExpandWhenDefined [] Nothing contents') + +defmacro :: PandocMonad m => LP m (Text, Macro) +defmacro = try $ + -- we use withVerbatimMode, because macros are to be expanded + -- at point of use, not point of definition + withVerbatimMode $ do + controlSeq "def" + Tok _ (CtrlSeq name) _ <- anyControlSeq + argspecs <- many (argspecArg <|> argspecPattern) + contents <- bracedOrToken + return (name, Macro ExpandWhenUsed argspecs Nothing contents) + +argspecArg :: PandocMonad m => LP m ArgSpec +argspecArg = do + Tok _ (Arg i) _ <- satisfyTok isArgTok + return $ ArgNum i + +argspecPattern :: PandocMonad m => LP m ArgSpec +argspecPattern = + Pattern <$> many1 (satisfyTok (\(Tok _ toktype' txt) -> + (toktype' == Symbol || toktype' == Word) && + (txt /= "{" && txt /= "\\" && txt /= "}"))) + +newcommand :: PandocMonad m => LP m (Text, Macro) +newcommand = do + pos <- getPosition + Tok _ (CtrlSeq mtype) _ <- controlSeq "newcommand" <|> + controlSeq "renewcommand" <|> + controlSeq "providecommand" <|> + controlSeq "DeclareMathOperator" <|> + controlSeq "DeclareRobustCommand" + withVerbatimMode $ do + Tok _ (CtrlSeq name) txt <- do + optional (symbol '*') + anyControlSeq <|> + (symbol '{' *> spaces *> anyControlSeq <* spaces <* symbol '}') + spaces + numargs <- option 0 $ try bracketedNum + let argspecs = map ArgNum [1..numargs] + spaces + optarg <- option Nothing $ Just <$> try bracketedToks + spaces + contents' <- bracedOrToken + let contents = + case mtype of + "DeclareMathOperator" -> + Tok pos (CtrlSeq "mathop") "\\mathop" + : Tok pos Symbol "{" + : Tok pos (CtrlSeq "mathrm") "\\mathrm" + : Tok pos Symbol "{" + : (contents' ++ + [ Tok pos Symbol "}", Tok pos Symbol "}" ]) + _ -> contents' + macros <- sMacros <$> getState + case M.lookup name macros of + Just macro + | mtype == "newcommand" -> do + report $ MacroAlreadyDefined txt pos + return (name, macro) + | mtype == "providecommand" -> return (name, macro) + _ -> return (name, Macro ExpandWhenUsed argspecs optarg contents) + +newenvironment :: PandocMonad m => LP m (Maybe (Text, Macro, Macro)) +newenvironment = do + pos <- getPosition + Tok _ (CtrlSeq mtype) _ <- controlSeq "newenvironment" <|> + controlSeq "renewenvironment" <|> + controlSeq "provideenvironment" + withVerbatimMode $ do + optional $ symbol '*' + spaces + name <- untokenize <$> braced + spaces + numargs <- option 0 $ try bracketedNum + spaces + optarg <- option Nothing $ Just <$> try bracketedToks + let argspecs = map (\i -> ArgNum i) [1..numargs] + startcontents <- spaces >> bracedOrToken + endcontents <- spaces >> bracedOrToken + macros <- sMacros <$> getState + case M.lookup name macros of + Just _ + | mtype == "newenvironment" -> do + report $ MacroAlreadyDefined name pos + return Nothing + | mtype == "provideenvironment" -> + return Nothing + _ -> return $ Just (name, + Macro ExpandWhenUsed argspecs optarg startcontents, + Macro ExpandWhenUsed [] Nothing endcontents) + +bracketedNum :: PandocMonad m => LP m Int +bracketedNum = do + ds <- untokenize <$> bracketedToks + case safeRead ds of + Just i -> return i + _ -> return 0 diff --git a/src/Text/Pandoc/Readers/LaTeX/Math.hs b/src/Text/Pandoc/Readers/LaTeX/Math.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/Readers/LaTeX/Math.hs @@ -0,0 +1,221 @@ +{-# LANGUAGE OverloadedStrings #-} +module Text.Pandoc.Readers.LaTeX.Math + ( dollarsMath + , inlineEnvironments + , inlineEnvironment + , mathInline + , mathDisplay + , theoremstyle + , theoremEnvironment + , newtheorem + , proof + ) +where +import Data.Maybe (fromMaybe) +import Text.Pandoc.Walk (walk) +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.Class +import Text.Pandoc.Shared (trimMath, stripTrailingNewlines) +import Text.Pandoc.Parsing hiding (blankline, mathDisplay, mathInline, + optional, space, spaces, withRaw, (<|>)) +import Control.Applicative ((<|>), optional) +import Control.Monad (guard, mzero) +import qualified Data.Map as M +import Data.Text (Text) + +dollarsMath :: PandocMonad m => LP m Inlines +dollarsMath = do + symbol '$' + display <- option False (True <$ symbol '$') + (do contents <- try $ untokenize <$> pDollarsMath 0 + if display + then mathDisplay contents <$ symbol '$' + else return $ mathInline contents) + <|> (guard display >> return (mathInline "")) + +-- Int is number of embedded groupings +pDollarsMath :: PandocMonad m => Int -> LP m [Tok] +pDollarsMath n = do + tk@(Tok _ toktype t) <- anyTok + case toktype of + Symbol | t == "$" + , n == 0 -> return [] + | t == "\\" -> do + tk' <- anyTok + (tk :) . (tk' :) <$> pDollarsMath n + | t == "{" -> (tk :) <$> pDollarsMath (n+1) + | t == "}" -> + if n > 0 + then (tk :) <$> pDollarsMath (n-1) + else mzero + _ -> (tk :) <$> pDollarsMath n + +mathDisplay :: Text -> Inlines +mathDisplay = displayMath . trimMath + +mathInline :: Text -> Inlines +mathInline = math . trimMath + +mathEnvWith :: PandocMonad m + => (Inlines -> a) -> Maybe Text -> Text -> LP m a +mathEnvWith f innerEnv name = f . mathDisplay . inner <$> mathEnv name + where inner x = case innerEnv of + Nothing -> x + Just y -> "\\begin{" <> y <> "}\n" <> x <> + "\\end{" <> y <> "}" + +mathEnv :: PandocMonad m => Text -> LP m Text +mathEnv name = do + skipopts + optional blankline + res <- manyTill anyTok (end_ name) + return $ stripTrailingNewlines $ untokenize res + +inlineEnvironment :: PandocMonad m => LP m Inlines +inlineEnvironment = try $ do + controlSeq "begin" + name <- untokenize <$> braced + M.findWithDefault mzero name inlineEnvironments + +inlineEnvironments :: PandocMonad m => M.Map Text (LP m Inlines) +inlineEnvironments = M.fromList [ + ("displaymath", mathEnvWith id Nothing "displaymath") + , ("math", math <$> mathEnv "math") + , ("equation", mathEnvWith id Nothing "equation") + , ("equation*", mathEnvWith id Nothing "equation*") + , ("gather", mathEnvWith id (Just "gathered") "gather") + , ("gather*", mathEnvWith id (Just "gathered") "gather*") + , ("multline", mathEnvWith id (Just "gathered") "multline") + , ("multline*", mathEnvWith id (Just "gathered") "multline*") + , ("eqnarray", mathEnvWith id (Just "aligned") "eqnarray") + , ("eqnarray*", mathEnvWith id (Just "aligned") "eqnarray*") + , ("align", mathEnvWith id (Just "aligned") "align") + , ("align*", mathEnvWith id (Just "aligned") "align*") + , ("alignat", mathEnvWith id (Just "aligned") "alignat") + , ("alignat*", mathEnvWith id (Just "aligned") "alignat*") + , ("dmath", mathEnvWith id Nothing "dmath") + , ("dmath*", mathEnvWith id Nothing "dmath*") + , ("dgroup", mathEnvWith id (Just "aligned") "dgroup") + , ("dgroup*", mathEnvWith id (Just "aligned") "dgroup*") + , ("darray", mathEnvWith id (Just "aligned") "darray") + , ("darray*", mathEnvWith id (Just "aligned") "darray*") + ] + +theoremstyle :: PandocMonad m => LP m Blocks +theoremstyle = do + stylename <- untokenize <$> braced + let mbstyle = case stylename of + "plain" -> Just PlainStyle + "definition" -> Just DefinitionStyle + "remark" -> Just RemarkStyle + _ -> Nothing + case mbstyle of + Nothing -> return () + Just sty -> updateState $ \s -> s{ sLastTheoremStyle = sty } + return mempty + +newtheorem :: PandocMonad m => LP m Inlines -> LP m Blocks +newtheorem inline = do + number <- option True (False <$ symbol '*' <* sp) + name <- untokenize <$> braced + sp + series <- option Nothing $ Just . untokenize <$> bracketedToks + sp + showName <- tokWith inline + sp + syncTo <- option Nothing $ Just . untokenize <$> bracketedToks + sty <- sLastTheoremStyle <$> getState + let spec = TheoremSpec { theoremName = showName + , theoremStyle = sty + , theoremSeries = series + , theoremSyncTo = syncTo + , theoremNumber = number + , theoremLastNum = DottedNum [0] } + tmap <- sTheoremMap <$> getState + updateState $ \s -> s{ sTheoremMap = + M.insert name spec tmap } + return mempty + +theoremEnvironment :: PandocMonad m + => LP m Blocks -> LP m Inlines -> Text -> LP m Blocks +theoremEnvironment blocks opt name = do + tmap <- sTheoremMap <$> getState + case M.lookup name tmap of + Nothing -> mzero + Just tspec -> do + optTitle <- option mempty $ (\x -> space <> "(" <> x <> ")") <$> opt + mblabel <- option Nothing $ Just . untokenize <$> + try (spaces >> controlSeq "label" >> spaces >> braced) + bs <- env name blocks + number <- + if theoremNumber tspec + then do + let name' = fromMaybe name $ theoremSeries tspec + num <- getNextNumber + (maybe (DottedNum [0]) theoremLastNum . + M.lookup name' . sTheoremMap) + updateState $ \s -> + s{ sTheoremMap = + M.adjust + (\spec -> spec{ theoremLastNum = num }) + name' + (sTheoremMap s) + } + + case mblabel of + Just ident -> + updateState $ \s -> + s{ sLabels = M.insert ident + (B.toList $ + theoremName tspec <> "\160" <> + str (renderDottedNum num)) (sLabels s) } + Nothing -> return () + return $ space <> B.text (renderDottedNum num) + else return mempty + let titleEmph = case theoremStyle tspec of + PlainStyle -> B.strong + DefinitionStyle -> B.strong + RemarkStyle -> B.emph + let title = titleEmph (theoremName tspec <> number) + <> optTitle <> "." <> space + return $ divWith (fromMaybe "" mblabel, [name], []) $ addTitle title + $ case theoremStyle tspec of + PlainStyle -> walk italicize bs + _ -> bs + + + +proof :: PandocMonad m => LP m Blocks -> LP m Inlines -> LP m Blocks +proof blocks opt = do + title <- option (B.text "Proof") opt + bs <- env "proof" blocks + return $ + B.divWith ("", ["proof"], []) $ + addQed $ addTitle (B.emph (title <> ".")) bs + +addTitle :: Inlines -> Blocks -> Blocks +addTitle ils bs = + case B.toList bs of + (Para xs : rest) + -> B.fromList (Para (B.toList ils ++ (Space : xs)) : rest) + _ -> B.para ils <> bs + +addQed :: Blocks -> Blocks +addQed bs = + case Seq.viewr (B.unMany bs) of + s Seq.:> Para ils + -> B.Many (s Seq.|> Para (ils ++ B.toList qedSign)) + _ -> bs <> B.para qedSign + where + qedSign = B.str "\xa0\x25FB" + +italicize :: Block -> Block +italicize x@(Para [Image{}]) = x -- see #6925 +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 @@ -32,6 +32,8 @@ , totoks , toksToString , satisfyTok + , parseFromToks + , disablingWithRaw , doMacros , doMacros' , setpos @@ -52,6 +54,7 @@ , comment , anyTok , singleChar + , tokWith , specialChars , endline , blankline @@ -78,6 +81,11 @@ , rawopt , overlaySpecification , getNextNumber + , label + , setCaption + , resetCaption + , env + , addMeta ) where import Control.Applicative (many, (<|>)) @@ -87,13 +95,15 @@ import Data.Char (chr, isAlphaNum, isDigit, isLetter, ord) import Data.Default import Data.List (intercalate) +import qualified Data.IntMap as IntMap import qualified Data.Map as M import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as T import Text.Pandoc.Builder import Text.Pandoc.Class.PandocMonad (PandocMonad, report) -import Text.Pandoc.Error (PandocError (PandocMacroLoop)) +import Text.Pandoc.Error + (PandocError (PandocMacroLoop,PandocShouldNeverHappenError)) import Text.Pandoc.Logging import Text.Pandoc.Options import Text.Pandoc.Parsing hiding (blankline, many, mathDisplay, mathInline, @@ -151,8 +161,9 @@ , sLabels :: M.Map Text [Inline] , sHasChapters :: Bool , sToggles :: M.Map Text Bool - , sExpanded :: Bool , sFileContents :: M.Map Text Text + , sEnableWithRaw :: Bool + , sRawTokens :: IntMap.IntMap [Tok] } deriving Show @@ -177,8 +188,9 @@ , sLabels = M.empty , sHasChapters = False , sToggles = M.empty - , sExpanded = False , sFileContents = M.empty + , sEnableWithRaw = True + , sRawTokens = IntMap.empty } instance PandocMonad m => HasQuoteContext LaTeXState m where @@ -248,7 +260,6 @@ Right toks' -> do res <- lift $ runParserT (do when retokenize $ do -- retokenize, applying macros - doMacros ts <- many (satisfyTok (const True)) setInput ts rawparser) @@ -281,6 +292,15 @@ Left e -> Prelude.fail (show e) Right s' -> return s' +{- +When tokenize or untokenize change, test with this +QuickCheck property: + +> tokUntokRoundtrip :: String -> Bool +> tokUntokRoundtrip s = +> let t = T.pack s in untokenize (tokenize "random" t) == t +-} + tokenize :: SourceName -> Text -> [Tok] tokenize sourcename = totoks (initialPos sourcename) @@ -404,12 +424,31 @@ toksToString :: [Tok] -> String toksToString = T.unpack . untokenize +parseFromToks :: PandocMonad m => LP m a -> [Tok] -> LP m a +parseFromToks parser toks = do + oldInput <- getInput + setInput toks + result <- disablingWithRaw parser + setInput oldInput + return result + +disablingWithRaw :: PandocMonad m => LP m a -> LP m a +disablingWithRaw parser = do + oldEnableWithRaw <- sEnableWithRaw <$> getState + updateState $ \st -> st{ sEnableWithRaw = False } + result <- parser + updateState $ \st -> st{ sEnableWithRaw = oldEnableWithRaw } + return result + satisfyTok :: PandocMonad m => (Tok -> Bool) -> LP m Tok satisfyTok f = do doMacros -- apply macros on remaining input stream res <- tokenPrim (T.unpack . untoken) updatePos matcher - updateState $ \st -> st{ sExpanded = False } - return res + updateState $ \st -> + if sEnableWithRaw st + then st{ sRawTokens = IntMap.map (res:) $ sRawTokens st } + else st + return $! res where matcher t | f t = Just t | otherwise = Nothing updatePos :: SourcePos -> Tok -> [Tok] -> SourcePos @@ -418,27 +457,24 @@ doMacros :: PandocMonad m => LP m () doMacros = do - expanded <- sExpanded <$> getState - verbatimMode <- sVerbatimMode <$> getState - unless (expanded || verbatimMode) $ do - getInput >>= doMacros' 1 >>= setInput - updateState $ \st -> st{ sExpanded = True } + st <- getState + unless (sVerbatimMode st || M.null (sMacros st)) $ do + getInput >>= doMacros' 1 >>= setInput doMacros' :: PandocMonad m => Int -> [Tok] -> LP m [Tok] doMacros' n inp = case inp of Tok spos (CtrlSeq "begin") _ : Tok _ Symbol "{" : Tok _ Word name : Tok _ Symbol "}" : ts - -> handleMacros n spos name ts + -> handleMacros n spos name ts <|> return inp Tok spos (CtrlSeq "end") _ : Tok _ Symbol "{" : Tok _ Word name : Tok _ Symbol "}" : ts - -> handleMacros n spos ("end" <> name) ts + -> handleMacros n spos ("end" <> name) ts <|> return inp Tok _ (CtrlSeq "expandafter") _ : t : ts -> combineTok t <$> doMacros' n ts Tok spos (CtrlSeq name) _ : ts - -> handleMacros n spos name ts + -> handleMacros n spos name ts <|> return inp _ -> return inp - <|> return inp where combineTok (Tok spos (CtrlSeq name) x) (Tok _ Word w : ts) @@ -594,18 +630,22 @@ anyTok :: PandocMonad m => LP m Tok anyTok = satisfyTok (const True) +singleCharTok :: PandocMonad m => LP m Tok +singleCharTok = + satisfyTok $ \case + Tok _ Word t -> T.length t == 1 + Tok _ Symbol t -> not (T.any (`Set.member` specialChars) t) + _ -> False + singleChar :: PandocMonad m => LP m Tok -singleChar = try $ do - Tok pos toktype t <- satisfyTok (tokTypeIn [Word, Symbol]) - guard $ not $ toktype == Symbol && - T.any (`Set.member` specialChars) t - if T.length t > 1 - then do - let (t1, t2) = (T.take 1 t, T.drop 1 t) - inp <- getInput - setInput $ Tok (incSourceColumn pos 1) toktype t2 : inp - return $ Tok pos toktype t1 - else return $ Tok pos toktype t +singleChar = singleCharTok <|> singleCharFromWord + where + singleCharFromWord = do + Tok pos toktype t <- disablingWithRaw $ satisfyTok isWordTok + let (t1, t2) = (T.take 1 t, T.drop 1 t) + inp <- getInput + setInput $ Tok pos toktype t1 : Tok (incSourceColumn pos 1) toktype t2 : inp + anyTok specialChars :: Set.Set Char specialChars = Set.fromList "#$%&~_^\\{}" @@ -648,28 +688,25 @@ -- {{a,b}} should be parsed the same as {a,b} try (grouped parser <* egroup) <|> (mconcat <$> manyTill parser egroup) -braced' :: PandocMonad m => LP m Tok -> Int -> LP m [Tok] -braced' getTok n = - handleEgroup <|> handleBgroup <|> handleOther - where handleEgroup = do - t <- symbol '}' - if n == 1 - then return [] - else (t:) <$> braced' getTok (n - 1) - handleBgroup = do - t <- symbol '{' - (t:) <$> braced' getTok (n + 1) - handleOther = do - t <- getTok - (t:) <$> braced' getTok n +braced' :: PandocMonad m => LP m Tok -> LP m [Tok] +braced' getTok = symbol '{' *> go (1 :: Int) + where + go n = do + t <- getTok + case t of + Tok _ Symbol "}" + | n > 1 -> (t:) <$> go (n - 1) + | otherwise -> return [] + Tok _ Symbol "{" -> (t:) <$> go (n + 1) + _ -> (t:) <$> go n braced :: PandocMonad m => LP m [Tok] -braced = symbol '{' *> braced' anyTok 1 +braced = braced' anyTok -- URLs require special handling, because they can contain % -- characters. So we retonenize comments as we go... bracedUrl :: PandocMonad m => LP m [Tok] -bracedUrl = bgroup *> braced' (retokenizeComment >> anyTok) 1 +bracedUrl = braced' (retokenizeComment >> anyTok) -- For handling URLs, which allow literal % characters... retokenizeComment :: PandocMonad m => LP m () @@ -725,11 +762,23 @@ withRaw :: PandocMonad m => LP m a -> LP m (a, [Tok]) withRaw parser = do - inp <- getInput + rawTokensMap <- sRawTokens <$> getState + let key = case IntMap.lookupMax rawTokensMap of + Nothing -> 0 + Just (n,_) -> n + 1 + -- insert empty list at key + updateState $ \st -> st{ sRawTokens = + IntMap.insert key [] $ sRawTokens st } result <- parser - nxtpos <- option Nothing ((\(Tok pos' _ _) -> Just pos') <$> lookAhead anyTok) - let raw = takeWhile (\(Tok pos _ _) -> maybe True - (\p -> sourceName p /= sourceName pos || pos < p) nxtpos) inp + mbRevToks <- IntMap.lookup key . sRawTokens <$> getState + raw <- case mbRevToks of + Just revtoks -> do + updateState $ \st -> st{ sRawTokens = + IntMap.delete key $ sRawTokens st} + return $ reverse revtoks + Nothing -> + throwError $ PandocShouldNeverHappenError $ + "sRawTokens has nothing at key " <> T.pack (show key) return (result, raw) keyval :: PandocMonad m => LP m (Text, Text) @@ -794,7 +843,7 @@ (_, rawargs) <- withRaw $ case name of "write" -> do - void $ satisfyTok isWordTok -- digits + void $ many $ satisfyTok isDigitTok -- digits void braced "titleformat" -> do void braced @@ -809,6 +858,10 @@ void $ many braced return $ txt <> untokenize rawargs +isDigitTok :: Tok -> Bool +isDigitTok (Tok _ Word t) = T.all isDigit t +isDigitTok _ = False + skipopts :: PandocMonad m => LP m () skipopts = skipMany (void overlaySpecification <|> void rawopt) @@ -876,3 +929,35 @@ Just n -> [n, 1] Nothing -> [1] +label :: PandocMonad m => LP m () +label = do + controlSeq "label" + t <- braced + updateState $ \st -> st{ sLastLabel = Just $ untokenize t } + +setCaption :: PandocMonad m => LP m Inlines -> LP m () +setCaption inline = try $ do + skipopts + ils <- tokWith inline + optional $ try $ spaces *> label + updateState $ \st -> st{ sCaption = Just ils } + +resetCaption :: PandocMonad m => LP m () +resetCaption = updateState $ \st -> st{ sCaption = Nothing + , sLastLabel = Nothing } + +env :: PandocMonad m => Text -> LP m a -> LP m a +env name p = p <* end_ name + +tokWith :: PandocMonad m => LP m Inlines -> LP m Inlines +tokWith inlineParser = try $ spaces >> + grouped inlineParser + <|> (lookAhead anyControlSeq >> inlineParser) + <|> singleChar' + where singleChar' = do + Tok _ _ t <- singleChar + return $ str t + +addMeta :: PandocMonad m => ToMetaValue a => Text -> a -> LP m () +addMeta field val = updateState $ \st -> + st{ sMeta = addMetaField field val $ sMeta st } 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 @@ -1,12 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} module Text.Pandoc.Readers.LaTeX.SIunitx - ( dosi - , doSI - , doSIrange - , doSInum - , doSInumlist - , doSIang - ) + ( siunitxCommands ) where import Text.Pandoc.Builder import Text.Pandoc.Readers.LaTeX.Parsing @@ -20,6 +14,19 @@ import Data.Text (Text) import qualified Data.Text as T import Data.List (intersperse) + + +siunitxCommands :: PandocMonad m + => LP m Inlines -> M.Map Text (LP m Inlines) +siunitxCommands tok = M.fromList + [ ("si", skipopts *> dosi tok) + , ("SI", doSI tok) + , ("SIrange", doSIrange True tok) + , ("numrange", doSIrange False tok) + , ("numlist", doSInumlist) + , ("num", doSInum) + , ("ang", doSIang) + ] dosi :: PandocMonad m => LP m Inlines -> LP m Inlines dosi tok = grouped (siUnit tok) <|> siUnit tok diff --git a/src/Text/Pandoc/Readers/LaTeX/Table.hs b/src/Text/Pandoc/Readers/LaTeX/Table.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/Readers/LaTeX/Table.hs @@ -0,0 +1,378 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +module Text.Pandoc.Readers.LaTeX.Table + ( tableEnvironments ) +where + +import Data.Functor (($>)) +import Text.Pandoc.Class +import Text.Pandoc.Readers.LaTeX.Parsing +import Text.Pandoc.Readers.LaTeX.Types +import Text.Pandoc.Builder as B +import qualified Data.Map as M +import Data.Text (Text) +import Data.Maybe (fromMaybe) +import qualified Data.Text as T +import Control.Applicative ((<|>), optional, many) +import Control.Monad (when, void) +import Text.Pandoc.Shared (safeRead, trim) +import Text.Pandoc.Logging (LogMessage(SkippedContent)) +import Text.Pandoc.Walk (walkM) +import Text.Pandoc.Parsing hiding (blankline, many, mathDisplay, mathInline, + optional, space, spaces, withRaw, (<|>)) + +tableEnvironments :: PandocMonad m + => LP m Blocks + -> LP m Inlines + -> M.Map Text (LP m Blocks) +tableEnvironments blocks inline = + M.fromList + [ ("longtable", env "longtable" $ + resetCaption *> + simpTable blocks inline "longtable" False >>= addTableCaption) + , ("table", env "table" $ + skipopts *> resetCaption *> blocks >>= addTableCaption) + , ("tabular*", env "tabular*" $ simpTable blocks inline "tabular*" True) + , ("tabularx", env "tabularx" $ simpTable blocks inline "tabularx" True) + , ("tabular", env "tabular" $ simpTable blocks inline "tabular" False) + ] + +hline :: PandocMonad m => LP m () +hline = try $ do + spaces + controlSeq "hline" <|> + -- booktabs rules: + controlSeq "toprule" <|> + controlSeq "bottomrule" <|> + controlSeq "midrule" <|> + controlSeq "endhead" <|> + controlSeq "endfirsthead" + spaces + optional rawopt + return () + +lbreak :: PandocMonad m => LP m Tok +lbreak = (controlSeq "\\" <|> controlSeq "tabularnewline") + <* skipopts <* spaces + +amp :: PandocMonad m => LP m Tok +amp = symbol '&' + +-- Split a Word into individual Symbols (for parseAligns) +splitWordTok :: PandocMonad m => LP m () +splitWordTok = do + inp <- getInput + case inp of + (Tok spos Word t : rest) -> + setInput $ map (Tok spos Symbol . T.singleton) (T.unpack t) <> rest + _ -> return () + +parseAligns :: PandocMonad m => LP m [(Alignment, ColWidth, ([Tok], [Tok]))] +parseAligns = try $ do + let maybeBar = skipMany + (try $ sp *> (() <$ symbol '|' <|> () <$ (symbol '@' >> braced))) + let cAlign = AlignCenter <$ symbol 'c' + let lAlign = AlignLeft <$ symbol 'l' + let rAlign = AlignRight <$ symbol 'r' + let parAlign = AlignLeft <$ symbol 'p' + -- aligns from tabularx + let xAlign = AlignLeft <$ symbol 'X' + let mAlign = AlignLeft <$ symbol 'm' + let bAlign = AlignLeft <$ symbol 'b' + let alignChar = splitWordTok *> ( cAlign <|> lAlign <|> rAlign <|> parAlign + <|> xAlign <|> mAlign <|> bAlign ) + let alignPrefix = symbol '>' >> braced + let alignSuffix = symbol '<' >> braced + let colWidth = try $ do + symbol '{' + ds <- trim . untokenize <$> manyTill anyTok (controlSeq "linewidth") + spaces + symbol '}' + return $ safeRead ds + let alignSpec = do + pref <- option [] alignPrefix + spaces + al <- alignChar + width <- colWidth <|> option Nothing (do s <- untokenize <$> braced + pos <- getPosition + report $ SkippedContent s pos + return Nothing) + spaces + suff <- option [] alignSuffix + return (al, width, (pref, suff)) + let starAlign = do -- '*{2}{r}' == 'rr', we just expand like a macro + symbol '*' + spaces + ds <- trim . untokenize <$> braced + spaces + spec <- braced + case safeRead ds of + Just n -> + getInput >>= setInput . (mconcat (replicate n spec) ++) + Nothing -> Prelude.fail $ "Could not parse " <> T.unpack ds <> " as number" + bgroup + spaces + maybeBar + aligns' <- many $ try $ spaces >> optional starAlign >> + (alignSpec <* maybeBar) + spaces + egroup + spaces + return $ map toSpec aligns' + where + toColWidth (Just w) | w > 0 = ColWidth w + toColWidth _ = ColWidthDefault + toSpec (x, y, z) = (x, toColWidth y, z) + +-- N.B. this parser returns a Row that may have erroneous empty cells +-- in it. See the note above fixTableHead for details. +parseTableRow :: PandocMonad m + => LP m Blocks -- ^ block parser + -> LP m Inlines -- ^ inline parser + -> Text -- ^ table environment name + -> [([Tok], [Tok])] -- ^ pref/suffixes + -> LP m Row +parseTableRow blocks inline envname prefsufs = do + notFollowedBy (spaces *> end_ envname) + -- contexts that can contain & that is not colsep: + let canContainAmp (Tok _ (CtrlSeq "begin") _) = True + canContainAmp (Tok _ (CtrlSeq "verb") _) = True + canContainAmp (Tok _ (CtrlSeq "Verb") _) = True + canContainAmp _ = False + -- add prefixes and suffixes in token stream: + let celltoks (pref, suff) = do + prefpos <- getPosition + contents <- mconcat <$> + many ( snd <$> withRaw + ((lookAhead (controlSeq "parbox") >> + void blocks) -- #5711 + <|> + (lookAhead (satisfyTok canContainAmp) >> void inline) + <|> + (lookAhead (symbol '$') >> void inline)) + <|> + (do notFollowedBy + (() <$ amp <|> () <$ lbreak <|> end_ envname) + count 1 anyTok) ) + + suffpos <- getPosition + option [] (count 1 amp) + return $ map (setpos prefpos) pref ++ contents ++ map (setpos suffpos) suff + rawcells <- mapM celltoks prefsufs + cells <- mapM (parseFromToks (parseTableCell blocks)) rawcells + spaces + return $ Row nullAttr cells + +parseTableCell :: PandocMonad m => LP m Blocks -> LP m Cell +parseTableCell blocks = do + spaces + updateState $ \st -> st{ sInTableCell = True } + cell' <- multicolumnCell blocks + <|> multirowCell blocks + <|> parseSimpleCell + <|> parseEmptyCell + updateState $ \st -> st{ sInTableCell = False } + spaces + return cell' + where + -- The parsing of empty cells is important in LaTeX, especially when dealing + -- with multirow/multicolumn. See #6603. + parseEmptyCell = spaces $> emptyCell + parseSimpleCell = simpleCell <$> (plainify <$> blocks) + + +cellAlignment :: PandocMonad m => LP m Alignment +cellAlignment = skipMany (symbol '|') *> alignment <* skipMany (symbol '|') + where + alignment = do + c <- untoken <$> singleChar + return $ case c of + "l" -> AlignLeft + "r" -> AlignRight + "c" -> AlignCenter + "*" -> AlignDefault + _ -> AlignDefault + +plainify :: Blocks -> Blocks +plainify bs = case toList bs of + [Para ils] -> plain (fromList ils) + _ -> bs + +multirowCell :: PandocMonad m => LP m Blocks -> LP m Cell +multirowCell blocks = controlSeq "multirow" >> do + -- Full prototype for \multirow macro is: + -- \multirow[vpos]{nrows}[bigstruts]{width}[vmove]{text} + -- However, everything except `nrows` and `text` make + -- sense in the context of the Pandoc AST + _ <- optional $ symbol '[' *> cellAlignment <* symbol ']' -- vertical position + nrows <- fmap (fromMaybe 1 . safeRead . untokenize) braced + _ <- optional $ symbol '[' *> manyTill anyTok (symbol ']') -- bigstrut-related + _ <- symbol '{' *> manyTill anyTok (symbol '}') -- Cell width + _ <- optional $ symbol '[' *> manyTill anyTok (symbol ']') -- Length used for fine-tuning + content <- symbol '{' *> (plainify <$> blocks) <* symbol '}' + return $ cell AlignDefault (RowSpan nrows) (ColSpan 1) content + +multicolumnCell :: PandocMonad m => LP m Blocks -> LP m Cell +multicolumnCell blocks = controlSeq "multicolumn" >> do + span' <- fmap (fromMaybe 1 . safeRead . untokenize) braced + alignment <- symbol '{' *> cellAlignment <* symbol '}' + + let singleCell = do + content <- plainify <$> blocks + return $ cell alignment (RowSpan 1) (ColSpan span') content + + -- Two possible contents: either a \multirow cell, or content. + -- E.g. \multicol{1}{c}{\multirow{2}{1em}{content}} + -- Note that a \multirow cell can be nested in a \multicolumn, + -- but not the other way around. See #6603 + let nestedCell = do + (Cell _ _ (RowSpan rs) _ bs) <- multirowCell blocks + return $ cell + alignment + (RowSpan rs) + (ColSpan span') + (fromList bs) + + symbol '{' *> (nestedCell <|> singleCell) <* symbol '}' + +-- LaTeX tables are stored with empty cells underneath multirow cells +-- denoting the grid spaces taken up by them. More specifically, if a +-- cell spans m rows, then it will overwrite all the cells in the +-- columns it spans for (m-1) rows underneath it, requiring padding +-- cells in these places. These padding cells need to be removed for +-- proper table reading. See #6603. +-- +-- These fixTable functions do not otherwise fix up malformed +-- input tables: that is left to the table builder. +fixTableHead :: TableHead -> TableHead +fixTableHead (TableHead attr rows) = TableHead attr rows' + where + rows' = fixTableRows rows + +fixTableBody :: TableBody -> TableBody +fixTableBody (TableBody attr rhc th tb) + = TableBody attr rhc th' tb' + where + th' = fixTableRows th + tb' = fixTableRows tb + +fixTableRows :: [Row] -> [Row] +fixTableRows = fixTableRows' $ repeat Nothing + where + fixTableRows' oldHang (Row attr cells : rs) + = let (newHang, cells') = fixTableRow oldHang cells + rs' = fixTableRows' newHang rs + in Row attr cells' : rs' + fixTableRows' _ [] = [] + +-- The overhang is represented as Just (relative cell dimensions) or +-- Nothing for an empty grid space. +fixTableRow :: [Maybe (ColSpan, RowSpan)] -> [Cell] -> ([Maybe (ColSpan, RowSpan)], [Cell]) +fixTableRow oldHang cells + -- If there's overhang, drop cells until their total width meets the + -- width of the occupied grid spaces (or we run out) + | (n, prefHang, restHang) <- splitHang oldHang + , n > 0 + = let cells' = dropToWidth getCellW n cells + (restHang', cells'') = fixTableRow restHang cells' + in (prefHang restHang', cells'') + -- Otherwise record the overhang of a pending cell and fix the rest + -- of the row + | c@(Cell _ _ h w _):cells' <- cells + = let h' = max 1 h + w' = max 1 w + oldHang' = dropToWidth getHangW w' oldHang + (newHang, cells'') = fixTableRow oldHang' cells' + in (toHang w' h' <> newHang, c : cells'') + | otherwise + = (oldHang, []) + where + getCellW (Cell _ _ _ w _) = w + getHangW = maybe 1 fst + getCS (ColSpan n) = n + + toHang c r + | r > 1 = [Just (c, r)] + | otherwise = replicate (getCS c) Nothing + + -- Take the prefix of the overhang list representing filled grid + -- spaces. Also return the remainder and the length of this prefix. + splitHang = splitHang' 0 id + + splitHang' !n l (Just (c, r):xs) + = splitHang' (n + c) (l . (toHang c (r-1) ++)) xs + splitHang' n l xs = (n, l, xs) + + -- Drop list items until the total width of the dropped items + -- exceeds the passed width. + dropToWidth _ n l | n < 1 = l + dropToWidth wproj n (c:cs) = dropToWidth wproj (n - wproj c) cs + dropToWidth _ _ [] = [] + +simpTable :: PandocMonad m + => LP m Blocks + -> LP m Inlines + -> Text + -> Bool + -> LP m Blocks +simpTable blocks inline envname hasWidthParameter = try $ do + when hasWidthParameter $ () <$ tokWith inline + skipopts + colspecs <- parseAligns + let (aligns, widths, prefsufs) = unzip3 colspecs + optional $ controlSeq "caption" *> setCaption inline + spaces + optional label + spaces + optional lbreak + spaces + skipMany hline + spaces + header' <- option [] . try . fmap (:[]) $ + parseTableRow blocks inline envname prefsufs <* + lbreak <* many1 hline + spaces + rows <- sepEndBy (parseTableRow blocks inline envname prefsufs) + (lbreak <* optional (skipMany hline)) + spaces + optional $ controlSeq "caption" *> setCaption inline + spaces + optional label + spaces + optional lbreak + spaces + lookAhead $ controlSeq "end" -- make sure we're at end + let th = fixTableHead $ TableHead nullAttr header' + let tbs = [fixTableBody $ TableBody nullAttr 0 [] rows] + let tf = TableFoot nullAttr [] + return $ table emptyCaption (zip aligns widths) th tbs tf + +addTableCaption :: PandocMonad m => Blocks -> LP m Blocks +addTableCaption = walkM go + where go (Table attr c spec th tb tf) = do + st <- getState + let mblabel = sLastLabel st + capt <- case (sCaption st, mblabel) of + (Just ils, Nothing) -> return $ caption Nothing (plain ils) + (Just ils, 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 + let attr' = case (attr, mblabel) of + ((_,classes,kvs), Just ident) -> + (ident,classes,kvs) + _ -> attr + return $ addAttrDiv attr' $ Table nullAttr capt spec th tb tf + go x = return x + +-- TODO: For now we add a Div to contain table attributes, since +-- most writers don't do anything yet with attributes on Table. +-- This can be removed when that changes. +addAttrDiv :: Attr -> Block -> Block +addAttrDiv ("",[],[]) b = b +addAttrDiv attr b = Div attr [b] 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 @@ -247,51 +247,60 @@ titleBlock = pandocTitleBlock <|> mmdTitleBlock pandocTitleBlock :: PandocMonad m => MarkdownParser m () -pandocTitleBlock = try $ do +pandocTitleBlock = do guardEnabled Ext_pandoc_title_block lookAhead (char '%') - title <- option mempty titleLine - author <- option (return []) authorsLine - date <- option mempty dateLine - optional blanklines - let meta' = do title' <- title - author' <- author - date' <- date - return $ - (if null title' then id else B.setMeta "title" title') - . (if null author' then id else B.setMeta "author" author') - . (if null date' then id else B.setMeta "date" date') - $ nullMeta - updateState $ \st -> st{ stateMeta' = stateMeta' st <> meta' } + try $ do + title <- option mempty titleLine + author <- option (return []) authorsLine + date <- option mempty dateLine + optional blanklines + let meta' = do title' <- title + author' <- author + date' <- date + return $ + (if null title' + then id + else B.setMeta "title" title') + . (if null author' + then id + else B.setMeta "author" author') + . (if null date' + then id + else B.setMeta "date" date') + $ nullMeta + updateState $ \st -> st{ stateMeta' = stateMeta' st <> meta' } yamlMetaBlock :: PandocMonad m => MarkdownParser m (F Blocks) -yamlMetaBlock = try $ do +yamlMetaBlock = do guardEnabled Ext_yaml_metadata_block - string "---" - blankline - notFollowedBy blankline -- if --- is followed by a blank it's an HRULE - rawYamlLines <- manyTill anyLine stopLine - -- by including --- and ..., we allow yaml blocks with just comments: - let rawYaml = T.unlines ("---" : (rawYamlLines ++ ["..."])) - optional blanklines - newMetaF <- yamlBsToMeta (fmap B.toMetaValue <$> parseBlocks) - $ UTF8.fromTextLazy $ TL.fromStrict rawYaml - -- Since `<>` is left-biased, existing values are not touched: - updateState $ \st -> st{ stateMeta' = stateMeta' st <> newMetaF } - return mempty + try $ do + string "---" + blankline + notFollowedBy blankline -- if --- is followed by a blank it's an HRULE + rawYamlLines <- manyTill anyLine stopLine + -- by including --- and ..., we allow yaml blocks with just comments: + let rawYaml = T.unlines ("---" : (rawYamlLines ++ ["..."])) + optional blanklines + newMetaF <- yamlBsToMeta (fmap B.toMetaValue <$> parseBlocks) + $ UTF8.fromTextLazy $ TL.fromStrict rawYaml + -- Since `<>` is left-biased, existing values are not touched: + updateState $ \st -> st{ stateMeta' = stateMeta' st <> newMetaF } + return mempty stopLine :: PandocMonad m => MarkdownParser m () stopLine = try $ (string "---" <|> string "...") >> blankline >> return () mmdTitleBlock :: PandocMonad m => MarkdownParser m () -mmdTitleBlock = try $ do +mmdTitleBlock = do guardEnabled Ext_mmd_title_block - firstPair <- kvPair False - restPairs <- many (kvPair True) - let kvPairs = firstPair : restPairs - blanklines - updateState $ \st -> st{ stateMeta' = stateMeta' st <> - return (Meta $ M.fromList kvPairs) } + try $ do + firstPair <- kvPair False + restPairs <- many (kvPair True) + let kvPairs = firstPair : restPairs + blanklines + updateState $ \st -> st{ stateMeta' = stateMeta' st <> + return (Meta $ M.fromList kvPairs) } kvPair :: PandocMonad m => Bool -> MarkdownParser m (Text, MetaValue) kvPair allowEmpty = try $ do @@ -334,6 +343,8 @@ skipMany spaceChar notFollowedBy' referenceTitle 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 '>') @@ -659,15 +670,15 @@ codeBlockFenced = try $ do indentchars <- nonindentSpaces let indentLevel = T.length indentchars - c <- try (guardEnabled Ext_fenced_code_blocks >> lookAhead (char '~')) + c <- (guardEnabled Ext_fenced_code_blocks >> lookAhead (char '~')) <|> (guardEnabled Ext_backtick_code_blocks >> lookAhead (char '`')) size <- blockDelimiter (== c) Nothing skipMany spaceChar rawattr <- - (Left <$> try (guardEnabled Ext_raw_attribute >> rawAttribute)) + (Left <$> (guardEnabled Ext_raw_attribute >> try rawAttribute)) <|> (Right <$> option ("",[],[]) - (try (guardEnabled Ext_fenced_code_attributes >> attributes) + ((guardEnabled Ext_fenced_code_attributes >> try attributes) <|> ((\x -> ("",[toLanguageId x],[])) <$> many1Char nonspaceChar))) blankline contents <- T.intercalate "\n" <$> @@ -1155,11 +1166,12 @@ -- lineBlock :: PandocMonad m => MarkdownParser m (F Blocks) -lineBlock = try $ do +lineBlock = do guardEnabled Ext_line_blocks - lines' <- lineBlockLines >>= - mapM (parseFromString' (trimInlinesF <$> inlines)) - return $ B.lineBlock <$> sequence lines' + try $ do + lines' <- lineBlockLines >>= + mapM (parseFromString' (trimInlinesF <$> inlines)) + return $ B.lineBlock <$> sequence lines' -- -- Tables @@ -1261,11 +1273,12 @@ -- Parses a table caption: inlines beginning with 'Table:' -- and followed by blank lines. tableCaption :: PandocMonad m => MarkdownParser m (F Inlines) -tableCaption = try $ do +tableCaption = do guardEnabled Ext_table_captions - skipNonindentSpaces - (string ":" <* notFollowedBy (satisfy isPunctuation)) <|> string "Table:" - trimInlinesF <$> inlines1 <* blanklines + try $ do + skipNonindentSpaces + (string ":" <* notFollowedBy (satisfy isPunctuation)) <|> string "Table:" + trimInlinesF <$> inlines1 <* blanklines -- Parse a simple table with '---' header and one line per row. simpleTable :: PandocMonad m @@ -1434,15 +1447,14 @@ table = try $ do frontCaption <- option Nothing (Just <$> tableCaption) (aligns, widths, heads, lns) <- - try (guardEnabled Ext_pipe_tables >> scanForPipe >> pipeTable) <|> - try (guardEnabled Ext_multiline_tables >> - multilineTable False) <|> - try (guardEnabled Ext_simple_tables >> - (simpleTable True <|> simpleTable False)) <|> - try (guardEnabled Ext_multiline_tables >> - multilineTable True) <|> - try (guardEnabled Ext_grid_tables >> - (gridTable False <|> gridTable True)) "table" + (guardEnabled Ext_pipe_tables >> try (scanForPipe >> pipeTable)) <|> + (guardEnabled Ext_multiline_tables >> try (multilineTable False)) <|> + (guardEnabled Ext_simple_tables >> + try (simpleTable True <|> simpleTable False)) <|> + (guardEnabled Ext_multiline_tables >> + try (multilineTable True)) <|> + (guardEnabled Ext_grid_tables >> + try (gridTable False <|> gridTable True)) "table" optional blanklines caption <- case frontCaption of Nothing -> option (return mempty) tableCaption @@ -1476,35 +1488,37 @@ inlines1 = mconcat <$> many1 inline inline :: PandocMonad m => MarkdownParser m (F Inlines) -inline = choice [ whitespace - , bareURL - , str - , endline - , code - , strongOrEmph - , note - , cite - , bracketedSpan - , link - , image - , math - , strikeout - , subscript - , superscript - , inlineNote -- after superscript because of ^[link](/foo)^ - , autoLink - , spanHtml - , rawHtmlInline - , escapedNewline - , escapedChar - , rawLaTeXInline' - , exampleRef - , smart - , return . B.singleton <$> charRef - , emoji - , symbol - , ltSign - ] "inline" +inline = do + c <- lookAhead anyChar + ((case c of + ' ' -> whitespace + '\t' -> whitespace + '\n' -> endline + '`' -> code + '_' -> strongOrEmph + '*' -> strongOrEmph + '^' -> superscript <|> inlineNote -- in this order bc ^[link](/foo)^ + '[' -> note <|> cite <|> bracketedSpan <|> link + '!' -> image + '$' -> math + '~' -> strikeout <|> subscript + '<' -> autoLink <|> spanHtml <|> rawHtmlInline <|> ltSign + '\\' -> escapedNewline <|> escapedChar <|> rawLaTeXInline' + '@' -> cite <|> exampleRef + '"' -> smart + '\'' -> smart + '\8216' -> smart + '\145' -> smart + '\8220' -> smart + '\147' -> smart + '-' -> smart + '.' -> smart + '&' -> return . B.singleton <$> charRef + ':' -> emoji + _ -> mzero) + <|> bareURL + <|> str + <|> symbol) "inline" escapedChar' :: PandocMonad m => MarkdownParser m Char escapedChar' = try $ do @@ -1515,11 +1529,12 @@ <|> oneOf "\\`*_{}[]()>#+-.!~\"" escapedNewline :: PandocMonad m => MarkdownParser m (F Inlines) -escapedNewline = try $ do +escapedNewline = do guardEnabled Ext_escaped_line_breaks - char '\\' - lookAhead (char '\n') -- don't consume the newline (see #3730) - return $ return B.linebreak + try $ do + char '\\' + lookAhead (char '\n') -- don't consume the newline (see #3730) + return $ return B.linebreak escapedChar :: PandocMonad m => MarkdownParser m (F Inlines) escapedChar = do @@ -1541,19 +1556,20 @@ -- whole document has been parsed. But we need this parser -- here in case citations is disabled. exampleRef :: PandocMonad m => MarkdownParser m (F Inlines) -exampleRef = try $ do +exampleRef = do guardEnabled Ext_example_lists - char '@' - lab <- mconcat . map T.pack <$> - many (many1 alphaNum <|> - try (do c <- char '_' <|> char '-' - cs <- many1 alphaNum - return (c:cs))) - return $ do - st <- askF - return $ case M.lookup lab (stateExamples st) of - Just n -> B.str $ tshow n - Nothing -> B.str $ "@" <> lab + try $ do + char '@' + lab <- mconcat . map T.pack <$> + many (many1 alphaNum <|> + try (do c <- char '_' <|> char '-' + cs <- many1 alphaNum + return (c:cs))) + return $ do + st <- askF + return $ case M.lookup lab (stateExamples st) of + Just n -> B.str $ tshow n + Nothing -> B.str $ "@" <> lab symbol :: PandocMonad m => MarkdownParser m (F Inlines) symbol = do @@ -1580,10 +1596,10 @@ >> count (length starts) (char '`') >> notFollowedBy (char '`')) rawattr <- - (Left <$> try (guardEnabled Ext_raw_attribute >> rawAttribute)) + (Left <$> (guardEnabled Ext_raw_attribute >> try rawAttribute)) <|> (Right <$> option ("",[],[]) - (try (guardEnabled Ext_inline_code_attributes >> attributes))) + (guardEnabled Ext_inline_code_attributes >> try attributes)) return $ return $ case rawattr of Left syn -> B.rawInline syn result @@ -1676,20 +1692,22 @@ strikeEnd = try $ string "~~" superscript :: PandocMonad m => MarkdownParser m (F Inlines) -superscript = fmap B.superscript <$> try (do +superscript = do guardEnabled Ext_superscript - char '^' - mconcat <$> many1Till (do notFollowedBy spaceChar - notFollowedBy newline - inline) (char '^')) + fmap B.superscript <$> try (do + char '^' + mconcat <$> many1Till (do notFollowedBy spaceChar + notFollowedBy newline + inline) (char '^')) subscript :: PandocMonad m => MarkdownParser m (F Inlines) -subscript = fmap B.subscript <$> try (do +subscript = do guardEnabled Ext_subscript - char '~' - mconcat <$> many1Till (do notFollowedBy spaceChar - notFollowedBy newline - inline) (char '~')) + fmap B.subscript <$> try (do + char '~' + mconcat <$> many1Till (do notFollowedBy spaceChar + notFollowedBy newline + inline) (char '~')) whitespace :: PandocMonad m => MarkdownParser m (F Inlines) whitespace = spaceChar >> return <$> (lb <|> regsp) "whitespace" @@ -1707,7 +1725,7 @@ updateLastStrPos (do guardEnabled Ext_smart abbrevs <- getOption readerAbbreviations - if not (T.null result) && T.last result == '.' && result `Set.member` abbrevs + if result `Set.member` abbrevs then try (do ils <- whitespace notFollowedBy (() <$ cite <|> () <$ note) -- ?? lookAhead alphaNum @@ -1790,15 +1808,16 @@ regLink B.linkWith lab <|> referenceLink B.linkWith (lab,raw) bracketedSpan :: PandocMonad m => MarkdownParser m (F Inlines) -bracketedSpan = try $ do +bracketedSpan = do guardEnabled Ext_bracketed_spans - (lab,_) <- reference - attr <- attributes - return $ if isSmallCaps attr - then B.smallcaps <$> lab - else if isUnderline attr - then B.underline <$> lab - else B.spanWith attr <$> lab + try $ do + (lab,_) <- reference + attr <- attributes + return $ if isSmallCaps attr + then B.smallcaps <$> lab + else if isUnderline attr + then B.underline <$> lab + else B.spanWith attr <$> lab -- | We treat a span as SmallCaps if class is "smallcaps" (and -- no other attributes are set or if style is "font-variant:small-caps" @@ -1877,12 +1896,13 @@ dropLB xs = xs bareURL :: PandocMonad m => MarkdownParser m (F Inlines) -bareURL = try $ do +bareURL = do guardEnabled Ext_autolink_bare_uris getState >>= guard . stateAllowLinks - (cls, (orig, src)) <- (("uri",) <$> uri) <|> (("email",) <$> emailAddress) - notFollowedBy $ try $ spaces >> htmlTag (~== TagClose ("a" :: Text)) - return $ return $ B.linkWith ("",[cls],[]) src "" (B.str orig) + try $ do + (cls, (orig, src)) <- (("uri",) <$> uri) <|> (("email",) <$> emailAddress) + notFollowedBy $ try $ spaces >> htmlTag (~== TagClose ("a" :: Text)) + return $ return $ B.linkWith ("",[cls],[]) src "" (B.str orig) autoLink :: PandocMonad m => MarkdownParser m (F Inlines) autoLink = try $ do @@ -1935,21 +1955,23 @@ return $ B.note $ walk adjustCite contents' inlineNote :: PandocMonad m => MarkdownParser m (F Inlines) -inlineNote = try $ do +inlineNote = do guardEnabled Ext_inline_notes - char '^' - updateState $ \st -> st{ stateInNote = True - , stateNoteNumber = stateNoteNumber st + 1 } - contents <- inlinesInBalancedBrackets - updateState $ \st -> st{ stateInNote = False } - return $ B.note . B.para <$> contents + try $ do + char '^' + updateState $ \st -> st{ stateInNote = True + , stateNoteNumber = stateNoteNumber st + 1 } + contents <- inlinesInBalancedBrackets + updateState $ \st -> st{ stateInNote = False } + return $ B.note . B.para <$> contents rawLaTeXInline' :: PandocMonad m => MarkdownParser m (F Inlines) -rawLaTeXInline' = try $ do +rawLaTeXInline' = do guardEnabled Ext_raw_tex notFollowedBy' rawConTeXtEnvironment - s <- rawLaTeXInline - return $ return $ B.rawInline "tex" s -- "tex" because it might be context + try $ do + s <- rawLaTeXInline + return $ return $ B.rawInline "tex" s -- "tex" because it might be context rawConTeXtEnvironment :: PandocMonad m => ParserT Text st m Text rawConTeXtEnvironment = try $ do @@ -1968,55 +1990,60 @@ return $ "[" <> contents <> "]" spanHtml :: PandocMonad m => MarkdownParser m (F Inlines) -spanHtml = try $ do +spanHtml = do guardEnabled Ext_native_spans - (TagOpen _ attrs, _) <- htmlTag (~== TagOpen ("span" :: Text) []) - contents <- mconcat <$> manyTill inline (htmlTag (~== TagClose ("span" :: Text))) - let ident = fromMaybe "" $ lookup "id" attrs - let classes = maybe [] T.words $ lookup "class" attrs - let keyvals = [(k,v) | (k,v) <- attrs, k /= "id" && k /= "class"] - return $ if isSmallCaps (ident, classes, keyvals) - then B.smallcaps <$> contents - else if isUnderline (ident, classes, keyvals) - then B.underline <$> contents - else B.spanWith (ident, classes, keyvals) <$> contents + try $ do + (TagOpen _ attrs, _) <- htmlTag (~== TagOpen ("span" :: Text) []) + contents <- mconcat <$> manyTill inline (htmlTag (~== TagClose ("span" :: Text))) + let ident = fromMaybe "" $ lookup "id" attrs + let classes = maybe [] T.words $ lookup "class" attrs + let keyvals = [(k,v) | (k,v) <- attrs, k /= "id" && k /= "class"] + return $ if isSmallCaps (ident, classes, keyvals) + then B.smallcaps <$> contents + else if isUnderline (ident, classes, keyvals) + then B.underline <$> contents + else B.spanWith (ident, classes, keyvals) <$> contents divHtml :: PandocMonad m => MarkdownParser m (F Blocks) -divHtml = try $ do +divHtml = do guardEnabled Ext_native_divs - (TagOpen _ attrs, rawtag) <- htmlTag (~== TagOpen ("div" :: Text) []) - -- we set stateInHtmlBlock so that closing tags that can be either block or - -- inline will not be parsed as inline tags - oldInHtmlBlock <- stateInHtmlBlock <$> getState - updateState $ \st -> st{ stateInHtmlBlock = Just "div" } - bls <- option "" (blankline >> option "" blanklines) - contents <- mconcat <$> - many (notFollowedBy' (htmlTag (~== TagClose ("div" :: Text))) >> block) - closed <- option False (True <$ htmlTag (~== TagClose ("div" :: Text))) - if closed - then do - updateState $ \st -> st{ stateInHtmlBlock = oldInHtmlBlock } - let ident = fromMaybe "" $ lookup "id" attrs - let classes = maybe [] T.words $ lookup "class" attrs - let keyvals = [(k,v) | (k,v) <- attrs, k /= "id" && k /= "class"] - return $ B.divWith (ident, classes, keyvals) <$> contents - else -- avoid backtracing - return $ return (B.rawBlock "html" (rawtag <> bls)) <> contents + try $ do + (TagOpen _ attrs, rawtag) <- htmlTag (~== TagOpen ("div" :: Text) []) + -- we set stateInHtmlBlock so that closing tags that can be either block + -- or inline will not be parsed as inline tags + oldInHtmlBlock <- stateInHtmlBlock <$> getState + updateState $ \st -> st{ stateInHtmlBlock = Just "div" } + bls <- option "" (blankline >> option "" blanklines) + contents <- mconcat <$> + many (notFollowedBy' (htmlTag (~== TagClose ("div" :: Text))) >> block) + closed <- option False (True <$ htmlTag (~== TagClose ("div" :: Text))) + if closed + then do + updateState $ \st -> st{ stateInHtmlBlock = oldInHtmlBlock } + let ident = fromMaybe "" $ lookup "id" attrs + let classes = maybe [] T.words $ lookup "class" attrs + let keyvals = [(k,v) | (k,v) <- attrs, k /= "id" && k /= "class"] + return $ B.divWith (ident, classes, keyvals) <$> contents + else -- avoid backtracing + return $ return (B.rawBlock "html" (rawtag <> bls)) <> contents divFenced :: PandocMonad m => MarkdownParser m (F Blocks) -divFenced = try $ do +divFenced = do guardEnabled Ext_fenced_divs - string ":::" - skipMany (char ':') - skipMany spaceChar - attribs <- attributes <|> ((\x -> ("",[x],[])) <$> many1Char nonspaceChar) - skipMany spaceChar - skipMany (char ':') - blankline - updateState $ \st -> st{ stateFencedDivLevel = stateFencedDivLevel st + 1 } - bs <- mconcat <$> manyTill block divFenceEnd - updateState $ \st -> st{ stateFencedDivLevel = stateFencedDivLevel st - 1 } - return $ B.divWith attribs <$> bs + try $ do + string ":::" + skipMany (char ':') + skipMany spaceChar + attribs <- attributes <|> ((\x -> ("",[x],[])) <$> many1Char nonspaceChar) + skipMany spaceChar + skipMany (char ':') + blankline + updateState $ \st -> + st{ stateFencedDivLevel = stateFencedDivLevel st + 1 } + bs <- mconcat <$> manyTill block divFenceEnd + updateState $ \st -> + st{ stateFencedDivLevel = stateFencedDivLevel st - 1 } + return $ B.divWith attribs <$> bs divFenceEnd :: PandocMonad m => MarkdownParser m () divFenceEnd = try $ do @@ -2048,14 +2075,15 @@ emojiChars = ['a'..'z'] ++ ['0'..'9'] ++ ['_','+','-'] emoji :: PandocMonad m => MarkdownParser m (F Inlines) -emoji = try $ do +emoji = do guardEnabled Ext_emoji - char ':' - emojikey <- many1Char (oneOf emojiChars) - char ':' - case emojiToInline emojikey of - Just i -> return (return $ B.singleton i) - Nothing -> mzero + try $ do + char ':' + emojikey <- many1Char (oneOf emojiChars) + char ':' + case emojiToInline emojikey of + Just i -> return (return $ B.singleton i) + Nothing -> mzero -- Citations 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 @@ -13,20 +13,20 @@ module Text.Pandoc.Readers.OPML ( readOPML ) where import Control.Monad.State.Strict -import Data.Char (toUpper) import Data.Default -import Data.Generics import Data.Maybe (fromMaybe) import Data.Text (Text) import qualified Data.Text as T -import Text.HTML.TagSoup.Entity (lookupEntity) +import qualified Data.Text.Lazy as TL import Text.Pandoc.Builder import Text.Pandoc.Class.PandocMonad (PandocMonad) import Text.Pandoc.Options +import Text.Pandoc.Error (PandocError(..)) import Text.Pandoc.Readers.HTML (readHtml) import Text.Pandoc.Readers.Markdown (readMarkdown) import Text.Pandoc.Shared (crFilter, blocksToInlines') -import Text.XML.Light +import Text.Pandoc.XML.Light +import Control.Monad.Except (throwError) type OPML m = StateT OPMLState m @@ -49,39 +49,20 @@ readOPML :: PandocMonad m => ReaderOptions -> Text -> m Pandoc readOPML opts inp = do (bs, st') <- runStateT - (mapM parseBlock $ normalizeTree $ - parseXML (T.unpack (crFilter inp))) def{ opmlOptions = opts } + (case parseXMLContents (TL.fromStrict (crFilter inp)) of + Left msg -> throwError $ PandocXMLError "" msg + Right ns -> mapM parseBlock ns) + def{ opmlOptions = opts } return $ setTitle (opmlDocTitle st') $ setAuthors (opmlDocAuthors st') $ setDate (opmlDocDate st') $ doc $ mconcat bs --- normalize input, consolidating adjacent Text and CRef elements -normalizeTree :: [Content] -> [Content] -normalizeTree = everywhere (mkT go) - where go :: [Content] -> [Content] - go (Text (CData CDataRaw _ _):xs) = xs - go (Text (CData CDataText s1 z):Text (CData CDataText s2 _):xs) = - Text (CData CDataText (s1 ++ s2) z):xs - go (Text (CData CDataText s1 z):CRef r:xs) = - Text (CData CDataText (s1 ++ convertEntity r) z):xs - go (CRef r:Text (CData CDataText s1 z):xs) = - Text (CData CDataText (convertEntity r ++ s1) z):xs - go (CRef r1:CRef r2:xs) = - Text (CData CDataText (convertEntity r1 ++ convertEntity r2) Nothing):xs - go xs = xs - -convertEntity :: String -> String -convertEntity e = Data.Maybe.fromMaybe (map toUpper e) (lookupEntity e) - -- convenience function to get an attribute value, defaulting to "" -attrValue :: String -> Element -> Text +attrValue :: Text -> Element -> Text attrValue attr elt = - maybe "" T.pack (lookupAttrBy (\x -> qName x == attr) (elAttribs elt)) - -textContent :: Element -> Text -textContent = T.pack . strContent + fromMaybe "" (lookupAttrBy (\x -> qName x == attr) (elAttribs elt)) -- exceptT :: PandocMonad m => Either PandocError a -> OPML m a -- exceptT = either throwError return @@ -105,11 +86,11 @@ parseBlock (Elem e) = case qName (elName e) of "ownerName" -> mempty <$ modify (\st -> - st{opmlDocAuthors = [text $ textContent e]}) + st{opmlDocAuthors = [text $ strContent e]}) "dateModified" -> mempty <$ modify (\st -> - st{opmlDocDate = text $ textContent e}) + st{opmlDocDate = text $ strContent e}) "title" -> mempty <$ modify (\st -> - st{opmlDocTitle = text $ textContent e}) + st{opmlDocTitle = text $ strContent e}) "outline" -> gets opmlSectionLevel >>= sect . (+1) "?xml" -> return mempty _ -> getBlocks e diff --git a/src/Text/Pandoc/Readers/Odt.hs b/src/Text/Pandoc/Readers/Odt.hs --- a/src/Text/Pandoc/Readers/Odt.hs +++ b/src/Text/Pandoc/Readers/Odt.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE PatternGuards #-} {-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Reader.Odt @@ -15,7 +14,7 @@ module Text.Pandoc.Readers.Odt ( readOdt ) where import Codec.Archive.Zip -import qualified Text.XML.Light as XML +import Text.Pandoc.XML.Light import qualified Data.ByteString.Lazy as B @@ -23,6 +22,8 @@ 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 @@ -60,35 +61,37 @@ bytesToOdt :: B.ByteString -> Either PandocError (Pandoc, MediaBag) bytesToOdt bytes = case toArchiveOrFail bytes of Right archive -> archiveToOdt archive - Left _ -> Left $ PandocParseError "Couldn't parse odt file." + Left err -> Left $ PandocParseError + $ "Could not unzip ODT: " <> T.pack err -- archiveToOdt :: Archive -> Either PandocError (Pandoc, MediaBag) -archiveToOdt archive - | Just contentEntry <- findEntryByPath "content.xml" archive - , Just stylesEntry <- findEntryByPath "styles.xml" archive - , Just contentElem <- entryToXmlElem contentEntry - , Just stylesElem <- entryToXmlElem stylesEntry - , Right styles <- chooseMax (readStylesAt stylesElem ) - (readStylesAt contentElem) - , media <- filteredFilesFromArchive archive filePathIsOdtMedia - , startState <- readerState styles media - , Right pandocWithMedia <- runConverter' read_body - startState - contentElem - - = Right pandocWithMedia - - | otherwise - -- Not very detailed, but I don't think more information would be helpful - = Left $ PandocParseError "Couldn't parse odt file." - where - filePathIsOdtMedia :: FilePath -> Bool +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 -> Maybe XML.Element -entryToXmlElem = XML.parseXMLDoc . UTF8.toStringLazy . fromEntry +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/ContentReader.hs b/src/Text/Pandoc/Readers/Odt/ContentReader.hs --- a/src/Text/Pandoc/Readers/Odt/ContentReader.hs +++ b/src/Text/Pandoc/Readers/Odt/ContentReader.hs @@ -29,14 +29,14 @@ import qualified Data.ByteString.Lazy as B import Data.Foldable (fold) -import Data.List (find, stripPrefix) +import Data.List (find) import qualified Data.Map as M import qualified Data.Text as T import Data.Maybe import Data.Semigroup (First(..), Option(..)) import Text.TeXMath (readMathML, writeTeX) -import qualified Text.XML.Light as XML +import qualified Text.Pandoc.XML.Light as XML import Text.Pandoc.Builder hiding (underline) import Text.Pandoc.MediaBag (MediaBag, insertMedia) @@ -557,7 +557,7 @@ >>?% mappend -- extractText :: XML.Content -> Fallible T.Text - extractText (XML.Text cData) = succeedWith (T.pack $ XML.cdData cData) + extractText (XML.Text cData) = succeedWith (XML.cdData cData) extractText _ = failEmpty read_text_seq :: InlineMatcher @@ -777,14 +777,14 @@ "" -> returnV mempty -< () src' -> do let exts = extensionsFromList [Ext_auto_identifiers] - resource <- lookupResource -< src' + 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, T.pack src', inlineListToIdentifier exts (toList titleNodes), alt) + (image_attributes w h, src', inlineListToIdentifier exts (toList titleNodes), alt) read_frame_title :: InlineMatcher read_frame_title = matchingElement NsSVG "title" (matchChildContent [] read_plain_text) @@ -804,7 +804,8 @@ case fold src of "" -> returnV mempty -< () src' -> do - let path = fromMaybe src' (stripPrefix "./" src') ++ "/content.xml" + 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 -< () diff --git a/src/Text/Pandoc/Readers/Odt/Generic/Namespaces.hs b/src/Text/Pandoc/Readers/Odt/Generic/Namespaces.hs --- a/src/Text/Pandoc/Readers/Odt/Generic/Namespaces.hs +++ b/src/Text/Pandoc/Readers/Odt/Generic/Namespaces.hs @@ -14,9 +14,10 @@ module Text.Pandoc.Readers.Odt.Generic.Namespaces where import qualified Data.Map as M +import Data.Text (Text) -- -type NameSpaceIRI = String +type NameSpaceIRI = Text -- type NameSpaceIRIs nsID = M.Map nsID NameSpaceIRI diff --git a/src/Text/Pandoc/Readers/Odt/Generic/Utils.hs b/src/Text/Pandoc/Readers/Odt/Generic/Utils.hs --- a/src/Text/Pandoc/Readers/Odt/Generic/Utils.hs +++ b/src/Text/Pandoc/Readers/Odt/Generic/Utils.hs @@ -20,7 +20,6 @@ , reverseComposition , tryToRead , Lookupable(..) -, readLookupables , readLookupable , readPercent , findBy @@ -30,11 +29,11 @@ import Control.Category (Category, (<<<), (>>>)) import qualified Control.Category as Cat (id) -import Control.Monad (msum) - +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 @@ -76,8 +75,8 @@ -- (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) => String -> Maybe r -tryToRead = reads >>> listToMaybe >>> fmap fst +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 @@ -88,26 +87,12 @@ -- | Data that can be looked up. -- This is mostly a utility to read data with kind *. class Lookupable a where - lookupTable :: [(String, a)] - --- | The idea is to use this function as if there was a declaration like --- --- > instance (Lookupable a) => (Read a) where --- > readsPrec _ = readLookupables --- . --- But including this code in this form would need UndecideableInstances. --- That is a bad idea. Luckily 'readLookupable' (without the s at the end) --- can be used directly in almost any case. -readLookupables :: (Lookupable a) => String -> [(a,String)] -readLookupables s = [ (a,rest) | (word,rest) <- lex s, - a <- maybeToList (lookup word lookupTable) - ] + lookupTable :: [(Text, a)] -- | Very similar to a simple 'lookup' in the 'lookupTable', but with a lexer. -readLookupable :: (Lookupable a) => String -> Maybe a -readLookupable s = msum - $ map ((`lookup` lookupTable).fst) - $ lex s +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 diff --git a/src/Text/Pandoc/Readers/Odt/Generic/XMLConverter.hs b/src/Text/Pandoc/Readers/Odt/Generic/XMLConverter.hs --- a/src/Text/Pandoc/Readers/Odt/Generic/XMLConverter.hs +++ b/src/Text/Pandoc/Readers/Odt/Generic/XMLConverter.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} @@ -60,11 +61,11 @@ import Data.Bool ( bool ) import Data.Either ( rights ) import qualified Data.Map as M -import qualified Data.Text as T +import Data.Text (Text) import Data.Default import Data.Maybe -import qualified Text.XML.Light as XML +import qualified Text.Pandoc.XML.Light as XML import Text.Pandoc.Readers.Odt.Arrows.State import Text.Pandoc.Readers.Odt.Arrows.Utils @@ -78,13 +79,13 @@ -------------------------------------------------------------------------------- -- -type ElementName = String -type AttributeName = String -type AttributeValue = String -type TextAttributeValue = T.Text +type ElementName = Text +type AttributeName = Text +type AttributeValue = Text +type TextAttributeValue = Text -- -type NameSpacePrefix = String +type NameSpacePrefix = Text -- type NameSpacePrefixes nsID = M.Map nsID NameSpacePrefix @@ -461,7 +462,7 @@ lookupDefaultingAttr nsID attrName = lookupAttrWithDefault nsID attrName def --- | Return value as a (Maybe String) +-- | Return value as a (Maybe Text) findAttr' :: (NameSpaceID nsID) => nsID -> AttributeName -> XMLConverter nsID extraState x (Maybe AttributeValue) @@ -477,7 +478,6 @@ = qualifyName nsID attrName &&& getCurrentElement >>% XML.findAttr - >>^ fmap T.pack -- | Return value as string or fail findAttr :: (NameSpaceID nsID) @@ -492,7 +492,6 @@ -> FallibleXMLConverter nsID extraState x TextAttributeValue findAttrText nsID attrName = findAttr' nsID attrName - >>^ fmap T.pack >>> maybeToChoice -- | Return value as string or return provided default value @@ -511,7 +510,7 @@ -> XMLConverter nsID extraState x TextAttributeValue findAttrTextWithDefault nsID attrName deflt = findAttr' nsID attrName - >>^ maybe deflt T.pack + >>^ fromMaybe deflt -- | Read and return value or fail readAttr :: (NameSpaceID nsID, Read attrValue) @@ -748,7 +747,7 @@ -- Internals -------------------------------------------------------------------------------- -stringToBool' :: String -> Maybe Bool +stringToBool' :: Text -> Maybe Bool stringToBool' val | val `elem` trueValues = Just True | val `elem` falseValues = Just False | otherwise = Nothing diff --git a/src/Text/Pandoc/Readers/Odt/Namespaces.hs b/src/Text/Pandoc/Readers/Odt/Namespaces.hs --- a/src/Text/Pandoc/Readers/Odt/Namespaces.hs +++ b/src/Text/Pandoc/Readers/Odt/Namespaces.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Reader.Odt.Namespaces Copyright : Copyright (C) 2015 Martin Linnemann @@ -13,10 +14,10 @@ module Text.Pandoc.Readers.Odt.Namespaces ( Namespace (..) ) where -import Data.List (isPrefixOf) 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 @@ -30,7 +31,7 @@ findID :: NameSpaceIRI -> Maybe Namespace -findID iri = listToMaybe [nsID | (iri',nsID) <- nsIDs, iri' `isPrefixOf` iri] +findID iri = listToMaybe [nsID | (iri',nsID) <- nsIDs, iri' `T.isPrefixOf` iri] nsIDmap :: NameSpaceIRIs Namespace nsIDmap = foldr (uncurry $ flip M.insert) M.empty nsIDs @@ -54,12 +55,12 @@ -- Core XML (basically only for the 'id'-attribute) | NsXML -- Fallback - | NsOther String + | 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 :: [(String,Namespace)] +nsIDs :: [(Text, Namespace)] nsIDs = [ ("urn:oasis:names:tc:opendocument:xmlns:animation" , NsAnim ), ("urn:oasis:names:tc:opendocument:xmlns:chart" , NsChart ), diff --git a/src/Text/Pandoc/Readers/Odt/StyleReader.hs b/src/Text/Pandoc/Readers/Odt/StyleReader.hs --- a/src/Text/Pandoc/Readers/Odt/StyleReader.hs +++ b/src/Text/Pandoc/Readers/Odt/StyleReader.hs @@ -2,6 +2,7 @@ {-# LANGUAGE Arrows #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Readers.Odt.StyleReader Copyright : Copyright (C) 2015 Martin Linnemann @@ -46,11 +47,13 @@ import Data.List (unfoldr) 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.XML.Light as XML +import qualified Text.Pandoc.XML.Light as XML -import Text.Pandoc.Shared (safeRead) +import Text.Pandoc.Shared (safeRead, tshow) import Text.Pandoc.Readers.Odt.Arrows.Utils @@ -90,7 +93,7 @@ -- -- Thus, we want -type FontFaceName = String +type FontFaceName = Text type FontPitches = M.Map FontFaceName FontPitch @@ -151,7 +154,7 @@ -- Definitions of main data -------------------------------------------------------------------------------- -type StyleName = String +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, @@ -355,8 +358,8 @@ -- \^ simpler, but in general less efficient data ListLevelStyle = ListLevelStyle { listLevelType :: ListLevelType - , listItemPrefix :: Maybe String - , listItemSuffix :: Maybe String + , listItemPrefix :: Maybe Text + , listItemSuffix :: Maybe Text , listItemFormat :: ListItemNumberFormat , listItemStart :: Int } @@ -366,9 +369,9 @@ show ListLevelStyle{..} = " listItemPrefix) ++ show listItemFormat - ++ maybeToString listItemSuffix + ++ maybeToString (T.unpack <$> listItemSuffix) ++ ">" where maybeToString = fromMaybe "" @@ -471,7 +474,7 @@ ) where isFontEmphasised = [("normal",False),("italic",True),("oblique",True)] isFontBold = ("normal",False):("bold",True) - :map ((,True).show) ([100,200..900]::[Int]) + :map ((,True) . tshow) ([100,200..900]::[Int]) readUnderlineMode :: StyleReaderSafe _x (Maybe UnderlineMode) readUnderlineMode = readLineMode "text-underline-mode" @@ -481,7 +484,7 @@ readStrikeThroughMode = readLineMode "text-line-through-mode" "text-line-through-style" -readLineMode :: String -> String -> StyleReaderSafe _x (Maybe UnderlineMode) +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 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 @@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {- | Module : Text.Pandoc.Readers.Org.Blocks Copyright : Copyright (C) 2014-2021 Albert Krewinkel @@ -850,16 +851,52 @@ definitionMarker = spaceChar *> string "::" <* (spaceChar <|> lookAhead newline) +-- | Checkbox for tasks. +data Checkbox + = UncheckedBox + | CheckedBox + | SemicheckedBox + +-- | Parses a checkbox in a plain list. +checkbox :: PandocMonad m + => OrgParser m Checkbox +checkbox = do + guardEnabled Ext_task_lists + try (char '[' *> status <* char ']') "checkbox" + where + status = choice + [ UncheckedBox <$ char ' ' + , CheckedBox <$ char 'X' + , SemicheckedBox <$ char '-' + ] + +checkboxToInlines :: Checkbox -> Inline +checkboxToInlines = B.Str . \case + UncheckedBox -> "☐" + SemicheckedBox -> "☐" + CheckedBox -> "☒" + -- | parse raw text for one list item listItem :: PandocMonad m => OrgParser m Int -> OrgParser m (F Blocks) listItem parseIndentedMarker = try . withContext ListItemState $ do markerLength <- try parseIndentedMarker + box <- optionMaybe checkbox firstLine <- anyLineNewline blank <- option "" ("\n" <$ blankline) rest <- T.concat <$> many (listContinuation markerLength) - parseFromString blocks $ firstLine <> blank <> rest + contents <- parseFromString blocks $ firstLine <> blank <> rest + return (maybe id (prependInlines . checkboxToInlines) box <$> contents) + +-- | Prepend inlines to blocks, adding them to the first paragraph or +-- creating a new Plain element if necessary. +prependInlines :: Inline -> Blocks -> Blocks +prependInlines inlns = B.fromList . prepend . B.toList + where + prepend (Plain is : bs) = Plain (inlns : Space : is) : bs + prepend (Para is : bs) = Para (inlns : Space : is) : bs + prepend bs = Plain [inlns, Space] : bs -- continuation of a list item - indented and separated by blankline or endline. -- Note: nested lists are parsed as continuations. 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 @@ -322,7 +322,7 @@ -- from the `org-ref-cite-re` variable in `org-ref.el`. orgRefCiteKey :: PandocMonad m => OrgParser m Text orgRefCiteKey = - let citeKeySpecialChars = "-_:\\./," :: String + let citeKeySpecialChars = "-_:\\./" :: String isCiteKeySpecialChar c = c `elem` citeKeySpecialChars isCiteKeyChar c = isAlphaNum c || isCiteKeySpecialChar c endOfCitation = try $ do diff --git a/src/Text/Pandoc/Readers/RST.hs b/src/Text/Pandoc/Readers/RST.hs --- a/src/Text/Pandoc/Readers/RST.hs +++ b/src/Text/Pandoc/Readers/RST.hs @@ -28,7 +28,7 @@ import Text.Pandoc.Builder (Blocks, Inlines, fromList, setMeta, trimInlines) import qualified Text.Pandoc.Builder as B import Text.Pandoc.Class.PandocMonad (PandocMonad, fetchItem, - readFileFromDirs, getCurrentTime) + readFileFromDirs, getTimestamp) import Text.Pandoc.CSV (CSVOptions (..), defaultCSVOptions, parseCSV) import Text.Pandoc.Definition import Text.Pandoc.Error @@ -685,7 +685,7 @@ "replace" -> B.para <$> -- consumed by substKey parseInlineFromText (trim top) "date" -> B.para <$> do -- consumed by substKey - t <- getCurrentTime + t <- getTimestamp let format = case T.unpack (T.strip top) of [] -> "%Y-%m-%d" x -> x @@ -877,10 +877,11 @@ (bs, _) <- fetchItem u return $ UTF8.toText bs Nothing -> return rawcsv - let res = parseCSV opts (case explicitHeader of - Just h -> h <> "\n" <> rawcsv' - Nothing -> rawcsv') - case res of + let header' = case explicitHeader of + Just h -> parseCSV defaultCSVOptions h + Nothing -> Right [] + let res = parseCSV opts rawcsv' + case (<>) <$> header' <*> res of Left e -> throwError $ PandocParsecError "csv table" e Right rawrows -> do 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 @@ -11,7 +11,7 @@ Portability : portable Conversion from Textile to 'Pandoc' document, based on the spec -available at http://redcloth.org/textile. +available at https://www.promptworks.com/textile/. Implemented and parsed: - Paragraphs 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 @@ -21,10 +21,7 @@ -- * List processing splitBy, splitTextBy, - splitByIndices, - splitStringByIndices, splitTextByIndices, - substitute, ordNub, findM, -- * Text processing @@ -70,10 +67,10 @@ isTightList, taskListItemFromAscii, taskListItemToAscii, + handleTaskListItem, addMetaField, makeMeta, eastAsianLineBreakFilter, - underlineSpan, htmlSpanLikeElements, splitSentences, filterIpynbOutput, @@ -98,7 +95,7 @@ safeRead, safeStrRead, -- * User data directory - defaultUserDataDirs, + defaultUserDataDir, -- * Version pandocVersion ) where @@ -112,7 +109,7 @@ import Data.Char (isAlpha, isLower, isSpace, isUpper, toLower, isAlphaNum, generalCategory, GeneralCategory(NonSpacingMark, SpacingCombiningMark, EnclosingMark, ConnectorPunctuation)) -import Data.List (find, intercalate, intersperse, stripPrefix, sortOn) +import Data.List (find, intercalate, intersperse, sortOn) import qualified Data.Map as M import Data.Maybe (mapMaybe, fromMaybe) import Data.Monoid (Any (..)) @@ -150,45 +147,22 @@ splitBy _ [] = [] splitBy isSep lst = let (first, rest) = break isSep lst - rest' = dropWhile isSep rest - in first:splitBy isSep rest' + in first:splitBy isSep (dropWhile isSep rest) +-- | Split text by groups of one or more separator. splitTextBy :: (Char -> Bool) -> T.Text -> [T.Text] splitTextBy isSep t | T.null t = [] | otherwise = let (first, rest) = T.break isSep t - rest' = T.dropWhile isSep rest - in first : splitTextBy isSep rest' - -splitByIndices :: [Int] -> [a] -> [[a]] -splitByIndices [] lst = [lst] -splitByIndices (x:xs) lst = first:splitByIndices (map (\y -> y - x) xs) rest - where (first, rest) = splitAt x lst - --- | Split string into chunks divided at specified indices. -splitStringByIndices :: [Int] -> [Char] -> [[Char]] -splitStringByIndices [] lst = [lst] -splitStringByIndices (x:xs) lst = - let (first, rest) = splitAt' x lst in - first : splitStringByIndices (map (\y -> y - x) xs) rest + in first : splitTextBy isSep (T.dropWhile isSep rest) splitTextByIndices :: [Int] -> T.Text -> [T.Text] -splitTextByIndices ns = fmap T.pack . splitStringByIndices ns . T.unpack - -splitAt' :: Int -> [Char] -> ([Char],[Char]) -splitAt' _ [] = ([],[]) -splitAt' n xs | n <= 0 = ([],xs) -splitAt' n (x:xs) = (x:ys,zs) - where (ys,zs) = splitAt' (n - charWidth x) xs - --- | Replace each occurrence of one sublist in a list with another. -substitute :: (Eq a) => [a] -> [a] -> [a] -> [a] -substitute _ _ [] = [] -substitute [] _ xs = xs -substitute target replacement lst@(x:xs) = - case stripPrefix target lst of - Just lst' -> replacement ++ substitute target replacement lst' - Nothing -> x : substitute target replacement xs +splitTextByIndices ns = splitTextByRelIndices (zipWith (-) ns (0:ns)) + where + splitTextByRelIndices [] t = [t] + splitTextByRelIndices (x:xs) t = + let (first, rest) = T.splitAt x t + in first : splitTextByRelIndices xs rest ordNub :: (Ord a) => [a] -> [a] ordNub l = go Set.empty l @@ -253,17 +227,24 @@ stripTrailingNewlines :: T.Text -> T.Text stripTrailingNewlines = T.dropWhileEnd (== '\n') +isWS :: Char -> Bool +isWS ' ' = True +isWS '\r' = True +isWS '\n' = True +isWS '\t' = True +isWS _ = False + -- | Remove leading and trailing space (including newlines) from string. trim :: T.Text -> T.Text -trim = T.dropAround (`elemText` " \r\n\t") +trim = T.dropAround isWS -- | Remove leading space (including newlines) from string. triml :: T.Text -> T.Text -triml = T.dropWhile (`elemText` " \r\n\t") +triml = T.dropWhile isWS -- | Remove trailing space (including newlines) from string. trimr :: T.Text -> T.Text -trimr = T.dropWhileEnd (`elemText` " \r\n\t") +trimr = T.dropWhileEnd isWS -- | Trim leading space and trailing space unless after \. trimMath :: T.Text -> T.Text @@ -274,7 +255,7 @@ | Just ('\\', _) <- T.uncons suff = T.cons (T.last pref) suff | otherwise = suff where - (pref, suff) = T.span (`elemText` " \t\n\r") t + (pref, suff) = T.span isWS t -- | Strip leading and trailing characters from string stripFirstAndLast :: T.Text -> T.Text @@ -749,13 +730,6 @@ go xs = xs -{-# DEPRECATED underlineSpan "Use Text.Pandoc.Builder.underline instead" #-} --- | Builder for underline (deprecated). --- This probably belongs in Builder.hs in pandoc-types. --- Will be replaced once Underline is an element. -underlineSpan :: Inlines -> Inlines -underlineSpan = B.underline - -- | Set of HTML elements that are represented as Span with a class equal as -- the element tag itself. htmlSpanLikeElements :: Set.Set T.Text @@ -1038,12 +1012,16 @@ -- -- | Return appropriate user data directory for platform. We use --- XDG_DATA_HOME (or its default value), but fall back to the --- legacy user data directory ($HOME/.pandoc on *nix) if this is --- missing. -defaultUserDataDirs :: IO [FilePath] -defaultUserDataDirs = E.catch (do +-- 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. +defaultUserDataDir :: IO FilePath +defaultUserDataDir = do xdgDir <- getXdgDirectory XdgData "pandoc" legacyDir <- getAppUserDataDirectory "pandoc" - return $ ordNub [xdgDir, legacyDir]) - (\(_ :: E.SomeException) -> return []) + xdgExists <- doesDirectoryExist xdgDir + legacyDirExists <- doesDirectoryExist legacyDir + if not xdgExists && legacyDirExists + then return legacyDir + else return xdgDir 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 @@ -81,8 +81,6 @@ case format of "native" -> return "" "csljson" -> return "" - "bibtex" -> return "" - "biblatex" -> return "" "json" -> return "" "docx" -> return "" "fb2" -> return "" 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,4 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.UTF8 @@ -40,67 +39,65 @@ import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as BL +import Data.Text (Text) import qualified Data.Text as T +import qualified Data.Text.IO as TIO import qualified Data.Text.Encoding as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL import Prelude hiding (getContents, putStr, putStrLn, readFile, writeFile) import System.IO hiding (getContents, hGetContents, hPutStr, hPutStrLn, putStr, putStrLn, readFile, writeFile) -import qualified System.IO as IO -readFile :: FilePath -> IO String +readFile :: FilePath -> IO Text readFile f = do h <- openFile (encodePath f) ReadMode hGetContents h -getContents :: IO String +getContents :: IO Text getContents = hGetContents stdin -writeFileWith :: Newline -> FilePath -> String -> IO () +writeFileWith :: Newline -> FilePath -> Text -> IO () writeFileWith eol f s = withFile (encodePath f) WriteMode $ \h -> hPutStrWith eol h s -writeFile :: FilePath -> String -> IO () +writeFile :: FilePath -> Text -> IO () writeFile = writeFileWith nativeNewline -putStrWith :: Newline -> String -> IO () +putStrWith :: Newline -> Text -> IO () putStrWith eol s = hPutStrWith eol stdout s -putStr :: String -> IO () +putStr :: Text -> IO () putStr = putStrWith nativeNewline -putStrLnWith :: Newline -> String -> IO () +putStrLnWith :: Newline -> Text -> IO () putStrLnWith eol s = hPutStrLnWith eol stdout s -putStrLn :: String -> IO () +putStrLn :: Text -> IO () putStrLn = putStrLnWith nativeNewline -hPutStrWith :: Newline -> Handle -> String -> IO () +hPutStrWith :: Newline -> Handle -> Text -> IO () hPutStrWith eol h s = hSetNewlineMode h (NewlineMode eol eol) >> - hSetEncoding h utf8 >> IO.hPutStr h s + hSetEncoding h utf8 >> TIO.hPutStr h s -hPutStr :: Handle -> String -> IO () +hPutStr :: Handle -> Text -> IO () hPutStr = hPutStrWith nativeNewline -hPutStrLnWith :: Newline -> Handle -> String -> IO () +hPutStrLnWith :: Newline -> Handle -> Text -> IO () hPutStrLnWith eol h s = hSetNewlineMode h (NewlineMode eol eol) >> - hSetEncoding h utf8 >> IO.hPutStrLn h s + hSetEncoding h utf8 >> TIO.hPutStrLn h s -hPutStrLn :: Handle -> String -> IO () +hPutStrLn :: Handle -> Text -> IO () hPutStrLn = hPutStrLnWith nativeNewline -hGetContents :: Handle -> IO String -hGetContents = fmap toString . B.hGetContents --- hGetContents h = hSetEncoding h utf8_bom --- >> hSetNewlineMode h universalNewlineMode --- >> IO.hGetContents h +hGetContents :: Handle -> IO Text +hGetContents = fmap toText . B.hGetContents -- | Convert UTF8-encoded ByteString to Text, also -- removing '\r' characters. -toText :: B.ByteString -> T.Text +toText :: B.ByteString -> Text toText = T.decodeUtf8 . filterCRs . dropBOM where dropBOM bs = if "\xEF\xBB\xBF" `B.isPrefixOf` bs @@ -128,7 +125,7 @@ toStringLazy :: BL.ByteString -> String toStringLazy = TL.unpack . toTextLazy -fromText :: T.Text -> B.ByteString +fromText :: Text -> B.ByteString fromText = T.encodeUtf8 fromTextLazy :: TL.Text -> BL.ByteString 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 @@ -25,7 +25,11 @@ import Text.Pandoc.Class (PandocMonad) import Text.Pandoc.Citeproc.BibTeX as BibTeX import Text.Pandoc.Citeproc.MetaValue (metaValueToReference) -import Text.Pandoc.Writers.Shared (lookupMetaString) +import Text.Pandoc.Writers.Shared (lookupMetaString, defField, + addVariablesToContext) +import Text.DocLayout (render, vcat) +import Text.DocTemplates (Context(..)) +import Text.Pandoc.Templates (renderTemplate) -- | Write BibTeX based on the references metadata from a Pandoc document. writeBibTeX :: PandocMonad m => WriterOptions -> Pandoc -> m Text @@ -43,6 +47,15 @@ let refs = case lookupMeta "references" meta of Just (MetaList xs) -> mapMaybe metaValueToReference xs _ -> [] - return $ mconcat $ - map (BibTeX.writeBibtexString opts variant mblang) refs + let main = vcat $ map (BibTeX.writeBibtexString opts variant mblang) refs + let context = defField "body" main + $ addVariablesToContext opts (mempty :: Context Text) + let colwidth = if writerWrapText opts == WrapAuto + then Just $ writerColumns opts + else Nothing + return $ render colwidth $ + case writerTemplate opts of + Nothing -> main + Just tpl -> renderTemplate tpl context + 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 @@ -46,11 +46,11 @@ locale <- case getLocale lang of Left e -> throwError $ PandocCiteprocError e Right l -> return l - case lookupMeta "references" meta of - Just (MetaList rs) -> return $ (UTF8.toText $ - toCslJson locale (mapMaybe metaValueToReference rs)) - <> "\n" - _ -> throwError $ PandocAppError "No references field" + let rs = case lookupMeta "references" meta of + Just (MetaList xs) -> xs + _ -> [] + return $ UTF8.toText + (toCslJson locale (mapMaybe metaValueToReference rs)) <> "\n" fromInlines :: [Inline] -> CslJson Text fromInlines = foldMap fromInline . B.fromList 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 @@ -31,6 +31,7 @@ import Data.Maybe (fromMaybe, isNothing, mapMaybe, maybeToList) import qualified Data.Set as Set import qualified Data.Text as T +import Data.Text (Text) import qualified Data.Text.Lazy as TL import Data.Time.Clock.POSIX import Data.Digest.Pure.SHA (sha1, showDigest) @@ -57,19 +58,19 @@ import Text.Pandoc.Writers.Shared import Text.Printf (printf) import Text.TeXMath -import Text.XML.Light as XML -import Text.XML.Light.Cursor as XMLC import Text.Pandoc.Writers.OOXML +import Text.Pandoc.XML.Light as XML +import Data.Generics (mkT, everywhere) data ListMarker = NoMarker | BulletMarker | NumberMarker ListNumberStyle ListNumberDelim Int deriving (Show, Read, Eq, Ord) -listMarkerToId :: ListMarker -> String +listMarkerToId :: ListMarker -> Text listMarkerToId NoMarker = "990" listMarkerToId BulletMarker = "991" -listMarkerToId (NumberMarker sty delim n) = +listMarkerToId (NumberMarker sty delim n) = T.pack $ '9' : '9' : styNum : delimNum : show n where styNum = case sty of DefaultStyle -> '2' @@ -106,8 +107,8 @@ , envListLevel :: Int , envListNumId :: Int , envInDel :: Bool - , envChangesAuthor :: T.Text - , envChangesDate :: T.Text + , envChangesAuthor :: Text + , envChangesDate :: Text , envPrintWidth :: Integer } @@ -125,9 +126,9 @@ data WriterState = WriterState{ stFootnotes :: [Element] - , stComments :: [([(T.Text, T.Text)], [Inline])] - , stSectionIds :: Set.Set T.Text - , stExternalLinks :: M.Map String String + , stComments :: [([(Text, Text)], [Inline])] + , stSectionIds :: Set.Set Text + , stExternalLinks :: M.Map Text Text , stImages :: M.Map FilePath (String, String, Maybe MimeType, B.ByteString) , stLists :: [ListMarker] , stInsId :: Int @@ -164,18 +165,18 @@ type WS m = ReaderT WriterEnv (StateT WriterState m) -renumIdMap :: Int -> [Element] -> M.Map String String +renumIdMap :: Int -> [Element] -> M.Map Text Text renumIdMap _ [] = M.empty renumIdMap n (e:es) | Just oldId <- findAttr (QName "Id" Nothing Nothing) e = - M.insert oldId ("rId" ++ show n) (renumIdMap (n+1) es) + M.insert oldId ("rId" <> tshow n) (renumIdMap (n+1) es) | otherwise = renumIdMap n es -replaceAttr :: (QName -> Bool) -> String -> [XML.Attr] -> [XML.Attr] +replaceAttr :: (QName -> Bool) -> Text -> [XML.Attr] -> [XML.Attr] replaceAttr f val = map $ \a -> if f (attrKey a) then XML.Attr (attrKey a) val else a -renumId :: (QName -> Bool) -> M.Map String String -> Element -> Element +renumId :: (QName -> Bool) -> M.Map Text Text -> Element -> Element renumId f renumMap e | Just oldId <- findAttrBy f e , Just newId <- M.lookup oldId renumMap = @@ -184,18 +185,12 @@ e { elAttribs = attrs' } | otherwise = e -renumIds :: (QName -> Bool) -> M.Map String String -> [Element] -> [Element] +renumIds :: (QName -> Bool) -> M.Map Text Text -> [Element] -> [Element] renumIds f renumMap = map (renumId f renumMap) -findAttrTextBy :: (QName -> Bool) -> Element -> Maybe T.Text -findAttrTextBy x = fmap T.pack . findAttrBy x - -lookupAttrTextBy :: (QName -> Bool) -> [XML.Attr] -> Maybe T.Text -lookupAttrTextBy x = fmap T.pack . lookupAttrBy x - -- | Certain characters are invalid in XML even if escaped. -- See #1992 -stripInvalidChars :: T.Text -> T.Text +stripInvalidChars :: Text -> Text stripInvalidChars = T.filter isValidChar -- | See XML reference @@ -217,7 +212,7 @@ let doc' = Pandoc meta blocks' username <- P.lookupEnv "USERNAME" - utctime <- P.getCurrentTime + utctime <- P.getTimestamp oldUserDataDir <- P.getUserDataDir P.setUserDataDir Nothing res <- P.readDefaultDataFile "reference.docx" @@ -234,11 +229,11 @@ -- Gets the template size let mbpgsz = mbsectpr >>= filterElementName (wname (=="pgSz")) - let mbAttrSzWidth = mbpgsz >>= lookupAttrTextBy ((=="w") . qName) . elAttribs + let mbAttrSzWidth = mbpgsz >>= lookupAttrBy ((=="w") . qName) . elAttribs let mbpgmar = mbsectpr >>= filterElementName (wname (=="pgMar")) - let mbAttrMarLeft = mbpgmar >>= lookupAttrTextBy ((=="left") . qName) . elAttribs - let mbAttrMarRight = mbpgmar >>= lookupAttrTextBy ((=="right") . qName) . elAttribs + let mbAttrMarLeft = mbpgmar >>= lookupAttrBy ((=="left") . qName) . elAttribs + let mbAttrMarRight = mbpgmar >>= lookupAttrBy ((=="right") . qName) . elAttribs -- Get the available area (converting the size and the margins to int and -- doing the difference @@ -250,25 +245,22 @@ -- styles mblang <- toLang $ getLang opts meta + -- TODO FIXME avoid this generic traversal! + -- lang is in w:docDefaults / w:rPr / w:lang let addLang :: Element -> Element - addLang e = case (\l -> XMLC.toTree . go (T.unpack $ renderLang l) $ - XMLC.fromElement e) <$> mblang of - Just (Elem e') -> e' - _ -> e -- return original - where go :: String -> Cursor -> Cursor - go l cursor = case XMLC.findRec (isLangElt . current) cursor of - Nothing -> cursor - Just t -> XMLC.modifyContent (setval l) t - setval :: String -> Content -> Content - setval l (Elem e') = Elem $ e'{ elAttribs = map (setvalattr l) $ - elAttribs e' } - setval _ x = x - setvalattr :: String -> XML.Attr -> XML.Attr - setvalattr l (XML.Attr qn@(QName "val" _ _) _) = XML.Attr qn l - setvalattr _ x = x - isLangElt (Elem e') = qName (elName e') == "lang" - isLangElt _ = False + addLang = case mblang of + Nothing -> id + Just l -> everywhere (mkT (go (renderLang l))) + where + go :: Text -> Element -> Element + go l e' + | qName (elName e') == "lang" + = e'{ elAttribs = map (setvalattr l) $ elAttribs e' } + | otherwise = e' + setvalattr l (XML.Attr qn@(QName "val" _ _) _) = XML.Attr qn l + setvalattr _ x = x + let stylepath = "word/styles.xml" styledoc <- addLang <$> parseXml refArchive distArchive stylepath @@ -337,12 +329,13 @@ -- [Content_Types].xml let mkOverrideNode (part', contentType') = mknode "Override" - [("PartName",part'),("ContentType",contentType')] () + [("PartName", T.pack part') + ,("ContentType", contentType')] () let mkImageOverride (_, imgpath, mbMimeType, _) = - mkOverrideNode ("/word/" ++ imgpath, - maybe "application/octet-stream" T.unpack mbMimeType) + mkOverrideNode ("/word/" <> imgpath, + fromMaybe "application/octet-stream" mbMimeType) let mkMediaOverride imgpath = - mkOverrideNode ('/':imgpath, T.unpack $ getMimeTypeDef imgpath) + mkOverrideNode ("/" <> imgpath, getMimeTypeDef imgpath) let overrides = map mkOverrideNode ( [("/word/webSettings.xml", "application/vnd.openxmlformats-officedocument.wordprocessingml.webSettings+xml") @@ -369,13 +362,14 @@ ,("/word/footnotes.xml", "application/vnd.openxmlformats-officedocument.wordprocessingml.footnotes+xml") ] ++ - map (\x -> (maybe "" ("/word/" ++) $ extractTarget x, + map (\x -> (maybe "" (T.unpack . ("/word/" <>)) (extractTarget x), "application/vnd.openxmlformats-officedocument.wordprocessingml.header+xml")) headers ++ - map (\x -> (maybe "" ("/word/" ++) $ extractTarget x, + map (\x -> (maybe "" (T.unpack . ("/word/" <>)) (extractTarget x), "application/vnd.openxmlformats-officedocument.wordprocessingml.footer+xml")) footers) ++ map mkImageOverride imgs ++ - [ mkMediaOverride (eRelativePath e) | e <- zEntries refArchive - , "word/media/" `isPrefixOf` eRelativePath e ] + [ mkMediaOverride (eRelativePath e) + | e <- zEntries refArchive + , "word/media/" `isPrefixOf` eRelativePath e ] let defaultnodes = [mknode "Default" [("Extension","xml"),("ContentType","application/xml")] (), @@ -421,7 +415,7 @@ let renumHeaders = renumIds (\q -> qName q == "Id") idMap headers let renumFooters = renumIds (\q -> qName q == "Id") idMap footers let baserels = baserels' ++ renumHeaders ++ renumFooters - let toImgRel (ident,path,_,_) = mknode "Relationship" [("Type","http://schemas.openxmlformats.org/officeDocument/2006/relationships/image"),("Id",ident),("Target",path)] () + let toImgRel (ident,path,_,_) = mknode "Relationship" [("Type","http://schemas.openxmlformats.org/officeDocument/2006/relationships/image"),("Id",T.pack ident),("Target",T.pack path)] () let imgrels = map toImgRel imgs let toLinkRel (src,ident) = mknode "Relationship" [("Type","http://schemas.openxmlformats.org/officeDocument/2006/relationships/hyperlink"),("Id",ident),("Target",src),("TargetMode","External") ] () let linkrels = map toLinkRel $ M.toList $ stExternalLinks st @@ -489,10 +483,10 @@ numbering <- parseXml refArchive distArchive numpath let newNumElts = mkNumbering (stLists st) let pandocAdded e = - case findAttrTextBy ((== "abstractNumId") . qName) e >>= safeRead of + case findAttrBy ((== "abstractNumId") . qName) e >>= safeRead of Just numid -> numid >= (990 :: Int) Nothing -> - case findAttrTextBy ((== "numId") . qName) e >>= safeRead of + case findAttrBy ((== "numId") . qName) e >>= safeRead of Just numid -> numid >= (1000 :: Int) Nothing -> False let oldElts = filter (not . pandocAdded) $ onlyElems (elContent numbering) @@ -514,7 +508,7 @@ let extraCoreProps = ["subject","lang","category","description"] let extraCorePropsMap = M.fromList $ zip extraCoreProps ["dc:subject","dc:language","cp:category","dc:description"] - let lookupMetaString' :: T.Text -> Meta -> T.Text + let lookupMetaString' :: Text -> Meta -> Text lookupMetaString' key' meta' = case key' of "description" -> T.intercalate "_x000d_\n" (map stringify $ lookupMetaBlocks "description" meta') @@ -530,21 +524,21 @@ : mktnode "dc:creator" [] (T.intercalate "; " (map stringify $ docAuthors meta)) : [ mktnode (M.findWithDefault "" k extraCorePropsMap) [] (lookupMetaString' k meta) | k <- M.keys (unMeta meta), k `elem` extraCoreProps] - ++ mknode "cp:keywords" [] (T.unpack $ T.intercalate ", " keywords) + ++ mknode "cp:keywords" [] (T.intercalate ", " keywords) : (\x -> [ mknode "dcterms:created" [("xsi:type","dcterms:W3CDTF")] x , mknode "dcterms:modified" [("xsi:type","dcterms:W3CDTF")] x - ]) (formatTime defaultTimeLocale "%FT%XZ" utctime) + ]) (T.pack $ formatTime defaultTimeLocale "%FT%XZ" utctime) let docPropsEntry = toEntry docPropsPath epochtime $ renderXml docProps -- docProps/custom.xml - let customProperties :: [(String, String)] - customProperties = [ (T.unpack k, T.unpack $ lookupMetaString k meta) + let customProperties :: [(Text, Text)] + customProperties = [ (k, lookupMetaString k meta) | k <- M.keys (unMeta meta) , k `notElem` (["title", "author", "keywords"] ++ extraCoreProps)] let mkCustomProp (k, v) pid = mknode "property" [("fmtid","{D5CDD505-2E9C-101B-9397-08002B2CF9AE}") - ,("pid", show pid) + ,("pid", tshow pid) ,("name", k)] $ mknode "vt:lpwstr" [] v let customPropsPath = "docProps/custom.xml" let customProps = mknode "Properties" @@ -594,7 +588,8 @@ fontTableEntry <- entryFromArchive refArchive "word/fontTable.xml" webSettingsEntry <- entryFromArchive refArchive "word/webSettings.xml" headerFooterEntries <- mapM (entryFromArchive refArchive . ("word/" ++)) $ - mapMaybe extractTarget (headers ++ footers) + mapMaybe (fmap T.unpack . extractTarget) + (headers ++ footers) let miscRelEntries = [ e | e <- zEntries refArchive , "word/_rels/" `isPrefixOf` eRelativePath e , ".xml.rels" `isSuffixOf` eRelativePath e @@ -620,8 +615,8 @@ let styleId = T.filter (not . isSpace) s in mknode "w:style" [ ("w:type", "paragraph") , ("w:customStyle", "1") - , ("w:styleId", T.unpack styleId)] - [ mknode "w:name" [("w:val", T.unpack s)] () + , ("w:styleId", styleId)] + [ mknode "w:name" [("w:val", s)] () , mknode "w:basedOn" [("w:val","BodyText")] () , mknode "w:qFormat" [] () ] @@ -631,8 +626,8 @@ let styleId = T.filter (not . isSpace) s in mknode "w:style" [ ("w:type", "character") , ("w:customStyle", "1") - , ("w:styleId", T.unpack styleId)] - [ mknode "w:name" [("w:val", T.unpack s)] () + , ("w:styleId", styleId)] + [ mknode "w:name" [("w:val", s)] () , mknode "w:basedOn" [("w:val","BodyTextChar")] () ] @@ -643,13 +638,14 @@ toStyle toktype | hasStyleName (fromString $ show toktype) (smCharStyle sm) = Nothing | otherwise = Just $ mknode "w:style" [("w:type","character"), - ("w:customStyle","1"),("w:styleId",show toktype)] - [ mknode "w:name" [("w:val",show toktype)] () + ("w:customStyle","1"),("w:styleId", tshow toktype)] + [ mknode "w:name" [("w:val", tshow toktype)] () , mknode "w:basedOn" [("w:val","VerbatimChar")] () , mknode "w:rPr" [] $ - [ mknode "w:color" [("w:val",tokCol toktype)] () + [ mknode "w:color" [("w:val", tokCol toktype)] () | tokCol toktype /= "auto" ] ++ - [ mknode "w:shd" [("w:val","clear"),("w:fill",tokBg toktype)] () + [ mknode "w:shd" [("w:val","clear") + ,("w:fill",tokBg toktype)] () | tokBg toktype /= "auto" ] ++ [ mknode "w:b" [] () | tokFeature tokenBold toktype ] ++ [ mknode "w:i" [] () | tokFeature tokenItalic toktype ] ++ @@ -657,10 +653,10 @@ ] tokStyles = tokenStyles style tokFeature f toktype = maybe False f $ M.lookup toktype tokStyles - tokCol toktype = maybe "auto" (drop 1 . fromColor) + tokCol toktype = maybe "auto" (T.pack . drop 1 . fromColor) $ (tokenColor =<< M.lookup toktype tokStyles) `mplus` defaultColor style - tokBg toktype = maybe "auto" (drop 1 . fromColor) + tokBg toktype = maybe "auto" (T.pack . drop 1 . fromColor) $ (tokenBackground =<< M.lookup toktype tokStyles) `mplus` backgroundColor style parStyle | hasStyleName "Source Code" (smParaStyle sm) = Nothing @@ -673,10 +669,11 @@ , mknode "w:pPr" [] $ mknode "w:wordWrap" [("w:val","off")] () : - maybe [] (\col -> [mknode "w:shd" [("w:val","clear"),("w:fill",drop 1 $ fromColor col)] ()]) (backgroundColor style) + maybe [] (\col -> [mknode "w:shd" [("w:val","clear"),("w:fill", T.pack $ drop 1 $ fromColor col)] ()]) (backgroundColor style) ] -copyChildren :: (PandocMonad m) => Archive -> Archive -> String -> Integer -> [String] -> m Entry +copyChildren :: (PandocMonad m) + => Archive -> Archive -> String -> Integer -> [Text] -> m Entry copyChildren refArchive distArchive path timestamp elNames = do ref <- parseXml refArchive distArchive path dist <- parseXml distArchive distArchive path @@ -685,7 +682,7 @@ } where strName QName{qName=name, qPrefix=prefix} - | Just p <- prefix = p++":"++name + | Just p <- prefix = p <> ":" <> name | otherwise = name shouldCopy = (`elem` elNames) . strName cleanElem el@Element{elName=name} = Elem el{elName=name{qURI=Nothing}} @@ -706,35 +703,35 @@ mkNum :: ListMarker -> Int -> Element mkNum marker numid = - mknode "w:num" [("w:numId",show numid)] + mknode "w:num" [("w:numId",tshow numid)] $ mknode "w:abstractNumId" [("w:val",listMarkerToId marker)] () : case marker of NoMarker -> [] BulletMarker -> [] NumberMarker _ _ start -> - map (\lvl -> mknode "w:lvlOverride" [("w:ilvl",show (lvl :: Int))] - $ mknode "w:startOverride" [("w:val",show start)] ()) + map (\lvl -> mknode "w:lvlOverride" [("w:ilvl",tshow (lvl :: Int))] + $ mknode "w:startOverride" [("w:val",tshow start)] ()) [0..maxListLevel] mkAbstractNum :: ListMarker -> Integer -> Element mkAbstractNum marker nsid = mknode "w:abstractNum" [("w:abstractNumId",listMarkerToId marker)] - $ mknode "w:nsid" [("w:val", printf "%8x" nsid)] () + $ mknode "w:nsid" [("w:val", T.pack $ printf "%8x" nsid)] () : mknode "w:multiLevelType" [("w:val","multilevel")] () : map (mkLvl marker) [0..maxListLevel] mkLvl :: ListMarker -> Int -> Element mkLvl marker lvl = - mknode "w:lvl" [("w:ilvl",show lvl)] $ + mknode "w:lvl" [("w:ilvl",tshow lvl)] $ [ mknode "w:start" [("w:val",start)] () | marker /= NoMarker && marker /= BulletMarker ] ++ [ mknode "w:numFmt" [("w:val",fmt)] () - , mknode "w:lvlText" [("w:val",lvltxt)] () + , mknode "w:lvlText" [("w:val", lvltxt)] () , mknode "w:lvlJc" [("w:val","left")] () , mknode "w:pPr" [] - [ mknode "w:ind" [ ("w:left",show $ lvl * step + step) - , ("w:hanging",show (hang :: Int)) + [ mknode "w:ind" [ ("w:left",tshow $ lvl * step + step) + , ("w:hanging",tshow (hang :: Int)) ] () ] ] @@ -743,8 +740,8 @@ NoMarker -> ("bullet"," ","1") BulletMarker -> ("bullet",bulletFor lvl,"1") NumberMarker st de n -> (styleFor st lvl - ,patternFor de ("%" ++ show (lvl + 1)) - ,show n) + ,patternFor de ("%" <> tshow (lvl + 1)) + ,tshow n) step = 720 hang = 480 bulletFor 0 = "\x2022" -- filled circle @@ -767,9 +764,9 @@ styleFor DefaultStyle 5 = "lowerRoman" styleFor DefaultStyle x = styleFor DefaultStyle (x `mod` 6) styleFor _ _ = "decimal" - patternFor OneParen s = s ++ ")" - patternFor TwoParens s = "(" ++ s ++ ")" - patternFor _ s = s ++ "." + patternFor OneParen s = s <> ")" + patternFor TwoParens s = "(" <> s <> ")" + patternFor _ s = s <> "." getNumId :: (PandocMonad m) => WS m Int getNumId = (((baseListId - 1) +) . length) `fmap` gets stLists @@ -777,8 +774,8 @@ makeTOC :: (PandocMonad m) => WriterOptions -> WS m [Element] makeTOC opts = do - let depth = "1-"++show (writerTOCDepth opts) - let tocCmd = "TOC \\o \""++depth++"\" \\h \\z \\u" + let depth = "1-" <> tshow (writerTOCDepth opts) + let tocCmd = "TOC \\o \"" <> depth <> "\" \\h \\z \\u" tocTitle <- gets stTocTitle title <- withParaPropM (pStyleM "TOC Heading") (blocksToOpenXML opts [Para tocTitle]) return @@ -831,7 +828,7 @@ let toComment (kvs, ils) = do annotation <- inlinesToOpenXML opts ils return $ - mknode "w:comment" [('w':':':T.unpack k,T.unpack v) | (k,v) <- kvs] + mknode "w:comment" [("w:" <> k, v) | (k,v) <- kvs] [ mknode "w:p" [] $ map Elem [ mknode "w:pPr" [] @@ -867,24 +864,24 @@ pStyleM styleName = do pStyleMap <- gets (smParaStyle . stStyleMaps) let sty' = getStyleIdFromName styleName pStyleMap - return $ mknode "w:pStyle" [("w:val", T.unpack $ fromStyleId sty')] () + return $ mknode "w:pStyle" [("w:val", fromStyleId sty')] () rStyleM :: (PandocMonad m) => CharStyleName -> WS m XML.Element rStyleM styleName = do cStyleMap <- gets (smCharStyle . stStyleMaps) let sty' = getStyleIdFromName styleName cStyleMap - return $ mknode "w:rStyle" [("w:val", T.unpack $ fromStyleId sty')] () + return $ mknode "w:rStyle" [("w:val", fromStyleId sty')] () -getUniqueId :: (PandocMonad m) => WS m String +getUniqueId :: (PandocMonad m) => WS m Text -- the + 20 is to ensure that there are no clashes with the rIds -- already in word/document.xml.rel getUniqueId = do n <- gets stCurId modify $ \st -> st{stCurId = n + 1} - return $ show n + return $ tshow n -- | Key for specifying user-defined docx styles. -dynamicStyleKey :: T.Text +dynamicStyleKey :: Text dynamicStyleKey = "custom-style" -- | Convert a Pandoc block element to OpenXML. @@ -979,7 +976,7 @@ blockToOpenXML' opts (LineBlock lns) = blockToOpenXML opts $ linesToPara lns blockToOpenXML' _ b@(RawBlock format str) | format == Format "openxml" = return [ - Text (CData CDataRaw (T.unpack str) Nothing) + Text (CData CDataRaw str Nothing) ] | otherwise = do report $ BlockNotRendered b @@ -1036,7 +1033,7 @@ let fullrow = 5000 -- 100% specified in pct let rowwidth = fullrow * sum widths let mkgridcol w = mknode "w:gridCol" - [("w:w", show (floor (textwidth * w) :: Integer))] () + [("w:w", tshow (floor (textwidth * w) :: Integer))] () let hasHeader = not $ all null headers modify $ \s -> s { stInTable = False } -- for compatibility with Word <= 2007, we include a val with a bitmask @@ -1054,16 +1051,16 @@ mknode "w:tbl" [] ( mknode "w:tblPr" [] ( mknode "w:tblStyle" [("w:val","Table")] () : - mknode "w:tblW" [("w:type", "pct"), ("w:w", show rowwidth)] () : + mknode "w:tblW" [("w:type", "pct"), ("w:w", tshow rowwidth)] () : mknode "w:tblLook" [("w:firstRow",if hasHeader then "1" else "0") ,("w:lastRow","0") ,("w:firstColumn","0") ,("w:lastColumn","0") ,("w:noHBand","0") ,("w:noVBand","0") - ,("w:val", printf "%04x" tblLookVal) + ,("w:val", T.pack $ printf "%04x" tblLookVal) ] () : - [ mknode "w:tblCaption" [("w:val", T.unpack captionStr)] () + [ mknode "w:tblCaption" [("w:val", captionStr)] () | not (null caption) ] ) : mknode "w:tblGrid" [] (if all (==0) widths @@ -1126,7 +1123,7 @@ modify $ \st -> st{ stInList = oldInList } return $ first'' ++ rest'' -alignmentToString :: Alignment -> [Char] +alignmentToString :: Alignment -> Text alignmentToString alignment = case alignment of AlignLeft -> "left" AlignRight -> "right" @@ -1169,8 +1166,8 @@ listLevel <- asks envListLevel numid <- asks envListNumId let listPr = [mknode "w:numPr" [] - [ mknode "w:ilvl" [("w:val",show listLevel)] () - , mknode "w:numId" [("w:val",show numid)] () ] | listLevel >= 0 && not displayMathPara] + [ mknode "w:ilvl" [("w:val",tshow listLevel)] () + , mknode "w:numId" [("w:val",tshow numid)] () ] | listLevel >= 0 && not displayMathPara] return $ case listPr ++ squashProps props of [] -> [] ps -> [mknode "w:pPr" [] ps] @@ -1185,7 +1182,7 @@ d <- md withParaProp d p -formattedString :: PandocMonad m => T.Text -> WS m [Element] +formattedString :: PandocMonad m => Text -> WS m [Element] formattedString str = -- properly handle soft hyphens case splitTextBy (=='\173') str of @@ -1194,7 +1191,7 @@ sh <- formattedRun [mknode "w:softHyphen" [] ()] intercalate sh <$> mapM formattedString' ws -formattedString' :: PandocMonad m => T.Text -> WS m [Element] +formattedString' :: PandocMonad m => Text -> WS m [Element] formattedString' str = do inDel <- asks envInDel formattedRun [ mktnode (if inDel then "w:delText" else "w:t") @@ -1226,7 +1223,7 @@ mknode "w:r" [] (mknode "w:t" [("xml:space","preserve")] - ("\t" :: String))] ++) + ("\t" :: Text))] ++) <$> inlinesToOpenXML opts ils inlineToOpenXML' opts (Span ("",["csl-indent"],[]) ils) = inlinesToOpenXML opts ils @@ -1236,17 +1233,17 @@ let ident' = fromMaybe ident (lookup "id" kvs) kvs' = filter (("id" /=) . fst) kvs modify $ \st -> st{ stComments = (("id",ident'):kvs', ils) : stComments st } - return [ Elem $ mknode "w:commentRangeStart" [("w:id", T.unpack ident')] () ] + return [ Elem $ mknode "w:commentRangeStart" [("w:id", ident')] () ] inlineToOpenXML' _ (Span (ident,["comment-end"],kvs) _) = -- prefer the "id" in kvs, since that is the one produced by the docx -- reader. let ident' = fromMaybe ident (lookup "id" kvs) in return . map Elem $ - [ mknode "w:commentRangeEnd" [("w:id", T.unpack ident')] () + [ mknode "w:commentRangeEnd" [("w:id", ident')] () , mknode "w:r" [] [ mknode "w:rPr" [] [ mknode "w:rStyle" [("w:val", "CommentReference")] () ] - , mknode "w:commentReference" [("w:id", T.unpack ident')] () ] + , mknode "w:commentReference" [("w:id", ident')] () ] ] inlineToOpenXML' opts (Span (ident,classes,kvs) ils) = do stylemod <- case lookup dynamicStyleKey kvs of @@ -1270,8 +1267,8 @@ defaultAuthor <- asks envChangesAuthor let author = fromMaybe defaultAuthor (lookup "author" kvs) let mdate = lookup "date" kvs - return $ ("w:author", T.unpack author) : - maybe [] (\date -> [("w:date", T.unpack date)]) mdate + return $ ("w:author", author) : + maybe [] (\date -> [("w:date", date)]) mdate insmod <- if "insertion" `elem` classes then do changeAuthorDate <- getChangeAuthorDate @@ -1281,7 +1278,7 @@ x <- f return [Elem $ mknode "w:ins" - (("w:id", show insId) : changeAuthorDate) x] + (("w:id", tshow insId) : changeAuthorDate) x] else return id delmod <- if "deletion" `elem` classes then do @@ -1291,7 +1288,7 @@ return $ \f -> local (\env->env{envInDel=True}) $ do x <- f return [Elem $ mknode "w:del" - (("w:id", show delId) : changeAuthorDate) x] + (("w:id", tshow delId) : changeAuthorDate) x] else return id contents <- insmod $ delmod $ dirmod $ stylemod $ pmod $ inlinesToOpenXML opts ils @@ -1322,7 +1319,7 @@ inlineToOpenXML' _ LineBreak = return [Elem br] inlineToOpenXML' _ il@(RawInline f str) | f == Format "openxml" = return - [Text (CData CDataRaw (T.unpack str) Nothing)] + [Text (CData CDataRaw str Nothing)] | otherwise = do report $ InlineNotRendered il return [] @@ -1335,7 +1332,7 @@ when (mathType == DisplayMath) setFirstPara res <- (lift . lift) (convertMath writeOMML mathType str) case res of - Right r -> return [Elem r] + Right r -> return [Elem $ fromXLElement r] Left il -> inlineToOpenXML' opts il inlineToOpenXML' opts (Cite _ lst) = inlinesToOpenXML opts lst inlineToOpenXML' opts (Code attrs str) = do @@ -1348,7 +1345,7 @@ mknode "w:r" [] [ mknode "w:rPr" [] $ maybeToList (lookup toktype tokTypesMap) - , mknode "w:t" [("xml:space","preserve")] (T.unpack tok) ] + , mknode "w:t" [("xml:space","preserve")] tok ] withTextPropM (rStyleM "Verbatim Char") $ if isNothing (writerHighlightStyle opts) then unhighlighted @@ -1365,7 +1362,7 @@ let notemarker = mknode "w:r" [] [ mknode "w:rPr" [] footnoteStyle , mknode "w:footnoteRef" [] () ] - let notemarkerXml = RawInline (Format "openxml") $ T.pack $ ppElement notemarker + let notemarkerXml = RawInline (Format "openxml") $ ppElement notemarker let insertNoteRef (Plain ils : xs) = Plain (notemarkerXml : Space : ils) : xs insertNoteRef (Para ils : xs) = Para (notemarkerXml : Space : ils) : xs insertNoteRef xs = Para [notemarkerXml] : xs @@ -1384,17 +1381,17 @@ inlineToOpenXML' opts (Link _ txt (T.uncons -> Just ('#', xs),_)) = do contents <- withTextPropM (rStyleM "Hyperlink") $ inlinesToOpenXML opts txt return - [ Elem $ mknode "w:hyperlink" [("w:anchor", T.unpack $ toBookmarkName xs)] contents ] + [ Elem $ mknode "w:hyperlink" [("w:anchor", toBookmarkName xs)] contents ] -- external link: inlineToOpenXML' opts (Link _ txt (src,_)) = do contents <- withTextPropM (rStyleM "Hyperlink") $ inlinesToOpenXML opts txt extlinks <- gets stExternalLinks - id' <- case M.lookup (T.unpack src) extlinks of + id' <- case M.lookup src extlinks of Just i -> return i Nothing -> do - i <- ("rId"++) `fmap` getUniqueId + i <- ("rId" <>) <$> getUniqueId modify $ \st -> st{ stExternalLinks = - M.insert (T.unpack src) i extlinks } + M.insert src i extlinks } return i return [ Elem $ mknode "w:hyperlink" [("r:id",id')] contents ] inlineToOpenXML' opts (Image attr@(imgident, _, _) alt (src, title)) = do @@ -1414,17 +1411,17 @@ ,("noChangeAspect","1")] () nvPicPr = mknode "pic:nvPicPr" [] [ mknode "pic:cNvPr" - [("descr",T.unpack src),("id","0"),("name","Picture")] () + [("descr",src),("id","0"),("name","Picture")] () , cNvPicPr ] blipFill = mknode "pic:blipFill" [] - [ mknode "a:blip" [("r:embed",ident)] () + [ mknode "a:blip" [("r:embed",T.pack ident)] () , mknode "a:stretch" [] $ mknode "a:fillRect" [] () ] xfrm = mknode "a:xfrm" [] [ mknode "a:off" [("x","0"),("y","0")] () - , mknode "a:ext" [("cx",show xemu) - ,("cy",show yemu)] () ] + , mknode "a:ext" [("cx",tshow xemu) + ,("cy",tshow yemu)] () ] prstGeom = mknode "a:prstGeom" [("prst","rect")] $ mknode "a:avLst" [] () ln = mknode "a:ln" [("w","9525")] @@ -1445,12 +1442,12 @@ imgElt = mknode "w:r" [] $ mknode "w:drawing" [] $ mknode "wp:inline" [] - [ mknode "wp:extent" [("cx",show xemu),("cy",show yemu)] () + [ mknode "wp:extent" [("cx",tshow xemu),("cy",tshow yemu)] () , mknode "wp:effectExtent" [("b","0"),("l","0"),("r","0"),("t","0")] () , mknode "wp:docPr" - [ ("descr", T.unpack $ stringify alt) - , ("title", T.unpack title) + [ ("descr", stringify alt) + , ("title", title) , ("id","1") , ("name","Picture") ] () @@ -1463,7 +1460,7 @@ Just imgData -> return [Elem $ generateImgElt imgData] Nothing -> ( do --try (img, mt) <- P.fetchItem src - ident <- ("rId"++) `fmap` getUniqueId + ident <- ("rId" <>) <$> getUniqueId let imgext = case mt >>= extensionFromMimeType of @@ -1477,10 +1474,10 @@ Just Svg -> ".svg" Just Emf -> ".emf" Nothing -> "" - imgpath = "media/" <> ident <> T.unpack imgext - mbMimeType = mt <|> getMimeType imgpath + imgpath = "media/" <> ident <> imgext + mbMimeType = mt <|> getMimeType (T.unpack imgpath) - imgData = (ident, imgpath, mbMimeType, img) + imgData = (T.unpack ident, T.unpack imgpath, mbMimeType, img) if T.null imgext then -- without an extension there is no rule for content type @@ -1538,20 +1535,20 @@ , envTextProperties = EnvProps textStyle textProps' } -wrapBookmark :: (PandocMonad m) => T.Text -> [Content] -> WS m [Content] +wrapBookmark :: (PandocMonad m) => Text -> [Content] -> WS m [Content] wrapBookmark "" contents = return contents wrapBookmark ident contents = do id' <- getUniqueId let bookmarkStart = mknode "w:bookmarkStart" [("w:id", id') - ,("w:name", T.unpack $ toBookmarkName ident)] () + ,("w:name", toBookmarkName ident)] () bookmarkEnd = mknode "w:bookmarkEnd" [("w:id", id')] () return $ Elem bookmarkStart : contents ++ [Elem bookmarkEnd] -- Word imposes a 40 character limit on bookmark names and requires -- that they begin with a letter. So we just use a hash of the -- identifier when otherwise we'd have an illegal bookmark name. -toBookmarkName :: T.Text -> T.Text +toBookmarkName :: Text -> Text toBookmarkName s | Just (c, _) <- T.uncons s , isLetter c 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 @@ -24,12 +24,13 @@ gets, lift, modify) import qualified Data.ByteString.Lazy as B import qualified Data.ByteString.Lazy.Char8 as B8 -import Data.Char (isAlphaNum, isAscii, isDigit, toLower) +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 qualified Data.Set as Set -import qualified Data.Text as TS +import qualified Data.Text as T +import Data.Text (Text) import qualified Data.Text.Lazy as TL import Network.HTTP (urlEncode) import System.FilePath (takeExtension, takeFileName, makeRelative) @@ -48,15 +49,13 @@ ObfuscationMethod (NoObfuscation), WrapOption (..), WriterOptions (..)) import Text.Pandoc.Shared (makeSections, normalizeDate, renderTags', - safeRead, stringify, trim, uniqueIdent, tshow) + 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.Writers.HTML (writeHtmlStringForEPUB) import Text.Printf (printf) -import Text.XML.Light (Attr (..), Element (..), Node (..), QName (..), - add_attrs, lookupAttr, node, onlyElems, parseXML, - ppElement, showElement, strContent, unode, unqual) +import Text.Pandoc.XML.Light import Text.Pandoc.XML (escapeStringForXML) import Text.DocTemplates (FromContext(lookupContext), Context(..), ToContext(toVal), Val(..)) @@ -68,69 +67,72 @@ data EPUBState = EPUBState { stMediaPaths :: [(FilePath, (FilePath, Maybe Entry))] , stMediaNextId :: Int - , stEpubSubdir :: String + , stEpubSubdir :: FilePath } type E m = StateT EPUBState m data EPUBMetadata = EPUBMetadata{ - epubIdentifier :: [Identifier] - , epubTitle :: [Title] - , epubDate :: [Date] - , epubLanguage :: String - , epubCreator :: [Creator] - , epubContributor :: [Creator] - , epubSubject :: [String] - , epubDescription :: Maybe String - , epubType :: Maybe String - , epubFormat :: Maybe String - , epubPublisher :: Maybe String - , epubSource :: Maybe String - , epubRelation :: Maybe String - , epubCoverage :: Maybe String - , epubRights :: Maybe String - , epubCoverImage :: Maybe String - , epubStylesheets :: [FilePath] - , epubPageDirection :: Maybe ProgressionDirection - , epubIbooksFields :: [(String, String)] - , epubCalibreFields :: [(String, String)] + epubIdentifier :: [Identifier] + , epubTitle :: [Title] + , epubDate :: [Date] + , epubLanguage :: Text + , epubCreator :: [Creator] + , epubContributor :: [Creator] + , epubSubject :: [Text] + , epubDescription :: Maybe Text + , epubType :: Maybe Text + , epubFormat :: Maybe Text + , epubPublisher :: Maybe Text + , epubSource :: Maybe Text + , epubRelation :: Maybe Text + , epubCoverage :: Maybe Text + , epubRights :: Maybe Text + , epubBelongsToCollection :: Maybe Text + , epubGroupPosition :: Maybe Text + , epubCoverImage :: Maybe FilePath + , epubStylesheets :: [FilePath] + , epubPageDirection :: Maybe ProgressionDirection + , epubIbooksFields :: [(Text, Text)] + , epubCalibreFields :: [(Text, Text)] } deriving Show data Date = Date{ - dateText :: String - , dateEvent :: Maybe String + dateText :: Text + , dateEvent :: Maybe Text } deriving Show data Creator = Creator{ - creatorText :: String - , creatorRole :: Maybe String - , creatorFileAs :: Maybe String + creatorText :: Text + , creatorRole :: Maybe Text + , creatorFileAs :: Maybe Text } deriving Show data Identifier = Identifier{ - identifierText :: String - , identifierScheme :: Maybe String + identifierText :: Text + , identifierScheme :: Maybe Text } deriving Show data Title = Title{ - titleText :: String - , titleFileAs :: Maybe String - , titleType :: Maybe String + titleText :: Text + , titleFileAs :: Maybe Text + , titleType :: Maybe Text } deriving Show data ProgressionDirection = LTR | RTL deriving Show -dcName :: String -> QName +dcName :: Text -> QName dcName n = QName n Nothing (Just "dc") -dcNode :: Node t => String -> t -> Element +dcNode :: Node t => Text -> t -> Element dcNode = node . dcName -opfName :: String -> QName +opfName :: Text -> QName opfName n = QName n Nothing (Just "opf") -toId :: FilePath -> String -toId = map (\x -> if isAlphaNum x || x == '-' || x == '_' +toId :: FilePath -> Text +toId = T.pack . + map (\x -> if isAlphaNum x || x == '-' || x == '_' then x else '_') . takeFileName @@ -138,8 +140,8 @@ removeNote (Note _) = Str "" removeNote x = x -toVal' :: String -> Val TS.Text -toVal' = toVal . TS.pack +toVal' :: Text -> Val T.Text +toVal' = toVal mkEntry :: PandocMonad m => FilePath -> B.ByteString -> E m Entry mkEntry path content = do @@ -158,32 +160,37 @@ getEPUBMetadata :: PandocMonad m => WriterOptions -> Meta -> E m EPUBMetadata getEPUBMetadata opts meta = do let md = metadataFromMeta opts meta - let elts = maybe [] (onlyElems . parseXML) $ writerEpubMetadata opts + elts <- case writerEpubMetadata opts of + Nothing -> return [] + Just t -> case parseXMLContents (TL.fromStrict t) of + Left msg -> throwError $ + PandocXMLError "epub metadata" msg + Right ns -> return (onlyElems ns) let md' = foldr addMetadataFromXML md elts let addIdentifier m = if null (epubIdentifier m) then do randomId <- getRandomUUID - return $ m{ epubIdentifier = [Identifier (show randomId) Nothing] } + return $ m{ epubIdentifier = [Identifier (tshow randomId) Nothing] } else return m let addLanguage m = - if null (epubLanguage m) + if T.null (epubLanguage m) then case lookupContext "lang" (writerVariables opts) of - Just x -> return m{ epubLanguage = TS.unpack x } + Just x -> return m{ epubLanguage = x } Nothing -> do mLang <- lift $ P.lookupEnv "LANG" let localeLang = case mLang of Just lang -> - TS.map (\c -> if c == '_' then '-' else c) $ - TS.takeWhile (/='.') lang + T.map (\c -> if c == '_' then '-' else c) $ + T.takeWhile (/='.') lang Nothing -> "en-US" - return m{ epubLanguage = TS.unpack localeLang } + return m{ epubLanguage = localeLang } else return m let fixDate m = if null (epubDate m) then do - currentTime <- lift P.getCurrentTime + currentTime <- lift P.getTimestamp return $ m{ epubDate = [ Date{ dateText = showDateTimeISO8601 currentTime , dateEvent = Nothing } ] } @@ -193,7 +200,7 @@ then return m else do let authors' = map stringify $ docAuthors meta - let toAuthor name = Creator{ creatorText = TS.unpack name + let toAuthor name = Creator{ creatorText = name , creatorRole = Just "aut" , creatorFileAs = Nothing } return $ m{ epubCreator = map toAuthor authors' ++ epubCreator m } @@ -235,35 +242,37 @@ | name == "relation" = md { epubRelation = Just $ strContent e } | name == "coverage" = md { epubCoverage = Just $ strContent e } | name == "rights" = md { epubRights = Just $ strContent e } + | name == "belongs-to-collection" = md { epubBelongsToCollection = Just $ strContent e } + | name == "group-position" = md { epubGroupPosition = Just $ strContent e } | otherwise = md where getAttr n = lookupAttr (opfName n) attrs addMetadataFromXML e@(Element (QName "meta" _ _) attrs _ _) md = case getAttr "property" of - Just s | "ibooks:" `isPrefixOf` s -> - md{ epubIbooksFields = (drop 7 s, strContent e) : + Just s | "ibooks:" `T.isPrefixOf` s -> + md{ epubIbooksFields = (T.drop 7 s, strContent e) : epubIbooksFields md } _ -> case getAttr "name" of - Just s | "calibre:" `isPrefixOf` s -> + Just s | "calibre:" `T.isPrefixOf` s -> md{ epubCalibreFields = - (drop 8 s, fromMaybe "" $ getAttr "content") : + (T.drop 8 s, fromMaybe "" $ getAttr "content") : epubCalibreFields md } _ -> md where getAttr n = lookupAttr (unqual n) attrs addMetadataFromXML _ md = md -metaValueToString :: MetaValue -> String -metaValueToString (MetaString s) = TS.unpack s -metaValueToString (MetaInlines ils) = TS.unpack $ stringify ils -metaValueToString (MetaBlocks bs) = TS.unpack $ stringify bs +metaValueToString :: MetaValue -> Text +metaValueToString (MetaString s) = s +metaValueToString (MetaInlines ils) = stringify ils +metaValueToString (MetaBlocks bs) = stringify bs metaValueToString (MetaBool True) = "true" metaValueToString (MetaBool False) = "false" metaValueToString _ = "" metaValueToPaths :: MetaValue -> [FilePath] -metaValueToPaths (MetaList xs) = map metaValueToString xs -metaValueToPaths x = [metaValueToString x] +metaValueToPaths (MetaList xs) = map (T.unpack . metaValueToString) xs +metaValueToPaths x = [T.unpack $ metaValueToString x] -getList :: TS.Text -> Meta -> (MetaValue -> a) -> [a] +getList :: T.Text -> Meta -> (MetaValue -> a) -> [a] getList s meta handleMetaValue = case lookupMeta s meta of Just (MetaList xs) -> map handleMetaValue xs @@ -287,7 +296,7 @@ , titleType = metaValueToString <$> M.lookup "type" m } handleMetaValue mv = Title (metaValueToString mv) Nothing Nothing -getCreator :: TS.Text -> Meta -> [Creator] +getCreator :: T.Text -> Meta -> [Creator] getCreator s meta = getList s meta handleMetaValue where handleMetaValue (MetaMap m) = Creator{ creatorText = maybe "" metaValueToString $ M.lookup "text" m @@ -295,7 +304,7 @@ , creatorRole = metaValueToString <$> M.lookup "role" m } handleMetaValue mv = Creator (metaValueToString mv) Nothing Nothing -getDate :: TS.Text -> Meta -> [Date] +getDate :: T.Text -> Meta -> [Date] getDate s meta = getList s meta handleMetaValue where handleMetaValue (MetaMap m) = Date{ dateText = fromMaybe "" $ @@ -304,7 +313,7 @@ handleMetaValue mv = Date { dateText = fromMaybe "" $ normalizeDate' $ metaValueToString mv , dateEvent = Nothing } -simpleList :: TS.Text -> Meta -> [String] +simpleList :: T.Text -> Meta -> [Text] simpleList s meta = case lookupMeta s meta of Just (MetaList xs) -> map metaValueToString xs @@ -313,26 +322,28 @@ metadataFromMeta :: WriterOptions -> Meta -> EPUBMetadata metadataFromMeta opts meta = EPUBMetadata{ - epubIdentifier = identifiers - , epubTitle = titles - , epubDate = date - , epubLanguage = language - , epubCreator = creators - , epubContributor = contributors - , epubSubject = subjects - , epubDescription = description - , epubType = epubtype - , epubFormat = format - , epubPublisher = publisher - , epubSource = source - , epubRelation = relation - , epubCoverage = coverage - , epubRights = rights - , epubCoverImage = coverImage - , epubStylesheets = stylesheets - , epubPageDirection = pageDirection - , epubIbooksFields = ibooksFields - , epubCalibreFields = calibreFields + epubIdentifier = identifiers + , epubTitle = titles + , epubDate = date + , epubLanguage = language + , epubCreator = creators + , epubContributor = contributors + , epubSubject = subjects + , epubDescription = description + , epubType = epubtype + , epubFormat = format + , epubPublisher = publisher + , epubSource = source + , epubRelation = relation + , epubCoverage = coverage + , epubRights = rights + , epubBelongsToCollection = belongsToCollection + , epubGroupPosition = groupPosition + , epubCoverImage = coverImage + , epubStylesheets = stylesheets + , epubPageDirection = pageDirection + , epubIbooksFields = ibooksFields + , epubCalibreFields = calibreFields } where identifiers = getIdentifier meta titles = getTitle meta @@ -350,30 +361,31 @@ relation = metaValueToString <$> lookupMeta "relation" meta coverage = metaValueToString <$> lookupMeta "coverage" meta rights = metaValueToString <$> lookupMeta "rights" meta - coverImage = - (TS.unpack <$> lookupContext "epub-cover-image" - (writerVariables opts)) + belongsToCollection = metaValueToString <$> lookupMeta "belongs-to-collection" meta + groupPosition = metaValueToString <$> lookupMeta "group-position" meta + coverImage = T.unpack <$> + lookupContext "epub-cover-image" (writerVariables opts) `mplus` (metaValueToString <$> lookupMeta "cover-image" meta) mCss = lookupMeta "css" meta <|> lookupMeta "stylesheet" meta stylesheets = maybe [] metaValueToPaths mCss ++ case lookupContext "css" (writerVariables opts) of - Just xs -> map TS.unpack xs + Just xs -> map T.unpack xs Nothing -> case lookupContext "css" (writerVariables opts) of - Just x -> [TS.unpack x] + Just x -> [T.unpack x] Nothing -> [] - pageDirection = case map toLower . metaValueToString <$> + pageDirection = case T.toLower . metaValueToString <$> lookupMeta "page-progression-direction" meta of Just "ltr" -> Just LTR Just "rtl" -> Just RTL _ -> Nothing ibooksFields = case lookupMeta "ibooks" meta of Just (MetaMap mp) - -> M.toList $ M.mapKeys TS.unpack $ M.map metaValueToString mp + -> M.toList $ M.map metaValueToString mp _ -> [] calibreFields = case lookupMeta "calibre" meta of Just (MetaMap mp) - -> M.toList $ M.mapKeys TS.unpack $ M.map metaValueToString mp + -> M.toList $ M.map metaValueToString mp _ -> [] -- | Produce an EPUB2 file from a Pandoc document. @@ -399,9 +411,11 @@ writeEPUB epubVersion opts doc = do let epubSubdir = writerEpubSubdirectory opts -- sanity check on epubSubdir - unless (TS.all (\c -> isAscii c && isAlphaNum c) epubSubdir) $ + unless (T.all (\c -> isAscii c && isAlphaNum c) epubSubdir) $ throwError $ PandocEpubSubdirectoryError epubSubdir - let initState = EPUBState { stMediaPaths = [], stMediaNextId = 0, stEpubSubdir = TS.unpack epubSubdir } + let initState = EPUBState { stMediaPaths = [] + , stMediaNextId = 0 + , stEpubSubdir = T.unpack epubSubdir } evalStateT (pandocToEPUB epubVersion opts doc) initState pandocToEPUB :: PandocMonad m @@ -425,7 +439,7 @@ [] -> case epubTitle metadata of [] -> "UNTITLED" (x:_) -> titleText x - x -> TS.unpack $ stringify x + x -> stringify x -- stylesheet stylesheets <- case epubStylesheets metadata of @@ -447,7 +461,8 @@ (ListVal $ map (\e -> toVal' $ (if useprefix then "../" else "") <> - makeRelative epubSubdir (eRelativePath e)) + T.pack + (makeRelative epubSubdir (eRelativePath e))) stylesheetEntries) mempty @@ -476,18 +491,19 @@ case imageSize opts' (B.toStrict imgContent) of Right sz -> return $ sizeInPixels sz Left err' -> (0, 0) <$ report - (CouldNotDetermineImageSize (TS.pack img) err') + (CouldNotDetermineImageSize (T.pack img) err') cpContent <- lift $ writeHtml opts'{ writerVariables = Context (M.fromList [ ("coverpage", toVal' "true"), ("pagetitle", toVal $ - escapeStringForXML $ TS.pack plainTitle), - ("cover-image", toVal' coverImageName), + escapeStringForXML plainTitle), + ("cover-image", + toVal' $ T.pack coverImageName), ("cover-image-width", toVal' $ - show coverImageWidth), + tshow coverImageWidth), ("cover-image-height", toVal' $ - show coverImageHeight)]) <> + tshow coverImageHeight)]) <> cssvars True <> vars } (Pandoc meta []) coverEntry <- mkEntry "text/cover.xhtml" cpContent @@ -503,7 +519,7 @@ ("titlepage", toVal' "true"), ("body-type", toVal' "frontmatter"), ("pagetitle", toVal $ - escapeStringForXML $ TS.pack plainTitle)]) + escapeStringForXML plainTitle)]) <> cssvars True <> vars } (Pandoc meta []) tpEntry <- mkEntry "text/title_page.xhtml" tpContent @@ -512,7 +528,7 @@ let matchingGlob f = do xs <- lift $ P.glob f when (null xs) $ - report $ CouldNotFetchResource (TS.pack f) "glob did not match any font files" + report $ CouldNotFetchResource (T.pack f) "glob did not match any font files" return xs let mkFontEntry f = mkEntry ("fonts/" ++ takeFileName f) =<< lift (P.readFileLazy f) @@ -559,13 +575,13 @@ let chapters' = secsToChapters secs - let extractLinkURL' :: Int -> Inline -> [(TS.Text, TS.Text)] + let extractLinkURL' :: Int -> Inline -> [(T.Text, T.Text)] extractLinkURL' num (Span (ident, _, _) _) - | not (TS.null ident) = [(ident, TS.pack (showChapter num) <> "#" <> ident)] + | not (T.null ident) = [(ident, showChapter num <> "#" <> ident)] extractLinkURL' num (Link (ident, _, _) _ _) - | not (TS.null ident) = [(ident, TS.pack (showChapter num) <> "#" <> ident)] + | not (T.null ident) = [(ident, showChapter num <> "#" <> ident)] extractLinkURL' num (Image (ident, _, _) _ _) - | not (TS.null ident) = [(ident, TS.pack (showChapter num) <> "#" <> ident)] + | not (T.null ident) = [(ident, showChapter num <> "#" <> ident)] extractLinkURL' num (RawInline fmt raw) | isHtmlFormat fmt = foldr (\tag -> @@ -573,18 +589,18 @@ TagOpen{} -> case fromAttrib "id" tag of "" -> id - x -> ((x, TS.pack (showChapter num) <> "#" <> x):) + x -> ((x, showChapter num <> "#" <> x):) _ -> id) [] (parseTags raw) extractLinkURL' _ _ = [] - let extractLinkURL :: Int -> Block -> [(TS.Text, TS.Text)] + let extractLinkURL :: Int -> Block -> [(T.Text, T.Text)] extractLinkURL num (Div (ident, _, _) _) - | not (TS.null ident) = [(ident, TS.pack (showChapter num) <> "#" <> ident)] + | not (T.null ident) = [(ident, showChapter num <> "#" <> ident)] extractLinkURL num (Header _ (ident, _, _) _) - | not (TS.null ident) = [(ident, TS.pack (showChapter num) <> "#" <> ident)] + | not (T.null ident) = [(ident, showChapter num <> "#" <> ident)] extractLinkURL num (Table (ident,_,_) _ _ _ _ _) - | not (TS.null ident) = [(ident, TS.pack (showChapter num) <> "#" <> ident)] + | not (T.null ident) = [(ident, showChapter num <> "#" <> ident)] extractLinkURL num (RawBlock fmt raw) | isHtmlFormat fmt = foldr (\tag -> @@ -592,7 +608,7 @@ TagOpen{} -> case fromAttrib "id" tag of "" -> id - x -> ((x, TS.pack (showChapter num) <> "#" <> x):) + x -> ((x, showChapter num <> "#" <> x):) _ -> id) [] (parseTags raw) extractLinkURL num b = query (extractLinkURL' num) b @@ -603,7 +619,7 @@ let fixInternalReferences :: Inline -> Inline fixInternalReferences (Link attr lab (src, tit)) - | Just ('#', xs) <- TS.uncons src = case lookup xs reftable of + | 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 @@ -616,7 +632,7 @@ chapters' let chapToEntry num (Chapter bs) = - mkEntry ("text/" ++ showChapter num) =<< + mkEntry ("text/" ++ T.unpack (showChapter num)) =<< writeHtml opts'{ writerVariables = Context (M.fromList [("body-type", toVal' bodyType), @@ -663,12 +679,12 @@ let chapterNode ent = unode "item" ! ([("id", toId $ makeRelative epubSubdir $ eRelativePath ent), - ("href", makeRelative epubSubdir + ("href", T.pack $ makeRelative epubSubdir $ eRelativePath ent), ("media-type", "application/xhtml+xml")] ++ case props ent of [] -> [] - xs -> [("properties", unwords xs)]) + xs -> [("properties", T.unwords xs)]) $ () let chapterRefNode ent = unode "itemref" ! @@ -677,17 +693,17 @@ let pictureNode ent = unode "item" ! [("id", toId $ makeRelative epubSubdir $ eRelativePath ent), - ("href", makeRelative epubSubdir + ("href", T.pack $ makeRelative epubSubdir $ eRelativePath ent), ("media-type", - maybe "application/octet-stream" TS.unpack + fromMaybe "application/octet-stream" $ mediaTypeOf $ eRelativePath ent)] $ () let fontNode ent = unode "item" ! [("id", toId $ makeRelative epubSubdir $ eRelativePath ent), - ("href", makeRelative epubSubdir + ("href", T.pack $ makeRelative epubSubdir $ eRelativePath ent), - ("media-type", maybe "" TS.unpack $ + ("media-type", fromMaybe "" $ getMimeType $ eRelativePath ent)] $ () let tocTitle = maybe plainTitle @@ -695,8 +711,8 @@ uuid <- case epubIdentifier metadata of (x:_) -> return $ identifierText x -- use first identifier as UUID [] -> throwError $ PandocShouldNeverHappenError "epubIdentifier is null" -- shouldn't happen - currentTime <- lift P.getCurrentTime - let contentsData = UTF8.fromStringLazy $ ppTopElement $ + currentTime <- lift P.getTimestamp + let contentsData = UTF8.fromTextLazy $ TL.fromStrict $ ppTopElement $ unode "package" ! ([("version", case version of EPUB2 -> "2.0" @@ -714,7 +730,8 @@ ,("media-type","application/xhtml+xml")] ++ [("properties","nav") | epub3 ]) $ () ] ++ - [ unode "item" ! [("id","stylesheet" ++ show n), ("href",fp) + [ unode "item" ! [("id","stylesheet" <> tshow n) + , ("href", T.pack fp) ,("media-type","text/css")] $ () | (n :: Int, fp) <- zip [1..] (map (makeRelative epubSubdir . eRelativePath) @@ -759,7 +776,7 @@ let tocLevel = writerTOCDepth opts let navPointNode :: PandocMonad m - => (Int -> [Inline] -> TS.Text -> [Element] -> Element) + => (Int -> [Inline] -> T.Text -> [Element] -> Element) -> Block -> StateT Int m [Element] navPointNode formatter (Div (ident,_,_) (Header lvl (_,_,kvs) ils : children)) = @@ -769,7 +786,7 @@ n <- get modify (+1) let num = fromMaybe "" $ lookup "number" kvs - let tit = if writerNumberSections opts && not (TS.null num) + let tit = if writerNumberSections opts && not (T.null num) then Span ("", ["section-header-number"], []) [Str num] : Space : ils else ils @@ -783,21 +800,21 @@ concat <$> mapM (navPointNode formatter) bs navPointNode _ _ = return [] - let navMapFormatter :: Int -> [Inline] -> TS.Text -> [Element] -> Element + let navMapFormatter :: Int -> [Inline] -> T.Text -> [Element] -> Element navMapFormatter n tit src subs = unode "navPoint" ! - [("id", "navPoint-" ++ show n)] $ - [ unode "navLabel" $ unode "text" $ TS.unpack $ stringify tit - , unode "content" ! [("src", "text/" <> TS.unpack src)] $ () + [("id", "navPoint-" <> tshow n)] $ + [ unode "navLabel" $ unode "text" $ stringify tit + , unode "content" ! [("src", "text/" <> src)] $ () ] ++ subs let tpNode = unode "navPoint" ! [("id", "navPoint-0")] $ - [ unode "navLabel" $ unode "text" (TS.unpack $ 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 tocData = UTF8.fromStringLazy $ ppTopElement $ + let tocData = B.fromStrict $ UTF8.fromText $ ppTopElement $ unode "ncx" ! [("version","2005-1") ,("xmlns","http://www.daisy.org/z3986/2005/ncx/")] $ [ unode "head" $ @@ -819,23 +836,24 @@ ] tocEntry <- mkEntry "toc.ncx" tocData - let navXhtmlFormatter :: Int -> [Inline] -> TS.Text -> [Element] -> Element + let navXhtmlFormatter :: Int -> [Inline] -> T.Text -> [Element] -> Element navXhtmlFormatter n tit src subs = unode "li" ! - [("id", "toc-li-" ++ show n)] $ + [("id", "toc-li-" <> tshow n)] $ (unode "a" ! - [("href", "text/" <> TS.unpack src)] + [("href", "text/" <> src)] $ titElements) : case subs of [] -> [] (_:_) -> [unode "ol" ! [("class","toc")] $ subs] - where titElements = parseXML titRendered + 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 $ TS.pack plainTitle)]) + escapeStringForXML plainTitle)]) <> writerVariables opts} (Pandoc nullMeta [Plain $ walk clean tit])) of @@ -850,7 +868,7 @@ tocBlocks <- lift $ evalStateT (concat <$> mapM (navPointNode navXhtmlFormatter) secs) 1 let navBlocks = [RawBlock (Format "html") - $ TS.pack $ showElement $ -- prettyprinting introduces bad spaces + $ showElement $ -- prettyprinting introduces bad spaces unode navtag ! ([("epub:type","toc") | epub3] ++ [("id","toc")]) $ [ unode "h1" ! [("id","toc-title")] $ tocTitle @@ -860,21 +878,21 @@ [ unode "a" ! [("href", "text/title_page.xhtml") ,("epub:type", "titlepage")] $ - ("Title Page" :: String) ] : + ("Title Page" :: Text) ] : [ unode "li" [ unode "a" ! [("href", "text/cover.xhtml") ,("epub:type", "cover")] $ - ("Cover" :: String)] | + ("Cover" :: Text)] | isJust (epubCoverImage metadata) ] ++ [ unode "li" [ unode "a" ! [("href", "#toc") ,("epub:type", "toc")] $ - ("Table of Contents" :: String) + ("Table of Contents" :: Text) ] | writerTableOfContents opts ] else [] - let landmarks = [RawBlock (Format "html") $ TS.pack $ ppElement $ + let landmarks = [RawBlock (Format "html") $ ppElement $ unode "nav" ! [("epub:type","landmarks") ,("id","landmarks") ,("hidden","hidden")] $ @@ -895,22 +913,22 @@ UTF8.fromStringLazy "application/epub+zip" -- container.xml - let containerData = UTF8.fromStringLazy $ ppTopElement $ + let containerData = B.fromStrict $ UTF8.fromText $ ppTopElement $ unode "container" ! [("version","1.0") ,("xmlns","urn:oasis:names:tc:opendocument:xmlns:container")] $ unode "rootfiles" $ unode "rootfile" ! [("full-path", (if null epubSubdir then "" - else epubSubdir ++ "/") ++ "content.opf") + else T.pack epubSubdir <> "/") <> "content.opf") ,("media-type","application/oebps-package+xml")] $ () containerEntry <- mkEntry "META-INF/container.xml" containerData -- com.apple.ibooks.display-options.xml - let apple = UTF8.fromStringLazy $ ppTopElement $ + let apple = B.fromStrict $ UTF8.fromText $ ppTopElement $ unode "display_options" $ unode "platform" ! [("name","*")] $ - unode "option" ! [("name","specified-fonts")] $ ("true" :: String) + unode "option" ! [("name","specified-fonts")] $ ("true" :: Text) appleEntry <- mkEntry "META-INF/com.apple.ibooks.display-options.xml" apple -- construct archive @@ -931,8 +949,9 @@ ++ descriptionNodes ++ typeNodes ++ formatNodes ++ publisherNodes ++ sourceNodes ++ relationNodes ++ coverageNodes ++ rightsNodes ++ coverImageNodes - ++ modifiedNodes - withIds base f = concat . zipWith f (map (\x -> base ++ ('-' : show x)) + ++ modifiedNodes ++ belongsToCollectionNodes + withIds base f = concat . zipWith f (map (\x -> base <> + T.cons '-' (tshow x)) ([1..] :: [Int])) identifierNodes = withIds "epub-id" toIdentifierNode $ epubIdentifier md @@ -946,9 +965,9 @@ (x:_) -> [dcNode "date" ! [("id","epub-date")] $ dateText x] ibooksNodes = map ibooksNode (epubIbooksFields md) - ibooksNode (k, v) = unode "meta" ! [("property", "ibooks:" ++ k)] $ v + ibooksNode (k, v) = unode "meta" ! [("property", "ibooks:" <> k)] $ v calibreNodes = map calibreNode (epubCalibreFields md) - calibreNode (k, v) = unode "meta" ! [("name", "calibre:" ++ k), + calibreNode (k, v) = unode "meta" ! [("name", "calibre:" <> k), ("content", v)] $ () languageNodes = [dcTag "language" $ epubLanguage md] creatorNodes = withIds "epub-creator" (toCreatorNode "creator") $ @@ -970,7 +989,16 @@ $ epubCoverImage md modifiedNodes = [ unode "meta" ! [("property", "dcterms:modified")] $ showDateTimeISO8601 currentTime | version == EPUB3 ] - dcTag n s = unode ("dc:" ++ n) s + belongsToCollectionNodes = + maybe [] + (\belongsToCollection -> (unode "meta" ! [("property", "belongs-to-collection"), ("id", "epub-id-1")] $ belongsToCollection ) + : + [unode "meta" ! [("refines", "#epub-id-1"), ("property", "collection-type")] $ ("series" :: Text) ]) + (epubBelongsToCollection md)++ + maybe [] + (\groupPosition -> [unode "meta" ! [("refines", "#epub-id-1"), ("property", "group-position")] $ groupPosition ]) + (epubGroupPosition md) + dcTag n s = unode ("dc:" <> n) s dcTag' n s = [dcTag n s] toIdentifierNode id' (Identifier txt scheme) | version == EPUB2 = [dcNode "identifier" ! @@ -978,7 +1006,7 @@ txt] | otherwise = (dcNode "identifier" ! [("id",id')] $ txt) : maybe [] ((\x -> [unode "meta" ! - [ ("refines",'#':id') + [ ("refines","#" <> id') , ("property","identifier-type") , ("scheme","onix:codelist5") ] @@ -994,10 +1022,10 @@ (creatorRole creator >>= toRelator)) $ creatorText creator] | otherwise = [dcNode s ! [("id",id')] $ creatorText creator] ++ maybe [] (\x -> [unode "meta" ! - [("refines",'#':id'),("property","file-as")] $ x]) + [("refines","#" <> id'),("property","file-as")] $ x]) (creatorFileAs creator) ++ maybe [] (\x -> [unode "meta" ! - [("refines",'#':id'),("property","role"), + [("refines","#" <> id'),("property","role"), ("scheme","marc:relators")] $ x]) (creatorRole creator >>= toRelator) toTitleNode id' title @@ -1009,16 +1037,16 @@ | otherwise = [dcNode "title" ! [("id",id')] $ titleText title] ++ maybe [] (\x -> [unode "meta" ! - [("refines",'#':id'),("property","file-as")] $ x]) + [("refines","#" <> id'),("property","file-as")] $ x]) (titleFileAs title) ++ maybe [] (\x -> [unode "meta" ! - [("refines",'#':id'),("property","title-type")] $ x]) + [("refines","#" <> id'),("property","title-type")] $ x]) (titleType title) toDateNode id' date = [dcNode "date" ! (("id",id') : maybe [] (\x -> [("opf:event",x)]) (dateEvent date)) $ dateText date] - schemeToOnix :: String -> String + schemeToOnix :: Text -> Text schemeToOnix "ISBN-10" = "02" schemeToOnix "GTIN-13" = "03" schemeToOnix "UPC" = "04" @@ -1036,48 +1064,48 @@ schemeToOnix "OLCC" = "28" schemeToOnix _ = "01" -showDateTimeISO8601 :: UTCTime -> String -showDateTimeISO8601 = formatTime defaultTimeLocale "%FT%TZ" +showDateTimeISO8601 :: UTCTime -> Text +showDateTimeISO8601 = T.pack . formatTime defaultTimeLocale "%FT%TZ" transformTag :: PandocMonad m - => Tag TS.Text - -> E m (Tag TS.Text) + => Tag T.Text + -> E m (Tag T.Text) transformTag tag@(TagOpen name attr) | name `elem` ["video", "source", "img", "audio"] && isNothing (lookup "data-external" attr) = do let src = fromAttrib "src" tag let poster = fromAttrib "poster" tag - newsrc <- modifyMediaRef $ TS.unpack src - newposter <- modifyMediaRef $ TS.unpack poster + newsrc <- modifyMediaRef $ T.unpack src + newposter <- modifyMediaRef $ T.unpack poster let attr' = filter (\(x,_) -> x /= "src" && x /= "poster") attr ++ - [("src", "../" <> newsrc) | not (TS.null newsrc)] ++ - [("poster", "../" <> newposter) | not (TS.null newposter)] + [("src", "../" <> newsrc) | not (T.null newsrc)] ++ + [("poster", "../" <> newposter) | not (T.null newposter)] return $ TagOpen name attr' transformTag tag = return tag modifyMediaRef :: PandocMonad m => FilePath - -> E m TS.Text + -> E m T.Text modifyMediaRef "" = return "" modifyMediaRef oldsrc = do media <- gets stMediaPaths case lookup oldsrc media of - Just (n,_) -> return $ TS.pack n + Just (n,_) -> return $ T.pack n Nothing -> catchError - (do (img, mbMime) <- P.fetchItem $ TS.pack oldsrc - let ext = maybe (takeExtension (takeWhile (/='?') oldsrc)) TS.unpack + (do (img, mbMime) <- P.fetchItem $ T.pack oldsrc + let ext = maybe (takeExtension (takeWhile (/='?') oldsrc)) T.unpack (("." <>) <$> (mbMime >>= extensionFromMimeType)) newName <- getMediaNextNewName ext let newPath = "media/" ++ newName entry <- mkEntry newPath (B.fromChunks . (:[]) $ img) modify $ \st -> st{ stMediaPaths = (oldsrc, (newPath, Just entry)):media} - return $ TS.pack newPath) + return $ T.pack newPath) (\e -> do - report $ CouldNotFetchResource (TS.pack oldsrc) (tshow e) - return $ TS.pack oldsrc) + report $ CouldNotFetchResource (T.pack oldsrc) (tshow e) + return $ T.pack oldsrc) -getMediaNextNewName :: PandocMonad m => String -> E m String +getMediaNextNewName :: PandocMonad m => FilePath -> E m FilePath getMediaNextNewName ext = do nextId <- gets stMediaNextId modify $ \st -> st { stMediaNextId = nextId + 1 } @@ -1104,11 +1132,11 @@ -> Inline -> E m Inline transformInline _opts (Image attr lab (src,tit)) = do - newsrc <- modifyMediaRef $ TS.unpack src + newsrc <- modifyMediaRef $ T.unpack src return $ Image attr lab ("../" <> newsrc, tit) transformInline opts x@(Math t m) | WebTeX url <- writerHTMLMathMethod opts = do - newsrc <- modifyMediaRef (TS.unpack url <> urlEncode (TS.unpack m)) + newsrc <- modifyMediaRef (T.unpack url <> urlEncode (T.unpack m)) let mathclass = if t == DisplayMath then "display" else "inline" return $ Span ("",["math",mathclass],[]) [Image nullAttr [x] ("../" <> newsrc, "")] @@ -1119,40 +1147,26 @@ return $ RawInline fmt (renderTags' tags') transformInline _ x = return x -(!) :: (t -> Element) -> [(String, String)] -> t -> Element +(!) :: (t -> Element) -> [(Text, Text)] -> t -> Element (!) f attrs n = add_attrs (map (\(k,v) -> Attr (unqual k) v) attrs) (f n) --- | Version of 'ppTopElement' that specifies UTF-8 encoding. -ppTopElement :: Element -> String -ppTopElement = ("\n" ++) . unEntity . ppElement - -- unEntity removes numeric entities introduced by ppElement - -- (kindlegen seems to choke on these). - where unEntity [] = "" - unEntity ('&':'#':xs) = - let (ds,ys) = break (==';') xs - rest = drop 1 ys - in case safeRead (TS.pack $ "'\\" <> ds <> "'") of - Just x -> x : unEntity rest - Nothing -> '&':'#':unEntity xs - unEntity (x:xs) = x : unEntity xs - mediaTypeOf :: FilePath -> Maybe MimeType mediaTypeOf x = let mediaPrefixes = ["image", "video", "audio"] in case getMimeType x of - Just y | any (`TS.isPrefixOf` y) mediaPrefixes -> Just y + Just y | any (`T.isPrefixOf` y) mediaPrefixes -> Just y _ -> Nothing -- Returns filename for chapter number. -showChapter :: Int -> String -showChapter = printf "ch%03d.xhtml" +showChapter :: Int -> Text +showChapter = T.pack . printf "ch%03d.xhtml" -- Add identifiers to any headers without them. addIdentifiers :: WriterOptions -> [Block] -> [Block] addIdentifiers opts bs = evalState (mapM go bs) Set.empty where go (Header n (ident,classes,kvs) ils) = do ids <- get - let ident' = if TS.null ident + let ident' = if T.null ident then uniqueIdent (writerExtensions opts) ils ids else ident modify $ Set.insert ident' @@ -1160,27 +1174,27 @@ go x = return x -- Variant of normalizeDate that allows partial dates: YYYY, YYYY-MM -normalizeDate' :: String -> Maybe String -normalizeDate' = fmap TS.unpack . go . trim . TS.pack +normalizeDate' :: Text -> Maybe Text +normalizeDate' = go . T.strip where go xs - | TS.length xs == 4 -- YYY - , TS.all isDigit xs = Just xs - | (y, s) <- TS.splitAt 4 xs -- YYY-MM - , Just ('-', m) <- TS.uncons s - , TS.length m == 2 - , TS.all isDigit y && TS.all isDigit m = Just xs + | T.length xs == 4 -- YYY + , T.all isDigit xs = Just xs + | (y, s) <- T.splitAt 4 xs -- YYY-MM + , Just ('-', m) <- T.uncons s + , T.length m == 2 + , T.all isDigit y && T.all isDigit m = Just xs | otherwise = normalizeDate xs -toRelator :: String -> Maybe String +toRelator :: Text -> Maybe Text toRelator x | x `elem` relators = Just x - | otherwise = lookup (map toLower x) relatorMap + | otherwise = lookup (T.toLower x) relatorMap -relators :: [String] +relators :: [Text] relators = map snd relatorMap -relatorMap :: [(String, String)] +relatorMap :: [(Text, Text)] relatorMap = [("abridger", "abr") ,("actor", "act") 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 @@ -19,29 +19,29 @@ module Text.Pandoc.Writers.FB2 (writeFB2) where import Control.Monad (zipWithM) -import Control.Monad.Except (catchError) +import Control.Monad.Except (catchError, throwError) import Control.Monad.State.Strict (StateT, evalStateT, get, gets, lift, liftM, modify) import Data.ByteString.Base64 (encode) import Data.Char (isAscii, isControl, isSpace) import Data.Either (lefts, rights) import Data.List (intercalate) -import Data.Text (Text, pack) +import Data.Text (Text) import qualified Data.Text as T +import qualified Data.Text.Lazy as TL import qualified Data.Text.Encoding as TE import Network.HTTP (urlEncode) -import Text.XML.Light -import qualified Text.XML.Light as X -import qualified Text.XML.Light.Cursor as XC -import qualified Text.XML.Light.Input as XI +import Text.Pandoc.XML.Light as X import Text.Pandoc.Class.PandocMonad (PandocMonad, report) import qualified Text.Pandoc.Class.PandocMonad as P import Text.Pandoc.Definition +import Text.Pandoc.Error (PandocError(..)) import Text.Pandoc.Logging import Text.Pandoc.Options (HTMLMathMethod (..), WriterOptions (..), def) import Text.Pandoc.Shared (capitalize, isURI, orderedListMarkers, makeSections, tshow, stringify) import Text.Pandoc.Writers.Shared (lookupMetaString, toLegacyTable) +import Data.Generics (everywhere, mkT) -- | Data to be written at the end of the document: -- (foot)notes, URLs, references, images. @@ -86,7 +86,7 @@ (imgs,missing) <- get >>= (lift . fetchImages . imagesToFetch) let body' = replaceImagesWithAlt missing body let fb2_xml = el "FictionBook" (fb2_attrs, [desc, body'] ++ notes ++ imgs) - return $ pack $ xml_head ++ showContent fb2_xml ++ "\n" + return $ xml_head <> showContent fb2_xml <> "\n" where xml_head = "\n" fb2_attrs = @@ -98,8 +98,8 @@ description :: PandocMonad m => Meta -> FBM m Content description meta' = do let genre = case lookupMetaString "genre" meta' of - "" -> el "genre" ("unrecognised" :: String) - s -> el "genre" (T.unpack s) + "" -> el "genre" ("unrecognised" :: Text) + s -> el "genre" s bt <- booktitle meta' let as = authors meta' dd <- docdate meta' @@ -110,7 +110,7 @@ Just (MetaInlines [Str s]) -> [el "lang" $ iso639 s] Just (MetaString s) -> [el "lang" $ iso639 s] _ -> [] - where iso639 = T.unpack . T.takeWhile (/= '-') -- Convert BCP 47 to ISO 639 + where iso639 = T.takeWhile (/= '-') -- Convert BCP 47 to ISO 639 let coverimage url = do let img = Image nullAttr mempty (url, "") im <- insertImage InlineImage img @@ -122,7 +122,7 @@ return $ el "description" [ el "title-info" (genre : (as ++ bt ++ annotation ++ dd ++ coverpage ++ lang)) - , el "document-info" [el "program-used" ("pandoc" :: String)] + , el "document-info" [el "program-used" ("pandoc" :: Text)] ] booktitle :: PandocMonad m => Meta -> FBM m [Content] @@ -135,15 +135,15 @@ author :: [Inline] -> [Content] author ss = - let ws = words . cMap plain $ ss - email = el "email" <$> take 1 (filter ('@' `elem`) ws) - ws' = filter ('@' `notElem`) ws + let ws = T.words $ mconcat $ map plain ss + email = el "email" <$> take 1 (filter (T.any (=='@')) ws) + ws' = filter (not . T.any (== '@')) ws names = case ws' of [nickname] -> [ el "nickname" nickname ] [fname, lname] -> [ el "first-name" fname , el "last-name" lname ] (fname:rest) -> [ el "first-name" fname - , el "middle-name" (concat . init $ rest) + , el "middle-name" (T.concat . init $ rest) , el "last-name" (last rest) ] [] -> [] in list $ el "author" (names ++ email) @@ -204,7 +204,7 @@ el "body" ([uattr "name" "notes"], map renderFN (reverse fns)) where renderFN (n, idstr, cs) = - let fn_texts = el "title" (el "p" (show n)) : cs + let fn_texts = el "title" (el "p" (tshow n)) : cs in el "section" ([uattr "id" idstr], fn_texts) -- | Fetch images and encode them for the FictionBook XML. @@ -280,7 +280,7 @@ where types = ["text","image","audio","video","application","message","multipart"] valid c = isAscii c && not (isControl c) && not (isSpace c) && - c `notElem` ("()<>@,;:\\\"/[]?=" :: String) + c `notElem` ("()<>@,;:\\\"/[]?=" :: [Char]) footnoteID :: Int -> Text footnoteID i = "n" <> tshow i @@ -304,10 +304,13 @@ = insertImage NormalImage (Image atr alt (src,tit)) blockToXml (Para ss) = list . el "p" <$> cMapM toXml ss blockToXml (CodeBlock _ s) = return . spaceBeforeAfter . - map (el "p" . el "code" . T.unpack) . T.lines $ s + map (el "p" . el "code") . T.lines $ s blockToXml (RawBlock f str) = if f == Format "fb2" - then return $ XI.parseXML str + then + case parseXMLContents (TL.fromStrict str) of + Left msg -> throwError $ PandocXMLError "" msg + Right nds -> return nds else return [] blockToXml (Div _ bs) = cMapM blockToXml bs blockToXml (BlockQuote bs) = list . el "cite" <$> cMapM blockToXml bs @@ -341,11 +344,11 @@ c <- el "emphasis" <$> cMapM toXml caption return [el "table" (hd <> bd), el "p" c] where - mkrow :: PandocMonad m => String -> [[Block]] -> [Alignment] -> FBM m Content + mkrow :: PandocMonad m => Text -> [[Block]] -> [Alignment] -> FBM m Content mkrow tag cells aligns' = el "tr" <$> mapM (mkcell tag) (zip cells aligns') -- - mkcell :: PandocMonad m => String -> ([Block], Alignment) -> FBM m Content + mkcell :: PandocMonad m => Text -> ([Block], Alignment) -> FBM m Content mkcell tag (cell, align) = do cblocks <- cMapM blockToXml cell return $ el tag ([align_attr align], cblocks) @@ -419,7 +422,7 @@ inner <- cMapM toXml ss return $ [txt "“"] ++ inner ++ [txt "”"] toXml (Cite _ ss) = cMapM toXml ss -- FIXME: support citation styles -toXml (Code _ s) = return [el "code" $ T.unpack s] +toXml (Code _ s) = return [el "code" s] toXml Space = return [txt " "] toXml SoftBreak = return [txt "\n"] toXml LineBreak = return [txt "\n"] @@ -451,7 +454,7 @@ let imgurl = url <> T.pack (urlEncode $ T.unpack formula) let img = Image nullAttr alt (imgurl, "") insertImage immode img - _ -> return [el "code" $ T.unpack formula] + _ -> return [el "code" formula] insertImage :: PandocMonad m => ImageMode -> Inline -> FBM m [Content] insertImage immode (Image _ alt (url,ttl)) = do @@ -466,31 +469,16 @@ el "image" $ [ attr ("l","href") ("#" <> fname) , attr ("l","type") (tshow immode) - , uattr "alt" (T.pack $ cMap plain alt) ] + , uattr "alt" (mconcat $ map plain alt) ] ++ ttlattr insertImage _ _ = error "unexpected inline instead of image" replaceImagesWithAlt :: [Text] -> Content -> Content -replaceImagesWithAlt missingHrefs body = - let cur = XC.fromContent body - cur' = replaceAll cur - in XC.toTree . XC.root $ cur' +replaceImagesWithAlt missingHrefs = everywhere (mkT go) where - -- - replaceAll :: XC.Cursor -> XC.Cursor - replaceAll c = - let n = XC.current c - c' = if isImage n && isMissing n - then XC.modifyContent replaceNode c - else c - in case XC.nextDF c' of - (Just cnext) -> replaceAll cnext - Nothing -> c' -- end of document - -- - isImage :: Content -> Bool - isImage (Elem e) = elName e == uname "image" - isImage _ = False - -- + go c = if isMissing c + then replaceNode c + else c isMissing (Elem img@Element{}) = let imgAttrs = elAttribs img badAttrs = map (attr ("l","href")) missingHrefs @@ -500,18 +488,18 @@ replaceNode :: Content -> Content replaceNode n@(Elem img@Element{}) = let attrs = elAttribs img - alt = getAttrVal attrs (uname "alt") + alt = getAttrVal attrs (unqual "alt") imtype = getAttrVal attrs (qname "l" "type") in case (alt, imtype) of (Just alt', Just imtype') -> - if imtype' == show NormalImage + if imtype' == tshow NormalImage then el "p" alt' - else txt $ T.pack alt' - (Just alt', Nothing) -> txt $ T.pack alt' -- no type attribute + else txt alt' + (Just alt', Nothing) -> txt alt' -- no type attribute _ -> n -- don't replace if alt text is not found replaceNode n = n -- - getAttrVal :: [X.Attr] -> QName -> Maybe String + getAttrVal :: [X.Attr] -> QName -> Maybe Text getAttrVal attrs name = case filter ((name ==) . attrKey) attrs of (a:_) -> Just (attrVal a) @@ -519,7 +507,7 @@ -- | Wrap all inlines with an XML tag (given its unqualified name). -wrap :: PandocMonad m => String -> [Inline] -> FBM m Content +wrap :: PandocMonad m => Text -> [Inline] -> FBM m Content wrap tagname inlines = el tagname `liftM` cMapM toXml inlines -- " Create a singleton list. @@ -527,31 +515,31 @@ list = (:[]) -- | Convert an 'Inline' to plaintext. -plain :: Inline -> String -plain (Str s) = T.unpack s -plain (Emph ss) = cMap plain ss -plain (Underline ss) = cMap plain ss -plain (Span _ ss) = cMap plain ss -plain (Strong ss) = cMap plain ss -plain (Strikeout ss) = cMap plain ss -plain (Superscript ss) = cMap plain ss -plain (Subscript ss) = cMap plain ss -plain (SmallCaps ss) = cMap plain ss -plain (Quoted _ ss) = cMap plain ss -plain (Cite _ ss) = cMap plain ss -- FIXME -plain (Code _ s) = T.unpack s +plain :: Inline -> Text +plain (Str s) = s +plain (Emph ss) = mconcat $ map plain ss +plain (Underline ss) = mconcat $ map plain ss +plain (Span _ ss) = mconcat $ map plain ss +plain (Strong ss) = mconcat $ map plain ss +plain (Strikeout ss) = mconcat $ map plain ss +plain (Superscript ss) = mconcat $ map plain ss +plain (Subscript ss) = mconcat $ map plain ss +plain (SmallCaps ss) = mconcat $ map plain ss +plain (Quoted _ ss) = mconcat $ map plain ss +plain (Cite _ ss) = mconcat $ map plain ss -- FIXME +plain (Code _ s) = s plain Space = " " plain SoftBreak = " " plain LineBreak = "\n" -plain (Math _ s) = T.unpack s +plain (Math _ s) = s plain (RawInline _ _) = "" -plain (Link _ text (url,_)) = concat (map plain text ++ [" <", T.unpack url, ">"]) -plain (Image _ alt _) = cMap plain alt +plain (Link _ text (url,_)) = mconcat (map plain text ++ [" <", url, ">"]) +plain (Image _ alt _) = mconcat $ map plain alt plain (Note _) = "" -- FIXME -- | Create an XML element. el :: (Node t) - => String -- ^ unqualified element name + => Text -- ^ unqualified element name -> t -- ^ node contents -> Content -- ^ XML content el name cs = Elem $ unode name cs @@ -564,22 +552,18 @@ -- | Create a plain-text XML content. txt :: Text -> Content -txt s = Text $ CData CDataText (T.unpack s) Nothing +txt s = Text $ CData CDataText s Nothing -- | Create an XML attribute with an unqualified name. -uattr :: String -> Text -> Text.XML.Light.Attr -uattr name = Attr (uname name) . T.unpack +uattr :: Text -> Text -> X.Attr +uattr name = Attr (unqual name) -- | Create an XML attribute with a qualified name from given namespace. -attr :: (String, String) -> Text -> Text.XML.Light.Attr -attr (ns, name) = Attr (qname ns name) . T.unpack - --- | Unqualified name -uname :: String -> QName -uname name = QName name Nothing Nothing +attr :: (Text, Text) -> Text -> X.Attr +attr (ns, name) = Attr (qname ns name) -- | Qualified name -qname :: String -> String -> QName +qname :: Text -> Text -> QName qname ns name = QName name Nothing (Just ns) -- | Abbreviation for 'concatMap'. 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 @@ -29,7 +29,7 @@ import Text.Pandoc.Options (WriterOptions) import Text.Pandoc.Shared (tshow) import Text.Pandoc.Writers.JATS.Types -import Text.Pandoc.XML (inTags) +import Text.Pandoc.XML (escapeStringForXML, inTags) import qualified Data.Text as T referencesToJATS :: PandocMonad m @@ -78,7 +78,8 @@ varInTagWith var tagName tagAttribs = case lookupVariable var ref >>= valToText of Nothing -> mempty - Just val -> inTags' tagName tagAttribs $ literal val + Just val -> inTags' tagName tagAttribs . literal $ + escapeStringForXML val authors = case lookupVariable "author" ref of Just (NamesVal names) -> @@ -143,7 +144,9 @@ then inTags' "name" [] nameTags else nameLiteral name `inNameTag` "string-name" where - inNameTag val tag = maybe empty (inTags' tag [] . literal) val + inNameTag mVal tag = case mVal of + Nothing -> empty + Just val -> inTags' tag [] . literal $ escapeStringForXML val surnamePrefix = maybe mempty (`T.snoc` ' ') $ nameNonDroppingParticle name givenSuffix = maybe mempty (T.cons ' ') $ 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 @@ -126,13 +126,13 @@ -> Text -> JiraConverter m [Jira.Block] toJiraCode (ident, classes, _attribs) code = do - let lang = case find (\c -> T.toLower c `elem` knownLanguages) classes of - Nothing -> Jira.Language "java" - Just l -> Jira.Language l let addAnchor b = if T.null ident then b else [Jira.Para (singleton (Jira.Anchor ident))] <> b - return . addAnchor . singleton $ Jira.Code lang mempty code + return . addAnchor . singleton $ + case find (\c -> T.toLower c `elem` knownLanguages) classes of + Nothing -> Jira.NoFormat mempty code + Just l -> Jira.Code (Jira.Language l) mempty code -- | Creates a Jira definition list toJiraDefinitionList :: PandocMonad m @@ -292,7 +292,9 @@ spanToJira :: PandocMonad m => Attr -> [Inline] -> JiraConverter m [Jira.Inline] -spanToJira (_, _classes, _) = toJiraInlines +spanToJira (ident, _classes, _attribs) inls = case ident of + "" -> toJiraInlines inls + _ -> (Jira.Anchor ident :) <$> toJiraInlines inls registerNotes :: PandocMonad m => [Block] -> JiraConverter m [Jira.Inline] registerNotes contents = do @@ -308,7 +310,7 @@ knownLanguages :: [Text] knownLanguages = [ "actionscript", "ada", "applescript", "bash", "c", "c#", "c++" - , "css", "erlang", "go", "groovy", "haskell", "html", "javascript" + , "css", "erlang", "go", "groovy", "haskell", "html", "java", "javascript" , "json", "lua", "nyan", "objc", "perl", "php", "python", "r", "ruby" , "scala", "sql", "swift", "visualbasic", "xml", "yaml" ] 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 @@ -18,11 +18,9 @@ writeLaTeX , writeBeamer ) where -import Control.Applicative ((<|>)) import Control.Monad.State.Strict -import Data.Char (isAlphaNum, isAscii, isDigit, isLetter, isSpace, - isPunctuation, ord) -import Data.List (foldl', intersperse, nubBy, (\\), uncons) +import Data.Char (isDigit) +import Data.List (intersperse, nubBy, (\\)) import Data.Maybe (catMaybes, fromMaybe, isJust, mapMaybe, isNothing) import qualified Data.Map as M import Data.Text (Text) @@ -34,7 +32,7 @@ import Text.Pandoc.Class.PandocMonad (PandocMonad, report, toLang) import Text.Pandoc.Definition import Text.Pandoc.Highlighting (formatLaTeXBlock, formatLaTeXInline, highlight, - styleToLaTeX, toListingsLanguage) + styleToLaTeX) import Text.Pandoc.ImageSize import Text.Pandoc.Logging import Text.Pandoc.Options @@ -44,10 +42,15 @@ import Text.Pandoc.Walk (query, walk, walkM) import Text.Pandoc.Writers.LaTeX.Caption (getCaption) import Text.Pandoc.Writers.LaTeX.Table (tableToLaTeX) +import Text.Pandoc.Writers.LaTeX.Citation (citationsToNatbib, + citationsToBiblatex) import Text.Pandoc.Writers.LaTeX.Types (LW, WriterState (..), startingState) +import Text.Pandoc.Writers.LaTeX.Lang (toPolyglossia, toBabel) +import Text.Pandoc.Writers.LaTeX.Util (stringToLaTeX, StringContext(..), + toLabel, inCmd, + wrapDiv, hypertarget, labelFor, + getListingsLanguage, mbBraced) import Text.Pandoc.Writers.Shared -import Text.Printf (printf) -import qualified Data.Text.Normalize as Normalize import qualified Text.Pandoc.Writers.AnnotatedTable as Ann -- | Convert Pandoc to LaTeX. @@ -241,154 +244,6 @@ Nothing -> main Just tpl -> renderTemplate tpl context' -data StringContext = TextString - | URLString - | CodeString - deriving (Eq) - --- escape things as needed for LaTeX -stringToLaTeX :: PandocMonad m => StringContext -> Text -> LW m Text -stringToLaTeX context zs = do - opts <- gets stOptions - return $ T.pack $ - foldr (go opts context) mempty $ T.unpack $ - if writerPreferAscii opts - then Normalize.normalize Normalize.NFD zs - else zs - where - go :: WriterOptions -> StringContext -> Char -> String -> String - go opts ctx x xs = - let ligatures = isEnabled Ext_smart opts && ctx == TextString - isUrl = ctx == URLString - mbAccentCmd = - if writerPreferAscii opts && ctx == TextString - then uncons xs >>= \(c,_) -> M.lookup c accents - else Nothing - emits s = - case mbAccentCmd of - Just cmd -> - cmd <> "{" <> s <> "}" <> drop 1 xs -- drop combining accent - Nothing -> s <> xs - emitc c = - case mbAccentCmd of - Just cmd -> - cmd <> "{" <> [c] <> "}" <> drop 1 xs -- drop combining accent - Nothing -> c : xs - emitcseq cs = - case xs of - c:_ | isLetter c - , ctx == TextString - -> cs <> " " <> xs - | isSpace c -> cs <> "{}" <> xs - | ctx == TextString - -> cs <> xs - _ -> cs <> "{}" <> xs - emitquote cs = - case xs of - '`':_ -> cs <> "\\," <> xs -- add thin space - '\'':_ -> cs <> "\\," <> xs -- add thin space - _ -> cs <> xs - in case x of - '?' | ligatures -> -- avoid ?` ligature - case xs of - '`':_ -> emits "?{}" - _ -> emitc x - '!' | ligatures -> -- avoid !` ligature - case xs of - '`':_ -> emits "!{}" - _ -> emitc x - '{' -> emits "\\{" - '}' -> emits "\\}" - '`' | ctx == CodeString -> emitcseq "\\textasciigrave" - '$' | not isUrl -> emits "\\$" - '%' -> emits "\\%" - '&' -> emits "\\&" - '_' | not isUrl -> emits "\\_" - '#' -> emits "\\#" - '-' | not isUrl -> case xs of - -- prevent adjacent hyphens from forming ligatures - ('-':_) -> emits "-\\/" - _ -> emitc '-' - '~' | not isUrl -> emitcseq "\\textasciitilde" - '^' -> emits "\\^{}" - '\\'| isUrl -> emitc '/' -- NB. / works as path sep even on Windows - | otherwise -> emitcseq "\\textbackslash" - '|' | not isUrl -> emitcseq "\\textbar" - '<' -> emitcseq "\\textless" - '>' -> emitcseq "\\textgreater" - '[' -> emits "{[}" -- to avoid interpretation as - ']' -> emits "{]}" -- optional arguments - '\'' | ctx == CodeString -> emitcseq "\\textquotesingle" - '\160' -> emits "~" - '\x200B' -> emits "\\hspace{0pt}" -- zero-width space - '\x202F' -> emits "\\," - '\x2026' -> emitcseq "\\ldots" - '\x2018' | ligatures -> emitquote "`" - '\x2019' | ligatures -> emitquote "'" - '\x201C' | ligatures -> emitquote "``" - '\x201D' | ligatures -> emitquote "''" - '\x2014' | ligatures -> emits "---" - '\x2013' | ligatures -> emits "--" - _ | writerPreferAscii opts - -> case x of - 'ı' -> emitcseq "\\i" - 'ȷ' -> emitcseq "\\j" - 'å' -> emitcseq "\\aa" - 'Å' -> emitcseq "\\AA" - 'ß' -> emitcseq "\\ss" - 'ø' -> emitcseq "\\o" - 'Ø' -> emitcseq "\\O" - 'Ł' -> emitcseq "\\L" - 'ł' -> emitcseq "\\l" - 'æ' -> emitcseq "\\ae" - 'Æ' -> emitcseq "\\AE" - 'œ' -> emitcseq "\\oe" - 'Œ' -> emitcseq "\\OE" - '£' -> emitcseq "\\pounds" - '€' -> emitcseq "\\euro" - '©' -> emitcseq "\\copyright" - _ -> emitc x - | otherwise -> emitc x - -accents :: M.Map Char String -accents = M.fromList - [ ('\779' , "\\H") - , ('\768' , "\\`") - , ('\769' , "\\'") - , ('\770' , "\\^") - , ('\771' , "\\~") - , ('\776' , "\\\"") - , ('\775' , "\\.") - , ('\772' , "\\=") - , ('\781' , "\\|") - , ('\817' , "\\b") - , ('\807' , "\\c") - , ('\783' , "\\G") - , ('\777' , "\\h") - , ('\803' , "\\d") - , ('\785' , "\\f") - , ('\778' , "\\r") - , ('\865' , "\\t") - , ('\782' , "\\U") - , ('\780' , "\\v") - , ('\774' , "\\u") - , ('\808' , "\\k") - , ('\785' , "\\newtie") - , ('\8413', "\\textcircled") - ] - -toLabel :: PandocMonad m => Text -> LW m Text -toLabel z = go `fmap` stringToLaTeX URLString z - where - go = T.concatMap $ \x -> case x of - _ | (isLetter x || isDigit x) && isAscii x -> T.singleton x - | x `elemText` "_-+=:;." -> T.singleton x - | otherwise -> T.pack $ "ux" <> printf "%x" (ord x) - --- | Puts contents into LaTeX command. -inCmd :: Text -> Doc Text -> Doc Text -inCmd cmd contents = char '\\' <> literal cmd <> braces contents - toSlides :: PandocMonad m => [Block] -> LW m [Block] toSlides bs = do opts <- gets stOptions @@ -500,12 +355,13 @@ else blockListToLaTeX bs modify $ \st -> st{ stIncremental = oldIncremental } linkAnchor' <- hypertarget True identifier empty - -- see #2704 for the motivation for adding \leavevmode: + -- see #2704 for the motivation for adding \leavevmode + -- and #7078 for \vadjust pre let linkAnchor = case bs of Para _ : _ | not (isEmpty linkAnchor') - -> "\\leavevmode" <> linkAnchor' <> "%" + -> "\\leavevmode\\vadjust pre{" <> linkAnchor' <> "}%" _ -> linkAnchor' wrapNotes txt = if beamer && "notes" `elem` classes then "\\note" <> braces txt -- speaker notes @@ -852,81 +708,6 @@ braces txtNoNotes else empty -mapAlignment :: Text -> Text -mapAlignment a = case a of - "top" -> "T" - "top-baseline" -> "t" - "bottom" -> "b" - "center" -> "c" - _ -> a - -wrapDiv :: PandocMonad m => Attr -> Doc Text -> LW m (Doc Text) -wrapDiv (_,classes,kvs) t = do - beamer <- gets stBeamer - let align dir txt = inCmd "begin" dir $$ txt $$ inCmd "end" dir - lang <- toLang $ lookup "lang" kvs - let wrapColumns = if beamer && "columns" `elem` classes - then \contents -> - let valign = maybe "T" mapAlignment (lookup "align" kvs) - totalwidth = maybe [] (\x -> ["totalwidth=" <> x]) - (lookup "totalwidth" kvs) - onlytextwidth = filter ("onlytextwidth" ==) classes - options = text $ T.unpack $ T.intercalate "," $ - valign : totalwidth ++ onlytextwidth - in inCmd "begin" "columns" <> brackets options - $$ contents - $$ inCmd "end" "columns" - else id - wrapColumn = if beamer && "column" `elem` classes - then \contents -> - let valign = - maybe "" - (brackets . text . T.unpack . mapAlignment) - (lookup "align" kvs) - w = maybe "0.48" fromPct (lookup "width" kvs) - in inCmd "begin" "column" <> - valign <> - braces (literal w <> "\\textwidth") - $$ contents - $$ inCmd "end" "column" - else id - fromPct xs = - case T.unsnoc xs of - Just (ds, '%') -> case safeRead ds of - Just digits -> showFl (digits / 100 :: Double) - Nothing -> xs - _ -> xs - wrapDir = case lookup "dir" kvs of - Just "rtl" -> align "RTL" - Just "ltr" -> align "LTR" - _ -> id - wrapLang txt = case lang of - Just lng -> let (l, o) = toPolyglossiaEnv lng - ops = if T.null o - then "" - else brackets $ literal o - in inCmd "begin" (literal l) <> ops - $$ blankline <> txt <> blankline - $$ inCmd "end" (literal l) - Nothing -> txt - return $ wrapColumns . wrapColumn . wrapDir . wrapLang $ t - -hypertarget :: PandocMonad m => Bool -> Text -> Doc Text -> LW m (Doc Text) -hypertarget _ "" x = return x -hypertarget addnewline ident x = do - ref <- literal `fmap` toLabel ident - return $ text "\\hypertarget" - <> braces ref - <> braces ((if addnewline && not (isEmpty x) - then "%" <> cr - else empty) <> x) - -labelFor :: PandocMonad m => Text -> LW m (Doc Text) -labelFor "" = return empty -labelFor ident = do - ref <- literal `fmap` toLabel ident - return $ text "\\label" <> braces ref - -- | Convert list of inline elements to LaTeX. inlineListToLaTeX :: PandocMonad m => [Inline] -- ^ Inlines to convert @@ -951,10 +732,6 @@ fixInitialLineBreaks xs fixInitialLineBreaks xs = xs -isQuoted :: Inline -> Bool -isQuoted (Quoted _ _) = True -isQuoted _ = False - -- | Convert inline element to LaTeX inlineToLaTeX :: PandocMonad m => Inline -- ^ Inline to convert @@ -1015,8 +792,8 @@ st <- get let opts = stOptions st case writerCiteMethod opts of - Natbib -> citationsToNatbib cits - Biblatex -> citationsToBiblatex cits + Natbib -> citationsToNatbib inlineListToLaTeX cits + Biblatex -> citationsToBiblatex inlineListToLaTeX cits _ -> inlineListToLaTeX lst inlineToLaTeX (Code (_,classes,kvs) str) = do @@ -1090,6 +867,9 @@ if isEnabled Ext_smart opts then char '`' <> inner <> char '\'' else char '\x2018' <> inner <> char '\x2019' + where + isQuoted (Quoted _ _) = True + isQuoted _ = False inlineToLaTeX (Str str) = do setEmptyLine False liftM literal $ stringToLaTeX TextString str @@ -1227,153 +1007,6 @@ setEmptyLine :: PandocMonad m => Bool -> LW m () setEmptyLine b = modify $ \st -> st{ stEmptyLine = b } -citationsToNatbib :: PandocMonad m => [Citation] -> LW m (Doc Text) -citationsToNatbib - [one] - = citeCommand c p s k - where - Citation { citationId = k - , citationPrefix = p - , citationSuffix = s - , citationMode = m - } - = one - c = case m of - AuthorInText -> "citet" - SuppressAuthor -> "citeyearpar" - NormalCitation -> "citep" - -citationsToNatbib cits - | noPrefix (tail cits) && noSuffix (init cits) && ismode NormalCitation cits - = citeCommand "citep" p s ks - where - noPrefix = all (null . citationPrefix) - noSuffix = all (null . citationSuffix) - ismode m = all ((==) m . citationMode) - p = citationPrefix $ - head cits - s = citationSuffix $ - last cits - ks = T.intercalate ", " $ map citationId cits - -citationsToNatbib (c:cs) | citationMode c == AuthorInText = do - author <- citeCommand "citeauthor" [] [] (citationId c) - cits <- citationsToNatbib (c { citationMode = SuppressAuthor } : cs) - return $ author <+> cits - -citationsToNatbib cits = do - cits' <- mapM convertOne cits - return $ text "\\citetext{" <> foldl' combineTwo empty cits' <> text "}" - where - combineTwo a b | isEmpty a = b - | otherwise = a <> text "; " <> b - convertOne Citation { citationId = k - , citationPrefix = p - , citationSuffix = s - , citationMode = m - } - = case m of - AuthorInText -> citeCommand "citealt" p s k - SuppressAuthor -> citeCommand "citeyear" p s k - NormalCitation -> citeCommand "citealp" p s k - -citeCommand :: PandocMonad m - => Text -> [Inline] -> [Inline] -> Text -> LW m (Doc Text) -citeCommand c p s k = do - args <- citeArguments p s k - return $ literal ("\\" <> c) <> args - -type Prefix = [Inline] -type Suffix = [Inline] -type CiteId = Text -data CiteGroup = CiteGroup Prefix Suffix [CiteId] - -citeArgumentsList :: PandocMonad m - => CiteGroup -> LW m (Doc Text) -citeArgumentsList (CiteGroup _ _ []) = return empty -citeArgumentsList (CiteGroup pfxs sfxs ids) = do - pdoc <- inlineListToLaTeX pfxs - sdoc <- inlineListToLaTeX sfxs' - return $ optargs pdoc sdoc <> - braces (literal (T.intercalate "," (reverse ids))) - where sfxs' = stripLocatorBraces $ case sfxs of - (Str t : r) -> case T.uncons t of - Just (x, xs) - | T.null xs - , isPunctuation x -> dropWhile (== Space) r - | isPunctuation x -> Str xs : r - _ -> sfxs - _ -> sfxs - optargs pdoc sdoc = case (isEmpty pdoc, isEmpty sdoc) of - (True, True ) -> empty - (True, False) -> brackets sdoc - (_ , _ ) -> brackets pdoc <> brackets sdoc - -citeArguments :: PandocMonad m - => [Inline] -> [Inline] -> Text -> LW m (Doc Text) -citeArguments p s k = citeArgumentsList (CiteGroup p s [k]) - --- strip off {} used to define locator in pandoc-citeproc; see #5722 -stripLocatorBraces :: [Inline] -> [Inline] -stripLocatorBraces = walk go - where go (Str xs) = Str $ T.filter (\c -> c /= '{' && c /= '}') xs - go x = x - -citationsToBiblatex :: PandocMonad m => [Citation] -> LW m (Doc Text) -citationsToBiblatex - [one] - = citeCommand cmd p s k - where - Citation { citationId = k - , citationPrefix = p - , citationSuffix = s - , citationMode = m - } = one - cmd = case m of - SuppressAuthor -> "autocite*" - AuthorInText -> "textcite" - NormalCitation -> "autocite" - -citationsToBiblatex (c:cs) - | all (\cit -> null (citationPrefix cit) && null (citationSuffix cit)) (c:cs) - = do - let cmd = case citationMode c of - SuppressAuthor -> "\\autocite*" - AuthorInText -> "\\textcite" - NormalCitation -> "\\autocite" - return $ text cmd <> - braces (literal (T.intercalate "," (map citationId (c:cs)))) - | otherwise - = do - let cmd = case citationMode c of - SuppressAuthor -> "\\autocites*" - AuthorInText -> "\\textcites" - NormalCitation -> "\\autocites" - - groups <- mapM citeArgumentsList (reverse (foldl' grouper [] (c:cs))) - - return $ text cmd <> mconcat groups - - where grouper prev cit = case prev of - ((CiteGroup oPfx oSfx ids):rest) - | null oSfx && null pfx -> CiteGroup oPfx sfx (cid:ids) : rest - _ -> CiteGroup pfx sfx [cid] : prev - where pfx = citationPrefix cit - sfx = citationSuffix cit - cid = citationId cit - -citationsToBiblatex _ = return empty - --- Determine listings language from list of class attributes. -getListingsLanguage :: [Text] -> Maybe Text -getListingsLanguage xs - = foldr ((<|>) . toListingsLanguage) Nothing xs - -mbBraced :: Text -> Text -mbBraced x = if not (T.all isAlphaNum x) - then "{" <> x <> "}" - else x - -- Extract a key from divs and spans extract :: Text -> Block -> [Text] extract key (Div attr _) = lookKey key attr @@ -1391,174 +1024,4 @@ lookKey :: Text -> Attr -> [Text] lookKey key (_,_,kvs) = maybe [] T.words $ lookup key kvs --- In environments \Arabic instead of \arabic is used -toPolyglossiaEnv :: Lang -> (Text, Text) -toPolyglossiaEnv l = - case toPolyglossia l of - ("arabic", o) -> ("Arabic", o) - x -> x --- Takes a list of the constituents of a BCP 47 language code and --- converts it to a Polyglossia (language, options) tuple --- http://mirrors.ctan.org/macros/latex/contrib/polyglossia/polyglossia.pdf -toPolyglossia :: Lang -> (Text, Text) -toPolyglossia (Lang "ar" _ "DZ" _) = ("arabic", "locale=algeria") -toPolyglossia (Lang "ar" _ "IQ" _) = ("arabic", "locale=mashriq") -toPolyglossia (Lang "ar" _ "JO" _) = ("arabic", "locale=mashriq") -toPolyglossia (Lang "ar" _ "LB" _) = ("arabic", "locale=mashriq") -toPolyglossia (Lang "ar" _ "LY" _) = ("arabic", "locale=libya") -toPolyglossia (Lang "ar" _ "MA" _) = ("arabic", "locale=morocco") -toPolyglossia (Lang "ar" _ "MR" _) = ("arabic", "locale=mauritania") -toPolyglossia (Lang "ar" _ "PS" _) = ("arabic", "locale=mashriq") -toPolyglossia (Lang "ar" _ "SY" _) = ("arabic", "locale=mashriq") -toPolyglossia (Lang "ar" _ "TN" _) = ("arabic", "locale=tunisia") -toPolyglossia (Lang "de" _ _ vars) - | "1901" `elem` vars = ("german", "spelling=old") -toPolyglossia (Lang "de" _ "AT" vars) - | "1901" `elem` vars = ("german", "variant=austrian, spelling=old") -toPolyglossia (Lang "de" _ "AT" _) = ("german", "variant=austrian") -toPolyglossia (Lang "de" _ "CH" vars) - | "1901" `elem` vars = ("german", "variant=swiss, spelling=old") -toPolyglossia (Lang "de" _ "CH" _) = ("german", "variant=swiss") -toPolyglossia (Lang "de" _ _ _) = ("german", "") -toPolyglossia (Lang "dsb" _ _ _) = ("lsorbian", "") -toPolyglossia (Lang "el" _ "polyton" _) = ("greek", "variant=poly") -toPolyglossia (Lang "en" _ "AU" _) = ("english", "variant=australian") -toPolyglossia (Lang "en" _ "CA" _) = ("english", "variant=canadian") -toPolyglossia (Lang "en" _ "GB" _) = ("english", "variant=british") -toPolyglossia (Lang "en" _ "NZ" _) = ("english", "variant=newzealand") -toPolyglossia (Lang "en" _ "UK" _) = ("english", "variant=british") -toPolyglossia (Lang "en" _ "US" _) = ("english", "variant=american") -toPolyglossia (Lang "grc" _ _ _) = ("greek", "variant=ancient") -toPolyglossia (Lang "hsb" _ _ _) = ("usorbian", "") -toPolyglossia (Lang "la" _ _ vars) - | "x-classic" `elem` vars = ("latin", "variant=classic") -toPolyglossia (Lang "pt" _ "BR" _) = ("portuguese", "variant=brazilian") -toPolyglossia (Lang "sl" _ _ _) = ("slovenian", "") -toPolyglossia x = (commonFromBcp47 x, "") - --- Takes a list of the constituents of a BCP 47 language code and --- converts it to a Babel language string. --- 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 "de" _ "AT" vars) - | "1901" `elem` vars = "austrian" - | otherwise = "naustrian" -toBabel (Lang "de" _ "CH" vars) - | "1901" `elem` vars = "swissgerman" - | otherwise = "nswissgerman" -toBabel (Lang "de" _ _ vars) - | "1901" `elem` vars = "german" - | otherwise = "ngerman" -toBabel (Lang "dsb" _ _ _) = "lowersorbian" -toBabel (Lang "el" _ _ vars) - | "polyton" `elem` vars = "polutonikogreek" -toBabel (Lang "en" _ "AU" _) = "australian" -toBabel (Lang "en" _ "CA" _) = "canadian" -toBabel (Lang "en" _ "GB" _) = "british" -toBabel (Lang "en" _ "NZ" _) = "newzealand" -toBabel (Lang "en" _ "UK" _) = "british" -toBabel (Lang "en" _ "US" _) = "american" -toBabel (Lang "fr" _ "CA" _) = "canadien" -toBabel (Lang "fra" _ _ vars) - | "aca" `elem` vars = "acadian" -toBabel (Lang "grc" _ _ _) = "polutonikogreek" -toBabel (Lang "hsb" _ _ _) = "uppersorbian" -toBabel (Lang "la" _ _ vars) - | "x-classic" `elem` vars = "classiclatin" -toBabel (Lang "pt" _ "BR" _) = "brazilian" -toBabel (Lang "sl" _ _ _) = "slovene" -toBabel x = commonFromBcp47 x - --- Takes a list of the constituents of a BCP 47 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" "Cyrl" _ _) = "serbianc" -commonFromBcp47 (Lang "zh" "Latn" _ vars) - | "pinyin" `elem` vars = "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 "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 "jp" = "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 "pa" = "panjabi" - 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 _ = "" diff --git a/src/Text/Pandoc/Writers/LaTeX/Citation.hs b/src/Text/Pandoc/Writers/LaTeX/Citation.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/Writers/LaTeX/Citation.hs @@ -0,0 +1,181 @@ +{-# LANGUAGE OverloadedStrings #-} +{- | + Module : Text.Pandoc.Writers.LaTeX.Citation + Copyright : Copyright (C) 2006-2021 John MacFarlane + License : GNU GPL, version 2 or above + + Maintainer : John MacFarlane + Stability : alpha + Portability : portable +-} +module Text.Pandoc.Writers.LaTeX.Citation + ( citationsToNatbib, + citationsToBiblatex + ) where + +import Data.Text (Text) +import Data.Char (isPunctuation) +import qualified Data.Text as T +import Text.Pandoc.Class.PandocMonad (PandocMonad) +import Text.Pandoc.Definition +import Data.List (foldl') +import Text.DocLayout (Doc, brackets, empty, (<+>), text, isEmpty, literal, + braces) +import Text.Pandoc.Walk +import Text.Pandoc.Writers.LaTeX.Types ( LW ) + +citationsToNatbib :: PandocMonad m + => ([Inline] -> LW m (Doc Text)) + -> [Citation] + -> LW m (Doc Text) +citationsToNatbib inlineListToLaTeX [one] + = citeCommand inlineListToLaTeX c p s k + where + Citation { citationId = k + , citationPrefix = p + , citationSuffix = s + , citationMode = m + } + = one + c = case m of + AuthorInText -> "citet" + SuppressAuthor -> "citeyearpar" + NormalCitation -> "citep" + +citationsToNatbib inlineListToLaTeX cits + | noPrefix (tail cits) && noSuffix (init cits) && ismode NormalCitation cits + = citeCommand inlineListToLaTeX "citep" p s ks + where + noPrefix = all (null . citationPrefix) + noSuffix = all (null . citationSuffix) + ismode m = all ((==) m . citationMode) + p = citationPrefix $ + head cits + s = citationSuffix $ + last cits + ks = T.intercalate ", " $ map citationId cits + +citationsToNatbib inlineListToLaTeX (c:cs) + | citationMode c == AuthorInText = do + author <- citeCommand inlineListToLaTeX "citeauthor" [] [] (citationId c) + cits <- citationsToNatbib inlineListToLaTeX + (c { citationMode = SuppressAuthor } : cs) + return $ author <+> cits + +citationsToNatbib inlineListToLaTeX cits = do + cits' <- mapM convertOne cits + return $ text "\\citetext{" <> foldl' combineTwo empty cits' <> text "}" + where + citeCommand' = citeCommand inlineListToLaTeX + combineTwo a b | isEmpty a = b + | otherwise = a <> text "; " <> b + convertOne Citation { citationId = k + , citationPrefix = p + , citationSuffix = s + , citationMode = m + } + = case m of + AuthorInText -> citeCommand' "citealt" p s k + SuppressAuthor -> citeCommand' "citeyear" p s k + NormalCitation -> citeCommand' "citealp" p s k + +citeCommand :: PandocMonad m + => ([Inline] -> LW m (Doc Text)) + -> Text + -> [Inline] + -> [Inline] + -> Text + -> LW m (Doc Text) +citeCommand inlineListToLaTeX c p s k = do + args <- citeArguments inlineListToLaTeX p s k + return $ literal ("\\" <> c) <> args + +type Prefix = [Inline] +type Suffix = [Inline] +type CiteId = Text +data CiteGroup = CiteGroup Prefix Suffix [CiteId] + +citeArgumentsList :: PandocMonad m + => ([Inline] -> LW m (Doc Text)) + -> CiteGroup + -> LW m (Doc Text) +citeArgumentsList _inlineListToLaTeX (CiteGroup _ _ []) = return empty +citeArgumentsList inlineListToLaTeX (CiteGroup pfxs sfxs ids) = do + pdoc <- inlineListToLaTeX pfxs + sdoc <- inlineListToLaTeX sfxs' + return $ optargs pdoc sdoc <> + braces (literal (T.intercalate "," (reverse ids))) + where sfxs' = stripLocatorBraces $ case sfxs of + (Str t : r) -> case T.uncons t of + Just (x, xs) + | T.null xs + , isPunctuation x -> dropWhile (== Space) r + | isPunctuation x -> Str xs : r + _ -> sfxs + _ -> sfxs + optargs pdoc sdoc = case (isEmpty pdoc, isEmpty sdoc) of + (True, True ) -> empty + (True, False) -> brackets sdoc + (_ , _ ) -> brackets pdoc <> brackets sdoc + +citeArguments :: PandocMonad m + => ([Inline] -> LW m (Doc Text)) + -> [Inline] + -> [Inline] + -> Text + -> LW m (Doc Text) +citeArguments inlineListToLaTeX p s k = + citeArgumentsList inlineListToLaTeX (CiteGroup p s [k]) + +-- strip off {} used to define locator in pandoc-citeproc; see #5722 +stripLocatorBraces :: [Inline] -> [Inline] +stripLocatorBraces = walk go + where go (Str xs) = Str $ T.filter (\c -> c /= '{' && c /= '}') xs + go x = x + +citationsToBiblatex :: PandocMonad m + => ([Inline] -> LW m (Doc Text)) + -> [Citation] -> LW m (Doc Text) +citationsToBiblatex inlineListToLaTeX [one] + = citeCommand inlineListToLaTeX cmd p s k + where + Citation { citationId = k + , citationPrefix = p + , citationSuffix = s + , citationMode = m + } = one + cmd = case m of + SuppressAuthor -> "autocite*" + AuthorInText -> "textcite" + NormalCitation -> "autocite" + +citationsToBiblatex inlineListToLaTeX (c:cs) + | all (\cit -> null (citationPrefix cit) && null (citationSuffix cit)) (c:cs) + = do + let cmd = case citationMode c of + SuppressAuthor -> "\\autocite*" + AuthorInText -> "\\textcite" + NormalCitation -> "\\autocite" + return $ text cmd <> + braces (literal (T.intercalate "," (map citationId (c:cs)))) + | otherwise + = do + let cmd = case citationMode c of + SuppressAuthor -> "\\autocites*" + AuthorInText -> "\\textcites" + NormalCitation -> "\\autocites" + + groups <- mapM (citeArgumentsList inlineListToLaTeX) + (reverse (foldl' grouper [] (c:cs))) + + return $ text cmd <> mconcat groups + + where grouper prev cit = case prev of + ((CiteGroup oPfx oSfx ids):rest) + | null oSfx && null pfx -> CiteGroup oPfx sfx (cid:ids) : rest + _ -> CiteGroup pfx sfx [cid] : prev + where pfx = citationPrefix cit + sfx = citationSuffix cit + cid = citationId cit + +citationsToBiblatex _ _ = return empty diff --git a/src/Text/Pandoc/Writers/LaTeX/Lang.hs b/src/Text/Pandoc/Writers/LaTeX/Lang.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/Writers/LaTeX/Lang.hs @@ -0,0 +1,191 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{- | + Module : Text.Pandoc.Writers.LaTeX.Lang + Copyright : Copyright (C) 2006-2021 John MacFarlane + License : GNU GPL, version 2 or above + + Maintainer : John MacFarlane + Stability : alpha + Portability : portable +-} +module Text.Pandoc.Writers.LaTeX.Lang + ( toPolyglossiaEnv, + toPolyglossia, + toBabel + ) where +import Data.Text (Text) +import Text.Pandoc.BCP47 (Lang (..)) + + +-- In environments \Arabic instead of \arabic is used +toPolyglossiaEnv :: Lang -> (Text, Text) +toPolyglossiaEnv l = + case toPolyglossia l of + ("arabic", o) -> ("Arabic", o) + x -> x + +-- Takes a list of the constituents of a BCP 47 language code and +-- converts it to a Polyglossia (language, options) tuple +-- http://mirrors.ctan.org/macros/latex/contrib/polyglossia/polyglossia.pdf +toPolyglossia :: Lang -> (Text, Text) +toPolyglossia (Lang "ar" _ "DZ" _) = ("arabic", "locale=algeria") +toPolyglossia (Lang "ar" _ "IQ" _) = ("arabic", "locale=mashriq") +toPolyglossia (Lang "ar" _ "JO" _) = ("arabic", "locale=mashriq") +toPolyglossia (Lang "ar" _ "LB" _) = ("arabic", "locale=mashriq") +toPolyglossia (Lang "ar" _ "LY" _) = ("arabic", "locale=libya") +toPolyglossia (Lang "ar" _ "MA" _) = ("arabic", "locale=morocco") +toPolyglossia (Lang "ar" _ "MR" _) = ("arabic", "locale=mauritania") +toPolyglossia (Lang "ar" _ "PS" _) = ("arabic", "locale=mashriq") +toPolyglossia (Lang "ar" _ "SY" _) = ("arabic", "locale=mashriq") +toPolyglossia (Lang "ar" _ "TN" _) = ("arabic", "locale=tunisia") +toPolyglossia (Lang "de" _ _ vars) + | "1901" `elem` vars = ("german", "spelling=old") +toPolyglossia (Lang "de" _ "AT" vars) + | "1901" `elem` vars = ("german", "variant=austrian, spelling=old") +toPolyglossia (Lang "de" _ "AT" _) = ("german", "variant=austrian") +toPolyglossia (Lang "de" _ "CH" vars) + | "1901" `elem` vars = ("german", "variant=swiss, spelling=old") +toPolyglossia (Lang "de" _ "CH" _) = ("german", "variant=swiss") +toPolyglossia (Lang "de" _ _ _) = ("german", "") +toPolyglossia (Lang "dsb" _ _ _) = ("lsorbian", "") +toPolyglossia (Lang "el" _ "polyton" _) = ("greek", "variant=poly") +toPolyglossia (Lang "en" _ "AU" _) = ("english", "variant=australian") +toPolyglossia (Lang "en" _ "CA" _) = ("english", "variant=canadian") +toPolyglossia (Lang "en" _ "GB" _) = ("english", "variant=british") +toPolyglossia (Lang "en" _ "NZ" _) = ("english", "variant=newzealand") +toPolyglossia (Lang "en" _ "UK" _) = ("english", "variant=british") +toPolyglossia (Lang "en" _ "US" _) = ("english", "variant=american") +toPolyglossia (Lang "grc" _ _ _) = ("greek", "variant=ancient") +toPolyglossia (Lang "hsb" _ _ _) = ("usorbian", "") +toPolyglossia (Lang "la" _ _ vars) + | "x-classic" `elem` vars = ("latin", "variant=classic") +toPolyglossia (Lang "pt" _ "BR" _) = ("portuguese", "variant=brazilian") +toPolyglossia (Lang "sl" _ _ _) = ("slovenian", "") +toPolyglossia x = (commonFromBcp47 x, "") + +-- Takes a list of the constituents of a BCP 47 language code and +-- converts it to a Babel language string. +-- 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 "de" _ "AT" vars) + | "1901" `elem` vars = "austrian" + | otherwise = "naustrian" +toBabel (Lang "de" _ "CH" vars) + | "1901" `elem` vars = "swissgerman" + | otherwise = "nswissgerman" +toBabel (Lang "de" _ _ vars) + | "1901" `elem` vars = "german" + | otherwise = "ngerman" +toBabel (Lang "dsb" _ _ _) = "lowersorbian" +toBabel (Lang "el" _ _ vars) + | "polyton" `elem` vars = "polutonikogreek" +toBabel (Lang "en" _ "AU" _) = "australian" +toBabel (Lang "en" _ "CA" _) = "canadian" +toBabel (Lang "en" _ "GB" _) = "british" +toBabel (Lang "en" _ "NZ" _) = "newzealand" +toBabel (Lang "en" _ "UK" _) = "british" +toBabel (Lang "en" _ "US" _) = "american" +toBabel (Lang "fr" _ "CA" _) = "canadien" +toBabel (Lang "fra" _ _ vars) + | "aca" `elem` vars = "acadian" +toBabel (Lang "grc" _ _ _) = "polutonikogreek" +toBabel (Lang "hsb" _ _ _) = "uppersorbian" +toBabel (Lang "la" _ _ vars) + | "x-classic" `elem` vars = "classiclatin" +toBabel (Lang "pt" _ "BR" _) = "brazilian" +toBabel (Lang "sl" _ _ _) = "slovene" +toBabel x = commonFromBcp47 x + +-- Takes a list of the constituents of a BCP 47 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" "Cyrl" _ _) = "serbianc" +commonFromBcp47 (Lang "zh" "Latn" _ vars) + | "pinyin" `elem` vars = "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 "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 "pa" = "panjabi" + 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 _ = "" diff --git a/src/Text/Pandoc/Writers/LaTeX/Util.hs b/src/Text/Pandoc/Writers/LaTeX/Util.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/Writers/LaTeX/Util.hs @@ -0,0 +1,274 @@ +{-# LANGUAGE OverloadedStrings #-} +{- | + Module : Text.Pandoc.Writers.LaTeX.Util + Copyright : Copyright (C) 2006-2021 John MacFarlane + License : GNU GPL, version 2 or above + + Maintainer : John MacFarlane + Stability : alpha + Portability : portable +-} +module Text.Pandoc.Writers.LaTeX.Util ( + stringToLaTeX + , StringContext(..) + , toLabel + , inCmd + , wrapDiv + , hypertarget + , labelFor + , getListingsLanguage + , mbBraced + ) +where + +import Control.Applicative ((<|>)) +import Text.Pandoc.Class (PandocMonad, toLang) +import Text.Pandoc.Options (WriterOptions(..), isEnabled) +import Text.Pandoc.Writers.LaTeX.Types (LW, WriterState(..)) +import Text.Pandoc.Writers.LaTeX.Lang (toPolyglossiaEnv) +import Text.Pandoc.Highlighting (toListingsLanguage) +import Text.DocLayout +import Text.Pandoc.Definition +import Text.Pandoc.ImageSize (showFl) +import Control.Monad.State.Strict (gets) +import Data.Text (Text) +import qualified Data.Text as T +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 qualified Data.Text.Normalize as Normalize +import Data.List (uncons) + +data StringContext = TextString + | URLString + | CodeString + deriving (Eq) + +-- escape things as needed for LaTeX +stringToLaTeX :: PandocMonad m => StringContext -> Text -> LW m Text +stringToLaTeX context zs = do + opts <- gets stOptions + return $ T.pack $ + foldr (go opts context) mempty $ T.unpack $ + if writerPreferAscii opts + then Normalize.normalize Normalize.NFD zs + else zs + where + go :: WriterOptions -> StringContext -> Char -> String -> String + go opts ctx x xs = + let ligatures = isEnabled Ext_smart opts && ctx == TextString + isUrl = ctx == URLString + mbAccentCmd = + if writerPreferAscii opts && ctx == TextString + then uncons xs >>= \(c,_) -> lookupAccent c + else Nothing + emits s = + case mbAccentCmd of + Just cmd -> + cmd <> "{" <> s <> "}" <> drop 1 xs -- drop combining accent + Nothing -> s <> xs + emitc c = + case mbAccentCmd of + Just cmd -> + cmd <> "{" <> [c] <> "}" <> drop 1 xs -- drop combining accent + Nothing -> c : xs + emitcseq cs = + case xs of + c:_ | isLetter c + , ctx == TextString + -> cs <> " " <> xs + | isSpace c -> cs <> "{}" <> xs + | ctx == TextString + -> cs <> xs + _ -> cs <> "{}" <> xs + emitquote cs = + case xs of + '`':_ -> cs <> "\\," <> xs -- add thin space + '\'':_ -> cs <> "\\," <> xs -- add thin space + _ -> cs <> xs + in case x of + '?' | ligatures -> -- avoid ?` ligature + case xs of + '`':_ -> emits "?{}" + _ -> emitc x + '!' | ligatures -> -- avoid !` ligature + case xs of + '`':_ -> emits "!{}" + _ -> emitc x + '{' -> emits "\\{" + '}' -> emits "\\}" + '`' | ctx == CodeString -> emitcseq "\\textasciigrave" + '$' | not isUrl -> emits "\\$" + '%' -> emits "\\%" + '&' -> emits "\\&" + '_' | not isUrl -> emits "\\_" + '#' -> emits "\\#" + '-' | not isUrl -> case xs of + -- prevent adjacent hyphens from forming ligatures + ('-':_) -> emits "-\\/" + _ -> emitc '-' + '~' | not isUrl -> emitcseq "\\textasciitilde" + '^' -> emits "\\^{}" + '\\'| isUrl -> emitc '/' -- NB. / works as path sep even on Windows + | otherwise -> emitcseq "\\textbackslash" + '|' | not isUrl -> emitcseq "\\textbar" + '<' -> emitcseq "\\textless" + '>' -> emitcseq "\\textgreater" + '[' -> emits "{[}" -- to avoid interpretation as + ']' -> emits "{]}" -- optional arguments + '\'' | ctx == CodeString -> emitcseq "\\textquotesingle" + '\160' -> emits "~" + '\x200B' -> emits "\\hspace{0pt}" -- zero-width space + '\x202F' -> emits "\\," + '\x2026' -> emitcseq "\\ldots" + '\x2018' | ligatures -> emitquote "`" + '\x2019' | ligatures -> emitquote "'" + '\x201C' | ligatures -> emitquote "``" + '\x201D' | ligatures -> emitquote "''" + '\x2014' | ligatures -> emits "---" + '\x2013' | ligatures -> emits "--" + _ | writerPreferAscii opts + -> case x of + 'ı' -> emitcseq "\\i" + 'ȷ' -> emitcseq "\\j" + 'å' -> emitcseq "\\aa" + 'Å' -> emitcseq "\\AA" + 'ß' -> emitcseq "\\ss" + 'ø' -> emitcseq "\\o" + 'Ø' -> emitcseq "\\O" + 'Ł' -> emitcseq "\\L" + 'ł' -> emitcseq "\\l" + 'æ' -> emitcseq "\\ae" + 'Æ' -> emitcseq "\\AE" + 'œ' -> emitcseq "\\oe" + 'Œ' -> emitcseq "\\OE" + '£' -> emitcseq "\\pounds" + '€' -> emitcseq "\\euro" + '©' -> emitcseq "\\copyright" + _ -> emitc x + | otherwise -> emitc x + +lookupAccent :: Char -> Maybe String +lookupAccent '\779' = Just "\\H" +lookupAccent '\768' = Just "\\`" +lookupAccent '\769' = Just "\\'" +lookupAccent '\770' = Just "\\^" +lookupAccent '\771' = Just "\\~" +lookupAccent '\776' = Just "\\\"" +lookupAccent '\775' = Just "\\." +lookupAccent '\772' = Just "\\=" +lookupAccent '\781' = Just "\\|" +lookupAccent '\817' = Just "\\b" +lookupAccent '\807' = Just "\\c" +lookupAccent '\783' = Just "\\G" +lookupAccent '\777' = Just "\\h" +lookupAccent '\803' = Just "\\d" +lookupAccent '\785' = Just "\\f" +lookupAccent '\778' = Just "\\r" +lookupAccent '\865' = Just "\\t" +lookupAccent '\782' = Just "\\U" +lookupAccent '\780' = Just "\\v" +lookupAccent '\774' = Just "\\u" +lookupAccent '\808' = Just "\\k" +lookupAccent '\8413' = Just "\\textcircled" +lookupAccent _ = Nothing + +toLabel :: PandocMonad m => Text -> LW m Text +toLabel z = go `fmap` stringToLaTeX URLString z + where + go = T.concatMap $ \x -> case x of + _ | (isLetter x || isDigit x) && isAscii x -> T.singleton x + | x `elemText` "_-+=:;." -> T.singleton x + | otherwise -> T.pack $ "ux" <> printf "%x" (ord x) + +-- | Puts contents into LaTeX command. +inCmd :: Text -> Doc Text -> Doc Text +inCmd cmd contents = char '\\' <> literal cmd <> braces contents + +mapAlignment :: Text -> Text +mapAlignment a = case a of + "top" -> "T" + "top-baseline" -> "t" + "bottom" -> "b" + "center" -> "c" + _ -> a + +wrapDiv :: PandocMonad m => Attr -> Doc Text -> LW m (Doc Text) +wrapDiv (_,classes,kvs) t = do + beamer <- gets stBeamer + let align dir txt = inCmd "begin" dir $$ txt $$ inCmd "end" dir + lang <- toLang $ lookup "lang" kvs + let wrapColumns = if beamer && "columns" `elem` classes + then \contents -> + let valign = maybe "T" mapAlignment (lookup "align" kvs) + totalwidth = maybe [] (\x -> ["totalwidth=" <> x]) + (lookup "totalwidth" kvs) + onlytextwidth = filter ("onlytextwidth" ==) classes + options = text $ T.unpack $ T.intercalate "," $ + valign : totalwidth ++ onlytextwidth + in inCmd "begin" "columns" <> brackets options + $$ contents + $$ inCmd "end" "columns" + else id + wrapColumn = if beamer && "column" `elem` classes + then \contents -> + let valign = + maybe "" + (brackets . text . T.unpack . mapAlignment) + (lookup "align" kvs) + w = maybe "0.48" fromPct (lookup "width" kvs) + in inCmd "begin" "column" <> + valign <> + braces (literal w <> "\\textwidth") + $$ contents + $$ inCmd "end" "column" + else id + fromPct xs = + case T.unsnoc xs of + Just (ds, '%') -> case safeRead ds of + Just digits -> showFl (digits / 100 :: Double) + Nothing -> xs + _ -> xs + wrapDir = case lookup "dir" kvs of + Just "rtl" -> align "RTL" + Just "ltr" -> align "LTR" + _ -> id + wrapLang txt = case lang of + Just lng -> let (l, o) = toPolyglossiaEnv lng + ops = if T.null o + then "" + else brackets $ literal o + in inCmd "begin" (literal l) <> ops + $$ blankline <> txt <> blankline + $$ inCmd "end" (literal l) + Nothing -> txt + return $ wrapColumns . wrapColumn . wrapDir . wrapLang $ t + +hypertarget :: PandocMonad m => Bool -> Text -> Doc Text -> LW m (Doc Text) +hypertarget _ "" x = return x +hypertarget addnewline ident x = do + ref <- literal `fmap` toLabel ident + return $ text "\\hypertarget" + <> braces ref + <> braces ((if addnewline && not (isEmpty x) + then "%" <> cr + else empty) <> x) + +labelFor :: PandocMonad m => Text -> LW m (Doc Text) +labelFor "" = return empty +labelFor ident = do + ref <- literal `fmap` toLabel ident + return $ text "\\label" <> braces ref + +-- Determine listings language from list of class attributes. +getListingsLanguage :: [Text] -> Maybe Text +getListingsLanguage xs + = foldr ((<|>) . toListingsLanguage) Nothing xs + +mbBraced :: Text -> Text +mbBraced x = if not (T.all isAlphaNum x) + then "{" <> x <> "}" + else x + + 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 @@ -14,7 +14,7 @@ Conversion of 'Pandoc' documents to markdown-formatted plain text. -Markdown: +Markdown: -} module Text.Pandoc.Writers.Markdown ( writeMarkdown, @@ -22,15 +22,13 @@ writePlain) where import Control.Monad.Reader import Control.Monad.State.Strict -import Data.Char (isAlphaNum) import Data.Default -import Data.List (find, intersperse, sortOn, transpose) +import Data.List (intersperse, sortOn, transpose) import qualified Data.Map as M import Data.Maybe (fromMaybe, mapMaybe) import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as T -import Network.HTTP (urlEncode) import Text.HTML.TagSoup (Tag (..), isTagText, parseTags) import Text.Pandoc.Class.PandocMonad (PandocMonad, report) import Text.Pandoc.Definition @@ -44,59 +42,11 @@ import Text.DocTemplates (Val(..), Context(..), FromContext(..)) import Text.Pandoc.Walk import Text.Pandoc.Writers.HTML (writeHtml5String) -import Text.Pandoc.Writers.Math (texMathToInlines) -import Text.Pandoc.XML (toHtml5Entities) -import Data.Coerce (coerce) - -type Notes = [[Block]] -type Ref = (Text, Target, Attr) -type Refs = [Ref] - -type MD m = ReaderT WriterEnv (StateT WriterState m) - -evalMD :: PandocMonad m => MD m a -> WriterEnv -> WriterState -> m a -evalMD md env st = evalStateT (runReaderT md env) st - -data WriterEnv = WriterEnv { envInList :: Bool - , envVariant :: MarkdownVariant - , envRefShortcutable :: Bool - , envBlockLevel :: Int - , envEscapeSpaces :: Bool - } - -data MarkdownVariant = - PlainText - | Commonmark - | Markdown - deriving (Show, Eq) - -instance Default WriterEnv - where def = WriterEnv { envInList = False - , envVariant = Markdown - , envRefShortcutable = True - , envBlockLevel = 0 - , envEscapeSpaces = False - } - -data WriterState = WriterState { stNotes :: Notes - , stPrevRefs :: Refs - , stRefs :: Refs - , stKeys :: M.Map Key - (M.Map (Target, Attr) Int) - , stLastIdx :: Int - , stIds :: Set.Set Text - , stNoteNum :: Int - } - -instance Default WriterState - where def = WriterState{ stNotes = [] - , stPrevRefs = [] - , stRefs = [] - , stKeys = M.empty - , stLastIdx = 0 - , stIds = Set.empty - , stNoteNum = 1 - } +import Text.Pandoc.Writers.Markdown.Inline (inlineListToMarkdown) +import Text.Pandoc.Writers.Markdown.Types (MarkdownVariant(..), + WriterState(..), + WriterEnv(..), + Ref, Refs, MD, evalMD) -- | Convert Pandoc to Markdown. writeMarkdown :: PandocMonad m => WriterOptions -> Pandoc -> m Text @@ -297,49 +247,6 @@ then hang (writerTabStop opts) (marker <> spacer) contents else marker <> spacer <> contents --- | Escape special characters for Markdown. -escapeText :: WriterOptions -> Text -> Text -escapeText opts = T.pack . go . T.unpack - where - go [] = [] - go (c:cs) = - case c of - '<' | isEnabled Ext_all_symbols_escapable opts -> - '\\' : '<' : go cs - | otherwise -> "<" ++ go cs - '>' | isEnabled Ext_all_symbols_escapable opts -> - '\\' : '>' : go cs - | otherwise -> ">" ++ go cs - '@' | isEnabled Ext_citations opts -> - case cs of - (d:_) - | isAlphaNum d || d == '_' - -> '\\':'@':go cs - _ -> '@':go cs - _ | c `elem` ['\\','`','*','_','[',']','#'] -> - '\\':c: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_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 - attrsToMarkdown :: Attr -> Doc Text attrsToMarkdown attribs = braces $ hsep [attribId, attribClasses, attribKeys] where attribId = case attribs of @@ -912,495 +819,7 @@ | otherwise = RawBlock "markdown" " \n" mconcat <$> mapM (blockToMarkdown opts) (fixBlocks blocks) -getKey :: Doc Text -> Key -getKey = toKey . render Nothing - -findUsableIndex :: [Text] -> Int -> Int -findUsableIndex lbls i = if tshow i `elem` lbls - then findUsableIndex lbls (i + 1) - else i - -getNextIndex :: PandocMonad m => MD m Int -getNextIndex = do - prevRefs <- gets stPrevRefs - refs <- gets stRefs - i <- (+ 1) <$> gets stLastIdx - modify $ \s -> s{ stLastIdx = i } - let refLbls = map (\(r,_,_) -> r) $ prevRefs ++ refs - return $ findUsableIndex refLbls i - --- | Get reference for target; if none exists, create unique one and return. --- Prefer label if possible; otherwise, generate a unique key. -getReference :: PandocMonad m => Attr -> Doc Text -> Target -> MD m Text -getReference attr label target = do - refs <- gets stRefs - case find (\(_,t,a) -> t == target && a == attr) refs of - Just (ref, _, _) -> return ref - Nothing -> do - keys <- gets stKeys - let key = getKey label - let rawkey = coerce key - case M.lookup key keys of - Nothing -> do -- no other refs with this label - (lab', idx) <- if T.null rawkey || - T.length rawkey > 999 || - T.any (\c -> c == '[' || c == ']') rawkey - then do - i <- getNextIndex - return (tshow i, i) - else - return (render Nothing label, 0) - modify (\s -> s{ - stRefs = (lab', target, attr) : refs, - stKeys = M.insert (getKey label) - (M.insert (target, attr) idx mempty) - (stKeys s) }) - return lab' - - Just km -> -- we have refs with this label - case M.lookup (target, attr) km of - Just i -> do - let lab' = render Nothing $ - label <> if i == 0 - then mempty - else literal (tshow i) - -- make sure it's in stRefs; it may be - -- a duplicate that was printed in a previous - -- block: - when ((lab', target, attr) `notElem` refs) $ - modify (\s -> s{ - stRefs = (lab', target, attr) : refs }) - return lab' - Nothing -> do -- but this one is to a new target - i <- getNextIndex - let lab' = tshow i - modify (\s -> s{ - stRefs = (lab', target, attr) : refs, - stKeys = M.insert key - (M.insert (target, attr) i km) - (stKeys s) }) - return lab' - --- | Convert list of Pandoc inline elements to markdown. -inlineListToMarkdown :: PandocMonad m => WriterOptions -> [Inline] -> MD m (Doc Text) -inlineListToMarkdown opts lst = do - inlist <- asks envInList - go (if inlist then avoidBadWrapsInList lst else lst) - where go [] = return empty - go (i:is) = case i of - Link {} -> case is of - -- If a link is followed by another link, or '[', '(' or ':' - -- then we don't shortcut - Link {}:_ -> unshortcutable - Space:Link {}:_ -> unshortcutable - Space:(Str(thead -> Just '[')):_ -> unshortcutable - Space:(RawInline _ (thead -> Just '[')):_ -> unshortcutable - Space:(Cite _ _):_ -> unshortcutable - SoftBreak:Link {}:_ -> unshortcutable - SoftBreak:(Str(thead -> Just '[')):_ -> unshortcutable - SoftBreak:(RawInline _ (thead -> Just '[')):_ -> unshortcutable - SoftBreak:(Cite _ _):_ -> unshortcutable - LineBreak:Link {}:_ -> unshortcutable - LineBreak:(Str(thead -> Just '[')):_ -> unshortcutable - LineBreak:(RawInline _ (thead -> Just '[')):_ -> unshortcutable - LineBreak:(Cite _ _):_ -> unshortcutable - (Cite _ _):_ -> unshortcutable - Str (thead -> Just '['):_ -> unshortcutable - Str (thead -> Just '('):_ -> unshortcutable - Str (thead -> Just ':'):_ -> unshortcutable - (RawInline _ (thead -> Just '[')):_ -> unshortcutable - (RawInline _ (thead -> Just '(')):_ -> unshortcutable - (RawInline _ (thead -> Just ':')):_ -> unshortcutable - (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 - -isSp :: Inline -> Bool -isSp Space = True -isSp SoftBreak = True -isSp _ = False - -avoidBadWrapsInList :: [Inline] -> [Inline] -avoidBadWrapsInList [] = [] -avoidBadWrapsInList (s:Str (T.uncons -> Just ('>',cs)):xs) | isSp s = - Str (" >" <> cs) : avoidBadWrapsInList xs -avoidBadWrapsInList [s, Str (T.uncons -> Just (c, cs))] - | T.null cs && isSp s && c `elem` ['-','*','+'] = [Str $ T.pack [' ', c]] -avoidBadWrapsInList (s:Str (T.uncons -> Just (c, cs)):Space:xs) - | T.null cs && isSp s && c `elem` ['-','*','+'] = - Str (T.pack [' ', c]) : Space : avoidBadWrapsInList xs -avoidBadWrapsInList (s:Str cs:Space:xs) - | isSp s && isOrderedListMarker cs = - Str (" " <> cs) : Space : avoidBadWrapsInList xs -avoidBadWrapsInList [s, Str cs] - | isSp s && isOrderedListMarker cs = [Str $ " " <> cs] -avoidBadWrapsInList (x:xs) = x : avoidBadWrapsInList xs - -isOrderedListMarker :: Text -> Bool -isOrderedListMarker xs = not (T.null xs) && (T.last xs `elem` ['.',')']) && - isRight (runParser (anyOrderedListMarker >> eof) - defaultParserState "" xs) - -isRight :: Either a b -> Bool -isRight (Right _) = True -isRight (Left _) = False - --- | Convert Pandoc inline element to markdown. -inlineToMarkdown :: PandocMonad m => WriterOptions -> Inline -> MD m (Doc Text) -inlineToMarkdown opts (Span ("",["emoji"],kvs) [Str s]) = - case lookup "data-emoji" kvs of - Just emojiname | isEnabled Ext_emoji opts -> - return $ ":" <> literal emojiname <> ":" - _ -> inlineToMarkdown opts (Str s) -inlineToMarkdown opts (Span attrs ils) = do - variant <- asks envVariant - contents <- inlineListToMarkdown opts ils - return $ case attrs of - (_,["csl-block"],_) -> (cr <>) - (_,["csl-left-margin"],_) -> (cr <>) - (_,["csl-indent"],_) -> (cr <>) - _ -> id - $ case variant of - PlainText -> contents - _ | attrs == nullAttr -> contents - | isEnabled Ext_bracketed_spans opts -> - let attrs' = if attrs /= nullAttr - then attrsToMarkdown attrs - else empty - in "[" <> contents <> "]" <> attrs' - | isEnabled Ext_raw_html opts || - isEnabled Ext_native_spans opts -> - tagWithAttrs "span" attrs <> contents <> literal "" - | otherwise -> contents -inlineToMarkdown _ (Emph []) = return empty -inlineToMarkdown opts (Emph lst) = do - variant <- asks envVariant - contents <- inlineListToMarkdown opts lst - return $ case variant of - PlainText - | isEnabled Ext_gutenberg opts -> "_" <> contents <> "_" - | otherwise -> contents - _ -> "*" <> contents <> "*" -inlineToMarkdown _ (Underline []) = return empty -inlineToMarkdown opts (Underline lst) = do - variant <- asks envVariant - contents <- inlineListToMarkdown opts lst - case variant of - PlainText -> return contents - _ | isEnabled Ext_bracketed_spans opts -> - return $ "[" <> contents <> "]" <> "{.ul}" - | isEnabled Ext_native_spans opts -> - return $ tagWithAttrs "span" ("", ["underline"], []) - <> contents - <> literal "" - | isEnabled Ext_raw_html opts -> - return $ "" <> contents <> "" - | otherwise -> inlineToMarkdown opts (Emph lst) -inlineToMarkdown _ (Strong []) = return empty -inlineToMarkdown opts (Strong lst) = do - variant <- asks envVariant - case variant of - PlainText -> - inlineListToMarkdown opts $ - if isEnabled Ext_gutenberg opts - then capitalize lst - else lst - _ -> do - contents <- inlineListToMarkdown opts lst - return $ "**" <> contents <> "**" -inlineToMarkdown _ (Strikeout []) = return empty -inlineToMarkdown opts (Strikeout lst) = do - contents <- inlineListToMarkdown opts lst - return $ if isEnabled Ext_strikeout opts - then "~~" <> contents <> "~~" - else if isEnabled Ext_raw_html opts - then "" <> contents <> "" - else contents -inlineToMarkdown _ (Superscript []) = return empty -inlineToMarkdown opts (Superscript lst) = - local (\env -> env {envEscapeSpaces = envVariant env == Markdown}) $ do - contents <- inlineListToMarkdown opts lst - if isEnabled Ext_superscript opts - then return $ "^" <> contents <> "^" - else if isEnabled Ext_raw_html opts - then return $ "" <> contents <> "" - else - case traverse toSuperscriptInline lst of - Just xs' | not (writerPreferAscii opts) - -> inlineListToMarkdown opts xs' - _ -> do - let rendered = render Nothing contents - return $ - case mapM toSuperscript (T.unpack rendered) of - Just r -> literal $ T.pack r - Nothing -> literal $ "^(" <> rendered <> ")" -inlineToMarkdown _ (Subscript []) = return empty -inlineToMarkdown opts (Subscript lst) = - local (\env -> env {envEscapeSpaces = envVariant env == Markdown}) $ do - contents <- inlineListToMarkdown opts lst - if isEnabled Ext_subscript opts - then return $ "~" <> contents <> "~" - else if isEnabled Ext_raw_html opts - then return $ "" <> contents <> "" - else - case traverse toSubscriptInline lst of - Just xs' | not (writerPreferAscii opts) - -> inlineListToMarkdown opts xs' - _ -> do - let rendered = render Nothing contents - return $ - case mapM toSuperscript (T.unpack rendered) of - Just r -> literal $ T.pack r - Nothing -> literal $ "_(" <> rendered <> ")" -inlineToMarkdown opts (SmallCaps lst) = do - variant <- asks envVariant - if variant /= PlainText && - (isEnabled Ext_raw_html opts || isEnabled Ext_native_spans opts) - then inlineToMarkdown opts (Span ("",["smallcaps"],[]) lst) - else inlineListToMarkdown opts $ capitalize lst -inlineToMarkdown opts (Quoted SingleQuote lst) = do - contents <- inlineListToMarkdown opts lst - return $ if isEnabled Ext_smart opts - then "'" <> contents <> "'" - else - if writerPreferAscii opts - then "‘" <> contents <> "’" - else "‘" <> contents <> "’" -inlineToMarkdown opts (Quoted DoubleQuote lst) = do - contents <- inlineListToMarkdown opts lst - return $ if isEnabled Ext_smart opts - then "\"" <> contents <> "\"" - else - if writerPreferAscii opts - then "“" <> contents <> "”" - else "“" <> contents <> "”" -inlineToMarkdown opts (Code attr str) = do - let tickGroups = filter (T.any (== '`')) $ T.group str - let longest = if null tickGroups - then 0 - else maximum $ map T.length tickGroups - let marker = T.replicate (longest + 1) "`" - let spacer = if longest == 0 then "" else " " - let attrs = if isEnabled Ext_inline_code_attributes opts && attr /= nullAttr - then attrsToMarkdown attr - else empty - variant <- asks envVariant - case variant of - PlainText -> return $ literal str - _ -> return $ literal - (marker <> spacer <> str <> spacer <> marker) <> attrs -inlineToMarkdown opts (Str str) = do - variant <- asks envVariant - let str' = (if writerPreferAscii opts - then toHtml5Entities - else id) . - (if isEnabled Ext_smart opts - then unsmartify opts - else id) . - (if variant == PlainText - then id - else escapeText opts) $ str - return $ literal str' -inlineToMarkdown opts (Math InlineMath str) = - case writerHTMLMathMethod opts of - WebTeX url -> inlineToMarkdown opts - (Image nullAttr [Str str] (url <> T.pack (urlEncode $ T.unpack str), str)) - _ | isEnabled Ext_tex_math_dollars opts -> - return $ "$" <> literal str <> "$" - | isEnabled Ext_tex_math_single_backslash opts -> - return $ "\\(" <> literal str <> "\\)" - | isEnabled Ext_tex_math_double_backslash opts -> - return $ "\\\\(" <> literal str <> "\\\\)" - | otherwise -> do - variant <- asks envVariant - texMathToInlines InlineMath str >>= - inlineListToMarkdown opts . - (if variant == PlainText then makeMathPlainer else id) -inlineToMarkdown opts (Math DisplayMath str) = - case writerHTMLMathMethod opts of - WebTeX url -> (\x -> blankline <> x <> blankline) `fmap` - inlineToMarkdown opts (Image nullAttr [Str str] - (url <> T.pack (urlEncode $ T.unpack str), str)) - _ | isEnabled Ext_tex_math_dollars opts -> - return $ "$$" <> literal str <> "$$" - | isEnabled Ext_tex_math_single_backslash opts -> - return $ "\\[" <> literal str <> "\\]" - | isEnabled Ext_tex_math_double_backslash opts -> - return $ "\\\\[" <> literal str <> "\\\\]" - | otherwise -> (\x -> cr <> x <> cr) `fmap` - (texMathToInlines DisplayMath str >>= inlineListToMarkdown opts) -inlineToMarkdown opts il@(RawInline f str) = do - let tickGroups = filter (T.any (== '`')) $ T.group str - let numticks = if null tickGroups - then 1 - else 1 + maximum (map T.length tickGroups) - variant <- asks envVariant - let Format fmt = f - let rawAttribInline = return $ - literal (T.replicate numticks "`") <> literal str <> - literal (T.replicate numticks "`") <> literal "{=" <> literal fmt <> literal "}" - let renderEmpty = mempty <$ report (InlineNotRendered il) - case variant of - PlainText -> renderEmpty - Commonmark - | f `elem` ["gfm", "commonmark", "commonmark_x", "markdown"] - -> return $ literal str - Markdown - | f `elem` ["markdown", "markdown_github", "markdown_phpextra", - "markdown_mmd", "markdown_strict"] - -> return $ literal str - _ | isEnabled Ext_raw_attribute opts -> rawAttribInline - | f `elem` ["html", "html5", "html4"] - , isEnabled Ext_raw_html opts - -> return $ literal str - | f `elem` ["latex", "tex"] - , isEnabled Ext_raw_tex opts - -> return $ literal str - _ -> renderEmpty - - -inlineToMarkdown opts LineBreak = do - variant <- asks envVariant - if variant == PlainText || isEnabled Ext_hard_line_breaks opts - then return cr - else return $ - if isEnabled Ext_escaped_line_breaks opts - then "\\" <> cr - else " " <> cr -inlineToMarkdown _ Space = do - escapeSpaces <- asks envEscapeSpaces - return $ if escapeSpaces then "\\ " else space -inlineToMarkdown opts SoftBreak = do - escapeSpaces <- asks envEscapeSpaces - let space' = if escapeSpaces then "\\ " else space - return $ case writerWrapText opts of - WrapNone -> space' - WrapAuto -> space' - WrapPreserve -> cr -inlineToMarkdown opts (Cite [] lst) = inlineListToMarkdown opts lst -inlineToMarkdown opts (Cite (c:cs) lst) - | not (isEnabled Ext_citations opts) = inlineListToMarkdown opts lst - | otherwise = - if citationMode c == AuthorInText - then do - suffs <- inlineListToMarkdown opts $ citationSuffix c - rest <- mapM convertOne cs - let inbr = suffs <+> joincits rest - br = if isEmpty inbr then empty else char '[' <> inbr <> char ']' - return $ literal ("@" <> citationId c) <+> br - else do - cits <- mapM convertOne (c:cs) - return $ literal "[" <> joincits cits <> literal "]" - where - joincits = hcat . intersperse (literal "; ") . filter (not . isEmpty) - convertOne Citation { citationId = k - , citationPrefix = pinlines - , citationSuffix = sinlines - , citationMode = m } - = do - pdoc <- inlineListToMarkdown opts pinlines - sdoc <- inlineListToMarkdown opts sinlines - let k' = literal (modekey m <> "@" <> k) - r = case sinlines of - Str (T.uncons -> Just (y,_)):_ | y `elem` (",;]@" :: String) -> k' <> sdoc - _ -> k' <+> sdoc - return $ pdoc <+> r - modekey SuppressAuthor = "-" - modekey _ = "" -inlineToMarkdown opts lnk@(Link attr txt (src, tit)) = do - variant <- asks envVariant - linktext <- inlineListToMarkdown opts txt - let linktitle = if T.null tit - then empty - else literal $ " \"" <> tit <> "\"" - let srcSuffix = fromMaybe src (T.stripPrefix "mailto:" src) - let useAuto = isURI src && - case txt of - [Str s] | escapeURI s == srcSuffix -> True - _ -> False - let useRefLinks = writerReferenceLinks opts && not useAuto - shortcutable <- asks envRefShortcutable - let useShortcutRefLinks = shortcutable && - isEnabled Ext_shortcut_reference_links opts - reftext <- if useRefLinks - then literal <$> getReference attr linktext (src, tit) - else return mempty - case variant of - PlainText - | useAuto -> return $ literal srcSuffix - | otherwise -> return linktext - _ | useAuto -> return $ "<" <> literal srcSuffix <> ">" - | useRefLinks -> - let first = "[" <> linktext <> "]" - second = if getKey linktext == getKey reftext - then if useShortcutRefLinks - then "" - else "[]" - else "[" <> reftext <> "]" - in return $ first <> second - | isEnabled Ext_raw_html opts - , not (isEnabled Ext_link_attributes opts) - , attr /= nullAttr -> -- use raw HTML to render attributes - literal . T.strip <$> - writeHtml5String opts{ writerTemplate = Nothing } - (Pandoc nullMeta [Plain [lnk]]) - | otherwise -> return $ - "[" <> linktext <> "](" <> literal src <> linktitle <> ")" <> - linkAttributes opts attr -inlineToMarkdown opts img@(Image attr alternate (source, tit)) - | isEnabled Ext_raw_html opts && - not (isEnabled Ext_link_attributes opts) && - attr /= nullAttr = -- use raw HTML - literal . T.strip <$> - writeHtml5String opts{ writerTemplate = Nothing } (Pandoc nullMeta [Plain [img]]) - | otherwise = do - variant <- asks envVariant - let txt = if null alternate || alternate == [Str source] - -- to prevent autolinks - then [Str ""] - else alternate - linkPart <- inlineToMarkdown opts (Link attr txt (source, tit)) - return $ case variant of - PlainText -> "[" <> linkPart <> "]" - _ -> "!" <> linkPart -inlineToMarkdown opts (Note contents) = do - modify (\st -> st{ stNotes = contents : stNotes st }) - st <- get - let ref = literal $ writerIdentifierPrefix opts <> tshow (stNoteNum st + length (stNotes st) - 1) - if isEnabled Ext_footnotes opts - then return $ "[^" <> ref <> "]" - else return $ "[" <> ref <> "]" - -makeMathPlainer :: [Inline] -> [Inline] -makeMathPlainer = walk go - where - go (Emph xs) = Span nullAttr xs - go x = x - lineBreakToSpace :: Inline -> Inline lineBreakToSpace LineBreak = Space lineBreakToSpace SoftBreak = Space lineBreakToSpace x = x - -toSubscriptInline :: Inline -> Maybe Inline -toSubscriptInline Space = Just Space -toSubscriptInline (Span attr ils) = Span attr <$> traverse toSubscriptInline ils -toSubscriptInline (Str s) = Str . T.pack <$> traverse toSubscript (T.unpack s) -toSubscriptInline LineBreak = Just LineBreak -toSubscriptInline SoftBreak = Just SoftBreak -toSubscriptInline _ = Nothing - -toSuperscriptInline :: Inline -> Maybe Inline -toSuperscriptInline Space = Just Space -toSuperscriptInline (Span attr ils) = Span attr <$> traverse toSuperscriptInline ils -toSuperscriptInline (Str s) = Str . T.pack <$> traverse toSuperscript (T.unpack s) -toSuperscriptInline LineBreak = Just LineBreak -toSuperscriptInline SoftBreak = Just SoftBreak -toSuperscriptInline _ = Nothing diff --git a/src/Text/Pandoc/Writers/Markdown/Inline.hs b/src/Text/Pandoc/Writers/Markdown/Inline.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/Writers/Markdown/Inline.hs @@ -0,0 +1,601 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} +{- | + Module : Text.Pandoc.Writers.Markdown.Inline + Copyright : Copyright (C) 2006-2021 John MacFarlane + License : GNU GPL, version 2 or above + + Maintainer : John MacFarlane + Stability : alpha + Portability : portable +-} +module Text.Pandoc.Writers.Markdown.Inline ( + inlineListToMarkdown + ) where +import Control.Monad.Reader +import Control.Monad.State.Strict +import Data.Char (isAlphaNum, isDigit) +import Data.List (find, intersperse) +import qualified Data.Map as M +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import Network.HTTP (urlEncode) +import Text.Pandoc.Class.PandocMonad (PandocMonad, report) +import Text.Pandoc.Definition +import Text.Pandoc.Logging +import Text.Pandoc.Options +import Text.Pandoc.Parsing hiding (blankline, blanklines, char, space) +import Text.DocLayout +import Text.Pandoc.Shared +import Text.Pandoc.Writers.Shared +import Text.Pandoc.Walk +import Text.Pandoc.Writers.HTML (writeHtml5String) +import Text.Pandoc.Writers.Math (texMathToInlines) +import Text.Pandoc.XML (toHtml5Entities) +import Data.Coerce (coerce) +import Text.Pandoc.Writers.Markdown.Types (MarkdownVariant(..), + WriterState(..), + WriterEnv(..), MD) + +-- | Escape special characters for Markdown. +escapeText :: WriterOptions -> Text -> Text +escapeText opts = T.pack . go . T.unpack + where + go [] = [] + go (c:cs) = + case c of + '<' | isEnabled Ext_all_symbols_escapable opts -> + '\\' : '<' : go cs + | otherwise -> "<" ++ go cs + '>' | isEnabled Ext_all_symbols_escapable opts -> + '\\' : '>' : go cs + | otherwise -> ">" ++ go cs + '@' | isEnabled Ext_citations opts -> + case cs of + (d:_) + | isAlphaNum d || d == '_' + -> '\\':'@':go cs + _ -> '@':go cs + _ | c `elem` ['\\','`','*','_','[',']','#'] -> + '\\':c: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_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 + +attrsToMarkdown :: Attr -> Doc Text +attrsToMarkdown attribs = braces $ hsep [attribId, attribClasses, attribKeys] + where attribId = case attribs of + ("",_,_) -> empty + (i,_,_) -> "#" <> escAttr i + attribClasses = case attribs of + (_,[],_) -> empty + (_,cs,_) -> hsep $ + map (escAttr . ("."<>)) + cs + attribKeys = case attribs of + (_,_,[]) -> empty + (_,_,ks) -> hsep $ + map (\(k,v) -> escAttr k + <> "=\"" <> + escAttr v <> "\"") ks + escAttr = mconcat . map escAttrChar . T.unpack + escAttrChar '"' = literal "\\\"" + escAttrChar '\\' = literal "\\\\" + escAttrChar c = literal $ T.singleton c + +linkAttributes :: WriterOptions -> Attr -> Doc Text +linkAttributes opts attr = + if isEnabled Ext_link_attributes opts && attr /= nullAttr + then attrsToMarkdown attr + else empty + +getKey :: Doc Text -> Key +getKey = toKey . render Nothing + +findUsableIndex :: [Text] -> Int -> Int +findUsableIndex lbls i = if tshow i `elem` lbls + then findUsableIndex lbls (i + 1) + else i + +getNextIndex :: PandocMonad m => MD m Int +getNextIndex = do + prevRefs <- gets stPrevRefs + refs <- gets stRefs + i <- (+ 1) <$> gets stLastIdx + modify $ \s -> s{ stLastIdx = i } + let refLbls = map (\(r,_,_) -> r) $ prevRefs ++ refs + return $ findUsableIndex refLbls i + +-- | Get reference for target; if none exists, create unique one and return. +-- Prefer label if possible; otherwise, generate a unique key. +getReference :: PandocMonad m => Attr -> Doc Text -> Target -> MD m Text +getReference attr label target = do + refs <- gets stRefs + case find (\(_,t,a) -> t == target && a == attr) refs of + Just (ref, _, _) -> return ref + Nothing -> do + keys <- gets stKeys + let key = getKey label + let rawkey = coerce key + case M.lookup key keys of + Nothing -> do -- no other refs with this label + (lab', idx) <- if T.null rawkey || + T.length rawkey > 999 || + T.any (\c -> c == '[' || c == ']') rawkey + then do + i <- getNextIndex + return (tshow i, i) + else + return (render Nothing label, 0) + modify (\s -> s{ + stRefs = (lab', target, attr) : refs, + stKeys = M.insert (getKey label) + (M.insert (target, attr) idx mempty) + (stKeys s) }) + return lab' + + Just km -> -- we have refs with this label + case M.lookup (target, attr) km of + Just i -> do + let lab' = render Nothing $ + label <> if i == 0 + then mempty + else literal (tshow i) + -- make sure it's in stRefs; it may be + -- a duplicate that was printed in a previous + -- block: + when ((lab', target, attr) `notElem` refs) $ + modify (\s -> s{ + stRefs = (lab', target, attr) : refs }) + return lab' + Nothing -> do -- but this one is to a new target + i <- getNextIndex + let lab' = tshow i + modify (\s -> s{ + stRefs = (lab', target, attr) : refs, + stKeys = M.insert key + (M.insert (target, attr) i km) + (stKeys s) }) + return lab' + +-- | Convert list of Pandoc inline elements to markdown. +inlineListToMarkdown :: PandocMonad m => WriterOptions -> [Inline] -> MD m (Doc Text) +inlineListToMarkdown opts lst = do + inlist <- asks envInList + go (if inlist then avoidBadWrapsInList lst else lst) + where go [] = return empty + go (x@Math{}:y@(Str t):zs) + | T.all isDigit (T.take 1 t) -- starts with digit -- see #7058 + = liftM2 (<>) (inlineToMarkdown opts x) + (go (RawInline (Format "html") "" : y : zs)) + go (i:is) = case i of + Link {} -> case is of + -- If a link is followed by another link, or '[', '(' or ':' + -- then we don't shortcut + Link {}:_ -> unshortcutable + Space:Link {}:_ -> unshortcutable + Space:(Str(thead -> Just '[')):_ -> unshortcutable + Space:(RawInline _ (thead -> Just '[')):_ -> unshortcutable + Space:(Cite _ _):_ -> unshortcutable + SoftBreak:Link {}:_ -> unshortcutable + SoftBreak:(Str(thead -> Just '[')):_ -> unshortcutable + SoftBreak:(RawInline _ (thead -> Just '[')):_ -> unshortcutable + SoftBreak:(Cite _ _):_ -> unshortcutable + LineBreak:Link {}:_ -> unshortcutable + LineBreak:(Str(thead -> Just '[')):_ -> unshortcutable + LineBreak:(RawInline _ (thead -> Just '[')):_ -> unshortcutable + LineBreak:(Cite _ _):_ -> unshortcutable + (Cite _ _):_ -> unshortcutable + Str (thead -> Just '['):_ -> unshortcutable + Str (thead -> Just '('):_ -> unshortcutable + Str (thead -> Just ':'):_ -> unshortcutable + (RawInline _ (thead -> Just '[')):_ -> unshortcutable + (RawInline _ (thead -> Just '(')):_ -> unshortcutable + (RawInline _ (thead -> Just ':')):_ -> unshortcutable + (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 + +isSp :: Inline -> Bool +isSp Space = True +isSp SoftBreak = True +isSp _ = False + +avoidBadWrapsInList :: [Inline] -> [Inline] +avoidBadWrapsInList [] = [] +avoidBadWrapsInList (s:Str (T.uncons -> Just ('>',cs)):xs) | isSp s = + Str (" >" <> cs) : avoidBadWrapsInList xs +avoidBadWrapsInList [s, Str (T.uncons -> Just (c, cs))] + | T.null cs && isSp s && c `elem` ['-','*','+'] = [Str $ T.pack [' ', c]] +avoidBadWrapsInList (s:Str (T.uncons -> Just (c, cs)):Space:xs) + | T.null cs && isSp s && c `elem` ['-','*','+'] = + Str (T.pack [' ', c]) : Space : avoidBadWrapsInList xs +avoidBadWrapsInList (s:Str cs:Space:xs) + | isSp s && isOrderedListMarker cs = + Str (" " <> cs) : Space : avoidBadWrapsInList xs +avoidBadWrapsInList [s, Str cs] + | isSp s && isOrderedListMarker cs = [Str $ " " <> cs] +avoidBadWrapsInList (x:xs) = x : avoidBadWrapsInList xs + +isOrderedListMarker :: Text -> Bool +isOrderedListMarker xs = not (T.null xs) && (T.last xs `elem` ['.',')']) && + isRight (runParser (anyOrderedListMarker >> eof) + defaultParserState "" xs) + where + isRight (Right _) = True + isRight (Left _) = False + +-- | Convert Pandoc inline element to markdown. +inlineToMarkdown :: PandocMonad m => WriterOptions -> Inline -> MD m (Doc Text) +inlineToMarkdown opts (Span ("",["emoji"],kvs) [Str s]) = + case lookup "data-emoji" kvs of + Just emojiname | isEnabled Ext_emoji opts -> + return $ ":" <> literal emojiname <> ":" + _ -> inlineToMarkdown opts (Str s) +inlineToMarkdown opts (Span attrs ils) = do + variant <- asks envVariant + contents <- inlineListToMarkdown opts ils + return $ case attrs of + (_,["csl-block"],_) -> (cr <>) + (_,["csl-left-margin"],_) -> (cr <>) + (_,["csl-indent"],_) -> (cr <>) + _ -> id + $ case variant of + PlainText -> contents + _ | attrs == nullAttr -> contents + | isEnabled Ext_bracketed_spans opts -> + let attrs' = if attrs /= nullAttr + then attrsToMarkdown attrs + else empty + in "[" <> contents <> "]" <> attrs' + | isEnabled Ext_raw_html opts || + isEnabled Ext_native_spans opts -> + tagWithAttrs "span" attrs <> contents <> literal "" + | otherwise -> contents +inlineToMarkdown _ (Emph []) = return empty +inlineToMarkdown opts (Emph lst) = do + variant <- asks envVariant + contents <- inlineListToMarkdown opts lst + return $ case variant of + PlainText + | isEnabled Ext_gutenberg opts -> "_" <> contents <> "_" + | otherwise -> contents + _ -> "*" <> contents <> "*" +inlineToMarkdown _ (Underline []) = return empty +inlineToMarkdown opts (Underline lst) = do + variant <- asks envVariant + contents <- inlineListToMarkdown opts lst + case variant of + PlainText -> return contents + _ | isEnabled Ext_bracketed_spans opts -> + return $ "[" <> contents <> "]" <> "{.ul}" + | isEnabled Ext_native_spans opts -> + return $ tagWithAttrs "span" ("", ["underline"], []) + <> contents + <> literal "" + | isEnabled Ext_raw_html opts -> + return $ "" <> contents <> "" + | otherwise -> inlineToMarkdown opts (Emph lst) +inlineToMarkdown _ (Strong []) = return empty +inlineToMarkdown opts (Strong lst) = do + variant <- asks envVariant + case variant of + PlainText -> + inlineListToMarkdown opts $ + if isEnabled Ext_gutenberg opts + then capitalize lst + else lst + _ -> do + contents <- inlineListToMarkdown opts lst + return $ "**" <> contents <> "**" +inlineToMarkdown _ (Strikeout []) = return empty +inlineToMarkdown opts (Strikeout lst) = do + contents <- inlineListToMarkdown opts lst + return $ if isEnabled Ext_strikeout opts + then "~~" <> contents <> "~~" + else if isEnabled Ext_raw_html opts + then "" <> contents <> "" + else contents +inlineToMarkdown _ (Superscript []) = return empty +inlineToMarkdown opts (Superscript lst) = + local (\env -> env {envEscapeSpaces = envVariant env == Markdown}) $ do + contents <- inlineListToMarkdown opts lst + if isEnabled Ext_superscript opts + then return $ "^" <> contents <> "^" + else if isEnabled Ext_raw_html opts + then return $ "" <> contents <> "" + else + case traverse toSuperscriptInline lst of + Just xs' | not (writerPreferAscii opts) + -> inlineListToMarkdown opts xs' + _ -> do + let rendered = render Nothing contents + return $ + case mapM toSuperscript (T.unpack rendered) of + Just r -> literal $ T.pack r + Nothing -> literal $ "^(" <> rendered <> ")" +inlineToMarkdown _ (Subscript []) = return empty +inlineToMarkdown opts (Subscript lst) = + local (\env -> env {envEscapeSpaces = envVariant env == Markdown}) $ do + contents <- inlineListToMarkdown opts lst + if isEnabled Ext_subscript opts + then return $ "~" <> contents <> "~" + else if isEnabled Ext_raw_html opts + then return $ "" <> contents <> "" + else + case traverse toSubscriptInline lst of + Just xs' | not (writerPreferAscii opts) + -> inlineListToMarkdown opts xs' + _ -> do + let rendered = render Nothing contents + return $ + case mapM toSuperscript (T.unpack rendered) of + Just r -> literal $ T.pack r + Nothing -> literal $ "_(" <> rendered <> ")" +inlineToMarkdown opts (SmallCaps lst) = do + variant <- asks envVariant + if variant /= PlainText && + (isEnabled Ext_raw_html opts || isEnabled Ext_native_spans opts) + then inlineToMarkdown opts (Span ("",["smallcaps"],[]) lst) + else inlineListToMarkdown opts $ capitalize lst +inlineToMarkdown opts (Quoted SingleQuote lst) = do + contents <- inlineListToMarkdown opts lst + return $ if isEnabled Ext_smart opts + then "'" <> contents <> "'" + else + if writerPreferAscii opts + then "‘" <> contents <> "’" + else "‘" <> contents <> "’" +inlineToMarkdown opts (Quoted DoubleQuote lst) = do + contents <- inlineListToMarkdown opts lst + return $ if isEnabled Ext_smart opts + then "\"" <> contents <> "\"" + else + if writerPreferAscii opts + then "“" <> contents <> "”" + else "“" <> contents <> "”" +inlineToMarkdown opts (Code attr str) = do + let tickGroups = filter (T.any (== '`')) $ T.group str + let longest = if null tickGroups + then 0 + else maximum $ map T.length tickGroups + let marker = T.replicate (longest + 1) "`" + let spacer = if longest == 0 then "" else " " + let attrs = if isEnabled Ext_inline_code_attributes opts && attr /= nullAttr + then attrsToMarkdown attr + else empty + variant <- asks envVariant + case variant of + PlainText -> return $ literal str + _ -> return $ literal + (marker <> spacer <> str <> spacer <> marker) <> attrs +inlineToMarkdown opts (Str str) = do + variant <- asks envVariant + let str' = (if writerPreferAscii opts + then toHtml5Entities + else id) . + (if isEnabled Ext_smart opts + then unsmartify opts + else id) . + (if variant == PlainText + then id + else escapeText opts) $ str + return $ literal str' +inlineToMarkdown opts (Math InlineMath str) = + case writerHTMLMathMethod opts of + WebTeX url -> inlineToMarkdown opts + (Image nullAttr [Str str] (url <> T.pack (urlEncode $ T.unpack str), str)) + _ | isEnabled Ext_tex_math_dollars opts -> + return $ "$" <> literal str <> "$" + | isEnabled Ext_tex_math_single_backslash opts -> + return $ "\\(" <> literal str <> "\\)" + | isEnabled Ext_tex_math_double_backslash opts -> + return $ "\\\\(" <> literal str <> "\\\\)" + | otherwise -> do + variant <- asks envVariant + texMathToInlines InlineMath str >>= + inlineListToMarkdown opts . + (if variant == PlainText then makeMathPlainer else id) +inlineToMarkdown opts (Math DisplayMath str) = + case writerHTMLMathMethod opts of + WebTeX url -> (\x -> blankline <> x <> blankline) `fmap` + inlineToMarkdown opts (Image nullAttr [Str str] + (url <> T.pack (urlEncode $ T.unpack str), str)) + _ | isEnabled Ext_tex_math_dollars opts -> + return $ "$$" <> literal str <> "$$" + | isEnabled Ext_tex_math_single_backslash opts -> + return $ "\\[" <> literal str <> "\\]" + | isEnabled Ext_tex_math_double_backslash opts -> + return $ "\\\\[" <> literal str <> "\\\\]" + | otherwise -> (\x -> cr <> x <> cr) `fmap` + (texMathToInlines DisplayMath str >>= inlineListToMarkdown opts) +inlineToMarkdown opts il@(RawInline f str) = do + let tickGroups = filter (T.any (== '`')) $ T.group str + let numticks = if null tickGroups + then 1 + else 1 + maximum (map T.length tickGroups) + variant <- asks envVariant + let Format fmt = f + let rawAttribInline = return $ + literal (T.replicate numticks "`") <> literal str <> + literal (T.replicate numticks "`") <> literal "{=" <> literal fmt <> literal "}" + let renderEmpty = mempty <$ report (InlineNotRendered il) + case variant of + PlainText -> renderEmpty + Commonmark + | f `elem` ["gfm", "commonmark", "commonmark_x", "markdown"] + -> return $ literal str + Markdown + | f `elem` ["markdown", "markdown_github", "markdown_phpextra", + "markdown_mmd", "markdown_strict"] + -> return $ literal str + _ | isEnabled Ext_raw_attribute opts -> rawAttribInline + | f `elem` ["html", "html5", "html4"] + , isEnabled Ext_raw_html opts + -> return $ literal str + | f `elem` ["latex", "tex"] + , isEnabled Ext_raw_tex opts + -> return $ literal str + _ -> renderEmpty + + +inlineToMarkdown opts LineBreak = do + variant <- asks envVariant + if variant == PlainText || isEnabled Ext_hard_line_breaks opts + then return cr + else return $ + if isEnabled Ext_escaped_line_breaks opts + then "\\" <> cr + else " " <> cr +inlineToMarkdown _ Space = do + escapeSpaces <- asks envEscapeSpaces + return $ if escapeSpaces then "\\ " else space +inlineToMarkdown opts SoftBreak = do + escapeSpaces <- asks envEscapeSpaces + let space' = if escapeSpaces then "\\ " else space + return $ case writerWrapText opts of + WrapNone -> space' + WrapAuto -> space' + WrapPreserve -> cr +inlineToMarkdown opts (Cite [] lst) = inlineListToMarkdown opts lst +inlineToMarkdown opts (Cite (c:cs) lst) + | not (isEnabled Ext_citations opts) = inlineListToMarkdown opts lst + | otherwise = + if citationMode c == AuthorInText + then do + suffs <- inlineListToMarkdown opts $ citationSuffix c + rest <- mapM convertOne cs + let inbr = suffs <+> joincits rest + br = if isEmpty inbr then empty else char '[' <> inbr <> char ']' + return $ literal ("@" <> citationId c) <+> br + else do + cits <- mapM convertOne (c:cs) + return $ literal "[" <> joincits cits <> literal "]" + where + joincits = hcat . intersperse (literal "; ") . filter (not . isEmpty) + convertOne Citation { citationId = k + , citationPrefix = pinlines + , citationSuffix = sinlines + , citationMode = m } + = do + pdoc <- inlineListToMarkdown opts pinlines + sdoc <- inlineListToMarkdown opts sinlines + let k' = literal (modekey m <> "@" <> k) + r = case sinlines of + Str (T.uncons -> Just (y,_)):_ | y `elem` (",;]@" :: String) -> k' <> sdoc + _ -> k' <+> sdoc + return $ pdoc <+> r + modekey SuppressAuthor = "-" + modekey _ = "" +inlineToMarkdown opts lnk@(Link attr txt (src, tit)) = do + variant <- asks envVariant + linktext <- inlineListToMarkdown opts txt + let linktitle = if T.null tit + then empty + else literal $ " \"" <> tit <> "\"" + let srcSuffix = fromMaybe src (T.stripPrefix "mailto:" src) + let useAuto = isURI src && + case txt of + [Str s] | escapeURI s == srcSuffix -> True + _ -> False + let useRefLinks = writerReferenceLinks opts && not useAuto + shortcutable <- asks envRefShortcutable + let useShortcutRefLinks = shortcutable && + isEnabled Ext_shortcut_reference_links opts + reftext <- if useRefLinks + then literal <$> getReference attr linktext (src, tit) + else return mempty + case variant of + PlainText + | useAuto -> return $ literal srcSuffix + | otherwise -> return linktext + _ | useAuto -> return $ "<" <> literal srcSuffix <> ">" + | useRefLinks -> + let first = "[" <> linktext <> "]" + second = if getKey linktext == getKey reftext + then if useShortcutRefLinks + then "" + else "[]" + else "[" <> reftext <> "]" + in return $ first <> second + | isEnabled Ext_raw_html opts + , not (isEnabled Ext_link_attributes opts) + , attr /= nullAttr -> -- use raw HTML to render attributes + literal . T.strip <$> + writeHtml5String opts{ writerTemplate = Nothing } + (Pandoc nullMeta [Plain [lnk]]) + | otherwise -> return $ + "[" <> linktext <> "](" <> literal src <> linktitle <> ")" <> + linkAttributes opts attr +inlineToMarkdown opts img@(Image attr alternate (source, tit)) + | isEnabled Ext_raw_html opts && + not (isEnabled Ext_link_attributes opts) && + attr /= nullAttr = -- use raw HTML + literal . T.strip <$> + writeHtml5String opts{ writerTemplate = Nothing } (Pandoc nullMeta [Plain [img]]) + | otherwise = do + variant <- asks envVariant + let txt = if null alternate || alternate == [Str source] + -- to prevent autolinks + then [Str ""] + else alternate + linkPart <- inlineToMarkdown opts (Link attr txt (source, tit)) + return $ case variant of + PlainText -> "[" <> linkPart <> "]" + _ -> "!" <> linkPart +inlineToMarkdown opts (Note contents) = do + modify (\st -> st{ stNotes = contents : stNotes st }) + st <- get + let ref = literal $ writerIdentifierPrefix opts <> tshow (stNoteNum st + length (stNotes st) - 1) + if isEnabled Ext_footnotes opts + then return $ "[^" <> ref <> "]" + else return $ "[" <> ref <> "]" + +makeMathPlainer :: [Inline] -> [Inline] +makeMathPlainer = walk go + where + go (Emph xs) = Span nullAttr xs + go x = x + +toSubscriptInline :: Inline -> Maybe Inline +toSubscriptInline Space = Just Space +toSubscriptInline (Span attr ils) = Span attr <$> traverse toSubscriptInline ils +toSubscriptInline (Str s) = Str . T.pack <$> traverse toSubscript (T.unpack s) +toSubscriptInline LineBreak = Just LineBreak +toSubscriptInline SoftBreak = Just SoftBreak +toSubscriptInline _ = Nothing + +toSuperscriptInline :: Inline -> Maybe Inline +toSuperscriptInline Space = Just Space +toSuperscriptInline (Span attr ils) = Span attr <$> traverse toSuperscriptInline ils +toSuperscriptInline (Str s) = Str . T.pack <$> traverse toSuperscript (T.unpack s) +toSuperscriptInline LineBreak = Just LineBreak +toSuperscriptInline SoftBreak = Just SoftBreak +toSuperscriptInline _ = Nothing diff --git a/src/Text/Pandoc/Writers/Markdown/Types.hs b/src/Text/Pandoc/Writers/Markdown/Types.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/Writers/Markdown/Types.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE OverloadedStrings #-} +{- | + Module : Text.Pandoc.Writers.Markdown.Types + Copyright : Copyright (C) 2006-2021 John MacFarlane + License : GNU GPL, version 2 or above + + Maintainer : John MacFarlane + Stability : alpha + Portability : portable +-} +module Text.Pandoc.Writers.Markdown.Types ( + MarkdownVariant(..), + WriterState(..), + WriterEnv(..), + Notes, + Ref, + Refs, + MD, + evalMD + ) where +import Control.Monad.Reader +import Control.Monad.State.Strict +import Data.Default +import qualified Data.Map as M +import qualified Data.Set as Set +import Data.Text (Text) +import Text.Pandoc.Parsing (Key) +import Text.Pandoc.Class.PandocMonad (PandocMonad) +import Text.Pandoc.Definition + +type Notes = [[Block]] +type Ref = (Text, Target, Attr) +type Refs = [Ref] + +type MD m = ReaderT WriterEnv (StateT WriterState m) + +evalMD :: PandocMonad m => MD m a -> WriterEnv -> WriterState -> m a +evalMD md env st = evalStateT (runReaderT md env) st + +data WriterEnv = WriterEnv { envInList :: Bool + , envVariant :: MarkdownVariant + , envRefShortcutable :: Bool + , envBlockLevel :: Int + , envEscapeSpaces :: Bool + } + +data MarkdownVariant = + PlainText + | Commonmark + | Markdown + deriving (Show, Eq) + +instance Default WriterEnv + where def = WriterEnv { envInList = False + , envVariant = Markdown + , envRefShortcutable = True + , envBlockLevel = 0 + , envEscapeSpaces = False + } + +data WriterState = WriterState { stNotes :: Notes + , stPrevRefs :: Refs + , stRefs :: Refs + , stKeys :: M.Map Key + (M.Map (Target, Attr) Int) + , stLastIdx :: Int + , stIds :: Set.Set Text + , stNoteNum :: Int + } + +instance Default WriterState + where def = WriterState{ stNotes = [] + , stPrevRefs = [] + , stRefs = [] + , stKeys = M.empty + , stLastIdx = 0 + , stIds = Set.empty + , stNoteNum = 1 + } + + 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 @@ -13,7 +13,7 @@ -} module Text.Pandoc.Writers.ODT ( writeODT ) where import Codec.Archive.Zip -import Control.Monad.Except (catchError) +import Control.Monad.Except (catchError, throwError) import Control.Monad.State.Strict import qualified Data.ByteString.Lazy as B import Data.Generics (everywhere', mkT) @@ -27,6 +27,7 @@ import Text.Pandoc.Class.PandocMonad (PandocMonad, report, toLang) import qualified Text.Pandoc.Class.PandocMonad as P import Text.Pandoc.Definition +import Text.Pandoc.Error (PandocError(..)) import Text.Pandoc.ImageSize import Text.Pandoc.Logging import Text.Pandoc.MIME (extensionFromMimeType, getMimeType) @@ -35,12 +36,13 @@ import Text.Pandoc.Shared (stringify, pandocVersion, tshow) import Text.Pandoc.Writers.Shared (lookupMetaString, lookupMetaBlocks, fixDisplayMath) -import Text.Pandoc.UTF8 (fromStringLazy, fromTextLazy, toStringLazy) +import Text.Pandoc.UTF8 (fromStringLazy, fromTextLazy, toTextLazy) import Text.Pandoc.Walk import Text.Pandoc.Writers.OpenDocument (writeOpenDocument) import Text.Pandoc.XML +import Text.Pandoc.XML.Light import Text.TeXMath -import Text.XML.Light +import qualified Text.XML.Light as XL newtype ODTState = ODTState { stEntries :: [Entry] } @@ -66,7 +68,7 @@ pandocToODT opts doc@(Pandoc meta _) = do let title = docTitle meta let authors = docAuthors meta - utctime <- P.getCurrentTime + utctime <- P.getTimestamp lang <- toLang (getLang opts meta) refArchive <- case writerReferenceDoc opts of @@ -172,24 +174,27 @@ updateStyleWithLang Nothing arch = return arch updateStyleWithLang (Just lang) arch = do epochtime <- floor `fmap` lift P.getPOSIXTime - return arch{ zEntries = [if eRelativePath e == "styles.xml" - then case parseXMLDoc - (toStringLazy (fromEntry e)) of - Nothing -> e - Just d -> - toEntry "styles.xml" epochtime - ( fromStringLazy - . ppTopElement - . addLang lang $ d ) - else e - | e <- zEntries arch] } + entries <- mapM (\e -> if eRelativePath e == "styles.xml" + then case parseXMLElement + (toTextLazy (fromEntry e)) of + Left msg -> throwError $ + PandocXMLError "styles.xml" msg + Right d -> return $ + toEntry "styles.xml" epochtime + ( fromTextLazy + . TL.fromStrict + . ppTopElement + . addLang lang $ d ) + else return e) (zEntries arch) + return arch{ zEntries = entries } +-- TODO FIXME avoid this generic traversal! addLang :: Lang -> Element -> Element addLang lang = everywhere' (mkT updateLangAttr) where updateLangAttr (Attr n@(QName "language" _ (Just "fo")) _) - = Attr n (T.unpack $ langLanguage lang) + = Attr n (langLanguage lang) updateLangAttr (Attr n@(QName "country" _ (Just "fo")) _) - = Attr n (T.unpack $ langRegion lang) + = Attr n (langRegion lang) updateLangAttr x = x -- | transform both Image and Math elements @@ -235,8 +240,8 @@ case writeMathML dt <$> readTeX math of Left _ -> return $ Math t math Right r -> do - let conf = useShortEmptyTags (const False) defaultConfigPP - let mathml = ppcTopElement conf r + let conf = XL.useShortEmptyTags (const False) XL.defaultConfigPP + let mathml = XL.ppcTopElement conf r epochtime <- floor `fmap` lift P.getPOSIXTime let dirname = "Formula-" ++ show (length entries) ++ "/" let fname = dirname ++ "content.xml" 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 @@ -29,32 +29,32 @@ import Text.Pandoc.Error import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL -import qualified Data.ByteString.Lazy.Char8 as BL8 import Data.Maybe (mapMaybe) import qualified Data.Text as T +import Data.Text (Text) import Text.Pandoc.Class.PandocMonad (PandocMonad) import qualified Text.Pandoc.UTF8 as UTF8 -import Text.XML.Light as XML +import Text.Pandoc.XML.Light -mknode :: Node t => String -> [(String,String)] -> t -> Element +mknode :: Node t => Text -> [(Text,Text)] -> t -> Element mknode s attrs = add_attrs (map (\(k,v) -> Attr (nodename k) v) attrs) . node (nodename s) -mktnode :: String -> [(String,String)] -> T.Text -> Element -mktnode s attrs = mknode s attrs . T.unpack +mktnode :: Text -> [(Text,Text)] -> T.Text -> Element +mktnode s attrs = mknode s attrs -nodename :: String -> QName +nodename :: Text -> QName nodename s = QName{ qName = name, qURI = Nothing, qPrefix = prefix } - where (name, prefix) = case break (==':') s of - (xs,[]) -> (xs, Nothing) - (ys, _:zs) -> (zs, Just ys) + where (name, prefix) = case T.break (==':') s of + (xs,ys) -> case T.uncons ys of + Nothing -> (xs, Nothing) + Just (_,zs) -> (zs, Just xs) toLazy :: B.ByteString -> BL.ByteString toLazy = BL.fromChunks . (:[]) renderXml :: Element -> BL.ByteString -renderXml elt = BL8.pack "\n" <> - UTF8.fromStringLazy (showElement elt) +renderXml elt = BL.fromStrict (UTF8.fromText (showTopElement elt)) parseXml :: PandocMonad m => Archive -> Archive -> String -> m Element parseXml refArchive distArchive relpath = @@ -62,32 +62,32 @@ findEntryByPath relpath distArchive of Nothing -> throwError $ PandocSomeError $ T.pack relpath <> " missing in reference file" - Just e -> case parseXMLDoc . UTF8.toStringLazy . fromEntry $ e of - Nothing -> throwError $ PandocSomeError $ - T.pack relpath <> " corrupt in reference file" - Just d -> return d + Just e -> case parseXMLElement . UTF8.toTextLazy . fromEntry $ e of + Left msg -> + throwError $ PandocXMLError (T.pack relpath) msg + Right d -> return d -- Copied from Util -attrToNSPair :: XML.Attr -> Maybe (String, String) -attrToNSPair (XML.Attr (QName s _ (Just "xmlns")) val) = Just (s, val) +attrToNSPair :: Attr -> Maybe (Text, Text) +attrToNSPair (Attr (QName s _ (Just "xmlns")) val) = Just (s, val) attrToNSPair _ = Nothing elemToNameSpaces :: Element -> NameSpaces elemToNameSpaces = mapMaybe attrToNSPair . elAttribs -elemName :: NameSpaces -> String -> String -> QName +elemName :: NameSpaces -> Text -> Text -> QName elemName ns prefix name = - QName name (lookup prefix ns) (if null prefix then Nothing else Just prefix) + QName name (lookup prefix ns) (if T.null prefix then Nothing else Just prefix) -isElem :: NameSpaces -> String -> String -> Element -> Bool +isElem :: NameSpaces -> Text -> Text -> Element -> Bool isElem ns prefix name element = let ns' = ns ++ elemToNameSpaces element in qName (elName element) == name && qURI (elName element) == lookup prefix ns' -type NameSpaces = [(String, String)] +type NameSpaces = [(Text, Text)] -- | Scales the image to fit the page -- sizes are passed in emu 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 @@ -213,24 +213,34 @@ -- | Convert bullet list item (list of blocks) to Org. bulletListItemToOrg :: PandocMonad m => [Block] -> Org m (Doc Text) bulletListItemToOrg items = do - contents <- blockListToOrg items + exts <- gets $ writerExtensions . stOptions + contents <- blockListToOrg (taskListItemToOrg exts items) return $ hang 2 "- " contents $$ if endsWithPlain items then cr else blankline - -- | Convert ordered list item (a list of blocks) to Org. orderedListItemToOrg :: PandocMonad m => Text -- ^ marker for list item -> [Block] -- ^ list item (list of blocks) -> Org m (Doc Text) orderedListItemToOrg marker items = do - contents <- blockListToOrg items + exts <- gets $ writerExtensions . stOptions + contents <- blockListToOrg (taskListItemToOrg exts items) return $ hang (T.length marker + 1) (literal marker <> space) contents $$ if endsWithPlain items then cr else blankline + +-- | Convert a list item containing text starting with @U+2610 BALLOT BOX@ +-- or @U+2612 BALLOT BOX WITH X@ to org checkbox syntax (e.g. @[X]@). +taskListItemToOrg :: Extensions -> [Block] -> [Block] +taskListItemToOrg = handleTaskListItem toOrg + where + toOrg (Str "☐" : Space : is) = Str "[ ]" : Space : is + toOrg (Str "☒" : Space : is) = Str "[X]" : Space : is + toOrg is = is -- | Convert definition list item (label, list of blocks) to Org. definitionListItemToOrg :: PandocMonad m 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 @@ -20,15 +20,16 @@ import Control.Monad.Reader import Control.Monad.State import Codec.Archive.Zip -import Data.Char (toUpper) import Data.List (intercalate, stripPrefix, nub, union, isPrefixOf, intersperse) import Data.Default +import Data.Text (Text) import qualified Data.Text as T +import qualified Data.Text.Read import Data.Time (formatTime, defaultTimeLocale) import Data.Time.Clock (UTCTime) import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, posixSecondsToUTCTime) import System.FilePath.Posix (splitDirectories, splitExtension, takeExtension) -import Text.XML.Light +import Text.Pandoc.XML.Light as XML import Text.Pandoc.Definition import qualified Text.Pandoc.UTF8 as UTF8 import Text.Pandoc.Class.PandocMonad (PandocMonad) @@ -47,6 +48,7 @@ import Text.TeXMath import Text.Pandoc.Writers.Math (convertMath) import Text.Pandoc.Writers.Powerpoint.Presentation +import Text.Pandoc.Shared (tshow) import Skylighting (fromColor) -- |The 'EMU' type is used to specify sizes in English Metric Units. @@ -77,15 +79,19 @@ getPresentationSize refArchive distArchive = do entry <- findEntryByPath "ppt/presentation.xml" refArchive `mplus` findEntryByPath "ppt/presentation.xml" distArchive - presElement <- parseXMLDoc $ UTF8.toStringLazy $ fromEntry entry + presElement <- either (const Nothing) return $ + parseXMLElement $ UTF8.toTextLazy $ fromEntry entry let ns = elemToNameSpaces presElement sldSize <- findChild (elemName ns "p" "sldSz") presElement cxS <- findAttr (QName "cx" Nothing Nothing) sldSize cyS <- findAttr (QName "cy" Nothing Nothing) sldSize - (cx, _) <- listToMaybe $ reads cxS :: Maybe (Integer, String) - (cy, _) <- listToMaybe $ reads cyS :: Maybe (Integer, String) + cx <- readTextAsInteger cxS + cy <- readTextAsInteger cyS return (cx `div` 12700, cy `div` 12700) +readTextAsInteger :: Text -> Maybe Integer +readTextAsInteger = either (const Nothing) (Just . fst) . Data.Text.Read.decimal + data WriterEnv = WriterEnv { envRefArchive :: Archive , envDistArchive :: Archive , envUTCTime :: UTCTime @@ -159,9 +165,6 @@ -------------------------------------------------------------------- -findAttrText :: QName -> Element -> Maybe T.Text -findAttrText n = fmap T.pack . findAttr n - monospaceFont :: Monad m => P m T.Text monospaceFont = do vars <- writerVariables <$> asks envOpts @@ -169,10 +172,9 @@ Just s -> return s Nothing -> return "Courier" --- Kept as string for XML.Light -fontSizeAttributes :: Monad m => RunProps -> P m [(String, String)] +fontSizeAttributes :: Monad m => RunProps -> P m [(Text, Text)] fontSizeAttributes RunProps { rPropForceSize = Just sz } = - return [("sz", show $ sz * 100)] + return [("sz", tshow $ sz * 100)] fontSizeAttributes _ = return [] copyFileToArchive :: PandocMonad m => Archive -> FilePath -> P m Archive @@ -310,7 +312,7 @@ Nothing -> toArchive . BL.fromStrict <$> P.readDataFile "reference.pptx" - utctime <- P.getCurrentTime + utctime <- P.getTimestamp presSize <- case getPresentationSize refArchive distArchive of Just sz -> return sz @@ -363,7 +365,7 @@ shapeHasId ns ident element | Just nvSpPr <- findChild (elemName ns "p" "nvSpPr") element , Just cNvPr <- findChild (elemName ns "p" "cNvPr") nvSpPr - , Just nm <- findAttrText (QName "id" Nothing Nothing) cNvPr = + , Just nm <- findAttr (QName "id" Nothing Nothing) cNvPr = nm == ident | otherwise = False @@ -394,10 +396,10 @@ ext <- findChild (elemName ns "a" "ext") xfrm cxS <- findAttr (QName "cx" Nothing Nothing) ext cyS <- findAttr (QName "cy" Nothing Nothing) ext - (x, _) <- listToMaybe $ reads xS - (y, _) <- listToMaybe $ reads yS - (cx, _) <- listToMaybe $ reads cxS - (cy, _) <- listToMaybe $ reads cyS + x <- readTextAsInteger xS + y <- readTextAsInteger yS + cx <- readTextAsInteger cxS + cy <- readTextAsInteger cyS return ((x `div` 12700, y `div` 12700), (cx `div` 12700, cy `div` 12700)) | otherwise = Nothing @@ -428,7 +430,7 @@ Nothing -> do let mbSz = findChild (elemName ns "p" "nvSpPr") sp >>= findChild (elemName ns "p" "cNvPr") >>= - findAttrText (QName "id" Nothing Nothing) >>= + findAttr (QName "id" Nothing Nothing) >>= flip getMasterShapeDimensionsById master case mbSz of Just sz' -> return sz' @@ -448,8 +450,8 @@ fn _ = True replaceNamedChildren :: NameSpaces - -> String - -> String + -> Text + -> Text -> [Element] -> Element -> Element @@ -652,10 +654,10 @@ ] , mknode "p:spPr" [] [ mknode "a:xfrm" [] - [ mknode "a:off" [("x", show $ 12700 * x), - ("y", show $ 12700 * (y + cy - captionHeight))] () - , mknode "a:ext" [("cx", show $ 12700 * cx), - ("cy", show $ 12700 * captionHeight)] () + [ mknode "a:off" [("x", tshow $ 12700 * x), + ("y", tshow $ 12700 * (y + cy - captionHeight))] () + , mknode "a:ext" [("cx", tshow $ 12700 * cx), + ("cy", tshow $ 12700 * captionHeight)] () ] , mknode "a:prstGeom" [("prst", "rect")] [ mknode "a:avLst" [] () @@ -704,11 +706,13 @@ ,("noChangeAspect","1")] () -- cNvPr will contain the link information so we do that separately, -- and register the link if necessary. - let cNvPrAttr = [("descr", mInfoFilePath mInfo), ("id","0"),("name","Picture 1")] + let cNvPrAttr = [("descr", T.pack $ mInfoFilePath mInfo), + ("id","0"), + ("name","Picture 1")] cNvPr <- case picPropLink picProps of Just link -> do idNum <- registerLink link return $ mknode "p:cNvPr" cNvPrAttr $ - mknode "a:hlinkClick" [("r:id", "rId" <> show idNum)] () + mknode "a:hlinkClick" [("r:id", "rId" <> tshow idNum)] () Nothing -> return $ mknode "p:cNvPr" cNvPrAttr () let nvPicPr = mknode "p:nvPicPr" [] [ cNvPr @@ -716,13 +720,13 @@ , mknode "p:nvPr" [] ()] let blipFill = mknode "p:blipFill" [] [ mknode "a:blip" [("r:embed", "rId" <> - show (mInfoLocalId mInfo))] () + tshow (mInfoLocalId mInfo))] () , mknode "a:stretch" [] $ mknode "a:fillRect" [] () ] let xfrm = mknode "a:xfrm" [] - [ mknode "a:off" [("x",show xoff'), ("y",show yoff')] () - , mknode "a:ext" [("cx",show dimX') - ,("cy",show dimY')] () ] + [ mknode "a:off" [("x", tshow xoff'), ("y", tshow yoff')] () + , mknode "a:ext" [("cx", tshow dimX') + ,("cy", tshow dimY')] () ] let prstGeom = mknode "a:prstGeom" [("prst","rect")] $ mknode "a:avLst" [] () let ln = mknode "a:ln" [("w","9525")] @@ -761,7 +765,7 @@ Just DoubleStrike -> [("strike", "dblStrike")] Nothing -> []) <> (case rBaseline rpr of - Just n -> [("baseline", show n)] + Just n -> [("baseline", tshow n)] Nothing -> []) <> (case rCap rpr of Just NoCapitals -> [("cap", "none")] @@ -778,43 +782,44 @@ return $ case link of InternalTarget _ -> let linkAttrs = - [ ("r:id", "rId" <> show idNum) + [ ("r:id", "rId" <> tshow idNum) , ("action", "ppaction://hlinksldjump") ] in [mknode "a:hlinkClick" linkAttrs ()] -- external ExternalTarget _ -> let linkAttrs = - [ ("r:id", "rId" <> show idNum) + [ ("r:id", "rId" <> tshow idNum) ] in [mknode "a:hlinkClick" linkAttrs ()] Nothing -> return [] let colorContents = case rSolidFill rpr of Just color -> case fromColor color of - '#':hx -> [mknode "a:solidFill" [] - [mknode "a:srgbClr" [("val", map toUpper hx)] ()] - ] + '#':hx -> + [mknode "a:solidFill" [] + [mknode "a:srgbClr" + [("val", T.toUpper $ T.pack hx)] ()]] _ -> [] Nothing -> [] codeFont <- monospaceFont let codeContents = - [mknode "a:latin" [("typeface", T.unpack codeFont)] () | rPropCode rpr] + [mknode "a:latin" [("typeface", codeFont)] () | rPropCode rpr] let propContents = linkProps <> colorContents <> codeContents return [Elem $ mknode "a:r" [] [ mknode "a:rPr" attrs propContents - , mknode "a:t" [] $ T.unpack s + , mknode "a:t" [] s ]] paraElemToElements (MathElem mathType texStr) = do isInSpkrNotes <- asks envInSpeakerNotes if isInSpkrNotes then paraElemToElements $ Run def $ unTeXString texStr else do res <- convertMath writeOMML mathType (unTeXString texStr) - case res of + case fromXLElement <$> res of Right r -> return [Elem $ mknode "a14:m" [] $ addMathInfo r] Left (Str s) -> paraElemToElements (Run def s) Left _ -> throwError $ PandocShouldNeverHappenError "non-string math fallback" paraElemToElements (RawOOXMLParaElem str) = return - [Text (CData CDataRaw (T.unpack str) Nothing)] + [Text (CData CDataRaw str Nothing)] -- This is a bit of a kludge -- really requires adding an option to @@ -822,9 +827,10 @@ -- step at a time. addMathInfo :: Element -> Element addMathInfo element = - let mathspace = Attr { attrKey = QName "m" Nothing (Just "xmlns") - , attrVal = "http://schemas.openxmlformats.org/officeDocument/2006/math" - } + let mathspace = + Attr { attrKey = QName "m" Nothing (Just "xmlns") + , attrVal = "http://schemas.openxmlformats.org/officeDocument/2006/math" + } in add_attr mathspace element -- We look through the element to see if it contains an a14:m @@ -847,13 +853,13 @@ paragraphToElement :: PandocMonad m => Paragraph -> P m Element paragraphToElement par = do let - attrs = [("lvl", show $ pPropLevel $ paraProps par)] <> + attrs = [("lvl", tshow $ pPropLevel $ paraProps par)] <> (case pPropMarginLeft (paraProps par) of - Just px -> [("marL", show $ pixelsToEmu px)] + Just px -> [("marL", tshow $ pixelsToEmu px)] Nothing -> [] ) <> (case pPropIndent (paraProps par) of - Just px -> [("indent", show $ pixelsToEmu px)] + Just px -> [("indent", tshow $ pixelsToEmu px)] Nothing -> [] ) <> (case pPropAlign (paraProps par) of @@ -865,7 +871,7 @@ props = [] <> (case pPropSpaceBefore $ paraProps par of Just px -> [mknode "a:spcBef" [] [ - mknode "a:spcPts" [("val", show $ 100 * px)] () + mknode "a:spcPts" [("val", tshow $ 100 * px)] () ] ] Nothing -> [] @@ -908,7 +914,7 @@ shapeToElements layout (GraphicFrame tbls cptn) = map Elem <$> graphicFrameToElements layout tbls cptn shapeToElements _ (RawOOXMLShape str) = return - [Text (CData CDataRaw (T.unpack str) Nothing)] + [Text (CData CDataRaw str Nothing)] shapeToElements layout shp = do element <- shapeToElement layout shp return [Elem element] @@ -940,8 +946,10 @@ [mknode "p:ph" [("idx", "1")] ()] ] , mknode "p:xfrm" [] - [ mknode "a:off" [("x", show $ 12700 * x), ("y", show $ 12700 * y)] () - , mknode "a:ext" [("cx", show $ 12700 * cx), ("cy", show $ 12700 * cy)] () + [ mknode "a:off" [("x", tshow $ 12700 * x), + ("y", tshow $ 12700 * y)] () + , mknode "a:ext" [("cx", tshow $ 12700 * cx), + ("cy", tshow $ 12700 * cy)] () ] ] <> elements @@ -955,7 +963,7 @@ refArchive <- asks envRefArchive distArchive <- asks envDistArchive tblStyleLst <- parseXml refArchive distArchive "ppt/tableStyles.xml" - return $ findAttrText (QName "def" Nothing Nothing) tblStyleLst + return $ findAttr (QName "def" Nothing Nothing) tblStyleLst graphicToElement :: PandocMonad m => Integer -> Graphic -> P m Element graphicToElement tableWidth (Tbl tblPr hdrCells rows) = do @@ -993,7 +1001,7 @@ let mkrow border cells = mknode "a:tr" [("h", "0")] $ map (mkcell border) cells let mkgridcol w = mknode "a:gridCol" - [("w", show ((12700 * w) :: Integer))] () + [("w", tshow ((12700 * w) :: Integer))] () let hasHeader = not (all null hdrCells) mbDefTblStyle <- getDefaultTableStyle @@ -1002,7 +1010,7 @@ , ("bandRow", if tblPrBandRow tblPr then "1" else "0") ] (case mbDefTblStyle of Nothing -> [] - Just sty -> [mknode "a:tableStyleId" [] $ T.unpack sty]) + Just sty -> [mknode "a:tableStyleId" [] sty]) return $ mknode "a:graphic" [] [mknode "a:graphicData" [("uri", "http://schemas.openxmlformats.org/drawingml/2006/table")] @@ -1035,7 +1043,7 @@ -- if it's a named PHType, we want to check that the attribute -- value matches. Just phElem | (PHType tp) <- phType -> - case findAttrText (QName "type" Nothing Nothing) phElem of + case findAttr (QName "type" Nothing Nothing) phElem of Just tp' -> tp == tp' Nothing -> False -- if it's an ObjType, we want to check that there is NO @@ -1202,7 +1210,7 @@ , Just txBody <- findChild (elemName ns "p" "txBody") sp , Just p <- findChild (elemName ns "a" "p") txBody , Just fld <- findChild (elemName ns "a" "fld") p - , Just fldId <- findAttrText (QName "id" Nothing Nothing) fld = + , Just fldId <- findAttr (QName "id" Nothing Nothing) fld = return fldId | otherwise = throwError $ PandocSomeError @@ -1281,11 +1289,11 @@ [ mknode "a:bodyPr" [] () , mknode "a:lstStyle" [] () , mknode "a:p" [] - [ mknode "a:fld" [ ("id", T.unpack fieldId) + [ mknode "a:fld" [ ("id", fieldId) , ("type", "slidenum") ] [ mknode "a:rPr" [("lang", "en-US")] () - , mknode "a:t" [] (show pgNum) + , mknode "a:t" [] (tshow pgNum) ] , mknode "a:endParaRPr" [("lang", "en-US")] () ] @@ -1337,7 +1345,7 @@ Just n -> return n Nothing -> throwError $ PandocShouldNeverHappenError $ - "Slide Id " <> T.pack (show sldId) <> " not found." + "Slide Id " <> tshow sldId <> " not found." slideNum :: PandocMonad m => Slide -> P m Int slideNum slide = getSlideIdNum $ slideId slide @@ -1354,7 +1362,7 @@ slideToRelId slide = do n <- slideNum slide offset <- asks envSlideIdOffset - return $ "rId" <> T.pack (show $ n + offset) + return $ "rId" <> tshow (n + offset) data Relationship = Relationship { relId :: Int @@ -1366,13 +1374,11 @@ elementToRel element | elName element == QName "Relationship" (Just "http://schemas.openxmlformats.org/package/2006/relationships") Nothing = do rId <- findAttr (QName "Id" Nothing Nothing) element - numStr <- stripPrefix "rId" rId - num <- case reads numStr :: [(Int, String)] of - (n, _) : _ -> Just n - [] -> Nothing - type' <- findAttrText (QName "Type" Nothing Nothing) element + numStr <- T.stripPrefix "rId" rId + num <- fromIntegral <$> readTextAsInteger numStr + type' <- findAttr (QName "Type" Nothing Nothing) element target <- findAttr (QName "Target" Nothing Nothing) element - return $ Relationship num type' target + return $ Relationship num type' (T.unpack target) | otherwise = Nothing slideToPresRel :: PandocMonad m => Slide -> P m Relationship @@ -1461,10 +1467,9 @@ topLevelRelsEntry = elemToEntry "_rels/.rels" $ relsToElement topLevelRels relToElement :: Relationship -> Element -relToElement rel = mknode "Relationship" [ ("Id", "rId" <> - show (relId rel)) - , ("Type", T.unpack $ relType rel) - , ("Target", relTarget rel) ] () +relToElement rel = mknode "Relationship" [ ("Id", "rId" <> tshow (relId rel)) + , ("Type", relType rel) + , ("Target", T.pack $ relTarget rel) ] () relsToElement :: [Relationship] -> Element relsToElement rels = mknode "Relationships" @@ -1499,7 +1504,8 @@ Just element | Just notesIdNum <- mbNotesIdNum -> Just <$> elemToEntry - ("ppt/notesSlides/notesSlide" <> show notesIdNum <> ".xml") + ("ppt/notesSlides/notesSlide" <> show notesIdNum <> + ".xml") element _ -> return Nothing @@ -1512,7 +1518,7 @@ [("xmlns", "http://schemas.openxmlformats.org/package/2006/relationships")] [ mknode "Relationship" [ ("Id", "rId2") , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide") - , ("Target", "../slides/slide" <> show idNum <> ".xml") + , ("Target", "../slides/slide" <> tshow idNum <> ".xml") ] () , mknode "Relationship" [ ("Id", "rId1") , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/notesMaster") @@ -1545,15 +1551,15 @@ linkRelElement (rIdNum, InternalTarget targetId) = do targetIdNum <- getSlideIdNum targetId return $ - mknode "Relationship" [ ("Id", "rId" <> show rIdNum) + mknode "Relationship" [ ("Id", "rId" <> tshow rIdNum) , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide") - , ("Target", "slide" <> show targetIdNum <> ".xml") + , ("Target", "slide" <> tshow targetIdNum <> ".xml") ] () linkRelElement (rIdNum, ExternalTarget (url, _)) = return $ - mknode "Relationship" [ ("Id", "rId" <> show rIdNum) + mknode "Relationship" [ ("Id", "rId" <> tshow rIdNum) , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/hyperlink") - , ("Target", T.unpack url) + , ("Target", url) , ("TargetMode", "External") ] () @@ -1565,10 +1571,10 @@ let ext = fromMaybe "" (mInfoExt mInfo) in mknode "Relationship" [ ("Id", "rId" <> - show (mInfoLocalId mInfo)) + tshow (mInfoLocalId mInfo)) , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/image") , ("Target", "../media/image" <> - show (mInfoGlobalId mInfo) <> T.unpack ext) + tshow (mInfoGlobalId mInfo) <> ext) ] () speakerNotesSlideRelElement :: PandocMonad m => Slide -> P m (Maybe Element) @@ -1578,7 +1584,7 @@ return $ case M.lookup idNum mp of Nothing -> Nothing Just n -> - let target = "../notesSlides/notesSlide" <> show n <> ".xml" + let target = "../notesSlides/notesSlide" <> tshow n <> ".xml" in Just $ mknode "Relationship" [ ("Id", "rId2") , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/notesSlide") @@ -1617,9 +1623,9 @@ slideToSldIdElement :: PandocMonad m => Slide -> P m Element slideToSldIdElement slide = do n <- slideNum slide - let id' = show $ n + 255 + let id' = tshow $ n + 255 rId <- slideToRelId slide - return $ mknode "p:sldId" [("id", id'), ("r:id", T.unpack rId)] () + return $ mknode "p:sldId" [("id", id'), ("r:id", rId)] () presentationToSldIdLst :: PandocMonad m => Presentation -> P m Element presentationToSldIdLst (Presentation _ slides) = do @@ -1644,7 +1650,7 @@ notesMasterElem = mknode "p:notesMasterIdLst" [] [ mknode "p:NotesMasterId" - [("r:id", "rId" <> show notesMasterRId)] + [("r:id", "rId" <> tshow notesMasterRId)] () ] @@ -1700,17 +1706,17 @@ ,("xmlns:dcmitype","http://purl.org/dc/dcmitype/") ,("xmlns:xsi","http://www.w3.org/2001/XMLSchema-instance")] $ - mknode "dc:title" [] (maybe "" T.unpack $ dcTitle docProps) + mknode "dc:title" [] (fromMaybe "" $ dcTitle docProps) : - mknode "dc:creator" [] (maybe "" T.unpack $ dcCreator docProps) + mknode "dc:creator" [] (fromMaybe "" $ dcCreator docProps) : - mknode "cp:keywords" [] (T.unpack keywords) - : ( [mknode "dc:subject" [] $ maybe "" T.unpack $ dcSubject docProps | isJust (dcSubject docProps)]) - <> ( [mknode "dc:description" [] $ maybe "" T.unpack $ dcDescription docProps | isJust (dcDescription docProps)]) - <> ( [mknode "cp:category" [] $ maybe "" T.unpack $ cpCategory docProps | isJust (cpCategory docProps)]) + mknode "cp:keywords" [] keywords + : ( [mknode "dc:subject" [] $ fromMaybe "" $ dcSubject docProps | isJust (dcSubject docProps)]) + <> ( [mknode "dc:description" [] $ fromMaybe "" $ dcDescription docProps | isJust (dcDescription docProps)]) + <> ( [mknode "cp:category" [] $ fromMaybe "" $ cpCategory docProps | isJust (cpCategory docProps)]) <> (\x -> [ mknode "dcterms:created" [("xsi:type","dcterms:W3CDTF")] x - , mknode "dcterms:modified" [("xsi:type","dcterms:W3CDTF")] x - ]) (formatTime defaultTimeLocale "%FT%XZ" utctime) + , mknode "dcterms:modified" [("xsi:type","dcterms:W3CDTF")] x + ]) (T.pack $ formatTime defaultTimeLocale "%FT%XZ" utctime) docPropsToEntry :: PandocMonad m => DocProps -> P m Entry docPropsToEntry docProps = docPropsElement docProps >>= @@ -1721,8 +1727,8 @@ docCustomPropsElement docProps = do let mkCustomProp (k, v) pid = mknode "property" [("fmtid","{D5CDD505-2E9C-101B-9397-08002B2CF9AE}") - ,("pid", show pid) - ,("name", T.unpack k)] $ mknode "vt:lpwstr" [] (T.unpack v) + ,("pid", tshow pid) + ,("name", k)] $ mknode "vt:lpwstr" [] v return $ mknode "Properties" [("xmlns","http://schemas.openxmlformats.org/officeDocument/2006/custom-properties") ,("xmlns:vt","http://schemas.openxmlformats.org/officeDocument/2006/docPropsVTypes") @@ -1741,7 +1747,7 @@ distArchive <- asks envDistArchive viewPrElement <- parseXml refArchive distArchive "ppt/viewProps.xml" -- remove "lastView" if it exists: - let notLastView :: Text.XML.Light.Attr -> Bool + let notLastView :: XML.Attr -> Bool notLastView attr = qName (attrKey attr) /= "lastView" return $ @@ -1753,15 +1759,15 @@ defaultContentTypeToElem :: DefaultContentType -> Element defaultContentTypeToElem dct = mknode "Default" - [("Extension", T.unpack $ defContentTypesExt dct), - ("ContentType", T.unpack $ defContentTypesType dct)] + [("Extension", defContentTypesExt dct), + ("ContentType", defContentTypesType dct)] () overrideContentTypeToElem :: OverrideContentType -> Element overrideContentTypeToElem oct = mknode "Override" - [("PartName", overrideContentTypesPart oct), - ("ContentType", T.unpack $ overrideContentTypesType oct)] + [("PartName", T.pack $ overrideContentTypesPart oct), + ("ContentType", overrideContentTypesType oct)] () contentTypesToElement :: ContentTypes -> Element @@ -1819,7 +1825,8 @@ getSpeakerNotesFilePaths = do mp <- asks envSpeakerNotesIdMap let notesIdNums = M.elems mp - return $ map (\n -> "ppt/notesSlides/notesSlide" <> show n <> ".xml") notesIdNums + return $ map (\n -> "ppt/notesSlides/notesSlide" <> show n <> ".xml") + notesIdNums presentationToContentTypes :: PandocMonad m => Presentation -> P m ContentTypes presentationToContentTypes p@(Presentation _ slides) = do @@ -1883,11 +1890,11 @@ | otherwise = Nothing -- Kept as String for XML.Light -autoNumAttrs :: ListAttributes -> [(String, String)] +autoNumAttrs :: ListAttributes -> [(Text, Text)] autoNumAttrs (startNum, numStyle, numDelim) = numAttr <> typeAttr where - numAttr = [("startAt", show startNum) | startNum /= 1] + numAttr = [("startAt", tshow startNum) | startNum /= 1] typeAttr = [("type", typeString <> delimString)] typeString = case numStyle of Decimal -> "arabic" 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 @@ -1,6 +1,5 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} {- | Module : Text.Pandoc.XML Copyright : Copyright (C) 2006-2021 John MacFarlane @@ -123,23 +122,20 @@ -- Unescapes XML entities fromEntities :: Text -> Text -fromEntities = T.pack . fromEntities' +fromEntities t + = let (x, y) = T.break (== '&') t + in if T.null y + then t + else x <> + let (ent, rest) = T.break (\c -> isSpace c || c == ';') y + rest' = case T.uncons rest of + Just (';',ys) -> ys + _ -> rest + ent' = T.drop 1 ent <> ";" + in case T.pack <$> lookupEntity (T.unpack ent') of + Just c -> c <> fromEntities rest' + Nothing -> ent <> fromEntities rest -fromEntities' :: Text -> String -fromEntities' (T.uncons -> Just ('&', xs)) = - case lookupEntity $ T.unpack ent' of - Just c -> c <> fromEntities' rest - Nothing -> "&" <> fromEntities' xs - where (ent, rest) = case T.break (\c -> isSpace c || c == ';') xs of - (zs,T.uncons -> Just (';',ys)) -> (zs,ys) - (zs, ys) -> (zs,ys) - ent' - | Just ys <- T.stripPrefix "#X" ent = "#x" <> ys -- workaround tagsoup bug - | Just ('#', _) <- T.uncons ent = ent - | otherwise = ent <> ";" -fromEntities' t = case T.uncons t of - Just (x, xs) -> x : fromEntities' xs - Nothing -> "" html5Attributes :: Set.Set Text html5Attributes = Set.fromList diff --git a/src/Text/Pandoc/XML/Light.hs b/src/Text/Pandoc/XML/Light.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/XML/Light.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{- | + Module : Text.Pandoc.XML.Light + Copyright : Copyright (C) 2021 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 + ) 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 + +-- Drop in replacement for parseXMLDoc in xml-light. +parseXMLElement :: TL.Text -> Either T.Text Element +parseXMLElement t = + elementToElement . Conduit.documentRoot <$> + either (Left . T.pack . E.displayException) Right + (Conduit.parseText Conduit.def{ Conduit.psRetainNamespaces = True } t) + +parseXMLContents :: TL.Text -> Either T.Text [Content] +parseXMLContents t = + case Conduit.parseText Conduit.def{ Conduit.psRetainNamespaces = True } t of + Left e -> + case E.fromException e of + Just (ContentAfterRoot _) -> + elContent <$> parseXMLElement ("" <> t <> "") + _ -> Left . T.pack . E.displayException $ e + Right x -> Right [Elem . elementToElement . Conduit.documentRoot $ x] + +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 new file mode 100644 --- /dev/null +++ b/src/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 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/src/Text/Pandoc/XML/Light/Proc.hs b/src/Text/Pandoc/XML/Light/Proc.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/XML/Light/Proc.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{- | + Module : Text.Pandoc.XML.Light.Proc + Copyright : Copyright (C) 2007 Galois, Inc., 2021 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 occurances of an element. +-- (i.e., once we have found an element, we do not search +-- for more occurances 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 occurances 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 occurences of an element wrt a predicate over element names. +-- (i.e., once we have found an element, we do not search +-- for more occurances 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 new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/XML/Light/Types.hs @@ -0,0 +1,193 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveDataTypeable #-} +{- | + Module : Text.Pandoc.XML.Light.Types + Copyright : Copyright (C) 2007 Galois, Inc., 2021 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) + +-- | XML elements +data Element = Element { + elName :: QName, + elAttribs :: [Attr], + elContent :: [Content], + elLine :: Maybe Line + } deriving (Show, Typeable, Data) + +-- | 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) + +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) + + diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -5,25 +5,13 @@ packages: - '.' extra-deps: -- pandoc-types-1.22 -- rfc5051-0.2 -- haddock-library-1.9.0 -- skylighting-0.10.2 -- skylighting-core-0.10.2 -- hslua-1.1.2 -- jira-wiki-markup-1.3.2 -- HsYAML-aeson-0.2.0.0 -- commonmark-0.1.1.3 -- commonmark-extensions-0.2.0.4 -- commonmark-pandoc-0.2.0.1 -- doctemplates-0.9 -- texmath-0.12.1 -- citeproc-0.3.0.5 -# - citeproc: -# git: https://github.com/jgm/citeproc.git -# commit: d44e24696ab444090d0e63e321c3a573f68b2e74 +- hslua-1.3.0 +- hslua-module-path-0.1.0 +#- citeproc: +# git: https://github.com/jgm/citeproc.git +# commit: feb3b7580c6738eec3b23921f7c1739cfba611aa ghc-options: "$locals": -fhide-source-paths -Wno-missing-home-modules -resolver: lts-16.23 +resolver: lts-17.5 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,4 +1,4 @@ -{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TupleSections #-} {- | Module : Tests.Command Copyright : © 2006-2021 John MacFarlane @@ -10,19 +10,18 @@ Run commands, and test results, defined in markdown files. -} -module Tests.Command (findPandoc, runTest, tests) +module Tests.Command (runTest, tests) where -import Prelude import Data.Algorithm.Diff +import System.Environment.Executable (getExecutablePath) import qualified Data.ByteString as BS import qualified Data.Text as T -import Data.List (isSuffixOf, intercalate) -import Data.Maybe (catMaybes) +import Data.List (isSuffixOf) import System.Directory import qualified System.Environment as Env import System.Exit -import System.FilePath (joinPath, splitDirectories, takeDirectory, ()) +import System.FilePath (takeDirectory, ()) import System.IO (hPutStr, stderr) import System.IO.Unsafe (unsafePerformIO) import System.Process @@ -34,27 +33,21 @@ import qualified Text.Pandoc.UTF8 as UTF8 -- | Run a test with and return output. -execTest :: FilePath -- ^ Path to pandoc +execTest :: String -- ^ Path to test executable -> String -- ^ Shell command -> String -- ^ Input text -> IO (ExitCode, String) -- ^ Exit code and actual output -execTest pandocpath cmd inp = do +execTest testExePath cmd inp = do mldpath <- Env.lookupEnv "LD_LIBRARY_PATH" mdyldpath <- Env.lookupEnv "DYLD_LIBRARY_PATH" - let findDynlibDir [] = Nothing - findDynlibDir ("build":xs) = Just $ joinPath (reverse xs) "build" - findDynlibDir (_:xs) = findDynlibDir xs - let mbDynlibDir = findDynlibDir (reverse $ splitDirectories $ - takeDirectory $ takeWhile (/=' ') cmd) - let dynlibEnv = [("DYLD_LIBRARY_PATH", - intercalate ":" $ catMaybes [mbDynlibDir, mdyldpath]) - ,("LD_LIBRARY_PATH", - intercalate ":" $ catMaybes [mbDynlibDir, mldpath])] - let env' = dynlibEnv ++ [("PATH",takeDirectory pandocpath),("TMP","."), - ("LANG","en_US.UTF-8"), - ("HOME", "./"), - ("pandoc_datadir", "..")] - let pr = (shell cmd){ env = Just env' } + let env' = ("PATH",takeDirectory testExePath) : + ("TMP",".") : + ("LANG","en_US.UTF-8") : + ("HOME", "./") : + ("pandoc_datadir", "..") : + maybe [] ((:[]) . ("LD_LIBRARY_PATH",)) mldpath ++ + maybe [] ((:[]) . ("DYLD_LIBRARY_PATH",)) mdyldpath + let pr = (shell (pandocToEmulate True cmd)){ env = Just env' } (ec, out', err') <- readCreateProcessWithExitCode pr inp -- filter \r so the tests will work on Windows machines let out = filter (/= '\r') $ err' ++ out' @@ -63,15 +56,23 @@ ExitSuccess -> return () return (ec, out) +pandocToEmulate :: Bool -> String -> String +pandocToEmulate True ('p':'a':'n':'d':'o':'c':cs) = + "test-pandoc --emulate" ++ pandocToEmulate False cs +pandocToEmulate False ('|':' ':'p':'a':'n':'d':'o':'c':cs) = + "| " ++ "test-pandoc --emulate" ++ pandocToEmulate False cs +pandocToEmulate _ (c:cs) = c : pandocToEmulate False cs +pandocToEmulate _ [] = [] + -- | Run a test, return True if test passed. -runTest :: String -- ^ Title of test - -> FilePath -- ^ Path to pandoc +runTest :: String -- ^ Path to test executable + -> String -- ^ Title of test -> String -- ^ Shell command -> String -- ^ Input text -> String -- ^ Expected output -> TestTree -runTest testname pandocpath cmd inp norm = testCase testname $ do - (ec, out) <- execTest pandocpath cmd inp +runTest testExePath testname cmd inp norm = testCase testname $ do + (ec, out) <- execTest testExePath cmd inp result <- if ec == ExitSuccess then if out == norm @@ -82,12 +83,13 @@ else return $ TestError ec assertBool (show result) (result == TestPassed) -tests :: FilePath -> TestTree +tests :: TestTree {-# NOINLINE tests #-} -tests pandocPath = unsafePerformIO $ do +tests = unsafePerformIO $ do files <- filter (".md" `isSuffixOf`) <$> getDirectoryContents "command" - let cmds = map (extractCommandTest pandocPath) files + testExePath <- getExecutablePath + let cmds = map (extractCommandTest testExePath) files return $ testGroup "Command:" cmds isCodeBlock :: Block -> Bool @@ -103,7 +105,7 @@ dropPercent xs = xs runCommandTest :: FilePath -> FilePath -> Int -> String -> TestTree -runCommandTest pandocpath fp num code = +runCommandTest testExePath fp num code = goldenTest testname getExpected getActual compareValues updateGolden where testname = "#" <> show num @@ -116,7 +118,7 @@ input = unlines inplines norm = unlines normlines getExpected = return norm - getActual = snd <$> execTest pandocpath cmd input + getActual = snd <$> execTest testExePath cmd input compareValues expected actual | actual == expected = return Nothing | otherwise = return $ Just $ "--- test/command/" ++ fp ++ "\n+++ " ++ @@ -128,14 +130,14 @@ let cmdline = "% " <> cmd let x = cmdline <> "\n" <> input <> "^D\n" <> norm let y = cmdline <> "\n" <> input <> "^D\n" <> newnorm - let updated = T.unpack $ T.replace (T.pack x) (T.pack y) (T.pack raw) + let updated = T.replace (T.pack x) (T.pack y) raw UTF8.writeFile fp' updated extractCommandTest :: FilePath -> FilePath -> TestTree -extractCommandTest pandocpath fp = unsafePerformIO $ do +extractCommandTest testExePath fp = unsafePerformIO $ do contents <- UTF8.toText <$> BS.readFile ("command" fp) Pandoc _ blocks <- runIOorExplode (readMarkdown def{ readerExtensions = pandocExtensions } contents) let codeblocks = map extractCode $ filter isCodeBlock blocks - let cases = zipWith (runCommandTest pandocpath fp) [1..] codeblocks + let cases = zipWith (runCommandTest testExePath fp) [1..] codeblocks return $ testGroup fp cases diff --git a/test/Tests/Helpers.hs b/test/Tests/Helpers.hs --- a/test/Tests/Helpers.hs +++ b/test/Tests/Helpers.hs @@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE FlexibleInstances #-} {- | Module : Tests.Helpers @@ -15,7 +14,6 @@ module Tests.Helpers ( test , TestResult(..) , showDiff - , findPandoc , (=?>) , purely , ToString(..) @@ -23,14 +21,10 @@ ) where -import Prelude import Data.Algorithm.Diff import qualified Data.Map as M import Data.Text (Text, unpack) -import System.Directory -import System.Environment.Executable (getExecutablePath) import System.Exit -import System.FilePath import Test.Tasty import Test.Tasty.HUnit import Text.Pandoc.Builder (Blocks, Inlines, doc, plain) @@ -41,7 +35,7 @@ import Text.Pandoc.Writers.Native (writeNative) import Text.Printf -test :: (ToString a, ToString b, ToString c) +test :: (ToString a, ToString b, ToString c, HasCallStack) => (a -> b) -- ^ function to test -> String -- ^ name of test case -> (a, c) -- ^ (input, expected value) @@ -85,34 +79,6 @@ printf "-%4d " r ++ ln ++ "\n" ++ showDiff (l,r+1) ds showDiff (l,r) (Both _ _ : ds) = showDiff (l+1,r+1) ds - --- | Find pandoc executable relative to test-pandoc -findPandoc :: IO FilePath -findPandoc = do - testExePath <- getExecutablePath - let pandocDir = - case reverse (splitDirectories (takeDirectory testExePath)) of - -- cabalv2 with --disable-optimization - "test-pandoc" : "build" : "noopt" : "test-pandoc" : "t" : ps - -> joinPath (reverse ps) - "x" "pandoc" "noopt" "build" "pandoc" - -- cabalv2 without --disable-optimization - "test-pandoc" : "build" : "test-pandoc" : "t" : ps - -> joinPath (reverse ps) - "x" "pandoc" "build" "pandoc" - -- cabalv1 - "test-pandoc" : "build" : ps - -> joinPath (reverse ps) "build" "pandoc" - _ -> error "findPandoc: could not find pandoc executable" - let pandocPath = pandocDir "pandoc" -#ifdef _WINDOWS - <.> "exe" -#endif - found <- doesFileExist pandocPath - if found - then return pandocPath - else error $ "findPandoc: could not find pandoc executable at " - ++ pandocPath vividize :: Diff String -> String vividize (Both s _) = " " ++ s diff --git a/test/Tests/Lua.hs b/test/Tests/Lua.hs --- a/test/Tests/Lua.hs +++ b/test/Tests/Lua.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {- | @@ -14,7 +13,6 @@ -} module Tests.Lua ( runLuaTest, tests ) where -import Prelude import Control.Monad (when) import System.FilePath (()) import Test.Tasty (TestTree, localOption) diff --git a/test/Tests/Lua/Module.hs b/test/Tests/Lua/Module.hs --- a/test/Tests/Lua/Module.hs +++ b/test/Tests/Lua/Module.hs @@ -25,6 +25,8 @@ ("lua" "module" "pandoc-list.lua") , testPandocLua "pandoc.mediabag" ("lua" "module" "pandoc-mediabag.lua") + , testPandocLua "pandoc.path" + ("lua" "module" "pandoc-path.lua") , testPandocLua "pandoc.types" ("lua" "module" "pandoc-types.lua") , testPandocLua "pandoc.util" diff --git a/test/Tests/Old.hs b/test/Tests/Old.hs --- a/test/Tests/Old.hs +++ b/test/Tests/Old.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TupleSections #-} {- | Module : Tests.Old Copyright : © 2006-2021 John MacFarlane @@ -12,18 +12,17 @@ -} module Tests.Old (tests) where -import Prelude import Data.Algorithm.Diff -import Data.List (intercalate) -import Data.Maybe (catMaybes) import System.Exit -import System.FilePath (joinPath, splitDirectories, (<.>), ()) +import System.FilePath ((<.>), ()) import qualified System.Environment as Env +import System.Environment.Executable (getExecutablePath) import Text.Pandoc.Process (pipeProcess) import Test.Tasty (TestTree, testGroup) import Test.Tasty.Golden.Advanced (goldenTest) import Tests.Helpers hiding (test) import qualified Text.Pandoc.UTF8 as UTF8 +import qualified Data.Text as T tests :: FilePath -> [TestTree] tests pandocPath = @@ -233,7 +232,7 @@ -- makes sure file is fully closed after reading readFile' :: FilePath -> IO String readFile' f = do s <- UTF8.readFile f - return $! (length s `seq` s) + return $! (T.length s `seq` T.unpack s) lhsWriterTests :: FilePath -> String -> [TestTree] lhsWriterTests pandocPath format @@ -322,25 +321,26 @@ getActual = do mldpath <- Env.lookupEnv "LD_LIBRARY_PATH" mdyldpath <- Env.lookupEnv "DYLD_LIBRARY_PATH" - let mbDynlibDir = findDynlibDir (reverse $ - splitDirectories pandocPath) - let dynlibEnv = [("DYLD_LIBRARY_PATH", intercalate ":" $ catMaybes [mbDynlibDir, mdyldpath]) - ,("LD_LIBRARY_PATH", intercalate ":" $ catMaybes [mbDynlibDir, mldpath])] - let env = dynlibEnv ++ - [("TMP","."),("LANG","en_US.UTF-8"),("HOME", "./")] - (ec, out) <- pipeProcess (Just env) pandocPath options mempty + let env = ("TMP",".") : + ("LANG","en_US.UTF-8") : + ("HOME", "./") : + maybe [] ((:[]) . ("LD_LIBRARY_PATH",)) mldpath ++ + maybe [] ((:[]) . ("DYLD_LIBRARY_PATH",)) mdyldpath + + (ec, out) <- pipeProcess (Just env) pandocPath + ("--emulate":options) mempty if ec == ExitSuccess then return $ filter (/='\r') . normalizer $ UTF8.toStringLazy out -- filter \r so the tests will work on Windows machines else fail $ "Pandoc failed with error code " ++ show ec - updateGolden = UTF8.writeFile norm + updateGolden = UTF8.writeFile norm . T.pack options = ["--data-dir=../data","--quiet"] ++ [inp] ++ opts compareValues :: FilePath -> [String] -> String -> String -> IO (Maybe String) compareValues norm options expected actual = do - pandocPath <- findPandoc - let cmd = pandocPath ++ " " ++ unwords options + testExePath <- getExecutablePath + let cmd = testExePath ++ " --emulate " ++ unwords options let dash = replicate 72 '-' let diff = getDiff (lines actual) (lines expected) if expected == actual @@ -350,8 +350,3 @@ "\n--- " ++ norm ++ "\n+++ " ++ cmd ++ "\n" ++ showDiff (1,1) diff ++ dash - -findDynlibDir :: [FilePath] -> Maybe FilePath -findDynlibDir [] = Nothing -findDynlibDir ("build":xs) = Just $ joinPath (reverse xs) "build" -findDynlibDir (_:xs) = findDynlibDir xs 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 @@ -1,4 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {- | Module : Tests.Readers.Creole @@ -14,7 +13,6 @@ -} module Tests.Readers.Creole (tests) where -import Prelude import Data.Text (Text) import qualified Data.Text as T import Test.Tasty diff --git a/test/Tests/Readers/Docx.hs b/test/Tests/Readers/Docx.hs --- a/test/Tests/Readers/Docx.hs +++ b/test/Tests/Readers/Docx.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {- | Module : Tests.Readers.Docx @@ -13,7 +12,6 @@ -} module Tests.Readers.Docx (tests) where -import Prelude import Codec.Archive.Zip import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as B diff --git a/test/Tests/Readers/DokuWiki.hs b/test/Tests/Readers/DokuWiki.hs --- a/test/Tests/Readers/DokuWiki.hs +++ b/test/Tests/Readers/DokuWiki.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {- | @@ -14,7 +13,6 @@ -} module Tests.Readers.DokuWiki (tests) where -import Prelude import Data.Text (Text) import qualified Data.Text as T import Test.Tasty 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,4 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} {- | Module : Tests.Readers.EPUB Copyright : © 2006-2021 John MacFarlane @@ -12,7 +11,6 @@ -} module Tests.Readers.EPUB (tests) where -import Prelude import qualified Data.ByteString.Lazy as BL import qualified Data.Text as T import Test.Tasty diff --git a/test/Tests/Readers/FB2.hs b/test/Tests/Readers/FB2.hs --- a/test/Tests/Readers/FB2.hs +++ b/test/Tests/Readers/FB2.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} {- | Module : Tests.Readers.FB2 Copyright : © 2018-2020 Alexander Krotov @@ -12,7 +11,6 @@ -} module Tests.Readers.FB2 (tests) where -import Prelude import Test.Tasty import Tests.Helpers import Test.Tasty.Golden (goldenVsString) 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,4 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {- | Module : Tests.Readers.HTML @@ -13,7 +12,6 @@ -} module Tests.Readers.HTML (tests) where -import Prelude import Data.Text (Text) import qualified Data.Text as T import Test.Tasty diff --git a/test/Tests/Readers/JATS.hs b/test/Tests/Readers/JATS.hs --- a/test/Tests/Readers/JATS.hs +++ b/test/Tests/Readers/JATS.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {- | Module : Tests.Readers.JATS @@ -13,7 +12,6 @@ -} module Tests.Readers.JATS (tests) where -import Prelude import Data.Text (Text) import Test.Tasty import Tests.Helpers @@ -90,6 +88,7 @@ "

\n\ \ \n\ \ \n\ + \ \n\ \

" =?> para (math "\\sigma|_{\\{x\\}}") , test jats "math ml only" $ 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 @@ -1,4 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {- | @@ -35,6 +34,9 @@ [ testGroup "para" [ "Simple sentence" =: "Hello, World!" =?> para "Hello, World!" + + , "leading blank lines" =: + "\n\ntext" =?> para "text" ] , testGroup "header" @@ -131,6 +133,10 @@ [ "external" =: "[Example|https://example.org]" =?> para (link "https://example.org" "" "Example") + + , "URL in alias" =: + "[See https://example.com|https://example.com]" =?> + para (link "https://example.com" "" "See https://example.com") , "email" =: "[mailto:me@example.org]" =?> 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,4 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {- | Module : Tests.Readers.LaTeX @@ -13,14 +12,9 @@ -} module Tests.Readers.LaTeX (tests) where -import Prelude import Data.Text (Text) import qualified Data.Text as T -import qualified Text.Pandoc.UTF8 as UTF8 -import Text.Pandoc.Readers.LaTeX (tokenize, untokenize) import Test.Tasty -import Test.Tasty.HUnit -import Test.Tasty.QuickCheck import Tests.Helpers import Text.Pandoc import Text.Pandoc.Arbitrary () @@ -49,21 +43,8 @@ where toRow = Row nullAttr . map simpleCell -tokUntokRt :: String -> Bool -tokUntokRt s = untokenize (tokenize "random" t) == t - where t = T.pack s - tests :: [TestTree] -tests = [ testGroup "tokenization" - [ testCase "tokenizer round trip on test case" $ do - orig <- T.pack <$> UTF8.readFile "../test/latex-reader.latex" - let new = untokenize $ tokenize "../test/latex-reader.latex" - orig - assertEqual "untokenize . tokenize is identity" orig new - , testProperty "untokenize . tokenize is identity" tokUntokRt - ] - - , testGroup "basic" +tests = [ testGroup "basic" [ "simple" =: "word" =?> para "word" , "space" =: 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 @@ -13,7 +13,6 @@ -} module Tests.Readers.Man (tests) where -import Prelude import Data.Text (Text) import Test.Tasty import Tests.Helpers 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,4 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {- | Module : Tests.Readers.Markdown @@ -13,7 +12,6 @@ -} module Tests.Readers.Markdown (tests) where -import Prelude import Data.Text (Text, unpack) import qualified Data.Text as T import Test.Tasty diff --git a/test/Tests/Readers/Muse.hs b/test/Tests/Readers/Muse.hs --- a/test/Tests/Readers/Muse.hs +++ b/test/Tests/Readers/Muse.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {- | Module : Tests.Readers.Muse @@ -13,7 +12,6 @@ -} module Tests.Readers.Muse (tests) where -import Prelude import Data.List (intersperse) import Data.Monoid (Any (..)) import Data.Text (Text) diff --git a/test/Tests/Readers/Odt.hs b/test/Tests/Readers/Odt.hs --- a/test/Tests/Readers/Odt.hs +++ b/test/Tests/Readers/Odt.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {- | Module : Tests.Readers.Odt @@ -14,7 +13,6 @@ -} module Tests.Readers.Odt (tests) where -import Prelude import Control.Monad (liftM) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as B 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,4 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {- | Module : Tests.Readers.Org.Block @@ -13,7 +12,6 @@ -} module Tests.Readers.Org.Block (tests) where -import Prelude import Test.Tasty (TestTree, testGroup) import Tests.Helpers ((=?>)) import Tests.Readers.Org.Shared ((=:), spcSep) 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,4 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {- | Module : Tests.Readers.Org.Block.CodeBlock @@ -13,7 +12,6 @@ -} module Tests.Readers.Org.Block.CodeBlock (tests) where -import Prelude import Test.Tasty (TestTree) import Tests.Helpers ((=?>)) import Tests.Readers.Org.Shared ((=:), spcSep) 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,4 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {- | Module : Tests.Readers.Org.Block.Figure @@ -13,7 +12,6 @@ -} module Tests.Readers.Org.Block.Figure (tests) where -import Prelude import Test.Tasty (TestTree) import Tests.Helpers ((=?>)) import Tests.Readers.Org.Shared ((=:)) 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,4 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {- | Module : Tests.Readers.Org.Block.Header @@ -13,7 +12,6 @@ -} module Tests.Readers.Org.Block.Header (tests) where -import Prelude import Test.Tasty (TestTree, testGroup) import Tests.Helpers ((=?>)) import Tests.Readers.Org.Shared ((=:), spcSep, tagSpan) 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,4 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {- | Module : Tests.Readers.Org.Block.Header @@ -13,7 +12,6 @@ -} module Tests.Readers.Org.Block.List (tests) where -import Prelude import Test.Tasty (TestTree) import Tests.Helpers ((=?>)) import Tests.Readers.Org.Shared ((=:), spcSep) @@ -119,6 +117,19 @@ , "- " ] =?> bulletList [ plain "", plain "" ] + + , "Task list" =: + T.unlines [ "- [ ] nope" + , "- [X] yup" + , "- [-] started" + , " 1. [X] sure" + , " 2. [ ] nuh-uh" + ] =?> + bulletList [ plain "☐ nope", plain "☒ yup" + , mconcat [ plain "☐ started" + , orderedList [plain "☒ sure", plain "☐ nuh-uh"] + ] + ] , "Simple Ordered List" =: ("1. Item1\n" <> 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,4 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {- | Module : Tests.Readers.Org.Block.Table @@ -13,7 +12,6 @@ -} module Tests.Readers.Org.Block.Table (tests) where -import Prelude import Test.Tasty (TestTree) import Tests.Helpers ((=?>)) import Tests.Readers.Org.Shared ((=:), spcSep) 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,4 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {- | Module : Tests.Readers.Org.Directive @@ -13,7 +12,6 @@ -} module Tests.Readers.Org.Directive (tests) where -import Prelude import Data.Time (UTCTime (UTCTime), secondsToDiffTime) import Data.Time.Calendar (Day (ModifiedJulianDay)) import Test.Tasty (TestTree, testGroup) 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,4 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {- | Module : Tests.Readers.Org.Inline @@ -13,7 +12,6 @@ -} module Tests.Readers.Org.Inline (tests) where -import Prelude import Data.List (intersperse) import Test.Tasty (TestTree, testGroup) import Tests.Helpers ((=?>)) 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,4 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {- | Module : Tests.Readers.Org.Inline.Citation @@ -13,7 +12,6 @@ -} module Tests.Readers.Org.Inline.Citation (tests) where -import Prelude import Test.Tasty (TestTree, testGroup) import Tests.Helpers ((=?>)) import Tests.Readers.Org.Shared ((=:)) @@ -117,6 +115,46 @@ , citationHash = 0 } in (para $ cite [citation] "citep:pandoc") + + , "multiple simple citations" =: + "citep:picard,riker" =?> + let picard = Citation + { citationId = "picard" + , citationPrefix = mempty + , citationSuffix = mempty + , citationMode = NormalCitation + , citationNoteNum = 0 + , citationHash = 0 + } + riker = Citation + { citationId = "riker" + , citationPrefix = mempty + , citationSuffix = mempty + , citationMode = NormalCitation + , citationNoteNum = 0 + , citationHash = 0 + } + in (para $ cite [picard,riker] "citep:picard,riker") + + , "multiple simple citations succeeded by comma" =: + "citep:picard,riker," =?> + let picard = Citation + { citationId = "picard" + , citationPrefix = mempty + , citationSuffix = mempty + , citationMode = NormalCitation + , citationNoteNum = 0 + , citationHash = 0 + } + riker = Citation + { citationId = "riker" + , citationPrefix = mempty + , citationSuffix = mempty + , citationMode = NormalCitation + , citationNoteNum = 0 + , citationHash = 0 + } + in (para $ cite [picard,riker] "citep:picard,riker" <> str ",") , "extended citation" =: "[[citep:Dominik201408][See page 20::, for example]]" =?> 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,4 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {- | Module : Tests.Readers.Org.Inline.Note @@ -13,7 +12,6 @@ -} module Tests.Readers.Org.Inline.Note (tests) where -import Prelude import Test.Tasty (TestTree) import Tests.Helpers ((=?>)) import Tests.Readers.Org.Shared ((=:)) 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,4 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {- | Module : Tests.Readers.Org.Inline.Smart @@ -13,7 +12,6 @@ -} module Tests.Readers.Org.Inline.Smart (tests) where -import Prelude import Data.Text (Text) import Test.Tasty (TestTree) import Tests.Helpers ((=?>), purely, test) 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,4 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {- | Module : Tests.Readers.Org.Meta @@ -13,7 +12,6 @@ -} module Tests.Readers.Org.Meta (tests) where -import Prelude import Test.Tasty (TestTree, testGroup) import Tests.Helpers ((=?>)) import Tests.Readers.Org.Shared ((=:), spcSep) 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,4 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {- | Module : Tests.Readers.Org.Shared @@ -18,7 +17,6 @@ , tagSpan ) where -import Prelude import Data.List (intersperse) import Data.Text (Text) import Tests.Helpers (ToString, purely, test) 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 @@ -1,4 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {- | @@ -14,7 +13,6 @@ -} module Tests.Readers.RST (tests) where -import Prelude import Data.Text (Text) import qualified Data.Text as T import Test.Tasty 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,4 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {- | Module : Tests.Readers.Txt2Tags @@ -14,7 +13,6 @@ -} module Tests.Readers.Txt2Tags (tests) where -import Prelude import Data.List (intersperse) import Data.Text (Text) import qualified Data.Text as T diff --git a/test/Tests/Shared.hs b/test/Tests/Shared.hs --- a/test/Tests/Shared.hs +++ b/test/Tests/Shared.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {- | Module : Tests.Shared @@ -13,7 +12,6 @@ -} module Tests.Shared (tests) where -import Prelude import System.FilePath.Posix (joinPath) import Test.Tasty import Test.Tasty.HUnit (assertBool, testCase, (@?=)) diff --git a/test/Tests/Writers/AnnotatedTable.hs b/test/Tests/Writers/AnnotatedTable.hs --- a/test/Tests/Writers/AnnotatedTable.hs +++ b/test/Tests/Writers/AnnotatedTable.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {- | Module : Tests.Writers.AnnotatedTable 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 @@ -1,8 +1,6 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} module Tests.Writers.AsciiDoc (tests) where -import Prelude import Data.Text (unpack) import Test.Tasty import Tests.Helpers 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 @@ -1,8 +1,6 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} module Tests.Writers.ConTeXt (tests) where -import Prelude import Data.Text (unpack, pack) import Test.Tasty import Test.Tasty.QuickCheck diff --git a/test/Tests/Writers/Docbook.hs b/test/Tests/Writers/Docbook.hs --- a/test/Tests/Writers/Docbook.hs +++ b/test/Tests/Writers/Docbook.hs @@ -1,8 +1,6 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} module Tests.Writers.Docbook (tests) where -import Prelude import Data.Text (unpack) import Test.Tasty import Tests.Helpers diff --git a/test/Tests/Writers/Docx.hs b/test/Tests/Writers/Docx.hs --- a/test/Tests/Writers/Docx.hs +++ b/test/Tests/Writers/Docx.hs @@ -1,7 +1,5 @@ -{-# LANGUAGE NoImplicitPrelude #-} module Tests.Writers.Docx (tests) where -import Prelude import Text.Pandoc import Test.Tasty import Tests.Writers.OOXML diff --git a/test/Tests/Writers/FB2.hs b/test/Tests/Writers/FB2.hs --- a/test/Tests/Writers/FB2.hs +++ b/test/Tests/Writers/FB2.hs @@ -1,8 +1,6 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} module Tests.Writers.FB2 (tests) where -import Prelude import Test.Tasty import Tests.Helpers import Text.Pandoc 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 @@ -1,8 +1,6 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} module Tests.Writers.HTML (tests) where -import Prelude import Data.Text (unpack) import Test.Tasty import Tests.Helpers 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 @@ -1,8 +1,6 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} module Tests.Writers.JATS (tests) where -import Prelude import Data.Text (unpack) import Test.Tasty import Tests.Helpers diff --git a/test/Tests/Writers/Jira.hs b/test/Tests/Writers/Jira.hs --- a/test/Tests/Writers/Jira.hs +++ b/test/Tests/Writers/Jira.hs @@ -3,6 +3,7 @@ import Data.Text (unpack) import Test.Tasty +import Test.Tasty.HUnit (HasCallStack) import Tests.Helpers import Text.Pandoc import Text.Pandoc.Arbitrary () @@ -12,7 +13,7 @@ jira = unpack . purely (writeJira def) . toPandoc infix 4 =: -(=:) :: (ToString a, ToPandoc a) +(=:) :: (ToString a, ToPandoc a, HasCallStack) => String -> (a, String) -> TestTree (=:) = test jira @@ -60,6 +61,22 @@ , "user link with user as description" =: linkWith ("", ["user-account"], []) "~johndoe" "" "~johndoe" =?> "[~johndoe]" + ] + + , testGroup "spans" + [ "id is used as anchor" =: + spanWith ("unicorn", [], []) (str "Unicorn") =?> + "{anchor:unicorn}Unicorn" + ] + + , testGroup "code" + [ "code block with known language" =: + codeBlockWith ("", ["java"], []) "Book book = new Book(\"Algebra\")" =?> + "{code:java}\nBook book = new Book(\"Algebra\")\n{code}" + + , "code block without language" =: + codeBlockWith ("", [], []) "preformatted\n text.\n" =?> + "{noformat}\npreformatted\n text.\n{noformat}" ] ] ] 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 @@ -1,8 +1,6 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} module Tests.Writers.LaTeX (tests) where -import Prelude import Data.Text (unpack) import Test.Tasty import Tests.Helpers diff --git a/test/Tests/Writers/Markdown.hs b/test/Tests/Writers/Markdown.hs --- a/test/Tests/Writers/Markdown.hs +++ b/test/Tests/Writers/Markdown.hs @@ -1,9 +1,7 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} module Tests.Writers.Markdown (tests) where -import Prelude import Data.Text (unpack) import Test.Tasty import Tests.Helpers diff --git a/test/Tests/Writers/Ms.hs b/test/Tests/Writers/Ms.hs --- a/test/Tests/Writers/Ms.hs +++ b/test/Tests/Writers/Ms.hs @@ -1,8 +1,6 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} module Tests.Writers.Ms (tests) where -import Prelude import Test.Tasty import Tests.Helpers import Text.Pandoc 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 @@ -1,4 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} module Tests.Writers.Muse (tests) where diff --git a/test/Tests/Writers/Native.hs b/test/Tests/Writers/Native.hs --- a/test/Tests/Writers/Native.hs +++ b/test/Tests/Writers/Native.hs @@ -1,7 +1,5 @@ -{-# LANGUAGE NoImplicitPrelude #-} module Tests.Writers.Native (tests) where -import Prelude import Data.Text (unpack) import Test.Tasty import Test.Tasty.QuickCheck diff --git a/test/Tests/Writers/OOXML.hs b/test/Tests/Writers/OOXML.hs --- a/test/Tests/Writers/OOXML.hs +++ b/test/Tests/Writers/OOXML.hs @@ -1,10 +1,8 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE OverloadedStrings #-} module Tests.Writers.OOXML (ooxmlTest) where -import Prelude import Text.Pandoc import Test.Tasty import Test.Tasty.Golden.Advanced @@ -45,7 +43,8 @@ displayDiff :: Content -> Content -> String displayDiff elemA elemB = - showDiff (1,1) $ getDiff (lines $ ppContent elemA) (lines $ ppContent elemB) + showDiff (1,1) + (getDiff (lines $ showContent elemA) (lines $ showContent elemB)) goldenArchive :: FilePath -> IO Archive goldenArchive fp = toArchive . BL.fromStrict <$> BS.readFile fp diff --git a/test/Tests/Writers/Org.hs b/test/Tests/Writers/Org.hs --- a/test/Tests/Writers/Org.hs +++ b/test/Tests/Writers/Org.hs @@ -1,8 +1,7 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} module Tests.Writers.Org (tests) where -import Prelude +import Data.Text as T import Test.Tasty import Tests.Helpers import Text.Pandoc @@ -11,17 +10,51 @@ infix 4 =: (=:) :: (ToString a, ToPandoc a) - => String -> (a, String) -> TestTree -(=:) = test (purely (writeOrg def . toPandoc)) + => String -> (a, Text) -> TestTree +(=:) = test org +defopts :: WriterOptions +defopts = def + { writerExtensions = getDefaultExtensions "org" + } + +org :: (ToPandoc a) => a -> Text +org = orgWithOpts defopts + +orgWithOpts :: (ToPandoc a) => WriterOptions -> a -> Text +orgWithOpts opts x = purely (writeOrg opts) $ toPandoc x + + tests :: [TestTree] -tests = [ testGroup "links" - -- See http://orgmode.org/manual/Internal-links.html#Internal-links - [ "simple link" - =: link "/url" "" "foo" - =?> "[[/url][foo]]" - , "internal link to anchor" - =: link "#my-custom-id" "" "#my-custom-id" - =?> "[[#my-custom-id]]" +tests = + [ testGroup "links" + -- See http://orgmode.org/manual/Internal-links.html#Internal-links + [ "simple link" + =: link "/url" "" "foo" + =?> "[[/url][foo]]" + , "internal link to anchor" + =: link "#my-custom-id" "" "#my-custom-id" + =?> "[[#my-custom-id]]" + ] + + , testGroup "lists" + [ "bullet task list" + =: bulletList [plain "☐ a", plain "☒ b"] + =?> T.unlines + [ "- [ ] a" + , "- [X] b" ] - ] + , "ordered task list" + =: orderedList [plain ("☐" <> space <> "a"), plain "☒ b"] + =?> T.unlines + [ "1. [ ] a" + , "2. [X] b" + ] + , test (orgWithOpts def) "bullet without task_lists" $ + bulletList [plain "☐ a", plain "☒ b"] + =?> T.unlines + [ "- ☐ a" + , "- ☒ b" + ] + ] + ] diff --git a/test/Tests/Writers/Plain.hs b/test/Tests/Writers/Plain.hs --- a/test/Tests/Writers/Plain.hs +++ b/test/Tests/Writers/Plain.hs @@ -1,8 +1,6 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} module Tests.Writers.Plain (tests) where -import Prelude import Test.Tasty import Tests.Helpers import Text.Pandoc diff --git a/test/Tests/Writers/Powerpoint.hs b/test/Tests/Writers/Powerpoint.hs --- a/test/Tests/Writers/Powerpoint.hs +++ b/test/Tests/Writers/Powerpoint.hs @@ -1,7 +1,5 @@ -{-# LANGUAGE NoImplicitPrelude #-} module Tests.Writers.Powerpoint (tests) where -import Prelude import Tests.Writers.OOXML (ooxmlTest) import Text.Pandoc import Test.Tasty diff --git a/test/Tests/Writers/RST.hs b/test/Tests/Writers/RST.hs --- a/test/Tests/Writers/RST.hs +++ b/test/Tests/Writers/RST.hs @@ -1,8 +1,6 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} module Tests.Writers.RST (tests) where -import Prelude import Control.Monad.Identity import Test.Tasty import Test.Tasty.HUnit diff --git a/test/Tests/Writers/TEI.hs b/test/Tests/Writers/TEI.hs --- a/test/Tests/Writers/TEI.hs +++ b/test/Tests/Writers/TEI.hs @@ -1,8 +1,6 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} module Tests.Writers.TEI (tests) where -import Prelude import Test.Tasty import Tests.Helpers import Text.Pandoc diff --git a/test/command/5321.md b/test/command/5321.md --- a/test/command/5321.md +++ b/test/command/5321.md @@ -4,7 +4,7 @@

bar

- + ^D [Para [Image ("fig-1",[],[]) [Str "bar"] ("foo.png","fig:")]] @@ -17,7 +17,7 @@ foo

bar

- + ^D [Para [Image ("fig-1",[],[]) [Str "foo",LineBreak,Str "bar"] ("foo.png","fig:")]] diff --git a/test/command/5686.md b/test/command/5686.md --- a/test/command/5686.md +++ b/test/command/5686.md @@ -4,6 +4,6 @@ This part does not make it to the html output. ^D -[Para [Str "FOO",RawInline (Format "tex") "\\t0BAR"] +[Para [Str "FOO",RawInline (Format "tex") "\\t0",Str "BAR"] ,Para [Str "This",Space,Str "part",Space,Str "does",Space,Str "not",Space,Str "make",Space,Str "it",Space,Str "to",Space,Str "the",Space,Str "html",Space,Str "output."]] ``` diff --git a/test/command/7058.md b/test/command/7058.md new file mode 100644 --- /dev/null +++ b/test/command/7058.md @@ -0,0 +1,6 @@ +``` +% pandoc -f latex -t markdown +5\(-\)8 \(x\) +^D +5$-$``{=html}8 $x$ +``` diff --git a/test/command/7064.md b/test/command/7064.md new file mode 100644 --- /dev/null +++ b/test/command/7064.md @@ -0,0 +1,32 @@ +``` +% pandoc -f rst -t html +.. csv-table:: Changes + :header: "Version", "Date", "Description" + :widths: 15, 15, 70 + :delim: $ + + 0.1.0 $ 18/02/2013 $ Initial Release +^D + + +++++ + + + + + + + + + + + + + + +
Changes
VersionDateDescription
0.1.018/02/2013Initial Release
+``` diff --git a/test/command/7067.md b/test/command/7067.md new file mode 100644 --- /dev/null +++ b/test/command/7067.md @@ -0,0 +1,90 @@ +``` +% pandoc -t biblatex +--- +references: +- id: garaud + author: + - family: Garaud + given: Marcel + container-title: Bulletin de la Societé des antiquaires de l’Ouest + collection-title: 4 + issued: + - year: 1967 + language: fr-FR + page: 11-27 + title: Recherches sur les défrichements dans la Gâtine poitevine aux XI^e^ et XII^e^ siècles + type: article-journal + volume: 9 +... +^D +@article{garaud, + author = {Garaud, Marcel}, + title = {Recherches sur les défrichements dans la Gâtine poitevine aux + XI\textsuperscript{e} et XII\textsuperscript{e} siècles}, + journal = {Bulletin de la Societé des antiquaires de l’Ouest}, + series = {4}, + volume = {9}, + pages = {11-27}, + date = {1967}, + langid = {fr-FR} +} +``` + +``` +% pandoc -t bibtex +--- +references: +- id: garaud + author: + - family: Garaud + given: Marcel + container-title: Bulletin de la Société des antiquaires de l’Ouest + collection-title: 4 + issued: + - year: 1967 + language: fr-FR + page: 11-27 + title: Recherches sur les défrichements dans la Gâtine poitevine aux XI^e^ et XII^e^ siècles + type: article-journal + volume: 9 +... +^D +@article{garaud, + author = {Garaud, Marcel}, + title = {{Recherches sur les défrichements dans la Gâtine poitevine + aux XI\textsuperscript{e} et XII\textsuperscript{e} siècles}}, + journal = {Bulletin de la Société des antiquaires de l’Ouest}, + series = {4}, + volume = {9}, + pages = {11-27}, + year = {1967} +} +``` + +This tests the titlecasing of a word with an accented second letter: +``` +% pandoc -t bibtex +--- +references: +- id: garaud + author: + - family: Garaud + given: Marcel + container-title: English Journal + issued: + - year: 1967 + language: en-US + title: Research on the défrichements in the Gâtine poitevine + type: article-journal + volume: 9 +... +^D +@article{garaud, + author = {Garaud, Marcel}, + title = {Research on the Défrichements in the {Gâtine} Poitevine}, + journal = {English Journal}, + volume = {9}, + year = {1967} +} +``` + diff --git a/test/command/7080.md b/test/command/7080.md new file mode 100644 --- /dev/null +++ b/test/command/7080.md @@ -0,0 +1,8 @@ +``` +% pandoc -f markdown_mmd -t native +![][image] + +[image]: image.png width=100px height=150px +^D +[Para [Image ("",[],[("width","100px"),("height","150px")]) [] ("image.png","")]] +``` diff --git a/test/command/7092.md b/test/command/7092.md new file mode 100644 --- /dev/null +++ b/test/command/7092.md @@ -0,0 +1,8 @@ +``` +% pandoc -flatex+raw_tex -t native +\newcommand{\em}[1]{\emph{#1}} + +\em{\parseMe{foo}} +^D +[Para [Emph [RawInline (Format "latex") "\\parseMe{foo}"]]] +``` diff --git a/test/command/7099.md b/test/command/7099.md new file mode 100644 --- /dev/null +++ b/test/command/7099.md @@ -0,0 +1,18 @@ +``` +% pandoc -f html -t native --verbose + +^D +[INFO] Skipped '' at input line 1 column 16 +[] +``` + +``` +% pandoc -f html -t native --verbose + +^D +[INFO] Fetching h:invalid@url... +[WARNING] Could not fetch resource 'h:invalid@url': Could not fetch h:invalid@url + InvalidUrlException "h:invalid@url" "Invalid scheme" +[INFO] Skipped '' at input line 1 column 29 +[] +``` diff --git a/test/command/7112.md b/test/command/7112.md new file mode 100644 --- /dev/null +++ b/test/command/7112.md @@ -0,0 +1,15 @@ +``` +% pandoc -f rst +.. csv-table:: + + setting, ``echo PATH="path"`` +^D + + + + + + + +
settingecho PATH="path"
+``` diff --git a/test/command/7129.md b/test/command/7129.md new file mode 100644 --- /dev/null +++ b/test/command/7129.md @@ -0,0 +1,27 @@ +``` +% pandoc -f latex -t native +\begin{tabular}{ll} \hline + FOO & BAR \\ \hline + foo & \verb|b&r| \\ \hline +\end{tabular} +^D +[Table ("",[],[]) (Caption Nothing + []) + [(AlignLeft,ColWidthDefault) + ,(AlignLeft,ColWidthDefault)] + (TableHead ("",[],[]) + [Row ("",[],[]) + [Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1) + [Plain [Str "FOO"]] + ,Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1) + [Plain [Str "BAR"]]]]) + [(TableBody ("",[],[]) (RowHeadColumns 0) + [] + [Row ("",[],[]) + [Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1) + [Plain [Str "foo"]] + ,Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1) + [Plain [Code ("",[],[]) "b&r"]]]])] + (TableFoot ("",[],[]) + [])] +``` diff --git a/test/command/biblatex-baez-article.md b/test/command/biblatex-baez-article.md --- a/test/command/biblatex-baez-article.md +++ b/test/command/biblatex-baez-article.md @@ -67,7 +67,7 @@ title: "Higher-dimensional algebra V: 2-groups" title-short: Higher-dimensional algebra V type: article-journal - url: "http://arxiv.org/abs/math/0307200v3" + url: "https://arxiv.org/abs/math/0307200v3" version: 3 volume: 12 --- diff --git a/test/command/biblatex-baez-online.md b/test/command/biblatex-baez-online.md --- a/test/command/biblatex-baez-online.md +++ b/test/command/biblatex-baez-online.md @@ -61,7 +61,7 @@ title: "Higher-dimensional algebra V: 2-groups" title-short: Higher-dimensional algebra V type: webpage - url: "http://arxiv.org/abs/math/0307200v3" + url: "https://arxiv.org/abs/math/0307200v3" version: 3 --- diff --git a/test/command/biblatex-cotton.md b/test/command/biblatex-cotton.md --- a/test/command/biblatex-cotton.md +++ b/test/command/biblatex-cotton.md @@ -43,9 +43,9 @@ --- nocite: "[@*]" references: -- annote: A book entry with author authors and an edition field. By - default, long author and editor lists are automatically truncated. - This is configurable +- annote: A book entry with `\arabic{author}`{=latex} authors and an + edition field. By default, long author and editor lists are + automatically truncated. This is configurable author: - family: Cotton given: Frank Albert diff --git a/test/command/biblatex-itzhaki.md b/test/command/biblatex-itzhaki.md --- a/test/command/biblatex-itzhaki.md +++ b/test/command/biblatex-itzhaki.md @@ -74,7 +74,7 @@ language: en-US title: Some remarks on '[t Hooft's]{.nocase} S-matrix for black holes type: webpage - url: "http://arxiv.org/abs/hep-th/9603067" + url: "https://arxiv.org/abs/hep-th/9603067" version: 1 --- diff --git a/test/command/biblatex-murray.md b/test/command/biblatex-murray.md --- a/test/command/biblatex-murray.md +++ b/test/command/biblatex-murray.md @@ -55,8 +55,9 @@ --- nocite: "[@*]" references: -- annote: An article entry with author authors. By default, long author - and editor lists are automatically truncated. This is configurable +- annote: An article entry with `\arabic{author}`{=latex} authors. By + default, long author and editor lists are automatically truncated. + This is configurable author: - family: Hostetler given: Michael J. diff --git a/test/command/biblatex-wassenberg.md b/test/command/biblatex-wassenberg.md --- a/test/command/biblatex-wassenberg.md +++ b/test/command/biblatex-wassenberg.md @@ -75,7 +75,7 @@ language: en-US title: Faster radix sort via virtual memory and write-combining type: webpage - url: "http://arxiv.org/abs/1008.2849v1" + url: "https://arxiv.org/abs/1008.2849v1" version: 1 --- diff --git a/test/command/biblatex-wilde.md b/test/command/biblatex-wilde.md --- a/test/command/biblatex-wilde.md +++ b/test/command/biblatex-wilde.md @@ -58,7 +58,7 @@ people" title-short: The importance of being earnest type: book - url: "http://books.google.com?id=4HIWAAAAYAAJ" + url: "https://books.google.com?id=4HIWAAAAYAAJ" --- diff --git a/test/docbook-reader.docbook b/test/docbook-reader.docbook --- a/test/docbook-reader.docbook +++ b/test/docbook-reader.docbook @@ -1,6 +1,11 @@ +"http://www.oasis-open.org/docbook/xml/4.4/docbookx.dtd" +[ + + + +]>
Pandoc Test Suite diff --git a/test/docx/golden/block_quotes.docx b/test/docx/golden/block_quotes.docx Binary files a/test/docx/golden/block_quotes.docx and b/test/docx/golden/block_quotes.docx differ diff --git a/test/docx/golden/codeblock.docx b/test/docx/golden/codeblock.docx Binary files a/test/docx/golden/codeblock.docx and b/test/docx/golden/codeblock.docx differ 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/custom_style_no_reference.docx b/test/docx/golden/custom_style_no_reference.docx Binary files a/test/docx/golden/custom_style_no_reference.docx and b/test/docx/golden/custom_style_no_reference.docx differ diff --git a/test/docx/golden/custom_style_preserve.docx b/test/docx/golden/custom_style_preserve.docx Binary files a/test/docx/golden/custom_style_preserve.docx and b/test/docx/golden/custom_style_preserve.docx differ diff --git a/test/docx/golden/custom_style_reference.docx b/test/docx/golden/custom_style_reference.docx Binary files a/test/docx/golden/custom_style_reference.docx and b/test/docx/golden/custom_style_reference.docx differ diff --git a/test/docx/golden/definition_list.docx b/test/docx/golden/definition_list.docx Binary files a/test/docx/golden/definition_list.docx and b/test/docx/golden/definition_list.docx differ diff --git a/test/docx/golden/document-properties-short-desc.docx b/test/docx/golden/document-properties-short-desc.docx Binary files a/test/docx/golden/document-properties-short-desc.docx and b/test/docx/golden/document-properties-short-desc.docx differ diff --git a/test/docx/golden/document-properties.docx b/test/docx/golden/document-properties.docx Binary files a/test/docx/golden/document-properties.docx and b/test/docx/golden/document-properties.docx differ diff --git a/test/docx/golden/headers.docx b/test/docx/golden/headers.docx Binary files a/test/docx/golden/headers.docx and b/test/docx/golden/headers.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/docx/golden/inline_code.docx b/test/docx/golden/inline_code.docx Binary files a/test/docx/golden/inline_code.docx and b/test/docx/golden/inline_code.docx differ diff --git a/test/docx/golden/inline_formatting.docx b/test/docx/golden/inline_formatting.docx Binary files a/test/docx/golden/inline_formatting.docx and b/test/docx/golden/inline_formatting.docx differ diff --git a/test/docx/golden/inline_images.docx b/test/docx/golden/inline_images.docx Binary files a/test/docx/golden/inline_images.docx and b/test/docx/golden/inline_images.docx differ diff --git a/test/docx/golden/link_in_notes.docx b/test/docx/golden/link_in_notes.docx Binary files a/test/docx/golden/link_in_notes.docx and b/test/docx/golden/link_in_notes.docx differ diff --git a/test/docx/golden/links.docx b/test/docx/golden/links.docx Binary files a/test/docx/golden/links.docx and b/test/docx/golden/links.docx differ diff --git a/test/docx/golden/lists.docx b/test/docx/golden/lists.docx Binary files a/test/docx/golden/lists.docx and b/test/docx/golden/lists.docx differ diff --git a/test/docx/golden/lists_continuing.docx b/test/docx/golden/lists_continuing.docx Binary files a/test/docx/golden/lists_continuing.docx and b/test/docx/golden/lists_continuing.docx differ diff --git a/test/docx/golden/lists_multiple_initial.docx b/test/docx/golden/lists_multiple_initial.docx Binary files a/test/docx/golden/lists_multiple_initial.docx and b/test/docx/golden/lists_multiple_initial.docx differ diff --git a/test/docx/golden/lists_restarting.docx b/test/docx/golden/lists_restarting.docx Binary files a/test/docx/golden/lists_restarting.docx and b/test/docx/golden/lists_restarting.docx differ diff --git a/test/docx/golden/nested_anchors_in_header.docx b/test/docx/golden/nested_anchors_in_header.docx Binary files a/test/docx/golden/nested_anchors_in_header.docx and b/test/docx/golden/nested_anchors_in_header.docx differ diff --git a/test/docx/golden/notes.docx b/test/docx/golden/notes.docx Binary files a/test/docx/golden/notes.docx and b/test/docx/golden/notes.docx differ diff --git a/test/docx/golden/raw-blocks.docx b/test/docx/golden/raw-blocks.docx Binary files a/test/docx/golden/raw-blocks.docx and b/test/docx/golden/raw-blocks.docx differ diff --git a/test/docx/golden/raw-bookmarks.docx b/test/docx/golden/raw-bookmarks.docx Binary files a/test/docx/golden/raw-bookmarks.docx and b/test/docx/golden/raw-bookmarks.docx differ diff --git a/test/docx/golden/table_one_row.docx b/test/docx/golden/table_one_row.docx Binary files a/test/docx/golden/table_one_row.docx and b/test/docx/golden/table_one_row.docx differ diff --git a/test/docx/golden/table_with_list_cell.docx b/test/docx/golden/table_with_list_cell.docx Binary files a/test/docx/golden/table_with_list_cell.docx and b/test/docx/golden/table_with_list_cell.docx differ diff --git a/test/docx/golden/tables.docx b/test/docx/golden/tables.docx Binary files a/test/docx/golden/tables.docx and b/test/docx/golden/tables.docx differ diff --git a/test/docx/golden/track_changes_deletion.docx b/test/docx/golden/track_changes_deletion.docx Binary files a/test/docx/golden/track_changes_deletion.docx and b/test/docx/golden/track_changes_deletion.docx differ diff --git a/test/docx/golden/track_changes_insertion.docx b/test/docx/golden/track_changes_insertion.docx Binary files a/test/docx/golden/track_changes_insertion.docx and b/test/docx/golden/track_changes_insertion.docx differ diff --git a/test/docx/golden/track_changes_move.docx b/test/docx/golden/track_changes_move.docx Binary files a/test/docx/golden/track_changes_move.docx and b/test/docx/golden/track_changes_move.docx differ diff --git a/test/docx/golden/track_changes_scrubbed_metadata.docx b/test/docx/golden/track_changes_scrubbed_metadata.docx Binary files a/test/docx/golden/track_changes_scrubbed_metadata.docx and b/test/docx/golden/track_changes_scrubbed_metadata.docx differ diff --git a/test/docx/golden/unicode.docx b/test/docx/golden/unicode.docx Binary files a/test/docx/golden/unicode.docx and b/test/docx/golden/unicode.docx differ diff --git a/test/docx/golden/verbatim_subsuper.docx b/test/docx/golden/verbatim_subsuper.docx Binary files a/test/docx/golden/verbatim_subsuper.docx and b/test/docx/golden/verbatim_subsuper.docx differ diff --git a/test/jats-reader.native b/test/jats-reader.native --- a/test/jats-reader.native +++ b/test/jats-reader.native @@ -1,4 +1,4 @@ -Pandoc (Meta {unMeta = fromList [("author",MetaList [MetaInlines [Str "John",Space,Str "MacFarlane"]]),("title",MetaInlines [Str "Pandoc",Space,Str "Test",Space,Str "Suite"])]}) +Pandoc (Meta {unMeta = fromList [("author",MetaList [MetaInlines [Str "John",Space,Str "MacFarlane"],MetaInlines [Str "Anonymous"]]),("title",MetaInlines [Str "Pandoc",Space,Str "Test",Space,Str "Suite"])]}) [Para [Str "This",Space,Str "is",Space,Str "a",Space,Str "set",Space,Str "of",Space,Str "tests",Space,Str "for",Space,Str "pandoc.",Space,Str "Most",Space,Str "of",Space,Str "them",Space,Str "are",Space,Str "adapted",Space,Str "from",Space,Str "John",Space,Str "Gruber's",Space,Str "markdown",Space,Str "test",Space,Str "suite."] ,Header 1 ("headers",[],[]) [Str "Headers"] ,Header 2 ("level-2-with-an-embedded-link",[],[]) [Str "Level",Space,Str "2",Space,Str "with",Space,Str "an",SoftBreak,Link ("",[],[]) [Str "embedded",SoftBreak,Str "link"] ("/url","")] diff --git a/test/jats-reader.xml b/test/jats-reader.xml --- a/test/jats-reader.xml +++ b/test/jats-reader.xml @@ -20,6 +20,7 @@ MacFarlane John + Anonymous diff --git a/test/lhs-test.latex b/test/lhs-test.latex --- a/test/lhs-test.latex +++ b/test/lhs-test.latex @@ -6,8 +6,8 @@ ]{article} \usepackage{amsmath,amssymb} \usepackage{lmodern} -\usepackage{ifxetex,ifluatex} -\ifnum 0\ifxetex 1\fi\ifluatex 1\fi=0 % if pdftex +\usepackage{iftex} +\ifPDFTeX \usepackage[T1]{fontenc} \usepackage[utf8]{inputenc} \usepackage{textcomp} % provide euro and other symbols @@ -81,7 +81,7 @@ \providecommand{\tightlist}{% \setlength{\itemsep}{0pt}\setlength{\parskip}{0pt}} \setcounter{secnumdepth}{-\maxdimen} % remove section numbering -\ifluatex +\ifLuaTeX \usepackage{selnolig} % disable illegal ligatures \fi diff --git a/test/lhs-test.latex+lhs b/test/lhs-test.latex+lhs --- a/test/lhs-test.latex+lhs +++ b/test/lhs-test.latex+lhs @@ -6,8 +6,8 @@ ]{article} \usepackage{amsmath,amssymb} \usepackage{lmodern} -\usepackage{ifxetex,ifluatex} -\ifnum 0\ifxetex 1\fi\ifluatex 1\fi=0 % if pdftex +\usepackage{iftex} +\ifPDFTeX \usepackage[T1]{fontenc} \usepackage[utf8]{inputenc} \usepackage{textcomp} % provide euro and other symbols @@ -48,7 +48,7 @@ \providecommand{\tightlist}{% \setlength{\itemsep}{0pt}\setlength{\parskip}{0pt}} \setcounter{secnumdepth}{-\maxdimen} % remove section numbering -\ifluatex +\ifLuaTeX \usepackage{selnolig} % disable illegal ligatures \fi diff --git a/test/lua/module/pandoc-path.lua b/test/lua/module/pandoc-path.lua new file mode 100644 --- /dev/null +++ b/test/lua/module/pandoc-path.lua @@ -0,0 +1,44 @@ +local tasty = require 'tasty' +local path = require 'pandoc.path' + +local assert = tasty.assert +local test = tasty.test_case +local group = tasty.test_group + +return { + group 'path separator' { + test('is string', function () + assert.are_same(type(path.separator), 'string') + end), + test('is slash or backslash', function () + assert.is_truthy(path.separator:match '^[/\\]$') + end), + }, + group 'search path separator' { + test('is string', function () + assert.are_same(type(path.search_path_separator), 'string') + end), + test('is colon or semicolon', function () + assert.is_truthy(path.search_path_separator:match '^[:;]$') + end) + }, + group 'module' { + test('check function existence', function () + local functions = { + 'directory', + 'filename', + 'is_absolute', + 'is_relative', + 'join', + 'make_relative', + 'normalize', + 'split', + 'split_extension', + 'split_search_path', + } + for _, f in ipairs(functions) do + assert.are_equal(type(path[f]), 'function') + end + end) + } +} diff --git a/test/pptx/code-custom.pptx b/test/pptx/code-custom.pptx Binary files a/test/pptx/code-custom.pptx and b/test/pptx/code-custom.pptx differ diff --git a/test/pptx/code-custom_templated.pptx b/test/pptx/code-custom_templated.pptx Binary files a/test/pptx/code-custom_templated.pptx and b/test/pptx/code-custom_templated.pptx differ diff --git a/test/pptx/code.pptx b/test/pptx/code.pptx Binary files a/test/pptx/code.pptx and b/test/pptx/code.pptx differ diff --git a/test/pptx/code_templated.pptx b/test/pptx/code_templated.pptx Binary files a/test/pptx/code_templated.pptx and b/test/pptx/code_templated.pptx differ diff --git a/test/pptx/document-properties-short-desc.pptx b/test/pptx/document-properties-short-desc.pptx Binary files a/test/pptx/document-properties-short-desc.pptx and b/test/pptx/document-properties-short-desc.pptx differ diff --git a/test/pptx/document-properties-short-desc_templated.pptx b/test/pptx/document-properties-short-desc_templated.pptx Binary files a/test/pptx/document-properties-short-desc_templated.pptx and b/test/pptx/document-properties-short-desc_templated.pptx differ diff --git a/test/pptx/document-properties.pptx b/test/pptx/document-properties.pptx Binary files a/test/pptx/document-properties.pptx and b/test/pptx/document-properties.pptx differ diff --git a/test/pptx/document-properties_templated.pptx b/test/pptx/document-properties_templated.pptx Binary files a/test/pptx/document-properties_templated.pptx and b/test/pptx/document-properties_templated.pptx differ diff --git a/test/pptx/endnotes.pptx b/test/pptx/endnotes.pptx Binary files a/test/pptx/endnotes.pptx and b/test/pptx/endnotes.pptx differ diff --git a/test/pptx/endnotes_templated.pptx b/test/pptx/endnotes_templated.pptx Binary files a/test/pptx/endnotes_templated.pptx and b/test/pptx/endnotes_templated.pptx differ diff --git a/test/pptx/endnotes_toc.pptx b/test/pptx/endnotes_toc.pptx Binary files a/test/pptx/endnotes_toc.pptx and b/test/pptx/endnotes_toc.pptx differ diff --git a/test/pptx/endnotes_toc_templated.pptx b/test/pptx/endnotes_toc_templated.pptx Binary files a/test/pptx/endnotes_toc_templated.pptx and b/test/pptx/endnotes_toc_templated.pptx differ diff --git a/test/pptx/images.pptx b/test/pptx/images.pptx Binary files a/test/pptx/images.pptx and b/test/pptx/images.pptx differ diff --git a/test/pptx/images_templated.pptx b/test/pptx/images_templated.pptx Binary files a/test/pptx/images_templated.pptx and b/test/pptx/images_templated.pptx differ diff --git a/test/pptx/inline_formatting.pptx b/test/pptx/inline_formatting.pptx Binary files a/test/pptx/inline_formatting.pptx and b/test/pptx/inline_formatting.pptx differ diff --git a/test/pptx/inline_formatting_templated.pptx b/test/pptx/inline_formatting_templated.pptx Binary files a/test/pptx/inline_formatting_templated.pptx and b/test/pptx/inline_formatting_templated.pptx differ diff --git a/test/pptx/lists.pptx b/test/pptx/lists.pptx Binary files a/test/pptx/lists.pptx and b/test/pptx/lists.pptx differ diff --git a/test/pptx/lists_templated.pptx b/test/pptx/lists_templated.pptx Binary files a/test/pptx/lists_templated.pptx and b/test/pptx/lists_templated.pptx differ diff --git a/test/pptx/raw_ooxml.pptx b/test/pptx/raw_ooxml.pptx Binary files a/test/pptx/raw_ooxml.pptx and b/test/pptx/raw_ooxml.pptx differ diff --git a/test/pptx/raw_ooxml_templated.pptx b/test/pptx/raw_ooxml_templated.pptx Binary files a/test/pptx/raw_ooxml_templated.pptx and b/test/pptx/raw_ooxml_templated.pptx differ diff --git a/test/pptx/remove_empty_slides.pptx b/test/pptx/remove_empty_slides.pptx Binary files a/test/pptx/remove_empty_slides.pptx and b/test/pptx/remove_empty_slides.pptx differ diff --git a/test/pptx/remove_empty_slides_templated.pptx b/test/pptx/remove_empty_slides_templated.pptx Binary files a/test/pptx/remove_empty_slides_templated.pptx and b/test/pptx/remove_empty_slides_templated.pptx differ diff --git a/test/pptx/slide_breaks.pptx b/test/pptx/slide_breaks.pptx Binary files a/test/pptx/slide_breaks.pptx and b/test/pptx/slide_breaks.pptx differ diff --git a/test/pptx/slide_breaks_slide_level_1.pptx b/test/pptx/slide_breaks_slide_level_1.pptx Binary files a/test/pptx/slide_breaks_slide_level_1.pptx and b/test/pptx/slide_breaks_slide_level_1.pptx differ diff --git a/test/pptx/slide_breaks_slide_level_1_templated.pptx b/test/pptx/slide_breaks_slide_level_1_templated.pptx Binary files a/test/pptx/slide_breaks_slide_level_1_templated.pptx and b/test/pptx/slide_breaks_slide_level_1_templated.pptx differ diff --git a/test/pptx/slide_breaks_templated.pptx b/test/pptx/slide_breaks_templated.pptx Binary files a/test/pptx/slide_breaks_templated.pptx and b/test/pptx/slide_breaks_templated.pptx differ diff --git a/test/pptx/slide_breaks_toc.pptx b/test/pptx/slide_breaks_toc.pptx Binary files a/test/pptx/slide_breaks_toc.pptx and b/test/pptx/slide_breaks_toc.pptx differ diff --git a/test/pptx/slide_breaks_toc_templated.pptx b/test/pptx/slide_breaks_toc_templated.pptx Binary files a/test/pptx/slide_breaks_toc_templated.pptx and b/test/pptx/slide_breaks_toc_templated.pptx differ diff --git a/test/pptx/speaker_notes.pptx b/test/pptx/speaker_notes.pptx Binary files a/test/pptx/speaker_notes.pptx and b/test/pptx/speaker_notes.pptx differ diff --git a/test/pptx/speaker_notes_after_metadata.pptx b/test/pptx/speaker_notes_after_metadata.pptx Binary files a/test/pptx/speaker_notes_after_metadata.pptx and b/test/pptx/speaker_notes_after_metadata.pptx differ diff --git a/test/pptx/speaker_notes_after_metadata_templated.pptx b/test/pptx/speaker_notes_after_metadata_templated.pptx Binary files a/test/pptx/speaker_notes_after_metadata_templated.pptx and b/test/pptx/speaker_notes_after_metadata_templated.pptx differ diff --git a/test/pptx/speaker_notes_afterheader.pptx b/test/pptx/speaker_notes_afterheader.pptx Binary files a/test/pptx/speaker_notes_afterheader.pptx and b/test/pptx/speaker_notes_afterheader.pptx differ diff --git a/test/pptx/speaker_notes_afterheader_templated.pptx b/test/pptx/speaker_notes_afterheader_templated.pptx Binary files a/test/pptx/speaker_notes_afterheader_templated.pptx and b/test/pptx/speaker_notes_afterheader_templated.pptx differ diff --git a/test/pptx/speaker_notes_afterseps.pptx b/test/pptx/speaker_notes_afterseps.pptx Binary files a/test/pptx/speaker_notes_afterseps.pptx and b/test/pptx/speaker_notes_afterseps.pptx differ diff --git a/test/pptx/speaker_notes_afterseps_templated.pptx b/test/pptx/speaker_notes_afterseps_templated.pptx Binary files a/test/pptx/speaker_notes_afterseps_templated.pptx and b/test/pptx/speaker_notes_afterseps_templated.pptx differ diff --git a/test/pptx/speaker_notes_templated.pptx b/test/pptx/speaker_notes_templated.pptx Binary files a/test/pptx/speaker_notes_templated.pptx and b/test/pptx/speaker_notes_templated.pptx differ diff --git a/test/pptx/start_numbering_at.pptx b/test/pptx/start_numbering_at.pptx Binary files a/test/pptx/start_numbering_at.pptx and b/test/pptx/start_numbering_at.pptx differ diff --git a/test/pptx/start_numbering_at_templated.pptx b/test/pptx/start_numbering_at_templated.pptx Binary files a/test/pptx/start_numbering_at_templated.pptx and b/test/pptx/start_numbering_at_templated.pptx differ diff --git a/test/pptx/tables.pptx b/test/pptx/tables.pptx Binary files a/test/pptx/tables.pptx and b/test/pptx/tables.pptx differ diff --git a/test/pptx/tables_templated.pptx b/test/pptx/tables_templated.pptx Binary files a/test/pptx/tables_templated.pptx and b/test/pptx/tables_templated.pptx differ diff --git a/test/pptx/two_column.pptx b/test/pptx/two_column.pptx Binary files a/test/pptx/two_column.pptx and b/test/pptx/two_column.pptx differ diff --git a/test/pptx/two_column_templated.pptx b/test/pptx/two_column_templated.pptx Binary files a/test/pptx/two_column_templated.pptx and b/test/pptx/two_column_templated.pptx differ diff --git a/test/test-pandoc.hs b/test/test-pandoc.hs --- a/test/test-pandoc.hs +++ b/test/test-pandoc.hs @@ -1,9 +1,13 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -Wall #-} module Main where -import Prelude +import System.Environment (getArgs) +import qualified Control.Exception as E +import Text.Pandoc.App (convertWithOpts, defaultOpts, options, + parseOptionsFromArgs) +import Text.Pandoc.Error (handleError) +import System.Environment.Executable (getExecutablePath) import GHC.IO.Encoding import Test.Tasty import qualified Tests.Command @@ -46,12 +50,11 @@ import qualified Tests.Writers.RST import qualified Tests.Writers.AnnotatedTable import qualified Tests.Writers.TEI -import Tests.Helpers (findPandoc) import Text.Pandoc.Shared (inDirectory) tests :: FilePath -> TestTree tests pandocPath = testGroup "pandoc tests" - [ Tests.Command.tests pandocPath + [ Tests.Command.tests , testGroup "Old" (Tests.Old.tests pandocPath) , testGroup "Shared" Tests.Shared.tests , testGroup "Writers" @@ -102,7 +105,15 @@ main :: IO () main = do setLocaleEncoding utf8 - inDirectory "test" $ do - fp <- findPandoc - putStrLn $ "Using pandoc executable at " ++ fp - defaultMain $ tests fp + args <- getArgs + case args of + "--emulate":args' -> -- emulate pandoc executable + E.catch + (parseOptionsFromArgs options defaultOpts "pandoc" args' >>= + convertWithOpts) + (handleError . Left) + _ -> inDirectory "test" $ do + fp <- getExecutablePath + -- putStrLn $ "Using pandoc executable at " ++ fp + defaultMain $ tests fp + diff --git a/test/txt2tags.native b/test/txt2tags.native --- a/test/txt2tags.native +++ b/test/txt2tags.native @@ -37,7 +37,7 @@ ,Para [Link ("",[],[]) [Str "mailto:user@domain.com"] ("user@domain.com",""),SoftBreak,Link ("",[],[]) [Str "mailto:user@domain.com"] ("user@domain.com",""),Str ".",SoftBreak,Link ("",[],[]) [Str "mailto:user@domain.com"] ("user@domain.com",""),Str ".",Space,Str "any",Space,Str "text.",SoftBreak,Str "any",Space,Str "text:",Space,Link ("",[],[]) [Str "mailto:user@domain.com"] ("user@domain.com",""),Str ".",Space,Str "any",Space,Str "text.",SoftBreak,Link ("",[],[]) [Str "label"] ("user@domain.com",""),SoftBreak,Link ("",[],[]) [Str "mailto:user@domain.com?subject=bla"] ("user@domain.com?subject=bla",""),SoftBreak,Link ("",[],[]) [Str "mailto:user@domain.com?subject=bla"] ("user@domain.com?subject=bla",""),Str ".",SoftBreak,Link ("",[],[]) [Str "mailto:user@domain.com?subject=bla"] ("user@domain.com?subject=bla",""),Str ",",SoftBreak,Link ("",[],[]) [Str "mailto:user@domain.com?subject=bla&cc=otheruser@domain.com"] ("user@domain.com?subject=bla&cc=otheruser@domain.com",""),SoftBreak,Link ("",[],[]) [Str "mailto:user@domain.com?subject=bla&cc=otheruser@domain.com"] ("user@domain.com?subject=bla&cc=otheruser@domain.com",""),Str ".",SoftBreak,Link ("",[],[]) [Str "mailto:user@domain.com?subject=bla&cc=otheruser@domain.com"] ("user@domain.com?subject=bla&cc=otheruser@domain.com",""),Str ",",SoftBreak,Link ("",[],[]) [Str "label"] ("user@domain.com?subject=bla&cc=otheruser@domain.com",""),Str ".",SoftBreak,Link ("",[],[]) [Str "label"] ("user@domain.com?subject=bla&cc=otheruser@domain.com.",""),Str ".",SoftBreak,Link ("",[],[]) [Str "http://www.domain.com"] ("http://www.domain.com",""),SoftBreak,Link ("",[],[]) [Str "http://www.domain.com/dir/"] ("http://www.domain.com/dir/",""),SoftBreak,Link ("",[],[]) [Str "http://www.domain.com/dir///"] ("http://www.domain.com/dir///",""),SoftBreak,Link ("",[],[]) [Str "http://www.domain.com."] ("http://www.domain.com.",""),SoftBreak,Link ("",[],[]) [Str "http://www.domain.com,"] ("http://www.domain.com,",""),SoftBreak,Link ("",[],[]) [Str "http://www.domain.com."] ("http://www.domain.com.",""),Space,Str "any",Space,Str "text.",SoftBreak,Link ("",[],[]) [Str "http://www.domain.com,"] ("http://www.domain.com,",""),Space,Str "any",Space,Str "text.",SoftBreak,Link ("",[],[]) [Str "http://www.domain.com/dir/."] ("http://www.domain.com/dir/.",""),Space,Str "any",Space,Str "text.",SoftBreak,Str "any",Space,Str "text:",Space,Link ("",[],[]) [Str "http://www.domain.com."] ("http://www.domain.com.",""),Space,Str "any",Space,Str "text.",SoftBreak,Str "any",Space,Str "text:",Space,Link ("",[],[]) [Str "http://www.domain.com/dir/."] ("http://www.domain.com/dir/.",""),Space,Str "any",Space,Str "text.",SoftBreak,Str "any",Space,Str "text:",Space,Link ("",[],[]) [Str "http://www.domain.com/dir/index.html."] ("http://www.domain.com/dir/index.html.",""),Space,Str "any",Space,Str "text.",SoftBreak,Str "any",Space,Str "text:",Space,Link ("",[],[]) [Str "http://www.domain.com/dir/index.html,"] ("http://www.domain.com/dir/index.html,",""),Space,Str "any",Space,Str "text.",SoftBreak,Link ("",[],[]) [Str "http://www.domain.com/dir/#anchor"] ("http://www.domain.com/dir/#anchor",""),SoftBreak,Link ("",[],[]) [Str "http://www.domain.com/dir/index.html#anchor"] ("http://www.domain.com/dir/index.html#anchor",""),SoftBreak,Link ("",[],[]) [Str "http://www.domain.com/dir/index.html#anchor."] ("http://www.domain.com/dir/index.html#anchor.",""),SoftBreak,Link ("",[],[]) [Str "http://www.domain.com/dir/#anchor."] ("http://www.domain.com/dir/#anchor.",""),Space,Str "any",Space,Str "text.",SoftBreak,Link ("",[],[]) [Str "http://www.domain.com/dir/index.html#anchor."] ("http://www.domain.com/dir/index.html#anchor.",""),Space,Str "any",Space,Str "text.",SoftBreak,Str "any",Space,Str "text:",Space,Link ("",[],[]) [Str "http://www.domain.com/dir/#anchor."] ("http://www.domain.com/dir/#anchor.",""),Space,Str "any",Space,Str "text.",SoftBreak,Str "any",Space,Str "text:",Space,Link ("",[],[]) [Str "http://www.domain.com/dir/index.html#anchor."] ("http://www.domain.com/dir/index.html#anchor.",""),Space,Str "any",Space,Str "text.",SoftBreak,Link ("",[],[]) [Str "http://domain.com?a=a@a.a&b=a+b+c."] ("http://domain.com?a=a@a.a&b=a+b+c.",""),SoftBreak,Link ("",[],[]) [Str "http://domain.com?a=a@a.a&b=a+b+c,"] ("http://domain.com?a=a@a.a&b=a+b+c,",""),SoftBreak,Link ("",[],[]) [Str "http://domain.com/bla.cgi?a=a@a.a&b=a+b+c."] ("http://domain.com/bla.cgi?a=a@a.a&b=a+b+c.",""),SoftBreak,Link ("",[],[]) [Str "http://domain.com/bla.cgi?a=a@a.a&b=a+b+c@."] ("http://domain.com/bla.cgi?a=a@a.a&b=a+b+c@.",""),SoftBreak,Link ("",[],[]) [Str "http://domain.com?a=a@a.a&b=a+b+c.#anchor"] ("http://domain.com?a=a@a.a&b=a+b+c.#anchor",""),SoftBreak,Link ("",[],[]) [Str "http://domain.com/bla.cgi?a=a@a.a&b=a+b+c.#anchor"] ("http://domain.com/bla.cgi?a=a@a.a&b=a+b+c.#anchor",""),SoftBreak,Link ("",[],[]) [Str "http://domain.com/bla.cgi?a=a@a.a&b=a+b+c@.#anchor"] ("http://domain.com/bla.cgi?a=a@a.a&b=a+b+c@.#anchor",""),SoftBreak,Link ("",[],[]) [Str "http://user:password@domain.com/bla.html."] ("http://user:password@domain.com/bla.html.",""),SoftBreak,Link ("",[],[]) [Str "http://user:password@domain.com/dir/."] ("http://user:password@domain.com/dir/.",""),SoftBreak,Link ("",[],[]) [Str "http://user:password@domain.com."] ("http://user:password@domain.com.",""),SoftBreak,Link ("",[],[]) [Str "http://user:@domain.com."] ("http://user:@domain.com.",""),SoftBreak,Link ("",[],[]) [Str "http://user@domain.com."] ("http://user@domain.com.",""),SoftBreak,Link ("",[],[]) [Str "http://user:password@domain.com/bla.cgi?a=a@a.a&b=a+b+c.#anchor"] ("http://user:password@domain.com/bla.cgi?a=a@a.a&b=a+b+c.#anchor",""),SoftBreak,Link ("",[],[]) [Str "http://user:password@domain.com/bla.cgi?a=a@a.a&b=a+b+c@#anchor"] ("http://user:password@domain.com/bla.cgi?a=a@a.a&b=a+b+c@#anchor",""),SoftBreak,Link ("",[],[]) [Str "label"] ("www.domain.com",""),SoftBreak,Str "[",Space,Str "label",Space,Link ("",[],[]) [Str "www.domain.com"] ("www.domain.com",""),Str "]",SoftBreak,Link ("",[],[]) [Str "label",Space] ("www.domain.com",""),SoftBreak,Link ("",[],[]) [Str "anchor",Space] ("http://www.domain.com/dir/index.html#anchor.",""),SoftBreak,Link ("",[],[]) [Str "login",Space] ("http://user:password@domain.com/bla.html",""),SoftBreak,Link ("",[],[]) [Str "form",Space] ("http://www.domain.com/bla.cgi?a=a@a.a&b=a+b+c.",""),SoftBreak,Link ("",[],[]) [Str "form",Space,Str "&",Space,Str "anchor"] ("http://www.domain.com/bla.cgi?a=a@a.a&b=a+b+c.#anchor",""),SoftBreak,Link ("",[],[]) [Str "login",Space,Str "&",Space,Str "form",Space] ("http://user:password@domain.com/bla.cgi?a=a@a.a&b=a+b+c.",""),SoftBreak,Link ("",[],[]) [Str "local",Space,Str "link",Space,Str "up",Space] ("..",""),SoftBreak,Link ("",[],[]) [Str "local",Space,Str "link",Space,Str "file",Space] ("bla.html",""),SoftBreak,Link ("",[],[]) [Str "local",Space,Str "link",Space,Str "anchor",Space] ("#anchor",""),SoftBreak,Link ("",[],[]) [Str "local",Space,Str "link",Space,Str "file/anchor"] ("bla.html#anchor",""),SoftBreak,Link ("",[],[]) [Str "local",Space,Str "link",Space,Str "file/anchor"] ("bla.html#anchor.",""),SoftBreak,Link ("",[],[]) [Str "local",Space,Str "link",Space,Str "img",Space] ("abc.gif",""),SoftBreak,Link ("",[],[]) [Str "www.fake.com"] ("www.domain.com",""),SoftBreak,Link ("",[],[]) [Str "http://domain.com:8080/~user/_st-r@a=n$g,e/index%20new.htm"] ("http://domain.com:8080/~user/_st-r@a=n$g,e/index%20new.htm",""),SoftBreak,Link ("",[],[]) [Str "http://domain.com:8080/~user/_st-r@a=n$g,e/index%20new.htm?a=/%22&b=+.@*_-"] ("http://domain.com:8080/~user/_st-r@a=n$g,e/index%20new.htm?a=/%22&b=+.@*_-",""),SoftBreak,Link ("",[],[]) [Str "http://domain.com:8080/~user/_st-r@a=n$g,e/index%20new.htm?a=/%22&b=+.@*_-#anchor_"] ("http://domain.com:8080/~user/_st-r@a=n$g,e/index%20new.htm?a=/%22&b=+.@*_-#anchor_",""),Str "-1%.",SoftBreak,Link ("",[],[]) [Str "http://foo._user-9:pass!#$%&*()+word@domain.com:8080/~user/_st-r@a=n$g,e/index%20new.htm?a=/%22&b=+.@*_-#anchor_"] ("http://foo._user-9:pass!#$%&*()+word@domain.com:8080/~user/_st-r@a=n$g,e/index%20new.htm?a=/%22&b=+.@*_-#anchor_",""),Str "-1%.",SoftBreak,Link ("",[],[]) [Str "http://L1.com"] ("http://L1.com",""),Space,Str "!",Space,Link ("",[],[]) [Str "mailto:L2@www.com"] ("L2@www.com",""),Space,Str "!",Space,Link ("",[],[]) [Str "L3"] ("www.com",""),Space,Str "!",Space,Link ("",[],[]) [Str "L4"] ("w@ww.com",""),Space,Str "!",Space,Link ("",[],[]) [Str "www.L5.com"] ("www.L5.com",""),SoftBreak,Link ("",[],[]) [Str "www.domain.com"] ("www.domain.com",""),SoftBreak,Link ("",[],[]) [Str "www2.domain.com"] ("www2.domain.com",""),SoftBreak,Link ("",[],[]) [Str "ftp.domain.com"] ("ftp.domain.com",""),SoftBreak,Link ("",[],[]) [Str "WWW.DOMAIN.COM"] ("WWW.DOMAIN.COM",""),SoftBreak,Link ("",[],[]) [Str "FTP.DOMAIN.COM"] ("FTP.DOMAIN.COM",""),SoftBreak,Link ("",[],[]) [Str "label"] ("www.domain.com",""),SoftBreak,Link ("",[],[]) [Str "label"] ("ftp.domain.com",""),SoftBreak,Link ("",[],[]) [Str "label"] ("WWW.DOMAIN.COM",""),SoftBreak,Link ("",[],[]) [Str "label"] ("FTP.DOMAIN.COM",""),SoftBreak,Str "[label",Space,Link ("",[],[]) [Str "www.domain.com"] ("www.domain.com",""),Space,Str "]",SoftBreak,Str "[label]",Space,Link ("",[],[]) [Str "www.domain.com"] ("www.domain.com",""),Str "]"] ,Header 1 ("image",[],[]) [Str "Image"] ,Para [Image ("",[],[]) [] ("img.png","")] -,Para [Link ("",[],[]) [Image ("",[],[]) [] ("img.png","")] ("http://txt2tags.org","")] +,Para [Link ("",[],[]) [Image ("",[],[]) [] ("img.png","")] ("https://txt2tags.org","")] ,Para [Image ("",[],[]) [] ("img.png",""),Space,Str "Image",Space,Str "at",Space,Str "the",Space,Str "line",Space,Str "beginning."] ,Para [Str "Image",Space,Str "in",Space,Str "the",Space,Str "middle",Space,Image ("",[],[]) [] ("img.png",""),Space,Str "of",Space,Str "the",Space,Str "line."] ,Para [Str "Image",Space,Str "at",Space,Str "the",Space,Str "line",Space,Str "end.",Space,Image ("",[],[]) [] ("img.png","")] diff --git a/test/txt2tags.t2t b/test/txt2tags.t2t --- a/test/txt2tags.t2t +++ b/test/txt2tags.t2t @@ -270,7 +270,7 @@ [img.png] %%% Syntax: Image pointing to a link: [[img] link] -[[img.png] http://txt2tags.org] +[[img.png] https://txt2tags.org] %%% Align: Image position is preserved when inside paragraph [img.png] Image at the line beginning. diff --git a/test/writer.jats_archiving b/test/writer.jats_archiving --- a/test/writer.jats_archiving +++ b/test/writer.jats_archiving @@ -24,7 +24,7 @@ Anonymous - + 17 7 2006 diff --git a/test/writer.jats_publishing b/test/writer.jats_publishing --- a/test/writer.jats_publishing +++ b/test/writer.jats_publishing @@ -24,7 +24,7 @@ Anonymous - + 17 7 2006 diff --git a/test/writer.jira b/test/writer.jira --- a/test/writer.jira +++ b/test/writer.jira @@ -33,11 +33,10 @@ {quote} Code in a block quote: -{code:java} +{noformat} sub status { print "working"; -} -{code} +}{noformat} A list: # item one @@ -56,22 +55,20 @@ h1. {anchor:code-blocks}Code Blocks Code: -{code:java} +{noformat} ---- (should be four hyphens) sub status { print "working"; } -this code block is indented by one tab -{code} +this code block is indented by one tab{noformat} And: -{code:java} +{noformat} this code block is indented by two tabs -These should not be escaped: \$ \\ \> \[ \{ -{code} +These should not be escaped: \$ \\ \> \[ \{{noformat} ---- h1. {anchor:lists}Lists h2. {anchor:unordered}Unordered @@ -236,9 +233,8 @@ contains seeds, crisp, pleasant to taste * *_orange_* orange fruit -{code:java} -{ orange code block } -{code} +{noformat} +{ orange code block }{noformat} bq. orange block quote Multiple definitions, tight: @@ -292,16 +288,14 @@ This should be a code block, though: -{code:java} +{noformat}
foo -
-{code} +{noformat} As should this: -{code:java} -
foo
-{code} +{noformat} +
foo
{noformat} Now, nested: foo @@ -312,16 +306,14 @@ Code block: -{code:java} - -{code} +{noformat} +{noformat} Just plain comment, with trailing spaces on the line: Code: -{code:java} -
-{code} +{noformat} +
{noformat} Hr’s: ---- @@ -478,9 +470,8 @@ This should \[not\]\[\] be a link. -{code:java} -[not]: /url -{code} +{noformat} +[not]: /url{noformat} Foo [bar|/url/]. Foo [biz|/url/]. @@ -506,9 +497,8 @@ bq. Blockquoted: [http://example.com/] Auto-links should not occur here: {{}} -{code:java} -or here: -{code} +{noformat} +or here: {noformat} ---- h1. {anchor:images}Images From "Voyage dans la Lune" by Georges Melies \(1902): @@ -534,9 +524,8 @@ Subsequent blocks are indented to show that they belong to the footnote \(as with list items). -{code:java} - { } -{code} +{noformat} + { }{noformat} If you want, you can indent every line, but you can also be lazy and just indent the first line of each block. diff --git a/test/writer.latex b/test/writer.latex --- a/test/writer.latex +++ b/test/writer.latex @@ -6,8 +6,8 @@ ]{article} \usepackage{amsmath,amssymb} \usepackage{lmodern} -\usepackage{ifxetex,ifluatex} -\ifnum 0\ifxetex 1\fi\ifluatex 1\fi=0 % if pdftex +\usepackage{iftex} +\ifPDFTeX \usepackage[T1]{fontenc} \usepackage[utf8]{inputenc} \usepackage{textcomp} % provide euro and other symbols @@ -63,7 +63,7 @@ \providecommand{\tightlist}{% \setlength{\itemsep}{0pt}\setlength{\parskip}{0pt}} \setcounter{secnumdepth}{-\maxdimen} % remove section numbering -\ifluatex +\ifLuaTeX \usepackage{selnolig} % disable illegal ligatures \fi diff --git a/test/writers-lang-and-dir.latex b/test/writers-lang-and-dir.latex --- a/test/writers-lang-and-dir.latex +++ b/test/writers-lang-and-dir.latex @@ -7,8 +7,8 @@ ]{article} \usepackage{amsmath,amssymb} \usepackage{lmodern} -\usepackage{ifxetex,ifluatex} -\ifnum 0\ifxetex 1\fi\ifluatex 1\fi=0 % if pdftex +\usepackage{iftex} +\ifPDFTeX \usepackage[T1]{fontenc} \usepackage[utf8]{inputenc} \usepackage{textcomp} % provide euro and other symbols @@ -45,7 +45,7 @@ \providecommand{\tightlist}{% \setlength{\itemsep}{0pt}\setlength{\parskip}{0pt}} \setcounter{secnumdepth}{-\maxdimen} % remove section numbering -\ifxetex +\ifXeTeX % Load polyglossia as late as possible: uses bidi with RTL langages (e.g. Hebrew, Arabic) \usepackage{polyglossia} \setmainlanguage[]{english} @@ -69,14 +69,14 @@ \newcommand{\textfrench}[2][]{\foreignlanguage{french}{#2}} \newenvironment{french}[2][]{\begin{otherlanguage}{french}}{\end{otherlanguage}} \fi -\ifluatex +\ifLuaTeX \usepackage{selnolig} % disable illegal ligatures \fi -\ifxetex +\ifXeTeX % Load bidi as late as possible as it modifies e.g. graphicx \usepackage{bidi} \fi -\ifnum 0\ifxetex 1\fi\ifluatex 1\fi=0 % if pdftex +\ifPDFTeX \TeXXeTstate=1 \newcommand{\RL}[1]{\beginR #1\endR} \newcommand{\LR}[1]{\beginL #1\endL} diff --git a/trypandoc/index.html b/trypandoc/index.html --- a/trypandoc/index.html +++ b/trypandoc/index.html @@ -14,7 +14,7 @@