diff options
| author | Yan Pashkovsky <Yanpas@users.noreply.github.com> | 2018-05-09 19:48:34 +0300 |
|---|---|---|
| committer | GitHub <noreply@github.com> | 2018-05-09 19:48:34 +0300 |
| commit | a337685fe0ab9c63b9456f27787bbe4f0d785a94 (patch) | |
| tree | e9fc4dfc0802f8acd97f06a8cc8d7c89b5a988ab /src | |
| parent | 8e9973b9f761262b6871206f741ac3f2a25aa6bb (diff) | |
| parent | 5f33d2e0cd9f19566904c93be04f586de811dd75 (diff) | |
| download | pandoc-a337685fe0ab9c63b9456f27787bbe4f0d785a94.tar.gz | |
Merge branch 'master' into groff_reader
Diffstat (limited to 'src')
130 files changed, 2476 insertions, 1295 deletions
diff --git a/src/Text/Pandoc/App.hs b/src/Text/Pandoc/App.hs index 26c754cd6..920462d48 100644 --- a/src/Text/Pandoc/App.hs +++ b/src/Text/Pandoc/App.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -42,6 +43,7 @@ module Text.Pandoc.App ( , options , applyFilters ) where +import Prelude import qualified Control.Exception as E import Control.Monad import Control.Monad.Except (catchError, throwError) @@ -50,11 +52,10 @@ import Data.Aeson (defaultOptions) import Data.Aeson.TH (deriveJSON) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as B -import Data.Char (toLower, toUpper) +import Data.Char (toLower, toUpper, isAscii, ord) import Data.List (find, intercalate, isPrefixOf, isSuffixOf, sort) import qualified Data.Map as M import Data.Maybe (fromMaybe, isJust, isNothing) -import Data.Monoid import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as T @@ -65,7 +66,12 @@ import Data.Yaml (decode) import qualified Data.Yaml as Yaml import GHC.Generics import Network.URI (URI (..), parseURI) +#ifdef EMBED_DATA_FILES +import Text.Pandoc.Data (dataFiles) +#else +import System.Directory (getDirectoryContents) import Paths_pandoc (getDataDir) +#endif import Data.Aeson.Encode.Pretty (encodePretty', Config(..), keyOrder, defConfig, Indent(..), NumberFormat(..)) import Skylighting (Style, Syntax (..), defaultSyntaxMap, parseTheme, @@ -87,7 +93,7 @@ import Text.Pandoc.Highlighting (highlightingStyles) import Text.Pandoc.PDF (makePDF) import Text.Pandoc.SelfContained (makeDataURI, makeSelfContained) import Text.Pandoc.Shared (eastAsianLineBreakFilter, stripEmptyParagraphs, - headerShift, isURI, ordNub, safeRead, tabFilter) + headerShift, isURI, ordNub, safeRead, tabFilter, uriPathToPath) import qualified Text.Pandoc.UTF8 as UTF8 import Text.Pandoc.Writers.Math (defaultKaTeXURL, defaultMathJaxURL) import Text.Pandoc.XML (toEntities) @@ -217,17 +223,16 @@ convertWithOpts opts = do then pdfWriterAndProg (optWriter opts) (optPdfEngine opts) else return (nonPdfWriterName $ optWriter opts, Nothing) - let format = baseWriterName + let format = map toLower $ baseWriterName $ takeFileName writerName -- in case path to lua script -- disabling the custom writer for now (writer, writerExts) <- if ".lua" `isSuffixOf` format - -- note: use non-lowercased version writerName then return (TextWriter (\o d -> writeCustom writerName o d) :: Writer PandocIO, mempty) - else case getWriter writerName of + else case getWriter (map toLower writerName) of Left e -> E.throwIO $ PandocAppError $ if format == "pdf" then e ++ @@ -351,12 +356,6 @@ convertWithOpts opts = do maybe return (addStringAsVariable "epub-cover-image") (optEpubCoverImage opts) >>= - (\vars -> case optHTMLMathMethod opts of - LaTeXMathML Nothing -> do - s <- UTF8.toString <$> readDataFile "LaTeXMathML.js" - return $ ("mathml-script", s) : vars - _ -> return vars) - >>= (\vars -> if format == "dzslides" then do dztempl <- UTF8.toString <$> readDataFile @@ -513,16 +512,19 @@ convertWithOpts opts = do let htmlFormat = format `elem` ["html","html4","html5","s5","slidy", "slideous","dzslides","revealjs"] - handleEntities = if (htmlFormat || - format == "docbook4" || - format == "docbook5" || - format == "docbook") && optAscii opts - then toEntities - else id + escape + | optAscii opts + , htmlFormat || format == "docbook4" || + format == "docbook5" || format == "docbook" || + format == "jats" || format == "opml" || + format == "icml" = toEntities + | optAscii opts + , format == "ms" || format == "man" = groffEscape + | otherwise = id addNl = if standalone then id else (<> T.singleton '\n') - output <- (addNl . handleEntities) <$> f writerOptions doc + output <- (addNl . escape) <$> f writerOptions doc writerFn eol outputFile =<< if optSelfContained opts && htmlFormat -- TODO not maximally efficient; change type @@ -530,6 +532,12 @@ convertWithOpts opts = do then T.pack <$> makeSelfContained (T.unpack output) else return output +groffEscape :: Text -> Text +groffEscape = T.concatMap toUchar + where toUchar c + | isAscii c = T.singleton c + | otherwise = T.pack $ printf "\\[u%04X]" (ord c) + type Transform = Pandoc -> Pandoc isTextFormat :: String -> Bool @@ -729,6 +737,7 @@ defaultReaderName fallback (x:xs) = ".odt" -> "odt" ".pdf" -> "pdf" -- so we get an "unknown reader" error ".doc" -> "doc" -- so we get an "unknown reader" error + ".fb2" -> "fb2" _ -> defaultReaderName fallback xs -- Determine default writer based on output file extension @@ -786,7 +795,7 @@ readSource src = case parseURI src of readURI src | uriScheme u == "file:" -> liftIO $ UTF8.toText <$> - BS.readFile (uriPath u) + BS.readFile (uriPathToPath $ uriPath u) _ -> liftIO $ UTF8.toText <$> BS.readFile src @@ -834,8 +843,7 @@ options = , Option "tw" ["to","write"] (ReqArg - (\arg opt -> return opt { optWriter = - Just (map toLower arg) }) + (\arg opt -> return opt { optWriter = Just arg }) "FORMAT") "" @@ -967,6 +975,9 @@ options = setUserDataDir Nothing getDefaultTemplate arg case templ of + Right "" -> do -- e.g. for docx, odt, json: + E.throwIO $ PandocCouldNotFindDataFileError + ("templates/default." ++ arg) Right t -> UTF8.hPutStr stdout t Left e -> E.throwIO e exitSuccess) @@ -1392,40 +1403,6 @@ options = "URL") "" -- Use KaTeX for HTML Math - , Option "m" ["latexmathml", "asciimathml"] - (OptArg - (\arg opt -> do - deprecatedOption "--latexmathml, --asciimathml, -m" "" - return opt { optHTMLMathMethod = LaTeXMathML arg }) - "URL") - "" -- "Use LaTeXMathML script in html output" - - , Option "" ["mimetex"] - (OptArg - (\arg opt -> do - deprecatedOption "--mimetex" "" - let url' = case arg of - Just u -> u ++ "?" - Nothing -> "/cgi-bin/mimetex.cgi?" - return opt { optHTMLMathMethod = WebTeX url' }) - "URL") - "" -- "Use mimetex for HTML math" - - , Option "" ["jsmath"] - (OptArg - (\arg opt -> do - deprecatedOption "--jsmath" "" - return opt { optHTMLMathMethod = JsMath arg}) - "URL") - "" -- "Use jsMath for HTML math" - - , Option "" ["gladtex"] - (NoArg - (\opt -> do - deprecatedOption "--gladtex" "" - return opt { optHTMLMathMethod = GladTeX })) - "" -- "Use gladtex for HTML math" - , Option "" ["abbreviations"] (ReqArg (\arg opt -> return opt { optAbbreviations = Just arg }) @@ -1471,7 +1448,7 @@ options = , Option "" ["bash-completion"] (NoArg (\_ -> do - ddir <- getDataDir + datafiles <- getDataFileNames tpl <- runIOorExplode $ UTF8.toString <$> readDefaultDataFile "bash_completion.tpl" @@ -1483,7 +1460,7 @@ options = (unwords readersNames) (unwords writersNames) (unwords $ map fst highlightingStyles) - ddir + (unwords datafiles) exitSuccess )) "" -- "Print bash completion script" @@ -1557,6 +1534,16 @@ options = ] +getDataFileNames :: IO [FilePath] +getDataFileNames = do +#ifdef EMBED_DATA_FILES + let allDataFiles = map fst dataFiles +#else + allDataFiles <- filter (\x -> x /= "." && x /= "..") <$> + (getDataDir >>= getDirectoryContents) +#endif + return $ "reference.docx" : "reference.odt" : "reference.pptx" : allDataFiles + -- Returns usage message usageMessage :: String -> [OptDescr (Opt -> IO Opt)] -> String usageMessage programName = usageInfo (programName ++ " [OPTIONS] [FILES]") diff --git a/src/Text/Pandoc/Asciify.hs b/src/Text/Pandoc/Asciify.hs index 11d3eddac..2de670270 100644 --- a/src/Text/Pandoc/Asciify.hs +++ b/src/Text/Pandoc/Asciify.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {- Copyright (C) 2013-2018 John MacFarlane <jgm@berkeley.edu> @@ -30,6 +31,7 @@ ascii equivalents (used in constructing HTML identifiers). -} module Text.Pandoc.Asciify (toAsciiChar) where +import Prelude import Data.Char (isAscii) import qualified Data.Map as M diff --git a/src/Text/Pandoc/BCP47.hs b/src/Text/Pandoc/BCP47.hs index 2dd825142..7aadea52a 100644 --- a/src/Text/Pandoc/BCP47.hs +++ b/src/Text/Pandoc/BCP47.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {- Copyright (C) 2017–2018 John MacFarlane <jgm@berkeley.edu> @@ -34,6 +35,7 @@ module Text.Pandoc.BCP47 ( , renderLang ) where +import Prelude import Control.Monad (guard) import Data.Char (isAlphaNum, isAscii, isLetter, isLower, isUpper, toLower, toUpper) diff --git a/src/Text/Pandoc/CSS.hs b/src/Text/Pandoc/CSS.hs index d44b5e1e2..2141b8430 100644 --- a/src/Text/Pandoc/CSS.hs +++ b/src/Text/Pandoc/CSS.hs @@ -1,9 +1,11 @@ +{-# LANGUAGE NoImplicitPrelude #-} module Text.Pandoc.CSS ( foldOrElse , pickStyleAttrProps , pickStylesToKVs ) where +import Prelude import Text.Pandoc.Shared (trim) import Text.Parsec import Text.Parsec.String diff --git a/src/Text/Pandoc/CSV.hs b/src/Text/Pandoc/CSV.hs index 3415ae88f..96bfd6d89 100644 --- a/src/Text/Pandoc/CSV.hs +++ b/src/Text/Pandoc/CSV.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {- Copyright (C) 2017–2018 John MacFarlane <jgm@berkeley.edu> @@ -34,6 +35,7 @@ module Text.Pandoc.CSV ( ParseError ) where +import Prelude import Control.Monad (void) import Data.Text (Text) import qualified Data.Text as T diff --git a/src/Text/Pandoc/Class.hs b/src/Text/Pandoc/Class.hs index aa0379942..4ade2dc6d 100644 --- a/src/Text/Pandoc/Class.hs +++ b/src/Text/Pandoc/Class.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE CPP #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE DeriveFunctor #-} @@ -96,6 +97,7 @@ module Text.Pandoc.Class ( PandocMonad(..) , Translations ) where +import Prelude import Prelude hiding (readFile) import System.Random (StdGen, next, mkStdGen) import qualified System.Random as IO (newStdGen) @@ -106,10 +108,11 @@ import Data.List (stripPrefix) import qualified Data.Unique as IO (newUnique) import qualified Text.Pandoc.UTF8 as UTF8 import qualified System.Directory as Directory -import Text.Pandoc.Compat.Time (UTCTime) +import Data.Time (UTCTime) import Text.Pandoc.Logging +import Text.Pandoc.Shared (uriPathToPath) import Text.Parsec (ParsecT, getPosition, sourceLine, sourceName) -import qualified Text.Pandoc.Compat.Time as IO (getCurrentTime) +import qualified Data.Time as IO (getCurrentTime) import Text.Pandoc.MIME (MimeType, getMimeType, extensionFromMimeType) import Text.Pandoc.Definition import Data.Digest.Pure.SHA (sha1, showDigest) @@ -475,6 +478,14 @@ liftIOError f u = do Left e -> throwError $ PandocIOError u e Right r -> return r +-- | Show potential IO errors to the user continuing execution anyway +logIOError :: IO () -> PandocIO () +logIOError f = do + res <- liftIO $ tryIOError f + case res of + Left e -> report $ IgnoredIOError (E.displayException e) + Right _ -> pure () + instance PandocMonad PandocIO where lookupEnv = liftIO . IO.lookupEnv getCurrentTime = liftIO IO.getCurrentTime @@ -588,7 +599,7 @@ downloadOrRead s = do -- We don't want to treat C:/ as a scheme: Just u' | length (uriScheme u') > 2 -> openURL (show u') Just u' | uriScheme u' == "file:" -> - readLocalFile $ dropWhile (=='/') (uriPath u') + readLocalFile $ uriPathToPath (uriPath u') _ -> readLocalFile fp -- get from local file system where readLocalFile f = do resourcePath <- getResourcePath @@ -853,14 +864,14 @@ writeMedia :: FilePath -> MediaBag -> FilePath -> PandocIO () writeMedia dir mediabag subpath = do -- we join and split to convert a/b/c to a\b\c on Windows; -- in zip containers all paths use / - let fullpath = dir </> normalise subpath + let fullpath = dir </> unEscapeString (normalise subpath) let mbcontents = lookupMedia subpath mediabag case mbcontents of Nothing -> throwError $ PandocResourceNotFound subpath Just (_, bs) -> do report $ Extracting fullpath liftIOError (createDirectoryIfMissing True) (takeDirectory fullpath) - liftIOError (\p -> BL.writeFile p bs) fullpath + logIOError $ BL.writeFile fullpath bs adjustImagePath :: FilePath -> [FilePath] -> Inline -> Inline adjustImagePath dir paths (Image attr lab (src, tit)) @@ -923,7 +934,7 @@ data FileInfo = FileInfo { infoFileMTime :: UTCTime } newtype FileTree = FileTree {unFileTree :: M.Map FilePath FileInfo} - deriving (Monoid) + deriving (Semigroup, Monoid) getFileInfo :: FilePath -> FileTree -> Maybe FileInfo getFileInfo fp tree = diff --git a/src/Text/Pandoc/Compat/Time.hs b/src/Text/Pandoc/Compat/Time.hs deleted file mode 100644 index b1cde82a4..000000000 --- a/src/Text/Pandoc/Compat/Time.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# LANGUAGE CPP #-} - -{- -This compatibility module is needed because, in time 1.5, the -`defaultTimeLocale` function was moved from System.Locale (in the -old-locale library) into Data.Time. - -We support both behaviors because time 1.4 is a boot library for GHC -7.8. time 1.5 is a boot library for GHC 7.10. - -When support is dropped for GHC 7.8, this module may be obsoleted. --} - -#if MIN_VERSION_time(1,5,0) -module Text.Pandoc.Compat.Time ( - module Data.Time -) -where -import Data.Time - -#else -module Text.Pandoc.Compat.Time ( - module Data.Time, - defaultTimeLocale -) -where -import Data.Time -import System.Locale ( defaultTimeLocale ) - -#endif diff --git a/src/Text/Pandoc/Data.hs b/src/Text/Pandoc/Data.hs index af0e4504f..2cf0d3f81 100644 --- a/src/Text/Pandoc/Data.hs +++ b/src/Text/Pandoc/Data.hs @@ -1,7 +1,9 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TemplateHaskell #-} module Text.Pandoc.Data (dataFiles) where +import Prelude import qualified Data.ByteString as B import Data.FileEmbed import System.FilePath (splitDirectories) diff --git a/src/Text/Pandoc/Emoji.hs b/src/Text/Pandoc/Emoji.hs index 3766960ea..5cc965153 100644 --- a/src/Text/Pandoc/Emoji.hs +++ b/src/Text/Pandoc/Emoji.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {- Copyright (C) 2015 John MacFarlane <jgm@berkeley.edu> @@ -28,6 +29,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Emoji symbol lookup from canonical string identifier. -} module Text.Pandoc.Emoji ( emojis ) where +import Prelude import qualified Data.Map as M emojis :: M.Map String String diff --git a/src/Text/Pandoc/Error.hs b/src/Text/Pandoc/Error.hs index f78a31481..feb047f68 100644 --- a/src/Text/Pandoc/Error.hs +++ b/src/Text/Pandoc/Error.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {- @@ -34,6 +35,7 @@ module Text.Pandoc.Error ( PandocError(..), handleError) where +import Prelude import Control.Exception (Exception) import Data.Typeable (Typeable) import GHC.Generics (Generic) diff --git a/src/Text/Pandoc/Extensions.hs b/src/Text/Pandoc/Extensions.hs index fe690713c..5ccb7dffb 100644 --- a/src/Text/Pandoc/Extensions.hs +++ b/src/Text/Pandoc/Extensions.hs @@ -1,3 +1,9 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TemplateHaskell #-} {- Copyright (C) 2012-2018 John MacFarlane <jgm@berkeley.edu> @@ -15,10 +21,6 @@ You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TemplateHaskell #-} {- | Module : Text.Pandoc.Extensions @@ -47,6 +49,7 @@ module Text.Pandoc.Extensions ( Extension(..) , githubMarkdownExtensions , multimarkdownExtensions ) where +import Prelude import Data.Aeson (FromJSON (..), ToJSON (..), defaultOptions) import Data.Aeson.TH (deriveJSON) import Data.Bits (clearBit, setBit, testBit, (.|.)) @@ -59,9 +62,11 @@ import Text.Parsec newtype Extensions = Extensions Integer deriving (Show, Read, Eq, Ord, Data, Typeable, Generic, ToJSON, FromJSON) +instance Semigroup Extensions where + (Extensions a) <> (Extensions b) = Extensions (a .|. b) instance Monoid Extensions where mempty = Extensions 0 - mappend (Extensions a) (Extensions b) = Extensions (a .|. b) + mappend = (<>) extensionsFromList :: [Extension] -> Extensions extensionsFromList = foldr enableExtension emptyExtensions @@ -317,6 +322,8 @@ getDefaultExtensions "muse" = extensionsFromList Ext_auto_identifiers] getDefaultExtensions "plain" = plainExtensions getDefaultExtensions "gfm" = githubMarkdownExtensions +getDefaultExtensions "commonmark" = extensionsFromList + [Ext_raw_html] getDefaultExtensions "org" = extensionsFromList [Ext_citations, Ext_auto_identifiers] @@ -338,6 +345,10 @@ getDefaultExtensions "latex" = extensionsFromList [Ext_smart, Ext_latex_macros, Ext_auto_identifiers] +getDefaultExtensions "beamer" = extensionsFromList + [Ext_smart, + Ext_latex_macros, + Ext_auto_identifiers] getDefaultExtensions "context" = extensionsFromList [Ext_smart, Ext_auto_identifiers] diff --git a/src/Text/Pandoc/Filter.hs b/src/Text/Pandoc/Filter.hs index e2a3c3e16..5461648e1 100644 --- a/src/Text/Pandoc/Filter.hs +++ b/src/Text/Pandoc/Filter.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {- Copyright (C) 2006-2017 John MacFarlane <jgm@berkeley.edu> @@ -33,6 +34,7 @@ module Text.Pandoc.Filter , applyFilters ) where +import Prelude import Data.Aeson (defaultOptions) import Data.Aeson.TH (deriveJSON) import Data.Foldable (foldrM) diff --git a/src/Text/Pandoc/Filter/JSON.hs b/src/Text/Pandoc/Filter/JSON.hs index 5772c2c41..97b291603 100644 --- a/src/Text/Pandoc/Filter/JSON.hs +++ b/src/Text/Pandoc/Filter/JSON.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {- Copyright (C) 2006-2018 John MacFarlane <jgm@berkeley.edu> @@ -29,6 +30,7 @@ Programmatically modifications of pandoc documents via JSON filters. -} module Text.Pandoc.Filter.JSON (apply) where +import Prelude import Control.Monad (unless, when) import Control.Monad.Trans (MonadIO (liftIO)) import Data.Aeson (eitherDecode', encode) diff --git a/src/Text/Pandoc/Filter/Lua.hs b/src/Text/Pandoc/Filter/Lua.hs index 597a31cbc..d559fb912 100644 --- a/src/Text/Pandoc/Filter/Lua.hs +++ b/src/Text/Pandoc/Filter/Lua.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {- Copyright (C) 2006-2018 John MacFarlane <jgm@berkeley.edu> @@ -29,6 +30,7 @@ Apply Lua filters to modify a pandoc documents programmatically. -} module Text.Pandoc.Filter.Lua (apply) where +import Prelude import Control.Exception (throw) import Text.Pandoc.Class (PandocIO) import Text.Pandoc.Definition (Pandoc) diff --git a/src/Text/Pandoc/Filter/Path.hs b/src/Text/Pandoc/Filter/Path.hs index 8074bcbb7..f244597aa 100644 --- a/src/Text/Pandoc/Filter/Path.hs +++ b/src/Text/Pandoc/Filter/Path.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {- Copyright (C) 2006-2018 John MacFarlane <jgm@berkeley.edu> @@ -31,6 +32,7 @@ module Text.Pandoc.Filter.Path ( expandFilterPath ) where +import Prelude import Text.Pandoc.Class (PandocMonad, fileExists, getUserDataDir) import System.FilePath ((</>), isRelative) diff --git a/src/Text/Pandoc/Highlighting.hs b/src/Text/Pandoc/Highlighting.hs index 113727750..70bb70302 100644 --- a/src/Text/Pandoc/Highlighting.hs +++ b/src/Text/Pandoc/Highlighting.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {- Copyright (C) 2008-2018 John MacFarlane <jgm@berkeley.edu> @@ -49,6 +50,7 @@ module Text.Pandoc.Highlighting ( highlightingStyles , fromListingsLanguage , toListingsLanguage ) where +import Prelude import Control.Monad import Data.Char (toLower) import qualified Data.Map as M diff --git a/src/Text/Pandoc/ImageSize.hs b/src/Text/Pandoc/ImageSize.hs index 4c76aac13..c5fe98a66 100644 --- a/src/Text/Pandoc/ImageSize.hs +++ b/src/Text/Pandoc/ImageSize.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings, ScopedTypeVariables, CPP #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-} {- @@ -49,6 +50,7 @@ module Text.Pandoc.ImageSize ( ImageType(..) , showInPixel , showFl ) where +import Prelude import Data.ByteString (ByteString, unpack) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy as BL @@ -126,7 +128,7 @@ imageType img = case B.take 4 img of | B.take 4 (B.drop 1 $ B.dropWhile (/=' ') img) == "EPSF" -> return Eps "\x01\x00\x00\x00" - | B.take 4 (B.drop 40 img) == " EMF" + | B.take 4 (B.drop 40 img) == " EMF" -> return Emf _ -> mzero @@ -361,9 +363,9 @@ svgSize opts img = do , dpiX = dpi , dpiY = dpi } - + emfSize :: ByteString -> Maybe ImageSize -emfSize img = +emfSize img = let parseheader = runGetOrFail $ do skip 0x18 -- 0x00 @@ -388,11 +390,11 @@ emfSize img = , dpiX = fromIntegral dpiW , dpiY = fromIntegral dpiH } - in + in case parseheader . BL.fromStrict $ img of Left _ -> Nothing Right (_, _, size) -> Just size - + jpegSize :: ByteString -> Either String ImageSize jpegSize img = diff --git a/src/Text/Pandoc/Logging.hs b/src/Text/Pandoc/Logging.hs index b22c08467..4b025821c 100644 --- a/src/Text/Pandoc/Logging.hs +++ b/src/Text/Pandoc/Logging.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} @@ -39,6 +40,7 @@ module Text.Pandoc.Logging ( , messageVerbosity ) where +import Prelude import Control.Monad (mzero) import Data.Aeson import Data.Aeson.Encode.Pretty (Config (..), defConfig, encodePretty', @@ -83,6 +85,7 @@ data LogMessage = | InlineNotRendered Inline | BlockNotRendered Block | DocxParserWarning String + | IgnoredIOError String | CouldNotFetchResource String String | CouldNotDetermineImageSize String String | CouldNotConvertImage String String @@ -99,6 +102,7 @@ data LogMessage = | Deprecated String String | NoTranslation String | CouldNotLoadTranslations String String + | UnexpectedXmlElement String String deriving (Show, Eq, Data, Ord, Typeable, Generic) instance ToJSON LogMessage where @@ -172,6 +176,8 @@ instance ToJSON LogMessage where ["contents" .= toJSON bl] DocxParserWarning s -> ["contents" .= Text.pack s] + IgnoredIOError s -> + ["contents" .= Text.pack s] CouldNotFetchResource fp s -> ["path" .= Text.pack fp, "message" .= Text.pack s] @@ -209,6 +215,9 @@ instance ToJSON LogMessage where CouldNotLoadTranslations lang msg -> ["lang" .= Text.pack lang, "message" .= Text.pack msg] + UnexpectedXmlElement element parent -> + ["element" .= Text.pack element, + "parent" .= Text.pack parent] showPos :: SourcePos -> String @@ -259,6 +268,8 @@ showLogMessage msg = "Not rendering " ++ show bl DocxParserWarning s -> "Docx parser warning: " ++ s + IgnoredIOError s -> + "IO Error (ignored): " ++ s CouldNotFetchResource fp s -> "Could not fetch resource '" ++ fp ++ "'" ++ if null s then "" else ": " ++ s @@ -303,6 +314,8 @@ showLogMessage msg = CouldNotLoadTranslations lang m -> "Could not load translations for " ++ lang ++ if null m then "" else '\n' : m + UnexpectedXmlElement element parent -> + "Unexpected XML element " ++ element ++ " in " ++ parent messageVerbosity:: LogMessage -> Verbosity messageVerbosity msg = @@ -324,6 +337,7 @@ messageVerbosity msg = InlineNotRendered{} -> INFO BlockNotRendered{} -> INFO DocxParserWarning{} -> INFO + IgnoredIOError{} -> WARNING CouldNotFetchResource{} -> WARNING CouldNotDetermineImageSize{} -> WARNING CouldNotConvertImage{} -> WARNING @@ -340,3 +354,4 @@ messageVerbosity msg = Deprecated{} -> WARNING NoTranslation{} -> WARNING CouldNotLoadTranslations{} -> WARNING + UnexpectedXmlElement {} -> WARNING diff --git a/src/Text/Pandoc/Lua.hs b/src/Text/Pandoc/Lua.hs index 790be47d5..cd7117074 100644 --- a/src/Text/Pandoc/Lua.hs +++ b/src/Text/Pandoc/Lua.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {- Copyright © 2017–2018 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> @@ -31,13 +32,14 @@ module Text.Pandoc.Lua , runPandocLua ) where +import Prelude import Control.Monad ((>=>)) import Foreign.Lua (FromLuaStack (peek), Lua, LuaException (..), Status (OK), ToLuaStack (push)) import Text.Pandoc.Class (PandocIO) import Text.Pandoc.Definition (Pandoc) import Text.Pandoc.Lua.Filter (LuaFilter, walkMWithLuaFilter) -import Text.Pandoc.Lua.Init (runPandocLua) +import Text.Pandoc.Lua.Init (runPandocLua, registerScriptPath) import Text.Pandoc.Lua.Util (popValue) import Text.Pandoc.Options (ReaderOptions) import qualified Foreign.Lua as Lua @@ -55,11 +57,12 @@ runLuaFilter' :: ReaderOptions -> FilePath -> String runLuaFilter' ropts filterPath format pd = do registerFormat registerReaderOptions + registerScriptPath filterPath top <- Lua.gettop stat <- Lua.dofile filterPath if stat /= OK then do - luaErrMsg <- peek (-1) <* Lua.pop 1 + luaErrMsg <- popValue Lua.throwLuaError luaErrMsg else do newtop <- Lua.gettop diff --git a/src/Text/Pandoc/Lua/Filter.hs b/src/Text/Pandoc/Lua/Filter.hs index cc2b9d47e..264066305 100644 --- a/src/Text/Pandoc/Lua/Filter.hs +++ b/src/Text/Pandoc/Lua/Filter.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE FlexibleContexts #-} module Text.Pandoc.Lua.Filter ( LuaFilterFunction @@ -10,6 +11,7 @@ module Text.Pandoc.Lua.Filter ( LuaFilterFunction , blockElementNames , inlineElementNames ) where +import Prelude import Control.Monad (mplus, unless, when, (>=>)) import Control.Monad.Catch (finally) import Text.Pandoc.Definition diff --git a/src/Text/Pandoc/Lua/Init.hs b/src/Text/Pandoc/Lua/Init.hs index d1a26ebad..c8c7fdfbd 100644 --- a/src/Text/Pandoc/Lua/Init.hs +++ b/src/Text/Pandoc/Lua/Init.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {- Copyright © 2017-2018 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> @@ -31,8 +32,10 @@ module Text.Pandoc.Lua.Init , runPandocLua , initLuaState , luaPackageParams + , registerScriptPath ) where +import Prelude import Control.Monad.Trans (MonadIO (..)) import Data.Data (Data, dataTypeConstrs, dataTypeOf, showConstr) import Data.IORef (newIORef, readIORef) @@ -88,6 +91,11 @@ initLuaState luaPkgParams = do loadScriptFromDataDir (luaPkgDataDir luaPkgParams) "init.lua" putConstructorsInRegistry +registerScriptPath :: FilePath -> Lua () +registerScriptPath fp = do + Lua.push fp + Lua.setglobal "PANDOC_SCRIPT_FILE" + putConstructorsInRegistry :: Lua () putConstructorsInRegistry = do Lua.getglobal "pandoc" @@ -101,7 +109,7 @@ putConstructorsInRegistry = do Lua.pop 1 where constrsToReg :: Data a => a -> Lua () - constrsToReg = mapM_ putInReg . map showConstr . dataTypeConstrs . dataTypeOf + constrsToReg = mapM_ (putInReg . showConstr) . dataTypeConstrs . dataTypeOf putInReg :: String -> Lua () putInReg name = do diff --git a/src/Text/Pandoc/Lua/Module/MediaBag.hs b/src/Text/Pandoc/Lua/Module/MediaBag.hs index 7d942a452..f48fe56c5 100644 --- a/src/Text/Pandoc/Lua/Module/MediaBag.hs +++ b/src/Text/Pandoc/Lua/Module/MediaBag.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {- Copyright © 2017-2018 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> @@ -29,6 +30,7 @@ module Text.Pandoc.Lua.Module.MediaBag ( pushModule ) where +import Prelude import Control.Monad (zipWithM_) import Data.IORef (IORef, modifyIORef', readIORef) import Data.Maybe (fromMaybe) diff --git a/src/Text/Pandoc/Lua/Module/Pandoc.hs b/src/Text/Pandoc/Lua/Module/Pandoc.hs index b9410a353..8cb630d7b 100644 --- a/src/Text/Pandoc/Lua/Module/Pandoc.hs +++ b/src/Text/Pandoc/Lua/Module/Pandoc.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {- Copyright © 2017-2018 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> @@ -30,6 +31,7 @@ module Text.Pandoc.Lua.Module.Pandoc ( pushModule ) where +import Prelude import Control.Monad (when) import Data.Default (Default (..)) import Data.Maybe (fromMaybe) diff --git a/src/Text/Pandoc/Lua/Module/Utils.hs b/src/Text/Pandoc/Lua/Module/Utils.hs index f8eb96dc7..7fa4616be 100644 --- a/src/Text/Pandoc/Lua/Module/Utils.hs +++ b/src/Text/Pandoc/Lua/Module/Utils.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {- Copyright © 2017-2018 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> @@ -29,6 +30,7 @@ module Text.Pandoc.Lua.Module.Utils ( pushModule ) where +import Prelude import Control.Applicative ((<|>)) import Data.Default (def) import Foreign.Lua (FromLuaStack, Lua, LuaInteger, NumResults) diff --git a/src/Text/Pandoc/Lua/Packages.hs b/src/Text/Pandoc/Lua/Packages.hs index 1e6ff22fe..59637826e 100644 --- a/src/Text/Pandoc/Lua/Packages.hs +++ b/src/Text/Pandoc/Lua/Packages.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {- Copyright © 2017-2018 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> @@ -32,6 +33,7 @@ module Text.Pandoc.Lua.Packages , installPandocPackageSearcher ) where +import Prelude import Control.Monad (forM_) import Data.ByteString.Char8 (unpack) import Data.IORef (IORef) diff --git a/src/Text/Pandoc/Lua/StackInstances.hs b/src/Text/Pandoc/Lua/StackInstances.hs index 7e0dc20c4..3298079c5 100644 --- a/src/Text/Pandoc/Lua/StackInstances.hs +++ b/src/Text/Pandoc/Lua/StackInstances.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {- Copyright © 2012-2018 John MacFarlane <jgm@berkeley.edu> 2017-2018 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> @@ -33,6 +34,7 @@ StackValue instances for pandoc types. -} module Text.Pandoc.Lua.StackInstances () where +import Prelude import Control.Applicative ((<|>)) import Control.Monad (when) import Control.Monad.Catch (finally) diff --git a/src/Text/Pandoc/Lua/Util.hs b/src/Text/Pandoc/Lua/Util.hs index b7149af39..ea9ec2554 100644 --- a/src/Text/Pandoc/Lua/Util.hs +++ b/src/Text/Pandoc/Lua/Util.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {- Copyright © 2012-2018 John MacFarlane <jgm@berkeley.edu> 2017-2018 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> @@ -46,6 +47,7 @@ module Text.Pandoc.Lua.Util , dostring' ) where +import Prelude import Control.Monad (when) import Control.Monad.Catch (finally) import Data.ByteString.Char8 (unpack) @@ -132,7 +134,7 @@ class PushViaCall a where instance PushViaCall (Lua ()) where pushViaCall' fn pushArgs num = do Lua.push fn - Lua.rawget (Lua.registryindex) + Lua.rawget Lua.registryindex pushArgs call num 1 diff --git a/src/Text/Pandoc/MIME.hs b/src/Text/Pandoc/MIME.hs index 43abe9b2f..cb7debb2e 100644 --- a/src/Text/Pandoc/MIME.hs +++ b/src/Text/Pandoc/MIME.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {- Copyright (C) 2011-2018 John MacFarlane <jgm@berkeley.edu> @@ -29,6 +30,7 @@ Mime type lookup for ODT writer. -} module Text.Pandoc.MIME ( MimeType, getMimeType, getMimeTypeDef, extensionFromMimeType )where +import Prelude import Data.Char (toLower) import Data.List (isPrefixOf, isSuffixOf) import qualified Data.Map as M @@ -172,7 +174,7 @@ mimeTypesList = -- List borrowed from happstack-server. ,("eml","message/rfc822") ,("ent","chemical/x-ncbi-asn1-ascii") ,("eot","application/vnd.ms-fontobject") - ,("eps","application/postscript") + ,("eps","application/eps") ,("etx","text/x-setext") ,("exe","application/x-msdos-program") ,("ez","application/andrew-inset") diff --git a/src/Text/Pandoc/MediaBag.hs b/src/Text/Pandoc/MediaBag.hs index 0d060fe1a..bb0d60aff 100644 --- a/src/Text/Pandoc/MediaBag.hs +++ b/src/Text/Pandoc/MediaBag.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {- @@ -36,6 +38,7 @@ module Text.Pandoc.MediaBag ( insertMedia, mediaDirectory, ) where +import Prelude import qualified Data.ByteString.Lazy as BL import Data.Data (Data) import qualified Data.Map as M @@ -50,7 +53,7 @@ import Text.Pandoc.MIME (MimeType, getMimeTypeDef) -- can be used for an empty 'MediaBag', and '<>' can be used to append -- two 'MediaBag's. newtype MediaBag = MediaBag (M.Map [String] (MimeType, BL.ByteString)) - deriving (Monoid, Data, Typeable) + deriving (Semigroup, Monoid, Data, Typeable) instance Show MediaBag where show bag = "MediaBag " ++ show (mediaDirectory bag) diff --git a/src/Text/Pandoc/Options.hs b/src/Text/Pandoc/Options.hs index bd4ab252b..4797a3094 100644 --- a/src/Text/Pandoc/Options.hs +++ b/src/Text/Pandoc/Options.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TemplateHaskell #-} @@ -46,6 +47,7 @@ module Text.Pandoc.Options ( module Text.Pandoc.Extensions , def , isEnabled ) where +import Prelude import Data.Aeson (defaultOptions) import Data.Aeson.TH (deriveJSON) import Data.Data (Data) @@ -104,9 +106,6 @@ defaultAbbrevs = Set.fromList data EPUBVersion = EPUB2 | EPUB3 deriving (Eq, Show, Read, Data, Typeable, Generic) data HTMLMathMethod = PlainMath - | LaTeXMathML (Maybe String) -- url of LaTeXMathML.js - | JsMath (Maybe String) -- url of jsMath load script - | GladTeX | WebTeX String -- url of TeX->image script. | MathML | MathJax String -- url of MathJax.js diff --git a/src/Text/Pandoc/PDF.hs b/src/Text/Pandoc/PDF.hs index 5f41d6c55..b171d65b0 100644 --- a/src/Text/Pandoc/PDF.hs +++ b/src/Text/Pandoc/PDF.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -32,6 +33,7 @@ Conversion of LaTeX documents to PDF. -} module Text.Pandoc.PDF ( makePDF ) where +import Prelude import qualified Codec.Picture as JP import qualified Control.Exception as E import Control.Monad (unless, when) @@ -41,10 +43,8 @@ import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy.Char8 as BC import Data.Maybe (fromMaybe) -import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as T -import qualified Data.Text.IO as TextIO import System.Directory import System.Environment import System.Exit (ExitCode (..)) @@ -61,7 +61,7 @@ import Text.Pandoc.Error (PandocError (PandocPDFProgramNotFoundError)) import Text.Pandoc.MIME (getMimeType) import Text.Pandoc.Options (HTMLMathMethod (..), WriterOptions (..)) import Text.Pandoc.Process (pipeProcess) -import Text.Pandoc.Shared (inDirectory, stringify, withTempDir) +import Text.Pandoc.Shared (inDirectory, stringify) import qualified Text.Pandoc.UTF8 as UTF8 import Text.Pandoc.Walk (walkM) import Text.Pandoc.Writers.Shared (getField, metaToJSON) @@ -127,9 +127,11 @@ makePDF "pdfroff" pdfargs writer opts doc = do verbosity <- getVerbosity liftIO $ ms2pdf verbosity args source makePDF program pdfargs writer opts doc = do - let withTemp = if takeBaseName program == "context" - then withTempDirectory "." - else withTempDir + -- With context and latex, we create a temp directory within + -- the working directory, since pdflatex sometimes tries to + -- use tools like epstopdf.pl, which are restricted if run + -- on files outside the working directory. + let withTemp = withTempDirectory "." commonState <- getCommonState verbosity <- getVerbosity liftIO $ withTemp "tex2pdf." $ \tmpdir -> do @@ -170,6 +172,8 @@ convertImage tmpdir fname = Just "image/png" -> doNothing Just "image/jpeg" -> doNothing Just "application/pdf" -> doNothing + -- Note: eps is converted by pdflatex using epstopdf.pl + Just "application/eps" -> doNothing Just "image/svg+xml" -> E.catch (do (exit, _) <- pipeProcess Nothing "rsvg-convert" ["-f","pdf","-a","-o",pdfOut,fname] BL.empty @@ -274,7 +278,12 @@ runTeXProgram verbosity program args runNumber numRuns tmpDir source = do let file' = file #endif let programArgs = ["-halt-on-error", "-interaction", "nonstopmode", - "-output-directory", tmpDir'] ++ args ++ [file'] + "-output-directory", tmpDir'] ++ + -- see #4484, only compress images on last run: + if program == "xelatex" && runNumber < numRuns + then ["-output-driver", "xdvipdfmx -z0"] + else [] + ++ args ++ [file'] env' <- getEnvironment let sep = [searchPathSeparator] let texinputs = maybe (tmpDir' ++ sep) ((tmpDir' ++ sep) ++) @@ -354,9 +363,14 @@ html2pdf :: Verbosity -- ^ Verbosity level -> Text -- ^ HTML5 source -> IO (Either ByteString ByteString) html2pdf verbosity program args source = do + -- write HTML to temp file so we don't have to rewrite + -- all links in `a`, `img`, `style`, `script`, etc. tags, + -- and piping to weasyprint didn't work on Windows either. + file <- withTempFile "." "html2pdf.html" $ \fp _ -> return fp pdfFile <- withTempFile "." "html2pdf.pdf" $ \fp _ -> return fp + BS.writeFile file $ UTF8.fromText source let pdfFileArgName = ["-o" | program == "prince"] - let programArgs = args ++ ["-"] ++ pdfFileArgName ++ [pdfFile] + let programArgs = args ++ [file] ++ pdfFileArgName ++ [pdfFile] env' <- getEnvironment when (verbosity >= INFO) $ do putStrLn "[makePDF] Command line:" @@ -365,15 +379,16 @@ html2pdf verbosity program args source = do putStrLn "[makePDF] Environment:" mapM_ print env' putStr "\n" - putStrLn "[makePDF] Contents of intermediate HTML:" - TextIO.putStr source + putStrLn $ "[makePDF] Contents of " ++ file ++ ":" + BL.readFile file >>= BL.putStr putStr "\n" (exit, out) <- E.catch - (pipeProcess (Just env') program programArgs $ BL.fromStrict $ UTF8.fromText source) + (pipeProcess (Just env') program programArgs BL.empty) (\(e :: IOError) -> if isDoesNotExistError e then E.throwIO $ PandocPDFProgramNotFoundError program else E.throwIO e) + removeFile file when (verbosity >= INFO) $ do BL.hPutStr stdout out putStr "\n" diff --git a/src/Text/Pandoc/Parsing.hs b/src/Text/Pandoc/Parsing.hs index 82abcb440..fa6baf1c7 100644 --- a/src/Text/Pandoc/Parsing.hs +++ b/src/Text/Pandoc/Parsing.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -133,7 +135,7 @@ module Text.Pandoc.Parsing ( takeWhileP, extractIdClass, insertIncludedFile, insertIncludedFileF, - -- * Re-exports from Text.Pandoc.Parsec + -- * Re-exports from Text.Parsec Stream, runParser, runParserT, @@ -194,6 +196,7 @@ module Text.Pandoc.Parsing ( takeWhileP, ) where +import Prelude import Control.Monad.Identity import Control.Monad.Reader import Data.Char (chr, isAlphaNum, isAscii, isAsciiUpper, isHexDigit, @@ -202,7 +205,6 @@ import Data.Default import Data.List (intercalate, isSuffixOf, transpose) import qualified Data.Map as M import Data.Maybe (mapMaybe, fromMaybe) -import Data.Monoid ((<>)) import qualified Data.Set as Set import Data.Text (Text) import Text.HTML.TagSoup.Entity (lookupEntity) @@ -250,10 +252,11 @@ returnF = return . return trimInlinesF :: Future s Inlines -> Future s Inlines trimInlinesF = liftM trimInlines -instance Monoid a => Monoid (Future s a) where +instance Semigroup a => Semigroup (Future s a) where + (<>) = liftM2 (<>) +instance (Semigroup a, Monoid a) => Monoid (Future s a) where mempty = return mempty - mappend = liftM2 mappend - mconcat = liftM mconcat . sequence + mappend = (<>) -- | Parse characters while a predicate is true. takeWhileP :: Monad m @@ -529,15 +532,15 @@ romanNumeral upperCase = do map char romanDigits thousands <- ((1000 *) . length) <$> many thousand ninehundreds <- option 0 $ try $ hundred >> thousand >> return 900 - fivehundreds <- ((500 *) . length) <$> many fivehundred + fivehundreds <- option 0 $ 500 <$ fivehundred fourhundreds <- option 0 $ try $ hundred >> fivehundred >> return 400 hundreds <- ((100 *) . length) <$> many hundred nineties <- option 0 $ try $ ten >> hundred >> return 90 - fifties <- ((50 *) . length) <$> many fifty + fifties <- option 0 $ (50 <$ fifty) forties <- option 0 $ try $ ten >> fifty >> return 40 tens <- ((10 *) . length) <$> many ten nines <- option 0 $ try $ one >> ten >> return 9 - fives <- ((5 *) . length) <$> many five + fives <- option 0 $ (5 <$ five) fours <- option 0 $ try $ one >> five >> return 4 ones <- length <$> many one let total = thousands + ninehundreds + fivehundreds + fourhundreds + @@ -590,7 +593,7 @@ uri = try $ do -- http://en.wikipedia.org/wiki/State_of_emergency_(disambiguation) -- as a URL, while NOT picking up the closing paren in -- (http://wikipedia.org). So we include balanced parens in the URL. - let isWordChar c = isAlphaNum c || c `elem` "#$%*+/@\\_-&=" + let isWordChar c = isAlphaNum c || c `elem` "#$%+/@\\_-&=" let wordChar = satisfy isWordChar let percentEscaped = try $ char '%' >> skipMany1 (satisfy isHexDigit) let entity = () <$ characterReference @@ -1437,7 +1440,7 @@ token pp pos match = tokenPrim pp (\_ t _ -> pos t) match infixr 5 <+?> (<+?>) :: (Monoid a) => ParserT s st m a -> ParserT s st m a -> ParserT s st m a -a <+?> b = a >>= flip fmap (try b <|> return mempty) . (<>) +a <+?> b = a >>= flip fmap (try b <|> return mempty) . mappend extractIdClass :: Attr -> Attr extractIdClass (ident, cls, kvs) = (ident', cls', kvs') diff --git a/src/Text/Pandoc/Pretty.hs b/src/Text/Pandoc/Pretty.hs index 25c2373a6..de3d54ee2 100644 --- a/src/Text/Pandoc/Pretty.hs +++ b/src/Text/Pandoc/Pretty.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {- @@ -77,12 +78,12 @@ module Text.Pandoc.Pretty ( ) where +import Prelude import Control.Monad import Control.Monad.State.Strict import Data.Char (isSpace) import Data.Foldable (toList) import Data.List (intersperse) -import Data.Monoid ((<>)) import Data.Sequence (Seq, ViewL (..), fromList, mapWithIndex, singleton, viewl, (<|)) import qualified Data.Sequence as Seq @@ -112,7 +113,7 @@ data D = Text Int String deriving (Show, Eq) newtype Doc = Doc { unDoc :: Seq D } - deriving (Monoid, Show, Eq) + deriving (Semigroup, Monoid, Show, Eq) instance IsString Doc where fromString = text diff --git a/src/Text/Pandoc/Process.hs b/src/Text/Pandoc/Process.hs index 27807a8c8..868977c86 100644 --- a/src/Text/Pandoc/Process.hs +++ b/src/Text/Pandoc/Process.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {- Copyright (C) 2013-2018 John MacFarlane <jgm@berkeley.edu> @@ -29,6 +30,7 @@ ByteString variant of 'readProcessWithExitCode'. -} module Text.Pandoc.Process (pipeProcess) where +import Prelude import Control.Concurrent (forkIO, newEmptyMVar, putMVar, takeMVar) import Control.Exception import Control.Monad (unless) diff --git a/src/Text/Pandoc/Readers.hs b/src/Text/Pandoc/Readers.hs index 77d6d9130..76492b0aa 100644 --- a/src/Text/Pandoc/Readers.hs +++ b/src/Text/Pandoc/Readers.hs @@ -1,6 +1,7 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-} + {- Copyright (C) 2006-2018 John MacFarlane <jgm@berkeley.edu> @@ -64,11 +65,13 @@ module Text.Pandoc.Readers , readTxt2Tags , readEPUB , readMuse + , readFB2 -- * Miscellaneous , getReader , getDefaultExtensions ) where +import Prelude import Control.Monad.Except (throwError) import Data.Aeson import qualified Data.ByteString.Lazy as BL @@ -84,6 +87,7 @@ import Text.Pandoc.Readers.Creole import Text.Pandoc.Readers.DocBook import Text.Pandoc.Readers.Docx import Text.Pandoc.Readers.EPUB +import Text.Pandoc.Readers.FB2 import Text.Pandoc.Readers.Haddock import Text.Pandoc.Readers.HTML (readHtml) import Text.Pandoc.Readers.JATS (readJATS) @@ -143,6 +147,7 @@ readers = [ ("native" , TextReader readNative) ,("epub" , ByteStringReader readEPUB) ,("muse" , TextReader readMuse) ,("man" , TextReader readMan) + ,("fb2" , TextReader readFB2) ] -- | Retrieve reader, extensions based on formatSpec (format+extensions). diff --git a/src/Text/Pandoc/Readers/CommonMark.hs b/src/Text/Pandoc/Readers/CommonMark.hs index 6fbc09c17..79a4abbc2 100644 --- a/src/Text/Pandoc/Readers/CommonMark.hs +++ b/src/Text/Pandoc/Readers/CommonMark.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {- Copyright (C) 2015-2018 John MacFarlane <jgm@berkeley.edu> @@ -32,6 +33,7 @@ CommonMark is a strongly specified variant of Markdown: http://commonmark.org. module Text.Pandoc.Readers.CommonMark (readCommonMark) where +import Prelude import CMarkGFM import Control.Monad.State import Data.Char (isAlphaNum, isLetter, isSpace, toLower) diff --git a/src/Text/Pandoc/Readers/Creole.hs b/src/Text/Pandoc/Readers/Creole.hs index 505d1686d..4fd38c0fd 100644 --- a/src/Text/Pandoc/Readers/Creole.hs +++ b/src/Text/Pandoc/Readers/Creole.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {- Copyright (C) 2017 Sascha Wilde <wilde@sha-bang.de> @@ -35,10 +36,10 @@ Conversion of creole text to 'Pandoc' document. module Text.Pandoc.Readers.Creole ( readCreole ) where +import Prelude import Control.Monad.Except (guard, liftM2, throwError) import qualified Data.Foldable as F import Data.Maybe (fromMaybe) -import Data.Monoid import Data.Text (Text) import qualified Data.Text as T import qualified Text.Pandoc.Builder as B @@ -67,7 +68,7 @@ type CRLParser = ParserT [Char] ParserState -- Utility functions -- -(<+>) :: (Monad m, Monoid a) => m a -> m a -> m a +(<+>) :: (Monad m, Semigroup a) => m a -> m a -> m a (<+>) = liftM2 (<>) -- we have to redefine `enclosed' from Text.Pandoc.Parsing, because it diff --git a/src/Text/Pandoc/Readers/DocBook.hs b/src/Text/Pandoc/Readers/DocBook.hs index 728f77a05..3d48c7ee8 100644 --- a/src/Text/Pandoc/Readers/DocBook.hs +++ b/src/Text/Pandoc/Readers/DocBook.hs @@ -1,5 +1,35 @@ -{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE NoImplicitPrelude #-} +{- +Copyright (C) 2006-2018 John MacFarlane <jgm@berkeley.edu> + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- | + Module : Text.Pandoc.Readers.DocBook + Copyright : Copyright (C) 2006-2018 John MacFarlane + License : GNU GPL, version 2 or above + + Maintainer : John MacFarlane <jgm@berkeley.edu> + Stability : alpha + Portability : portable + +Conversion of DocBook XML to 'Pandoc' document. +-} module Text.Pandoc.Readers.DocBook ( readDocBook ) where +import Prelude import Control.Monad.State.Strict import Data.Char (isSpace, toUpper) import Data.Default @@ -235,7 +265,7 @@ List of all DocBook tags, with [x] indicating implemented, [ ] manvolnum - A reference volume number [x] markup - A string of formatting markup in text that is to be represented literally -[ ] mathphrase - A mathematical phrase, an expression that can be represented +[x] mathphrase - A mathematical phrase, an expression that can be represented with ordinary text and a small amount of markup [ ] medialabel - A name that identifies the physical medium on which some information resides @@ -697,6 +727,8 @@ parseBlock (Elem e) = "bibliodiv" -> sect 1 "biblioentry" -> parseMixed para (elContent e) "bibliomixed" -> parseMixed para (elContent e) + "equation" -> para <$> equation e displayMath + "informalequation" -> para <$> equation e displayMath "glosssee" -> para . (\ils -> text "See " <> ils <> str ".") <$> getInlines e "glossseealso" -> para . (\ils -> text "See also " <> ils <> str ".") @@ -923,9 +955,9 @@ parseInline (CRef ref) = return $ maybe (text $ map toUpper ref) text $ lookupEntity ref parseInline (Elem e) = case qName (elName e) of - "equation" -> equation displayMath - "informalequation" -> equation displayMath - "inlineequation" -> equation math + "equation" -> equation e displayMath + "informalequation" -> equation e displayMath + "inlineequation" -> equation e math "subscript" -> subscript <$> innerInlines "superscript" -> superscript <$> innerInlines "inlinemediaobject" -> getMediaobject e @@ -1004,13 +1036,6 @@ parseInline (Elem e) = _ -> innerInlines where innerInlines = (trimInlines . mconcat) <$> mapM parseInline (elContent e) - equation constructor = return $ mconcat $ - map (constructor . writeTeX) - $ rights - $ map (readMathML . showElement . everywhere (mkT removePrefix)) - $ filterChildren (\x -> qName (elName x) == "math" && - qPrefix (elName x) == Just "mml") e - removePrefix elname = elname { qPrefix = Nothing } codeWithLang = do let classes' = case attrValue "language" e of "" -> [] @@ -1048,6 +1073,7 @@ parseInline (Elem e) = | not (null xrefLabel) = xrefLabel | otherwise = case qName (elName el) of "chapter" -> descendantContent "title" el + "section" -> descendantContent "title" el "sect1" -> descendantContent "title" el "sect2" -> descendantContent "title" el "sect3" -> descendantContent "title" el @@ -1060,3 +1086,45 @@ parseInline (Elem e) = xrefLabel = attrValue "xreflabel" el descendantContent name = maybe "???" strContent . filterElementName (\n -> qName n == name) + +-- | Extract a math equation from an element +-- +-- asciidoc can generate Latex math in CDATA sections. +-- +-- Note that if some MathML can't be parsed it is silently ignored! +equation + :: Monad m + => Element + -- ^ The element from which to extract a mathematical equation + -> (String -> Inlines) + -- ^ A constructor for some Inlines, taking the TeX code as input + -> m Inlines +equation e constructor = + return $ mconcat $ map constructor $ mathMLEquations ++ latexEquations + where + mathMLEquations :: [String] + mathMLEquations = map writeTeX $ rights $ readMath + (\x -> qName (elName x) == "math" && qPrefix (elName x) == Just "mml") + (readMathML . showElement) + + latexEquations :: [String] + latexEquations = readMath (\x -> qName (elName x) == "mathphrase") + (concat . fmap showVerbatimCData . elContent) + + readMath :: (Element -> Bool) -> (Element -> b) -> [b] + readMath childPredicate fromElement = + ( map (fromElement . everywhere (mkT removePrefix)) + $ filterChildren childPredicate e + ) + +-- | Get the actual text stored in a verbatim CData block. 'showContent' +-- returns the text still surrounded by the [[CDATA]] tags. +-- +-- Returns 'showContent' if this is not a verbatim CData +showVerbatimCData :: Content -> String +showVerbatimCData (Text (CData CDataVerbatim d _)) = d +showVerbatimCData c = showContent c + +-- | Set the prefix of a name to 'Nothing' +removePrefix :: QName -> QName +removePrefix elname = elname { qPrefix = Nothing } diff --git a/src/Text/Pandoc/Readers/Docx.hs b/src/Text/Pandoc/Readers/Docx.hs index 5f2ca0fff..ca9f8c8dd 100644 --- a/src/Text/Pandoc/Readers/Docx.hs +++ b/src/Text/Pandoc/Readers/Docx.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} @@ -74,6 +75,7 @@ module Text.Pandoc.Readers.Docx ( readDocx ) where +import Prelude import Codec.Archive.Zip import Control.Monad.Reader import Control.Monad.State.Strict @@ -122,7 +124,6 @@ data DState = DState { docxAnchorMap :: M.Map String String , docxImmedPrevAnchor :: Maybe String , docxMediaBag :: MediaBag , docxDropCap :: Inlines - , docxWarnings :: [String] -- keep track of (numId, lvl) values for -- restarting , docxListState :: M.Map (String, String) Integer @@ -135,18 +136,16 @@ instance Default DState where , docxImmedPrevAnchor = Nothing , docxMediaBag = mempty , docxDropCap = mempty - , docxWarnings = [] , docxListState = M.empty , docxPrevPara = mempty } data DEnv = DEnv { docxOptions :: ReaderOptions , docxInHeaderBlock :: Bool - , docxCustomStyleAlready :: Bool } instance Default DEnv where - def = DEnv def False False + def = DEnv def False type DocxContext m = ReaderT DEnv (StateT DState m) @@ -252,103 +251,88 @@ parPartToString _ = "" blacklistedCharStyles :: [String] blacklistedCharStyles = ["Hyperlink"] -resolveDependentRunStyle :: RunStyle -> RunStyle +resolveDependentRunStyle :: PandocMonad m => RunStyle -> DocxContext m RunStyle resolveDependentRunStyle rPr | Just (s, _) <- rStyle rPr, s `elem` blacklistedCharStyles = - rPr - | Just (_, cs) <- rStyle rPr = - let rPr' = resolveDependentRunStyle cs - in - RunStyle { isBold = case isBold rPr of - Just bool -> Just bool - Nothing -> isBold rPr' - , isItalic = case isItalic rPr of - Just bool -> Just bool - Nothing -> isItalic rPr' - , isSmallCaps = case isSmallCaps rPr of - Just bool -> Just bool - Nothing -> isSmallCaps rPr' - , isStrike = case isStrike rPr of - Just bool -> Just bool - Nothing -> isStrike rPr' - , rVertAlign = case rVertAlign rPr of - Just valign -> Just valign - Nothing -> rVertAlign rPr' - , rUnderline = case rUnderline rPr of - Just ulstyle -> Just ulstyle - Nothing -> rUnderline rPr' - , rStyle = rStyle rPr } - | otherwise = rPr - -extraRunStyleInfo :: PandocMonad m => RunStyle -> DocxContext m (Inlines -> Inlines) -extraRunStyleInfo rPr - | Just (s, _) <- rStyle rPr = do - already <- asks docxCustomStyleAlready + return rPr + | Just (_, cs) <- rStyle rPr = do opts <- asks docxOptions - return $ if isEnabled Ext_styles opts && not already - then spanWith ("", [], [("custom-style", s)]) - else id - | otherwise = return id + if isEnabled Ext_styles opts + then return rPr + else do rPr' <- resolveDependentRunStyle cs + return $ + RunStyle { isBold = case isBold rPr of + Just bool -> Just bool + Nothing -> isBold rPr' + , isItalic = case isItalic rPr of + Just bool -> Just bool + Nothing -> isItalic rPr' + , isSmallCaps = case isSmallCaps rPr of + Just bool -> Just bool + Nothing -> isSmallCaps rPr' + , isStrike = case isStrike rPr of + Just bool -> Just bool + Nothing -> isStrike rPr' + , rVertAlign = case rVertAlign rPr of + Just valign -> Just valign + Nothing -> rVertAlign rPr' + , rUnderline = case rUnderline rPr of + Just ulstyle -> Just ulstyle + Nothing -> rUnderline rPr' + , rStyle = rStyle rPr } + | otherwise = return rPr runStyleToTransform :: PandocMonad m => RunStyle -> DocxContext m (Inlines -> Inlines) runStyleToTransform rPr | Just (s, _) <- rStyle rPr , s `elem` spansToKeep = do - let rPr' = rPr{rStyle = Nothing} - transform <- runStyleToTransform rPr' + transform <- runStyleToTransform rPr{rStyle = Nothing} return $ spanWith ("", [s], []) . transform + | Just (s, _) <- rStyle rPr = do + opts <- asks docxOptions + let extraInfo = if isEnabled Ext_styles opts + then spanWith ("", [], [("custom-style", s)]) + else id + transform <- runStyleToTransform rPr{rStyle = Nothing} + return $ extraInfo . transform | Just True <- isItalic rPr = do - extraInfo <- extraRunStyleInfo rPr - transform <- local (\e -> e{docxCustomStyleAlready = True}) $ - runStyleToTransform rPr {isItalic = Nothing} - return $ extraInfo . emph . transform + transform <- runStyleToTransform rPr{isItalic = Nothing} + return $ emph . transform | Just True <- isBold rPr = do - extraInfo <- extraRunStyleInfo rPr - transform <- local (\e -> e{docxCustomStyleAlready = True}) $ - runStyleToTransform rPr {isBold = Nothing} - return $ extraInfo . strong . transform + transform <- runStyleToTransform rPr{isBold = Nothing} + return $ strong . transform | Just True <- isSmallCaps rPr = do - extraInfo <- extraRunStyleInfo rPr - transform <- local (\e -> e{docxCustomStyleAlready = True}) $ - runStyleToTransform rPr {isSmallCaps = Nothing} - return $ extraInfo . smallcaps . transform + transform <- runStyleToTransform rPr{isSmallCaps = Nothing} + return $ smallcaps . transform | Just True <- isStrike rPr = do - extraInfo <- extraRunStyleInfo rPr - transform <- local (\e -> e{docxCustomStyleAlready = True}) $ - runStyleToTransform rPr {isStrike = Nothing} - return $ extraInfo . strikeout . transform + transform <- runStyleToTransform rPr{isStrike = Nothing} + return $ strikeout . transform | Just SupScrpt <- rVertAlign rPr = do - extraInfo <- extraRunStyleInfo rPr - transform <- local (\e -> e{docxCustomStyleAlready = True}) $ - runStyleToTransform rPr {rVertAlign = Nothing} - return $ extraInfo . superscript . transform + transform <- runStyleToTransform rPr{rVertAlign = Nothing} + return $ superscript . transform | Just SubScrpt <- rVertAlign rPr = do - extraInfo <- extraRunStyleInfo rPr - transform <- local (\e -> e{docxCustomStyleAlready = True}) $ - runStyleToTransform rPr {rVertAlign = Nothing} - return $ extraInfo . subscript . transform + transform <- runStyleToTransform rPr{rVertAlign = Nothing} + return $ subscript . transform | Just "single" <- rUnderline rPr = do - extraInfo <- extraRunStyleInfo rPr - transform <- local (\e -> e{docxCustomStyleAlready = True}) $ - runStyleToTransform rPr {rUnderline = Nothing} - return $ extraInfo . underlineSpan . transform - | otherwise = extraRunStyleInfo rPr + transform <- runStyleToTransform rPr{rUnderline = Nothing} + return $ underlineSpan . transform + | otherwise = return id runToInlines :: PandocMonad m => Run -> DocxContext m Inlines runToInlines (Run rs runElems) | Just (s, _) <- rStyle rs - , s `elem` codeStyles = - let rPr = resolveDependentRunStyle rs - codeString = code $ concatMap runElemToString runElems - in - return $ case rVertAlign rPr of - Just SupScrpt -> superscript codeString - Just SubScrpt -> subscript codeString - _ -> codeString + , s `elem` codeStyles = do + rPr <- resolveDependentRunStyle rs + let codeString = code $ concatMap runElemToString runElems + return $ case rVertAlign rPr of + Just SupScrpt -> superscript codeString + Just SubScrpt -> subscript codeString + _ -> codeString | otherwise = do - let ils = smushInlines (map runElemToInlines runElems) - transform <- runStyleToTransform $ resolveDependentRunStyle rs - return $ transform ils + rPr <- resolveDependentRunStyle rs + let ils = smushInlines (map runElemToInlines runElems) + transform <- runStyleToTransform rPr + return $ transform ils runToInlines (Footnote bps) = do blksList <- smushBlocks <$> mapM bodyPartToBlocks bps return $ note blksList @@ -385,7 +369,7 @@ blocksToInlinesWarn cmtId blks = do parPartToInlines :: PandocMonad m => ParPart -> DocxContext m Inlines parPartToInlines parPart = case parPart of - (BookMark _ anchor) | notElem anchor dummyAnchors -> do + (BookMark _ anchor) | anchor `notElem` dummyAnchors -> do inHdrBool <- asks docxInHeaderBlock ils <- parPartToInlines' parPart immedPrevAnchor <- gets docxImmedPrevAnchor @@ -478,8 +462,6 @@ parPartToInlines' (ExternalHyperLink target runs) = do return $ link target "" ils parPartToInlines' (PlainOMath exps) = return $ math $ writeTeX exps -parPartToInlines' (SmartTag runs) = - smushInlines <$> mapM runToInlines runs parPartToInlines' (Field info runs) = case info of HyperlinkField url -> parPartToInlines' $ ExternalHyperLink url runs @@ -706,6 +688,10 @@ bodyPartToBlocks (Tbl cap _ look parts@(r:rs)) = do rowLength :: Row -> Int rowLength (Row c) = length c + -- pad cells. New Text.Pandoc.Builder will do that for us, + -- so this is for compatibility while we switch over. + let cells' = map (\row -> take width (row ++ repeat mempty)) cells + hdrCells <- case hdr of Just r' -> rowToBlocksList r' Nothing -> return $ replicate width mempty @@ -718,7 +704,7 @@ bodyPartToBlocks (Tbl cap _ look parts@(r:rs)) = do let alignments = replicate width AlignDefault widths = replicate width 0 :: [Double] - return $ table caption (zip alignments widths) hdrCells cells + return $ table caption (zip alignments widths) hdrCells cells' bodyPartToBlocks (OMathPara e) = return $ para $ displayMath (writeTeX e) diff --git a/src/Text/Pandoc/Readers/Docx/Combine.hs b/src/Text/Pandoc/Readers/Docx/Combine.hs index 003265e6e..108c4bbe5 100644 --- a/src/Text/Pandoc/Readers/Docx/Combine.hs +++ b/src/Text/Pandoc/Readers/Docx/Combine.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE TypeSynonymInstances #-} @@ -7,6 +8,7 @@ module Text.Pandoc.Readers.Docx.Combine ( smushInlines ) where +import Prelude import Data.List import Data.Sequence (ViewL (..), ViewR (..), viewl, viewr, (><), (|>)) import qualified Data.Sequence as Seq (null) @@ -133,6 +135,10 @@ combineBlocks bs cs | bs' :> BlockQuote bs'' <- viewr (unMany bs) , BlockQuote cs'' :< cs' <- viewl (unMany cs) = Many $ (bs' |> BlockQuote (bs'' <> cs'')) >< cs' + | bs' :> CodeBlock attr codeStr <- viewr (unMany bs) + , CodeBlock attr' codeStr' :< cs' <- viewl (unMany cs) + , attr == attr' = + Many $ (bs' |> CodeBlock attr (codeStr <> "\n" <> codeStr')) >< cs' combineBlocks bs cs = bs <> cs instance (Monoid a, Eq a) => Eq (Modifier a) where diff --git a/src/Text/Pandoc/Readers/Docx/Fields.hs b/src/Text/Pandoc/Readers/Docx/Fields.hs index 6eeb55d2f..c3f54560b 100644 --- a/src/Text/Pandoc/Readers/Docx/Fields.hs +++ b/src/Text/Pandoc/Readers/Docx/Fields.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {- Copyright (C) 2014-2018 Jesse Rosenthal <jrosenthal@jhu.edu> @@ -32,6 +33,7 @@ module Text.Pandoc.Readers.Docx.Fields ( FieldInfo(..) , parseFieldInfo ) where +import Prelude import Text.Parsec import Text.Parsec.String (Parser) diff --git a/src/Text/Pandoc/Readers/Docx/Lists.hs b/src/Text/Pandoc/Readers/Docx/Lists.hs index c0f05094a..49ea71601 100644 --- a/src/Text/Pandoc/Readers/Docx/Lists.hs +++ b/src/Text/Pandoc/Readers/Docx/Lists.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {- Copyright (C) 2014-2018 Jesse Rosenthal <jrosenthal@jhu.edu> @@ -33,6 +34,7 @@ module Text.Pandoc.Readers.Docx.Lists ( blocksToBullets , listParagraphDivs ) where +import Prelude import Data.List import Data.Maybe import Text.Pandoc.Generic (bottomUp) diff --git a/src/Text/Pandoc/Readers/Docx/Parse.hs b/src/Text/Pandoc/Readers/Docx/Parse.hs index c123a0018..4c4c06073 100644 --- a/src/Text/Pandoc/Readers/Docx/Parse.hs +++ b/src/Text/Pandoc/Readers/Docx/Parse.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE ViewPatterns #-} @@ -58,6 +59,7 @@ module Text.Pandoc.Readers.Docx.Parse ( Docx(..) , archiveToDocx , archiveToDocxWithWarnings ) where +import Prelude import Codec.Archive.Zip import Control.Applicative ((<|>)) import Control.Monad.Except @@ -132,21 +134,23 @@ mapD f xs = in concatMapM handler xs -unwrapSDT :: NameSpaces -> Content -> [Content] -unwrapSDT ns (Elem element) +unwrap :: NameSpaces -> Content -> [Content] +unwrap ns (Elem element) | isElem ns "w" "sdt" element , Just sdtContent <- findChildByName ns "w" "sdtContent" element - = map Elem $ elChildren sdtContent -unwrapSDT _ content = [content] + = concatMap ((unwrap ns) . Elem) (elChildren sdtContent) + | isElem ns "w" "smartTag" element + = concatMap ((unwrap ns) . Elem) (elChildren element) +unwrap _ content = [content] -unwrapSDTchild :: NameSpaces -> Content -> Content -unwrapSDTchild ns (Elem element) = - Elem $ element { elContent = concatMap (unwrapSDT ns) (elContent element) } -unwrapSDTchild _ content = content +unwrapChild :: NameSpaces -> Content -> Content +unwrapChild ns (Elem element) = + Elem $ element { elContent = concatMap (unwrap ns) (elContent element) } +unwrapChild _ content = content walkDocument' :: NameSpaces -> XMLC.Cursor -> XMLC.Cursor walkDocument' ns cur = - let modifiedCur = XMLC.modifyContent (unwrapSDTchild ns) cur + let modifiedCur = XMLC.modifyContent (unwrapChild ns) cur in case XMLC.nextDF modifiedCur of Just cur' -> walkDocument' ns cur' @@ -275,7 +279,6 @@ data ParPart = PlainRun Run | Drawing FilePath String String B.ByteString Extent -- title, alt | Chart -- placeholder for now | PlainOMath [Exp] - | SmartTag [Run] | Field FieldInfo [Run] | NullParPart -- when we need to return nothing, but -- not because of an error. @@ -826,10 +829,6 @@ elemToParPart ns element runs <- mapD (elemToRun ns) (elChildren element) return $ ChangedRuns change runs elemToParPart ns element - | isElem ns "w" "smartTag" element = do - runs <- mapD (elemToRun ns) (elChildren element) - return $ SmartTag runs -elemToParPart ns element | isElem ns "w" "bookmarkStart" element , Just bmId <- findAttrByName ns "w" "id" element , Just bmName <- findAttrByName ns "w" "name" element = diff --git a/src/Text/Pandoc/Readers/Docx/StyleMap.hs b/src/Text/Pandoc/Readers/Docx/StyleMap.hs index b32a73770..6ccda3ccc 100644 --- a/src/Text/Pandoc/Readers/Docx/StyleMap.hs +++ b/src/Text/Pandoc/Readers/Docx/StyleMap.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} module Text.Pandoc.Readers.Docx.StyleMap ( StyleMaps(..) , alterMap , getMap @@ -7,6 +8,7 @@ module Text.Pandoc.Readers.Docx.StyleMap ( StyleMaps(..) , hasStyleName ) where +import Prelude import Control.Monad.State.Strict import Data.Char (toLower) import qualified Data.Map as M diff --git a/src/Text/Pandoc/Readers/Docx/Util.hs b/src/Text/Pandoc/Readers/Docx/Util.hs index d9d65bc07..088950d26 100644 --- a/src/Text/Pandoc/Readers/Docx/Util.hs +++ b/src/Text/Pandoc/Readers/Docx/Util.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} module Text.Pandoc.Readers.Docx.Util ( NameSpaces , elemName @@ -8,6 +9,7 @@ module Text.Pandoc.Readers.Docx.Util ( , findAttrByName ) where +import Prelude import Data.Maybe (mapMaybe) import Text.XML.Light diff --git a/src/Text/Pandoc/Readers/EPUB.hs b/src/Text/Pandoc/Readers/EPUB.hs index 3b13bbe13..c26447641 100644 --- a/src/Text/Pandoc/Readers/EPUB.hs +++ b/src/Text/Pandoc/Readers/EPUB.hs @@ -1,12 +1,41 @@ -{-# LANGUAGE FlexibleContexts #-} - -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} +{- +Copyright (C) 2014-2018 Matthew Pickering + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- | + Module : Text.Pandoc.Readers.EPUB + Copyright : Copyright (C) 2014-2018 Matthew Pickering + License : GNU GPL, version 2 or above + + Maintainer : John MacFarlane <jgm@berkeley.edu> + Stability : alpha + Portability : portable + +Conversion of EPUB to 'Pandoc' document. +-} module Text.Pandoc.Readers.EPUB (readEPUB) where +import Prelude import Codec.Archive.Zip (Archive (..), Entry, findEntryByPath, fromEntry, toArchiveOrFail) import Control.DeepSeq (NFData, deepseq) @@ -16,7 +45,6 @@ import qualified Data.ByteString.Lazy as BL (ByteString) import Data.List (isInfixOf, isPrefixOf) import qualified Data.Map as M (Map, elems, fromList, lookup) import Data.Maybe (fromMaybe, mapMaybe) -import Data.Monoid ((<>)) import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL import Network.URI (unEscapeString) @@ -93,7 +121,7 @@ fetchImages mimes root arc (query iq -> links) = mapM_ (uncurry3 insertMedia) (mapMaybe getEntry links) where getEntry link = - let abslink = normalise (root </> link) in + let abslink = normalise (unEscapeString (root </> link)) in (link , lookup link mimes, ) . fromEntry <$> findEntryByPath abslink arc @@ -264,7 +292,7 @@ findAttrE :: PandocMonad m => QName -> Element -> m String findAttrE q e = mkE "findAttr" $ findAttr q e findEntryByPathE :: PandocMonad m => FilePath -> Archive -> m Entry -findEntryByPathE (normalise -> path) a = +findEntryByPathE (normalise . unEscapeString -> path) a = mkE ("No entry on path: " ++ path) $ findEntryByPath path a parseXMLDocE :: PandocMonad m => String -> m Element diff --git a/src/Text/Pandoc/Readers/FB2.hs b/src/Text/Pandoc/Readers/FB2.hs new file mode 100644 index 000000000..577fc85b6 --- /dev/null +++ b/src/Text/Pandoc/Readers/FB2.hs @@ -0,0 +1,404 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TupleSections #-} +{- +Copyright (C) 2018 Alexander Krotov <ilabdsf@gmail.com> + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- | + Module : Text.Pandoc.Readers.FB2 + Copyright : Copyright (C) 2018 Alexander Krotov + License : GNU GPL, version 2 or above + + Maintainer : Alexander Krotov <ilabdsf@gmail.com> + Stability : alpha + Portability : portable + +Conversion of FB2 to 'Pandoc' document. +-} + +{- + +TODO: + - Tables + - Named styles + - Parse ID attribute for all elements that have it + +-} + +module Text.Pandoc.Readers.FB2 ( readFB2 ) where +import Prelude +import Control.Monad.Except (throwError) +import Control.Monad.State.Strict +import Data.ByteString.Lazy.Char8 ( pack ) +import Data.ByteString.Base64.Lazy +import Data.Char (isSpace, toUpper) +import Data.Functor +import Data.List (dropWhileEnd, intersperse) +import Data.List.Split (splitOn) +import Data.Text (Text) +import Data.Default +import Data.Maybe +import Text.HTML.TagSoup.Entity (lookupEntity) +import Text.Pandoc.Builder +import Text.Pandoc.Class (PandocMonad, insertMedia, report) +import Text.Pandoc.Error +import Text.Pandoc.Logging +import Text.Pandoc.Options +import Text.Pandoc.Shared (crFilter) +import Text.XML.Light + +type FB2 m = StateT FB2State m + +data FB2State = FB2State{ fb2SectionLevel :: Int + , fb2Meta :: Meta + , fb2Authors :: [String] + } deriving Show + +instance Default FB2State where + def = FB2State{ fb2SectionLevel = 1 + , fb2Meta = mempty + , fb2Authors = [] + } + +instance HasMeta FB2State where + setMeta field v s = s {fb2Meta = setMeta field v (fb2Meta s)} + deleteMeta field s = s {fb2Meta = deleteMeta field (fb2Meta s)} + +readFB2 :: PandocMonad m => ReaderOptions -> Text -> m Pandoc +readFB2 _ inp = do + (bs, st) <- runStateT (mapM parseBlock $ parseXML (crFilter inp)) def + let authors = if null $ fb2Authors st + then id + else setMeta "author" (map text $ reverse $ fb2Authors st) + pure $ Pandoc (authors $ fb2Meta st) (toList . mconcat $ bs) + +-- * Utility functions + +trim :: String -> String +trim = dropWhileEnd isSpace . dropWhile isSpace + +removeHash :: String -> String +removeHash ('#':xs) = xs +removeHash xs = xs + +convertEntity :: String -> String +convertEntity e = fromMaybe (map toUpper e) (lookupEntity e) + +parseInline :: PandocMonad m => Content -> FB2 m Inlines +parseInline (Elem e) = + case qName $ elName e of + "strong" -> strong <$> parseStyleType e + "emphasis" -> emph <$> parseStyleType e + "style" -> parseNamedStyle e + "a" -> parseLinkType e + "strikethrough" -> strikeout <$> parseStyleType e + "sub" -> subscript <$> parseStyleType e + "sup" -> superscript <$> parseStyleType e + "code" -> pure $ code $ strContent e + "image" -> parseInlineImageElement e + name -> throwError $ PandocParseError ("Couldn't parse FB2 file: unexpected element " ++ name ++ ".") +parseInline (Text x) = pure $ text $ cdData x +parseInline (CRef r) = pure $ str $ convertEntity r + +parseSubtitle :: PandocMonad m => Element -> FB2 m Blocks +parseSubtitle e = headerWith ("", ["unnumbered"], []) <$> gets fb2SectionLevel <*> parsePType e + +-- * Root element parser + +parseBlock :: PandocMonad m => Content -> FB2 m Blocks +parseBlock (Elem e) = + case qName $ elName e of + "?xml" -> pure mempty + "FictionBook" -> mconcat <$> mapM parseFictionBookChild (elChildren e) + name -> report (UnexpectedXmlElement name "root") $> mempty +parseBlock _ = pure mempty + +-- | Parse a child of @\<FictionBook>@ element. +parseFictionBookChild :: PandocMonad m => Element -> FB2 m Blocks +parseFictionBookChild e = + case qName $ elName e of + "stylesheet" -> pure mempty -- stylesheet is ignored + "description" -> mempty <$ mapM_ parseDescriptionChild (elChildren e) + "body" -> mconcat <$> mapM parseBodyChild (elChildren e) + "binary" -> mempty <$ parseBinaryElement e + name -> report (UnexpectedXmlElement name "FictionBook") $> mempty + +-- | Parse a child of @\<description>@ element. +parseDescriptionChild :: PandocMonad m => Element -> FB2 m () +parseDescriptionChild e = + case qName $ elName e of + "title-info" -> mapM_ parseTitleInfoChild (elChildren e) + "src-title-info" -> pure () -- ignore + "document-info" -> pure () + "publish-info" -> pure () + "custom-info" -> pure () + "output" -> pure () + name -> throwError $ PandocParseError ("Couldn't parse FB2 file: unexpected element " ++ name ++ "in description.") + +-- | Parse a child of @\<body>@ element. +parseBodyChild :: PandocMonad m => Element -> FB2 m Blocks +parseBodyChild e = + case qName $ elName e of + "image" -> parseImageElement e + "title" -> header <$> gets fb2SectionLevel <*> parseTitleType (elContent e) + "epigraph" -> parseEpigraph e + "section" -> parseSection e + name -> throwError $ PandocParseError ("Couldn't parse FB2 file: unexpected element " ++ name ++ " in body.") + +-- | Parse a @\<binary>@ element. +parseBinaryElement :: PandocMonad m => Element -> FB2 m () +parseBinaryElement e = + case (findAttr (QName "id" Nothing Nothing) e, findAttr (QName "content-type" Nothing Nothing) e) of + (Nothing, _) -> throwError $ PandocParseError "<binary> element must have an \"id\" attribute" + (Just _, Nothing) -> throwError $ PandocParseError "<binary> element must have a \"content-type\" attribute" + (Just filename, contentType) -> insertMedia filename contentType (decodeLenient (pack (strContent e))) + +-- * Type parsers + +-- | Parse @authorType@ +parseAuthor :: PandocMonad m => Element -> FB2 m String +parseAuthor e = unwords <$> mapM parseAuthorChild (elChildren e) + +parseAuthorChild :: PandocMonad m => Element -> FB2 m String +parseAuthorChild e = + case qName $ elName e of + "first-name" -> pure $ strContent e + "middle-name" -> pure $ strContent e + "last-name" -> pure $ strContent e + "nickname" -> pure $ strContent e + "home-page" -> pure $ strContent e + "email" -> pure $ strContent e + name -> throwError $ PandocParseError ("Couldn't parse FB2 file: unexpected element " ++ name ++ " in author.") + +-- | Parse @titleType@ +parseTitle :: PandocMonad m => Element -> FB2 m Blocks +parseTitle e = header <$> gets fb2SectionLevel <*> parseTitleType (elContent e) + +parseTitleType :: PandocMonad m => [Content] -> FB2 m Inlines +parseTitleType c = mconcat . intersperse linebreak . catMaybes <$> mapM parseTitleContent c + +parseTitleContent :: PandocMonad m => Content -> FB2 m (Maybe Inlines) +parseTitleContent (Elem e) = + case qName $ elName e of + "p" -> Just <$> parsePType e + "empty-line" -> pure $ Just mempty + _ -> pure mempty +parseTitleContent _ = pure Nothing + +-- | Parse @imageType@ +parseImageElement :: PandocMonad m => Element -> FB2 m Blocks +parseImageElement e = + case href of + Just src -> pure $ para $ imageWith (imgId, [], []) (removeHash src) title alt + Nothing -> throwError $ PandocParseError "Couldn't parse FB2 file: image without href." + where alt = maybe mempty str $ findAttr (QName "alt" Nothing Nothing) e + title = fromMaybe "" $ findAttr (QName "title" Nothing Nothing) e + imgId = fromMaybe "" $ findAttr (QName "id" Nothing Nothing) e + href = findAttr (QName "href" (Just "http://www.w3.org/1999/xlink") Nothing) e + +-- | Parse @pType@ +parsePType :: PandocMonad m => Element -> FB2 m Inlines +parsePType = parseStyleType -- TODO add support for optional "id" and "style" attributes + +-- | Parse @citeType@ +parseCite :: PandocMonad m => Element -> FB2 m Blocks +parseCite e = blockQuote . mconcat <$> mapM parseCiteChild (elChildren e) + +-- | Parse @citeType@ child +parseCiteChild :: PandocMonad m => Element -> FB2 m Blocks +parseCiteChild e = + case qName $ elName e of + "p" -> para <$> parsePType e + "poem" -> parsePoem e + "empty-line" -> pure horizontalRule + "subtitle" -> parseSubtitle e + "table" -> parseTable e + "text-author" -> para <$> parsePType e + name -> report (UnexpectedXmlElement name "cite") $> mempty + +-- | Parse @poemType@ +parsePoem :: PandocMonad m => Element -> FB2 m Blocks +parsePoem e = mconcat <$> mapM parsePoemChild (elChildren e) + +parsePoemChild :: PandocMonad m => Element -> FB2 m Blocks +parsePoemChild e = + 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 $ strContent e + name -> report (UnexpectedXmlElement name "poem") $> mempty + +parseStanza :: PandocMonad m => Element -> FB2 m Blocks +parseStanza e = fromList . joinLineBlocks . toList . mconcat <$> mapM parseStanzaChild (elChildren e) + +joinLineBlocks :: [Block] -> [Block] +joinLineBlocks (LineBlock xs:LineBlock ys:zs) = joinLineBlocks (LineBlock (xs ++ ys) : zs) +joinLineBlocks (x:xs) = x:joinLineBlocks xs +joinLineBlocks [] = [] + +parseStanzaChild :: PandocMonad m => Element -> FB2 m Blocks +parseStanzaChild e = + case qName $ elName e of + "title" -> parseTitle e + "subtitle" -> parseSubtitle e + "v" -> lineBlock . (:[]) <$> parsePType e + name -> report (UnexpectedXmlElement name "stanza") $> mempty + +-- | Parse @epigraphType@ +parseEpigraph :: PandocMonad m => Element -> FB2 m Blocks +parseEpigraph e = + divWith (divId, ["epigraph"], []) . mconcat <$> mapM parseEpigraphChild (elChildren e) + where divId = fromMaybe "" $ findAttr (QName "id" Nothing Nothing) e + +parseEpigraphChild :: PandocMonad m => Element -> FB2 m Blocks +parseEpigraphChild e = + case qName $ elName e of + "p" -> para <$> parsePType e + "poem" -> parsePoem e + "cite" -> parseCite e + "empty-line" -> pure horizontalRule + "text-author" -> para <$> parsePType e + name -> report (UnexpectedXmlElement name "epigraph") $> mempty + +-- | Parse @annotationType@ +parseAnnotation :: PandocMonad m => Element -> FB2 m Blocks +parseAnnotation e = mconcat <$> mapM parseAnnotationChild (elChildren e) + +parseAnnotationChild :: PandocMonad m => Element -> FB2 m Blocks +parseAnnotationChild e = + case qName $ elName e of + "p" -> para <$> parsePType e + "poem" -> parsePoem e + "cite" -> parseCite e + "subtitle" -> parseSubtitle e + "table" -> parseTable e + "empty-line" -> pure horizontalRule + name -> report (UnexpectedXmlElement name "annotation") $> mempty + +-- | Parse @sectionType@ +parseSection :: PandocMonad m => Element -> FB2 m Blocks +parseSection e = do + n <- gets fb2SectionLevel + modify $ \st -> st{ fb2SectionLevel = n + 1 } + let sectionId = fromMaybe "" $ findAttr (QName "id" Nothing Nothing) 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 qName $ elName e of + "title" -> parseBodyChild e + "epigraph" -> parseEpigraph e + "image" -> parseImageElement e + "annotation" -> parseAnnotation e + "poem" -> parsePoem e + "cite" -> parseCite e + "empty-line" -> pure horizontalRule + "table" -> parseTable e + "subtitle" -> parseSubtitle e + "p" -> para <$> parsePType e + "section" -> parseSection e + name -> report (UnexpectedXmlElement name "section") $> mempty + +-- | parse @styleType@ +parseStyleType :: PandocMonad m => Element -> FB2 m Inlines +parseStyleType e = mconcat <$> mapM parseInline (elContent e) + +-- | Parse @namedStyleType@ +parseNamedStyle :: PandocMonad m => Element -> FB2 m Inlines +parseNamedStyle e = do + content <- mconcat <$> mapM parseNamedStyleChild (elContent e) + let lang = maybeToList $ ("lang",) <$> findAttr (QName "lang" Nothing (Just "xml")) e + case findAttr (QName "name" Nothing Nothing) e of + Just name -> pure $ spanWith ("", [name], lang) content + Nothing -> throwError $ PandocParseError "Couldn't parse FB2 file: link without required name." + +parseNamedStyleChild :: PandocMonad m => Content -> FB2 m Inlines +parseNamedStyleChild (Elem e) = + case qName (elName e) of + "strong" -> strong <$> parseStyleType e + "emphasis" -> emph <$> parseStyleType e + "style" -> parseNamedStyle e + "a" -> parseLinkType e + "strikethrough" -> strikeout <$> parseStyleType e + "sub" -> subscript <$> parseStyleType e + "sup" -> superscript <$> parseStyleType e + "code" -> pure $ code $ strContent e + "image" -> parseInlineImageElement e + name -> throwError $ PandocParseError ("Couldn't parse FB2 file: unexpected element " ++ name ++ ".") +parseNamedStyleChild x = parseInline x + +-- | Parse @linkType@ +parseLinkType :: PandocMonad m => Element -> FB2 m Inlines +parseLinkType e = do + content <- mconcat <$> mapM parseStyleLinkType (elContent e) + case findAttr (QName "href" (Just "http://www.w3.org/1999/xlink") Nothing) e of + Just href -> pure $ link href "" content + Nothing -> throwError $ PandocParseError "Couldn't parse FB2 file: link without required href." + +-- | Parse @styleLinkType@ +parseStyleLinkType :: PandocMonad m => Content -> FB2 m Inlines +parseStyleLinkType x@(Elem e) = + case qName (elName e) of + "a" -> throwError $ PandocParseError "Couldn't parse FB2 file: links cannot be nested." + _ -> parseInline x +parseStyleLinkType x = parseInline x + +-- | Parse @tableType@ +parseTable :: PandocMonad m => Element -> FB2 m Blocks +parseTable _ = pure mempty -- TODO: tables are not supported yet + +-- | Parse @title-infoType@ +parseTitleInfoChild :: PandocMonad m => Element -> FB2 m () +parseTitleInfoChild e = + case qName (elName e) of + "genre" -> pure () + "author" -> parseAuthor e >>= \author -> modify (\st -> st {fb2Authors = author:fb2Authors st}) + "book-title" -> modify (setMeta "title" (text $ strContent e)) + "annotation" -> parseAnnotation e >>= modify . setMeta "abstract" + "keywords" -> modify (setMeta "keywords" (map (MetaString . trim) $ splitOn "," $ strContent e)) + "date" -> modify (setMeta "date" (text $ strContent e)) + "coverpage" -> parseCoverPage e + "lang" -> pure () + "src-lang" -> pure () + "translator" -> pure () + "sequence" -> pure () + name -> throwError $ PandocParseError ("Couldn't parse FB2 file: unexpected element " ++ name ++ " in title-info.") + +parseCoverPage :: PandocMonad m => Element -> FB2 m () +parseCoverPage e = + case findChild (QName "image" (Just "http://www.gribuser.ru/xml/fictionbook/2.0") Nothing) e of + Just img -> case href of + Just src -> modify (setMeta "cover-image" (MetaString $ removeHash src)) + Nothing -> pure () + where href = findAttr (QName "href" (Just "http://www.w3.org/1999/xlink") Nothing) img + Nothing -> pure () + +-- | Parse @inlineImageType@ element +parseInlineImageElement :: PandocMonad m + => Element + -> FB2 m Inlines +parseInlineImageElement e = + case href of + Just src -> pure $ imageWith ("", [], []) (removeHash src) "" alt + Nothing -> throwError $ PandocParseError "Couldn't parse FB2 file: inline image without href." + where alt = maybe mempty str $ findAttr (QName "alt" Nothing Nothing) 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 index 0e79f9ec3..32a1ba5a6 100644 --- a/src/Text/Pandoc/Readers/HTML.hs +++ b/src/Text/Pandoc/Readers/HTML.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -42,6 +43,7 @@ module Text.Pandoc.Readers.HTML ( readHtml , isCommentTag ) where +import Prelude import Control.Applicative ((<|>)) import Control.Arrow (first) import Control.Monad (guard, mplus, msum, mzero, unless, void) @@ -54,7 +56,7 @@ import Data.List (isPrefixOf) import Data.List.Split (wordsBy, splitWhen) import qualified Data.Map as M import Data.Maybe (fromMaybe, isJust, isNothing) -import Data.Monoid (First (..), (<>)) +import Data.Monoid (First (..)) import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as T @@ -508,14 +510,16 @@ pTable = try $ do [Plain _] -> True _ -> False let isSimple = all isSinglePlain $ concat (head':rows''') - let cols = length $ if null head' then head rows''' else head' + let cols = if null head' + then maximum (map length rows''') + else length head' -- add empty cells to short rows let addEmpties r = case cols - length r of n | n > 0 -> r <> replicate n mempty | otherwise -> r let rows = map addEmpties rows''' let aligns = case rows'' of - (cs:_) -> map fst cs + (cs:_) -> take cols $ map fst cs ++ repeat AlignDefault _ -> replicate cols AlignDefault let widths = if null widths' then if isSimple diff --git a/src/Text/Pandoc/Readers/Haddock.hs b/src/Text/Pandoc/Readers/Haddock.hs index e98c79ed8..967037e4e 100644 --- a/src/Text/Pandoc/Readers/Haddock.hs +++ b/src/Text/Pandoc/Readers/Haddock.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE CPP #-} {- | Module : Text.Pandoc.Readers.Haddock @@ -14,13 +15,13 @@ module Text.Pandoc.Readers.Haddock ( readHaddock ) where +import Prelude import Control.Monad.Except (throwError) import Data.List (intersperse, stripPrefix) import Data.Maybe (fromMaybe) -import Data.Monoid ((<>)) import Data.Text (Text, unpack) import Documentation.Haddock.Parser -import Documentation.Haddock.Types +import Documentation.Haddock.Types as H import Text.Pandoc.Builder (Blocks, Inlines) import qualified Text.Pandoc.Builder as B import Text.Pandoc.Class (PandocMonad) @@ -86,6 +87,20 @@ docHToBlocks d' = DocProperty s -> B.codeBlockWith ("",["property","haskell"],[]) (trim s) DocExamples es -> mconcat $ map (\e -> makeExample ">>>" (exampleExpression e) (exampleResult e)) es +#if MIN_VERSION_haddock_library(1,5,0) + DocTable H.Table{ tableHeaderRows = headerRows + , tableBodyRows = bodyRows + } + -> let toCells = map (docHToBlocks . tableCellContents) . tableRowCells + (header, body) = + if null headerRows + then ([], map toCells bodyRows) + else (toCells (head headerRows), + map toCells (tail headerRows ++ bodyRows)) + colspecs = replicate (maximum (map length body)) + (AlignDefault, 0.0) + in B.table mempty colspecs header body +#endif where inlineFallback = B.plain $ docHToInlines False d' consolidatePlains = B.fromList . consolidatePlains' . B.toList @@ -134,6 +149,9 @@ docHToInlines isCode d' = DocAName s -> B.spanWith (s,["anchor"],[]) mempty DocProperty _ -> mempty DocExamples _ -> mempty +#if MIN_VERSION_haddock_library(1,5,0) + DocTable _ -> mempty +#endif -- | Create an 'Example', stripping superfluous characters as appropriate makeExample :: String -> String -> [String] -> Blocks diff --git a/src/Text/Pandoc/Readers/JATS.hs b/src/Text/Pandoc/Readers/JATS.hs index 8158a4511..59af76d23 100644 --- a/src/Text/Pandoc/Readers/JATS.hs +++ b/src/Text/Pandoc/Readers/JATS.hs @@ -1,5 +1,37 @@ -{-# LANGUAGE ExplicitForAll, TupleSections #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TupleSections #-} +{- +Copyright (C) 2017-2018 Hamish Mackenzie + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- | + Module : Text.Pandoc.Readers.JATS + Copyright : Copyright (C) 2017-2018 Hamish Mackenzie + License : GNU GPL, version 2 or above + + Maintainer : John MacFarlane <jgm@berkeley.edu> + Stability : alpha + Portability : portable + +Conversion of JATS XML to 'Pandoc' document. +-} + module Text.Pandoc.Readers.JATS ( readJATS ) where +import Prelude import Control.Monad.State.Strict import Data.Char (isDigit, isSpace, toUpper) import Data.Default diff --git a/src/Text/Pandoc/Readers/LaTeX.hs b/src/Text/Pandoc/Readers/LaTeX.hs index cb70b6403..39dffde76 100644 --- a/src/Text/Pandoc/Readers/LaTeX.hs +++ b/src/Text/Pandoc/Readers/LaTeX.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} @@ -42,11 +43,12 @@ module Text.Pandoc.Readers.LaTeX ( readLaTeX, untokenize ) where +import Prelude import Control.Applicative (many, optional, (<|>)) import Control.Monad import Control.Monad.Except (throwError) import Control.Monad.Trans (lift) -import Data.Char (chr, isAlphaNum, isDigit, isLetter, ord, toLower) +import Data.Char (chr, isAlphaNum, isDigit, isLetter, ord, toLower, toUpper) import Data.Default import Data.List (intercalate, isPrefixOf) import qualified Data.Map as M @@ -60,7 +62,7 @@ import Text.Pandoc.BCP47 (Lang (..), renderLang) import Text.Pandoc.Builder import Text.Pandoc.Class (PandocMonad, PandocPure, getResourcePath, lookupEnv, readFileFromDirs, report, setResourcePath, - setTranslations, translateTerm) + setTranslations, translateTerm, trace) import Text.Pandoc.Error (PandocError (PandocMacroLoop, PandocParseError, PandocParsecError)) import Text.Pandoc.Highlighting (fromListingsLanguage, languagesByExtension) import Text.Pandoc.ImageSize (numUnit, showFl) @@ -74,6 +76,7 @@ import Text.Pandoc.Shared import qualified Text.Pandoc.Translations as Translations import Text.Pandoc.Walk import Text.Parsec.Pos +import qualified Text.Pandoc.Builder as B -- for debugging: -- import Text.Pandoc.Extensions (getDefaultExtensions) @@ -161,6 +164,7 @@ data LaTeXState = LaTeXState{ sOptions :: ReaderOptions , sInTableCell :: Bool , sLastHeaderNum :: HeaderNum , sLabels :: M.Map String [Inline] + , sHasChapters :: Bool , sToggles :: M.Map String Bool } deriving Show @@ -180,6 +184,7 @@ defaultLaTeXState = LaTeXState{ sOptions = def , sInTableCell = False , sLastHeaderNum = HeaderNum [] , sLabels = M.empty + , sHasChapters = False , sToggles = M.empty } @@ -237,21 +242,30 @@ withVerbatimMode parser = do return result rawLaTeXParser :: (PandocMonad m, HasMacros s, HasReaderOptions s) - => LP m a -> ParserT String s m (a, String) -rawLaTeXParser parser = do + => LP m a -> LP m a -> ParserT String s m (a, String) +rawLaTeXParser parser valParser = do inp <- getInput let toks = tokenize "source" $ T.pack inp pstate <- getState - let lstate = def{ sOptions = extractReaderOptions pstate - , sMacros = extractMacros pstate } - let rawparser = (,) <$> withRaw parser <*> getState - res <- lift $ runParserT rawparser lstate "chunk" toks - case res of + let lstate = def{ sOptions = extractReaderOptions pstate } + let lstate' = lstate { sMacros = extractMacros pstate } + let rawparser = (,) <$> withRaw valParser <*> getState + res' <- lift $ runParserT (snd <$> withRaw parser) lstate "chunk" toks + case res' of Left _ -> mzero - Right ((val, raw), st) -> do - updateState (updateMacros (sMacros st <>)) - rawstring <- takeP (T.length (untokenize raw)) - return (val, rawstring) + Right toks' -> do + res <- lift $ runParserT (do doMacros 0 + -- retokenize, applying macros + ts <- many (satisfyTok (const True)) + setInput ts + rawparser) + lstate' "chunk" toks' + case res of + Left _ -> mzero + Right ((val, raw), st) -> do + updateState (updateMacros (sMacros st <>)) + _ <- takeP (T.length (untokenize toks')) + return (val, T.unpack (untokenize raw)) applyMacros :: (PandocMonad m, HasMacros s, HasReaderOptions s) => String -> ParserT String s m String @@ -272,19 +286,18 @@ rawLaTeXBlock = do lookAhead (try (char '\\' >> letter)) -- we don't want to apply newly defined latex macros to their own -- definitions: - snd <$> rawLaTeXParser macroDef - <|> ((snd <$> rawLaTeXParser (environment <|> blockCommand)) >>= applyMacros) + snd <$> rawLaTeXParser (environment <|> macroDef <|> blockCommand) blocks rawLaTeXInline :: (PandocMonad m, HasMacros s, HasReaderOptions s) => ParserT String s m String rawLaTeXInline = do lookAhead (try (char '\\' >> letter)) - rawLaTeXParser (inlineEnvironment <|> inlineCommand') >>= applyMacros . snd + snd <$> rawLaTeXParser (inlineEnvironment <|> inlineCommand') inlines inlineCommand :: PandocMonad m => ParserT String ParserState m Inlines inlineCommand = do lookAhead (try (char '\\' >> letter)) - fst <$> rawLaTeXParser (inlineEnvironment <|> inlineCommand') + fst <$> rawLaTeXParser (inlineEnvironment <|> inlineCommand') inlines tokenize :: SourceName -> Text -> [Tok] tokenize sourcename = totoks (initialPos sourcename) @@ -665,7 +678,7 @@ dosiunitx = do skipopts value <- tok valueprefix <- option "" $ bracketed tok - unit <- tok + unit <- inlineCommand' <|> tok let emptyOr160 "" = "" emptyOr160 _ = "\160" return . mconcat $ [valueprefix, @@ -674,6 +687,12 @@ dosiunitx = do emptyOr160 unit, unit] +-- siunitx's \square command +dosquare :: PandocMonad m => LP m Inlines +dosquare = do + unit <- inlineCommand' <|> tok + return . mconcat $ [unit, "\178"] + lit :: String -> LP m Inlines lit = pure . str @@ -1034,13 +1053,28 @@ dollarsMath :: PandocMonad m => LP m Inlines dollarsMath = do symbol '$' display <- option False (True <$ symbol '$') - contents <- trim . toksToString <$> - many (notFollowedBy (symbol '$') >> anyTok) - if display - then - mathDisplay contents <$ try (symbol '$' >> symbol '$') - <|> (guard (null contents) >> return (mathInline "")) - else mathInline contents <$ symbol '$' + (do contents <- try $ T.unpack <$> 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 Text +pDollarsMath n = do + Tok _ toktype t <- anyTok + case toktype of + Symbol | t == "$" + , n == 0 -> return mempty + | t == "\\" -> do + Tok _ _ t' <- anyTok + return (t <> t') + | t == "{" -> (t <>) <$> pDollarsMath (n+1) + | t == "}" -> + if n > 0 + then (t <>) <$> pDollarsMath (n-1) + else mzero + _ -> (t <>) <$> pDollarsMath n -- citations @@ -1161,7 +1195,7 @@ singleChar = try $ do else return $ Tok pos toktype t opt :: PandocMonad m => LP m Inlines -opt = bracketed inline +opt = bracketed inline <|> (str . T.unpack <$> rawopt) rawopt :: PandocMonad m => LP m Text rawopt = do @@ -1304,6 +1338,12 @@ inlineCommands = M.union inlineLanguageCommands $ M.fromList , ("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 "Å") @@ -1467,6 +1507,13 @@ inlineCommands = M.union inlineLanguageCommands $ M.fromList , ("acsp", doAcronymPlural "abbrv") -- siuntix , ("SI", dosiunitx) + -- units of siuntix + , ("celsius", lit "°C") + , ("degreeCelsius", lit "°C") + , ("gram", lit "g") + , ("meter", lit "m") + , ("milli", lit "m") + , ("square", dosquare) -- hyphenat , ("bshyp", lit "\\\173") , ("fshyp", lit "/\173") @@ -1497,6 +1544,16 @@ inlineCommands = M.union inlineLanguageCommands $ M.fromList , ("foreignlanguage", foreignlanguage) ] +makeUppercase :: Inlines -> Inlines +makeUppercase = fromList . walk (alterStr (map toUpper)) . toList + +makeLowercase :: Inlines -> Inlines +makeLowercase = fromList . walk (alterStr (map toLower)) . toList + +alterStr :: (String -> String) -> Inline -> Inline +alterStr f (Str xs) = Str (f xs) +alterStr _ x = x + foreignlanguage :: PandocMonad m => LP m Inlines foreignlanguage = do babelLang <- T.unpack . untokenize <$> braced @@ -1669,6 +1726,9 @@ treatAsBlock = Set.fromList , "clearpage" , "pagebreak" , "titleformat" + , "listoffigures" + , "listoftables" + , "write" ] isInlineCommand :: Text -> Bool @@ -1968,9 +2028,13 @@ section starred (ident, classes, kvs) lvl = do try (spaces >> controlSeq "label" >> spaces >> toksToString <$> braced) let classes' = if starred then "unnumbered" : classes else classes + when (lvl == 0) $ + updateState $ \st -> st{ sHasChapters = True } unless starred $ do hn <- sLastHeaderNum <$> getState - let num = incrementHeaderNum lvl hn + hasChapters <- sHasChapters <$> getState + let lvl' = lvl + if hasChapters then 1 else 0 + let num = incrementHeaderNum lvl' hn updateState $ \st -> st{ sLastHeaderNum = num } updateState $ \st -> st{ sLabels = M.insert lab [Str (renderHeaderNum num)] @@ -2095,6 +2159,7 @@ environments :: PandocMonad m => M.Map Text (LP m Blocks) environments = M.fromList [ ("document", env "document" blocks) , ("abstract", mempty <$ (env "abstract" blocks >>= addMeta "abstract")) + , ("sloppypar", env "sloppypar" $ blocks) , ("letter", env "letter" letterContents) , ("minipage", env "minipage" $ skipopts *> spaces *> optional braced *> spaces *> blocks) @@ -2126,19 +2191,6 @@ environments = M.fromList codeBlockWith attr <$> verbEnv "lstlisting") , ("minted", minted) , ("obeylines", obeylines) - , ("displaymath", mathEnvWith para Nothing "displaymath") - , ("equation", mathEnvWith para Nothing "equation") - , ("equation*", mathEnvWith para Nothing "equation*") - , ("gather", mathEnvWith para (Just "gathered") "gather") - , ("gather*", mathEnvWith para (Just "gathered") "gather*") - , ("multline", mathEnvWith para (Just "gathered") "multline") - , ("multline*", mathEnvWith para (Just "gathered") "multline*") - , ("eqnarray", mathEnvWith para (Just "aligned") "eqnarray") - , ("eqnarray*", mathEnvWith para (Just "aligned") "eqnarray*") - , ("align", mathEnvWith para (Just "aligned") "align") - , ("align*", mathEnvWith para (Just "aligned") "align*") - , ("alignat", mathEnvWith para (Just "aligned") "alignat") - , ("alignat*", mathEnvWith para (Just "aligned") "alignat*") , ("tikzpicture", rawVerbEnv "tikzpicture") -- etoolbox , ("ifstrequal", ifstrequal) @@ -2149,11 +2201,14 @@ environments = M.fromList ] environment :: PandocMonad m => LP m Blocks -environment = do +environment = try $ do controlSeq "begin" name <- untokenize <$> braced - M.findWithDefault mzero name environments - <|> rawEnv name + M.findWithDefault mzero name environments <|> + if M.member name (inlineEnvironments + :: M.Map Text (LP PandocPure Inlines)) + then mzero + else rawEnv name env :: PandocMonad m => Text -> LP m a -> LP m a env name p = p <* end_ name @@ -2532,13 +2587,16 @@ addTableCaption = walkM go block :: PandocMonad m => LP m Blocks -block = (mempty <$ spaces1) +block = do + res <- (mempty <$ spaces1) <|> environment <|> include <|> macroDef <|> blockCommand <|> paragraph <|> grouped block + trace (take 60 $ show $ B.toList res) + return res blocks :: PandocMonad m => LP m Blocks blocks = mconcat <$> many block diff --git a/src/Text/Pandoc/Readers/LaTeX/Types.hs b/src/Text/Pandoc/Readers/LaTeX/Types.hs index c9cbaa9b9..fa832114b 100644 --- a/src/Text/Pandoc/Readers/LaTeX/Types.hs +++ b/src/Text/Pandoc/Readers/LaTeX/Types.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {- Copyright (C) 2017-2018 John MacFarlane <jgm@berkeley.edu> @@ -34,6 +35,7 @@ module Text.Pandoc.Readers.LaTeX.Types ( Tok(..) , SourcePos ) where +import Prelude import Data.Text (Text) import Text.Parsec.Pos (SourcePos) diff --git a/src/Text/Pandoc/Readers/Markdown.hs b/src/Text/Pandoc/Readers/Markdown.hs index 14cf73de4..156b2b622 100644 --- a/src/Text/Pandoc/Readers/Markdown.hs +++ b/src/Text/Pandoc/Readers/Markdown.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE RelaxedPolyRec #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -32,6 +33,7 @@ Conversion of markdown-formatted plain text to 'Pandoc' document. -} module Text.Pandoc.Readers.Markdown ( readMarkdown ) where +import Prelude import Control.Monad import Control.Monad.Except (throwError) import Data.Char (isAlphaNum, isPunctuation, isSpace, toLower) @@ -39,7 +41,6 @@ import qualified Data.HashMap.Strict as H import Data.List (intercalate, sortBy, transpose, elemIndex) import qualified Data.Map as M import Data.Maybe -import Data.Monoid ((<>)) import Data.Ord (comparing) import Data.Scientific (base10Exponent, coefficient) import qualified Data.Set as Set @@ -162,7 +163,7 @@ inlinesInBalancedBrackets = stripBracket xs = if last xs == ']' then init xs else xs go :: PandocMonad m => Int -> MarkdownParser m () go 0 = return () - go openBrackets = + go openBrackets = (() <$ (escapedChar <|> code <|> rawHtmlInline <|> @@ -673,6 +674,8 @@ keyValAttr = try $ do char '=' val <- enclosed (char '"') (char '"') litChar <|> enclosed (char '\'') (char '\'') litChar + <|> ("" <$ try (string "\"\"")) + <|> ("" <$ try (string "''")) <|> many (escapedChar' <|> noneOf " \t\n\r}") return $ \(id',cs,kvs) -> case key of @@ -909,6 +912,17 @@ listContinuation continuationIndent = try $ do blanks <- many blankline return $ concat (x:xs) ++ blanks +-- Variant of blanklines that doesn't require blank lines +-- before a fence or eof. +blanklines' :: PandocMonad m => MarkdownParser m [Char] +blanklines' = blanklines <|> try checkDivCloser + where checkDivCloser = do + guardEnabled Ext_fenced_divs + divLevel <- stateFencedDivLevel <$> getState + guard (divLevel >= 1) + lookAhead divFenceEnd + return "" + notFollowedByDivCloser :: PandocMonad m => MarkdownParser m () notFollowedByDivCloser = guardDisabled Ext_fenced_divs <|> @@ -1250,7 +1264,7 @@ alignType strLst len = -- Parse a table footer - dashed lines followed by blank line. tableFooter :: PandocMonad m => MarkdownParser m String -tableFooter = try $ skipNonindentSpaces >> many1 (dashedLine '-') >> blanklines +tableFooter = try $ skipNonindentSpaces >> many1 (dashedLine '-') >> blanklines' -- Parse a table separator - dashed line. tableSep :: PandocMonad m => MarkdownParser m Char @@ -1261,7 +1275,7 @@ rawTableLine :: PandocMonad m => [Int] -> MarkdownParser m [String] rawTableLine indices = do - notFollowedBy' (blanklines <|> tableFooter) + notFollowedBy' (blanklines' <|> tableFooter) line <- many1Till anyChar newline return $ map trim $ tail $ splitStringByIndices (init indices) line @@ -1299,7 +1313,7 @@ simpleTable headless = do (aligns, _widths, heads', lines') <- tableWith (simpleTableHeader headless) tableLine (return ()) - (if headless then tableFooter else tableFooter <|> blanklines) + (if headless then tableFooter else tableFooter <|> blanklines') -- Simple tables get 0s for relative column widths (i.e., use default) return (aligns, replicate (length aligns) 0, heads', lines') @@ -1327,11 +1341,16 @@ multilineTableHeader headless = try $ do newline let (lengths, lines') = unzip dashes let indices = scanl (+) (length initSp) lines' + -- compensate for the fact that intercolumn spaces are + -- not included in the last index: + let indices' = case reverse indices of + [] -> [] + (x:xs) -> reverse (x+1:xs) rawHeadsList <- if headless then fmap (map (:[]) . tail . - splitStringByIndices (init indices)) $ lookAhead anyLine + splitStringByIndices (init indices')) $ lookAhead anyLine else return $ transpose $ map - (tail . splitStringByIndices (init indices)) + (tail . splitStringByIndices (init indices')) rawContent let aligns = zipWith alignType rawHeadsList lengths let rawHeads = if headless @@ -1339,7 +1358,7 @@ multilineTableHeader headless = try $ do else map (unlines . map trim) rawHeadsList heads <- fmap sequence $ mapM ((parseFromString' (mconcat <$> many plain)).trim) rawHeads - return (heads, aligns, indices) + return (heads, aligns, indices') -- Parse a grid table: starts with row of '-' on top, then header -- (which may be grid), then the rows, @@ -2145,7 +2164,6 @@ singleQuoted = try $ do doubleQuoted :: PandocMonad m => MarkdownParser m (F Inlines) doubleQuoted = try $ do doubleQuoteStart - contents <- mconcat <$> many (try $ notFollowedBy doubleQuoteEnd >> inline) - withQuoteContext InDoubleQuote (doubleQuoteEnd >> return - (fmap B.doubleQuoted . trimInlinesF $ contents)) - <|> return (return (B.str "\8220") <> contents) + withQuoteContext InDoubleQuote $ + fmap B.doubleQuoted . trimInlinesF . mconcat <$> + many1Till inline doubleQuoteEnd diff --git a/src/Text/Pandoc/Readers/MediaWiki.hs b/src/Text/Pandoc/Readers/MediaWiki.hs index c19ef2f46..764b57f18 100644 --- a/src/Text/Pandoc/Readers/MediaWiki.hs +++ b/src/Text/Pandoc/Readers/MediaWiki.hs @@ -1,6 +1,5 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE RelaxedPolyRec #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RelaxedPolyRec #-} -- RelaxedPolyRec needed for inlinesBetween on GHC < 7 {- Copyright (C) 2012-2018 John MacFarlane <jgm@berkeley.edu> @@ -38,6 +37,7 @@ _ parse templates? -} module Text.Pandoc.Readers.MediaWiki ( readMediaWiki ) where +import Prelude import Control.Monad import Control.Monad.Except (throwError) import Data.Char (isDigit, isSpace) @@ -45,7 +45,6 @@ import qualified Data.Foldable as F import Data.List (intercalate, intersperse, isPrefixOf) import qualified Data.Map as M import Data.Maybe (fromMaybe, maybeToList) -import Data.Monoid ((<>)) import Data.Sequence (ViewL (..), viewl, (<|)) import qualified Data.Set as Set import Data.Text (Text, unpack) @@ -231,7 +230,8 @@ para = do table :: PandocMonad m => MWParser m Blocks table = do tableStart - styles <- option [] parseAttrs + styles <- option [] $ + parseAttrs <* skipMany spaceChar <* optional (char '|') skipMany spaceChar optional blanklines let tableWidth = case lookup "width" styles of @@ -282,17 +282,29 @@ rowsep = try $ guardColumnOne *> skipSpaces *> sym "|-" <* cellsep :: PandocMonad m => MWParser m () cellsep = try $ do + col <- sourceColumn <$> getPosition skipSpaces - (char '|' *> notFollowedBy (oneOf "-}+") *> optional (char '|')) - <|> (char '!' *> optional (char '!')) + let pipeSep = do + char '|' + notFollowedBy (oneOf "-}+") + if col == 1 + then optional (char '|') + else void (char '|') + let exclSep = do + char '!' + if col == 1 + then optional (char '!') + else void (char '!') + pipeSep <|> exclSep tableCaption :: PandocMonad m => MWParser m Inlines tableCaption = try $ do guardColumnOne skipSpaces sym "|+" - optional (try $ parseAttr *> skipSpaces *> char '|' *> skipSpaces) - (trimInlines . mconcat) <$> many (notFollowedBy (cellsep <|> rowsep) *> inline) + optional (try $ parseAttr *> skipSpaces *> char '|' *> blanklines) + (trimInlines . mconcat) <$> + many (notFollowedBy (cellsep <|> rowsep) *> inline) tableRow :: PandocMonad m => MWParser m [((Alignment, Double), Blocks)] tableRow = try $ skipMany htmlComment *> many tableCell diff --git a/src/Text/Pandoc/Readers/Muse.hs b/src/Text/Pandoc/Readers/Muse.hs index 1fb37aa16..fe6b3698c 100644 --- a/src/Text/Pandoc/Readers/Muse.hs +++ b/src/Text/Pandoc/Readers/Muse.hs @@ -1,4 +1,6 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TupleSections #-} {- Copyright (C) 2017-2018 Alexander Krotov <ilabdsf@gmail.com> @@ -34,13 +36,14 @@ TODO: - Org tables - table.el tables - Images with attributes (floating and width) -- Citations and <biblio> -- <play> environment +- <cite> tag -} module Text.Pandoc.Readers.Muse (readMuse) where +import Prelude import Control.Monad import Control.Monad.Except (throwError) +import Data.Bifunctor import Data.Char (isLetter) import Data.Default import Data.List (stripPrefix, intercalate) @@ -81,24 +84,21 @@ data MuseState = MuseState { museMeta :: F Meta -- ^ Document metadata , museLastStrPos :: Maybe SourcePos -- ^ Position after last str parsed , museLogMessages :: [LogMessage] , museNotes :: M.Map String (SourcePos, F Blocks) - , museInLink :: Bool - , museInPara :: Bool + , museInLink :: Bool -- ^ True when parsing a link description to avoid nested links + , museInPara :: Bool -- ^ True when looking for a paragraph terminator } instance Default MuseState where - def = defaultMuseState - -defaultMuseState :: MuseState -defaultMuseState = MuseState { museMeta = return nullMeta - , museOptions = def - , museHeaders = M.empty - , museIdentifierList = Set.empty - , museLastStrPos = Nothing - , museLogMessages = [] - , museNotes = M.empty - , museInLink = False - , museInPara = False - } + def = MuseState { museMeta = return nullMeta + , museOptions = def + , museHeaders = M.empty + , museIdentifierList = Set.empty + , museLastStrPos = Nothing + , museLogMessages = [] + , museNotes = M.empty + , museInLink = False + , museInPara = False + } type MuseParser = ParserT String MuseState @@ -121,10 +121,7 @@ instance HasLogMessages MuseState where addLogMessage m s = s{ museLogMessages = m : museLogMessages s } getLogMessages = reverse . museLogMessages --- --- main parser --- - +-- | Parse Muse document parseMuse :: PandocMonad m => MuseParser m Pandoc parseMuse = do many directive @@ -136,14 +133,56 @@ parseMuse = do reportLogMessages return doc --- --- utility functions --- +-- * Utility functions + +commonPrefix :: String -> String -> String +commonPrefix _ [] = [] +commonPrefix [] _ = [] +commonPrefix (x:xs) (y:ys) + | x == y = x : commonPrefix xs ys + | otherwise = [] + +-- | Trim up to one newline from the beginning of the string. +lchop :: String -> String +lchop s = case s of + '\n':ss -> ss + _ -> s + +-- | Trim up to one newline from the end of the string. +rchop :: String -> String +rchop = reverse . lchop . reverse + +dropSpacePrefix :: [String] -> [String] +dropSpacePrefix lns = + map (drop maxIndent) lns + where flns = filter (not . all (== ' ')) lns + maxIndent = if null flns then maximum (map length lns) else length $ takeWhile (== ' ') $ foldl1 commonPrefix flns + +atStart :: PandocMonad m => MuseParser m a -> MuseParser m a +atStart p = do + pos <- getPosition + st <- getState + guard $ museLastStrPos st /= Just pos + p +-- * Parsers + +-- | Parse end-of-line, which can be either a newline or end-of-file. eol :: Stream s m Char => ParserT s st m () eol = void newline <|> eof -htmlElement :: PandocMonad m => String -> MuseParser m (Attr, String) +someUntil :: (Stream s m t) + => ParserT s u m a + -> ParserT s u m b + -> ParserT s u m ([a], b) +someUntil p end = first <$> ((:) <$> p) <*> manyUntil p end + +-- ** HTML parsers + +-- | Parse HTML tag, returning its attributes and literal contents. +htmlElement :: PandocMonad m + => String -- ^ Tag name + -> MuseParser m (Attr, String) htmlElement tag = try $ do (TagOpen _ attr, _) <- htmlTag (~== TagOpen tag []) content <- manyTill anyChar endtag @@ -151,12 +190,16 @@ htmlElement tag = try $ do where endtag = void $ htmlTag (~== TagClose tag) -htmlBlock :: PandocMonad m => String -> MuseParser m (Attr, String) +htmlBlock :: PandocMonad m + => String -- ^ Tag name + -> MuseParser m (Attr, String) htmlBlock tag = try $ do + many spaceChar res <- htmlElement tag manyTill spaceChar eol return res +-- | Convert HTML attributes to Pandoc 'Attr' htmlAttrToPandoc :: [Attribute String] -> Attr htmlAttrToPandoc attrs = (ident, classes, keyvals) where @@ -165,48 +208,24 @@ htmlAttrToPandoc attrs = (ident, classes, keyvals) keyvals = [(k,v) | (k,v) <- attrs, k /= "id" && k /= "class"] parseHtmlContent :: PandocMonad m - => String -> MuseParser m (Attr, F Blocks) -parseHtmlContent tag = do + => String -- ^ Tag name + -> MuseParser m (Attr, F Blocks) +parseHtmlContent tag = try $ do + many spaceChar + pos <- getPosition (TagOpen _ attr, _) <- htmlTag (~== TagOpen tag []) manyTill spaceChar eol - content <- parseBlocksTill (manyTill spaceChar endtag) + content <- parseBlocksTill $ try $ count (sourceColumn pos - 1) spaceChar >> endtag manyTill spaceChar eol -- closing tag must be followed by optional whitespace and newline return (htmlAttrToPandoc attr, content) where endtag = void $ htmlTag (~== TagClose tag) -commonPrefix :: String -> String -> String -commonPrefix _ [] = [] -commonPrefix [] _ = [] -commonPrefix (x:xs) (y:ys) - | x == y = x : commonPrefix xs ys - | otherwise = [] - -atStart :: PandocMonad m => MuseParser m a -> MuseParser m a -atStart p = do - pos <- getPosition - st <- getState - guard $ museLastStrPos st /= Just pos - p - -someUntil :: (Stream s m t) - => ParserT s u m a - -> ParserT s u m b - -> ParserT s u m ([a], b) -someUntil p end = do - first <- p - (rest, e) <- manyUntil p end - return (first:rest, e) - --- --- directive parsers --- +-- ** Directive parsers -- While not documented, Emacs Muse allows "-" in directive name parseDirectiveKey :: PandocMonad m => MuseParser m String -parseDirectiveKey = do - char '#' - many (letter <|> char '-') +parseDirectiveKey = char '#' *> many (letter <|> char '-') parseEmacsDirective :: PandocMonad m => MuseParser m (String, F Inlines) parseEmacsDirective = do @@ -233,55 +252,42 @@ directive = do where translateKey "cover" = "cover-image" translateKey x = x --- --- block parsers --- +-- ** Block parsers parseBlocks :: PandocMonad m => MuseParser m (F Blocks) parseBlocks = - try parseEnd <|> - try blockStart <|> - try listStart <|> - try paraStart + try (parseEnd <|> + blockStart <|> + listStart <|> + paraStart) where parseEnd = mempty <$ eof - blockStart = do first <- header <|> blockElements <|> emacsNoteBlock - rest <- parseBlocks - return $ first B.<> rest + blockStart = ((B.<>) <$> (emacsHeading <|> blockElements <|> emacsNoteBlock) + <*> parseBlocks) <|> (uncurry (B.<>) <$> amuseHeadingUntil parseBlocks) listStart = do updateState (\st -> st { museInPara = False }) - (first, rest) <- anyListUntil parseBlocks <|> amuseNoteBlockUntil parseBlocks - return $ first B.<> rest + uncurry (B.<>) <$> (anyListUntil parseBlocks <|> amuseNoteBlockUntil parseBlocks) paraStart = do indent <- length <$> many spaceChar - (first, rest) <- paraUntil parseBlocks - let first' = if indent >= 2 && indent < 6 then B.blockQuote <$> first else first - return $ first' B.<> rest + uncurry (B.<>) . first (p indent) <$> paraUntil parseBlocks + where p indent = if indent >= 2 && indent < 6 then fmap B.blockQuote else id parseBlocksTill :: PandocMonad m => MuseParser m a -> MuseParser m (F Blocks) parseBlocksTill end = - try parseEnd <|> - try blockStart <|> - try listStart <|> - try paraStart + try (parseEnd <|> + blockStart <|> + listStart <|> + paraStart) where parseEnd = mempty <$ end - blockStart = do first <- blockElements - rest <- continuation - return $ first B.<> rest + blockStart = (B.<>) <$> blockElements <*> continuation listStart = do updateState (\st -> st { museInPara = False }) - (first, e) <- anyListUntil ((Left <$> end) <|> (Right <$> continuation)) - case e of - Left _ -> return first - Right rest -> return $ first B.<> rest - paraStart = do (first, e) <- paraUntil ((Left <$> end) <|> (Right <$> continuation)) - case e of - Left _ -> return first - Right rest -> return $ first B.<> rest + uncurry (B.<>) <$> anyListUntil (parseEnd <|> continuation) + paraStart = uncurry (B.<>) <$> paraUntil (parseEnd <|> continuation) continuation = parseBlocksTill end listItemContentsUntil :: PandocMonad m @@ -294,24 +300,17 @@ listItemContentsUntil col pre end = try listStart <|> try paraStart where - parsePre = do e <- pre - return (mempty, e) - parseEnd = do e <- end - return (mempty, e) + parsePre = (mempty,) <$> pre + parseEnd = (mempty,) <$> end paraStart = do - (first, e) <- paraUntil ((Left <$> pre) <|> (Right <$> continuation) <|> (Left <$> end)) - case e of - Left ee -> return (first, ee) - Right (rest, ee) -> return (first B.<> rest, ee) - blockStart = do first <- blockElements - (rest, e) <- parsePre <|> continuation <|> parseEnd - return (first B.<> rest, e) + (f, (r, e)) <- paraUntil (parsePre <|> continuation <|> parseEnd) + return (f B.<> r, e) + blockStart = first <$> ((B.<>) <$> blockElements) + <*> (parsePre <|> continuation <|> parseEnd) listStart = do updateState (\st -> st { museInPara = False }) - (first, e) <- anyListUntil ((Left <$> pre) <|> (Right <$> continuation) <|> (Left <$> end)) - case e of - Left ee -> return (first, ee) - Right (rest, ee) -> return (first B.<> rest, ee) + (f, (r, e)) <- anyListUntil (parsePre <|> continuation <|> parseEnd) + return (f B.<> r, e) continuation = try $ do blank <- optionMaybe blankline skipMany blankline indentWith col @@ -338,19 +337,24 @@ blockElements = do , rightTag , quoteTag , divTag + , biblioTag + , playTag , verseTag , lineBlock , table , commentTag ] +-- | Parse a line comment, starting with @;@ in the first column. comment :: PandocMonad m => MuseParser m (F Blocks) comment = try $ do + getPosition >>= \pos -> guard (sourceColumn pos == 1) char ';' optional (spaceChar >> many (noneOf "\n")) eol return mempty +-- | Parse a horizontal rule, consisting of 4 or more @\'-\'@ characters. separator :: PandocMonad m => MuseParser m (F Blocks) separator = try $ do string "----" @@ -359,17 +363,37 @@ separator = try $ do eol return $ return B.horizontalRule -header :: PandocMonad m => MuseParser m (F Blocks) -header = try $ do +-- | Parse a single-line heading. +emacsHeading :: PandocMonad m => MuseParser m (F Blocks) +emacsHeading = try $ do + guardDisabled Ext_amuse + anchorId <- option "" $ try (parseAnchor <* manyTill spaceChar eol) getPosition >>= \pos -> guard (sourceColumn pos == 1) level <- fmap length $ many1 $ char '*' guard $ level <= 5 spaceChar content <- trimInlinesF . mconcat <$> manyTill inline eol - anchorId <- option "" parseAnchor attr <- registerHeader (anchorId, [], []) (runF content def) return $ B.headerWith attr level <$> content +-- | Parse a multi-line heading. +-- It is a Text::Amuse extension, Emacs Muse does not allow heading to span multiple lines. +amuseHeadingUntil :: PandocMonad m + => MuseParser m a -- ^ Terminator parser + -> MuseParser m (F Blocks, a) +amuseHeadingUntil end = try $ do + guardEnabled Ext_amuse + anchorId <- option "" $ try (parseAnchor <* manyTill spaceChar eol) + getPosition >>= \pos -> guard (sourceColumn pos == 1) + level <- fmap length $ many1 $ char '*' + guard $ level <= 5 + spaceChar + (content, e) <- paraContentsUntil end + attr <- registerHeader (anchorId, [], []) (runF content def) + return (B.headerWith attr level <$> content, e) + +-- | Parse an example between @{{{@ and @}}}@. +-- It is an Amusewiki extension influenced by Creole wiki, as described in @Text::Amuse@ documentation. example :: PandocMonad m => MuseParser m (F Blocks) example = try $ do string "{{{" @@ -377,57 +401,63 @@ example = try $ do contents <- manyTill anyChar $ try (optional blankline >> string "}}}") return $ return $ B.codeBlock contents --- Trim up to one newline from the beginning and the end, --- in case opening and/or closing tags are on separate lines. -chop :: String -> String -chop = lchop . rchop - -lchop :: String -> String -lchop s = case s of - '\n':ss -> ss - _ -> s - -rchop :: String -> String -rchop = reverse . lchop . reverse - -dropSpacePrefix :: [String] -> [String] -dropSpacePrefix lns = - map (drop maxIndent) lns - where flns = filter (not . all (== ' ')) lns - maxIndent = if null flns then maximum (map length lns) else length $ takeWhile (== ' ') $ foldl1 commonPrefix flns - +-- | Parse an @\<example>@ tag. exampleTag :: PandocMonad m => MuseParser m (F Blocks) exampleTag = try $ do - many spaceChar (attr, contents) <- htmlBlock "example" return $ return $ B.codeBlockWith attr $ rchop $ intercalate "\n" $ dropSpacePrefix $ splitOn "\n" $ lchop contents +-- | Parse a @\<literal>@ tag as a raw block. +-- For 'RawInline' @\<literal>@ parser, see 'inlineLiteralTag'. literalTag :: PandocMonad m => MuseParser m (F Blocks) -literalTag = do - guardDisabled Ext_amuse -- Text::Amuse does not support <literal> - (return . rawBlock) <$> htmlBlock "literal" +literalTag = try $ do + many spaceChar + (TagOpen _ attr, _) <- htmlTag (~== TagOpen "literal" []) + manyTill spaceChar eol + content <- manyTill anyChar endtag + manyTill spaceChar eol + return $ return $ rawBlock (htmlAttrToPandoc attr, content) where + endtag = void $ htmlTag (~== TagClose "literal") -- FIXME: Emacs Muse inserts <literal> without style into all output formats, but we assume HTML format (_, _, kvs) = fromMaybe "html" $ lookup "style" kvs - rawBlock (attrs, content) = B.rawBlock (format attrs) $ chop content + rawBlock (attrs, content) = B.rawBlock (format attrs) $ rchop $ intercalate "\n" $ dropSpacePrefix $ splitOn "\n" $ lchop content --- <center> tag is ignored +-- | Parse @\<center>@ tag. +-- Currently it is ignored as Pandoc cannot represent centered blocks. centerTag :: PandocMonad m => MuseParser m (F Blocks) centerTag = snd <$> parseHtmlContent "center" --- <right> tag is ignored +-- | Parse @\<right>@ tag. +-- Currently it is ignored as Pandoc cannot represent centered blocks. rightTag :: PandocMonad m => MuseParser m (F Blocks) rightTag = snd <$> parseHtmlContent "right" +-- | Parse @\<quote>@ tag. quoteTag :: PandocMonad m => MuseParser m (F Blocks) quoteTag = fmap B.blockQuote . snd <$> parseHtmlContent "quote" --- <div> tag is supported by Emacs Muse, but not Amusewiki 2.025 +-- | Parse @\<div>@ tag. +-- @\<div>@ tag is supported by Emacs Muse, but not Amusewiki 2.025. divTag :: PandocMonad m => MuseParser m (F Blocks) divTag = do (attrs, content) <- parseHtmlContent "div" return $ B.divWith attrs <$> content +-- | Parse @\<biblio>@ tag, the result is the same as @\<div class="biblio">@. +-- @\<biblio>@ tag is supported only in Text::Amuse mode. +biblioTag :: PandocMonad m => MuseParser m (F Blocks) +biblioTag = do + guardEnabled Ext_amuse + fmap (B.divWith ("", ["biblio"], [])) . snd <$> parseHtmlContent "biblio" + +-- | Parse @\<play>@ tag, the result is the same as @\<div class="play">@. +-- @\<play>@ tag is supported only in Text::Amuse mode. +playTag :: PandocMonad m => MuseParser m (F Blocks) +playTag = do + guardEnabled Ext_amuse + fmap (B.divWith ("", ["play"], [])) . snd <$> parseHtmlContent "play" + verseLine :: PandocMonad m => MuseParser m (F Inlines) verseLine = do indent <- (B.str <$> many1 (char ' ' >> pure '\160')) <|> pure mempty @@ -439,32 +469,39 @@ verseLines = do lns <- many verseLine return $ B.lineBlock <$> sequence lns +-- | Parse @\<verse>@ tag. verseTag :: PandocMonad m => MuseParser m (F Blocks) verseTag = do (_, content) <- htmlBlock "verse" parseFromString verseLines (intercalate "\n" $ dropSpacePrefix $ splitOn "\n" $ lchop content) +-- | Parse @\<comment>@ tag. commentTag :: PandocMonad m => MuseParser m (F Blocks) commentTag = htmlBlock "comment" >> return mempty --- Indented paragraph is either center, right or quote +-- | Parse paragraph contents. +paraContentsUntil :: PandocMonad m + => MuseParser m a -- ^ Terminator parser + -> MuseParser m (F Inlines, a) +paraContentsUntil end = do + updateState (\st -> st { museInPara = True }) + (l, e) <- someUntil inline $ try (manyTill spaceChar eol >> end) + updateState (\st -> st { museInPara = False }) + return (trimInlinesF $ mconcat l, e) + +-- | Parse a paragraph. paraUntil :: PandocMonad m - => MuseParser m a + => MuseParser m a -- ^ Terminator parser -> MuseParser m (F Blocks, a) paraUntil end = do state <- getState guard $ not $ museInPara state - setState $ state{ museInPara = True } - (l, e) <- someUntil inline $ try (manyTill spaceChar eol >> end) - updateState (\st -> st { museInPara = False }) - return (fmap B.para $ trimInlinesF $ mconcat l, e) + first (fmap B.para) <$> paraContentsUntil end noteMarker :: PandocMonad m => MuseParser m String noteMarker = try $ do char '[' - first <- oneOf "123456789" - rest <- manyTill digit (char ']') - return $ first:rest + (:) <$> oneOf "123456789" <*> manyTill digit (char ']') -- Amusewiki version of note -- Parsing is similar to list item, except that note marker is used instead of list marker @@ -473,14 +510,13 @@ amuseNoteBlockUntil :: PandocMonad m -> MuseParser m (F Blocks, a) amuseNoteBlockUntil end = try $ do guardEnabled Ext_amuse - pos <- getPosition ref <- noteMarker <* spaceChar + pos <- getPosition updateState (\st -> st { museInPara = False }) - (content, e) <- listItemContentsUntil (sourceColumn pos) (fail "x") end + (content, e) <- listItemContentsUntil (sourceColumn pos - 1) (fail "x") end oldnotes <- museNotes <$> getState - case M.lookup ref oldnotes of - Just _ -> logMessage $ DuplicateNoteReference ref pos - Nothing -> return () + when (M.member ref oldnotes) + (logMessage $ DuplicateNoteReference ref pos) updateState $ \s -> s{ museNotes = M.insert ref (pos, content) oldnotes } return (mempty, e) @@ -493,9 +529,8 @@ emacsNoteBlock = try $ do ref <- noteMarker <* skipSpaces content <- mconcat <$> blocksTillNote oldnotes <- museNotes <$> getState - case M.lookup ref oldnotes of - Just _ -> logMessage $ DuplicateNoteReference ref pos - Nothing -> return () + when (M.member ref oldnotes) + (logMessage $ DuplicateNoteReference ref pos) updateState $ \s -> s{ museNotes = M.insert ref (pos, content) oldnotes } return mempty where @@ -509,9 +544,10 @@ emacsNoteBlock = try $ do lineVerseLine :: PandocMonad m => MuseParser m (F Inlines) lineVerseLine = try $ do string "> " - indent <- B.str <$> many (char ' ' >> pure '\160') + indent <- many (char ' ' >> pure '\160') + let indentEl = if null indent then mempty else B.str indent rest <- manyTill (choice inlineList) eol - return $ trimInlinesF $ mconcat (pure indent : rest) + return $ trimInlinesF $ mconcat (pure indentEl : rest) blanklineVerseLine :: PandocMonad m => MuseParser m (F Inlines) blanklineVerseLine = try $ do @@ -519,29 +555,28 @@ blanklineVerseLine = try $ do blankline pure mempty +-- | Parse a line block indicated by @\'>\'@ characters. lineBlock :: PandocMonad m => MuseParser m (F Blocks) lineBlock = try $ do + many spaceChar col <- sourceColumn <$> getPosition lns <- (blanklineVerseLine <|> lineVerseLine) `sepBy1'` try (indentWith (col - 1)) return $ B.lineBlock <$> sequence lns --- --- lists --- +-- *** List parsers bulletListItemsUntil :: PandocMonad m - => Int - -> MuseParser m a + => Int -- ^ Indentation + -> MuseParser m a -- ^ Terminator parser -> MuseParser m ([F Blocks], a) bulletListItemsUntil indent end = try $ do char '-' void spaceChar <|> lookAhead eol updateState (\st -> st { museInPara = False }) - (x, e) <- listItemContentsUntil (indent + 2) (Right <$> try (optional blankline >> indentWith indent >> bulletListItemsUntil indent end)) (Left <$> end) - case e of - Left ee -> return ([x], ee) - Right (xs, ee) -> return (x:xs, ee) + (x, (xs, e)) <- listItemContentsUntil (indent + 2) (try (optional blankline >> indentWith indent >> bulletListItemsUntil indent end)) (([],) <$> end) + return (x:xs, e) +-- | Parse a bullet list. bulletListUntil :: PandocMonad m => MuseParser m a -> MuseParser m (F Blocks, a) @@ -563,16 +598,15 @@ anyMuseOrderedListMarker = do museOrderedListMarker :: PandocMonad m => ListNumberStyle -> MuseParser m Int -museOrderedListMarker style = do - (_, start) <- case style of - Decimal -> decimal - UpperRoman -> upperRoman - LowerRoman -> lowerRoman - UpperAlpha -> upperAlpha - LowerAlpha -> lowerAlpha - _ -> fail "Unhandled case" - char '.' - return start +museOrderedListMarker style = + snd <$> p <* char '.' + where p = case style of + Decimal -> decimal + UpperRoman -> upperRoman + LowerRoman -> lowerRoman + UpperAlpha -> upperAlpha + LowerAlpha -> lowerAlpha + _ -> fail "Unhandled case" orderedListItemsUntil :: PandocMonad m => Int @@ -586,11 +620,10 @@ orderedListItemsUntil indent style end = pos <- getPosition void spaceChar <|> lookAhead eol updateState (\st -> st { museInPara = False }) - (x, e) <- listItemContentsUntil (sourceColumn pos) (Right <$> try (optionMaybe blankline >> indentWith indent >> museOrderedListMarker style >> continuation)) (Left <$> end) - case e of - Left ee -> return ([x], ee) - Right (xs, ee) -> return (x:xs, ee) + (x, (xs, e)) <- listItemContentsUntil (sourceColumn pos) (try (optional blankline >> indentWith indent >> museOrderedListMarker style >> continuation)) (([],) <$> end) + return (x:xs, e) +-- | Parse an ordered list. orderedListUntil :: PandocMonad m => MuseParser m a -> MuseParser m (F Blocks, a) @@ -611,10 +644,8 @@ descriptionsUntil :: PandocMonad m descriptionsUntil indent end = do void spaceChar <|> lookAhead eol updateState (\st -> st { museInPara = False }) - (x, e) <- listItemContentsUntil indent (Right <$> try (optional blankline >> indentWith indent >> manyTill spaceChar (string "::") >> descriptionsUntil indent end)) (Left <$> end) - case e of - Right (xs, ee) -> return (x:xs, ee) - Left ee -> return ([x], ee) + (x, (xs, e)) <- listItemContentsUntil indent (try (optional blankline >> indentWith indent >> manyTill spaceChar (string "::") >> descriptionsUntil indent end)) (([],) <$> end) + return (x:xs, e) definitionListItemsUntil :: PandocMonad m => Int @@ -625,37 +656,31 @@ definitionListItemsUntil indent end = where continuation = try $ do pos <- getPosition - term <- trimInlinesF . mconcat <$> manyTill (choice inlineList) (string "::") - (x, e) <- descriptionsUntil (sourceColumn pos) ((Right <$> try (optional blankline >> indentWith indent >> continuation)) <|> (Left <$> end)) - let xx = do - term' <- term - x' <- sequence x - return (term', x') - case e of - Left ee -> return ([xx], ee) - Right (xs, ee) -> return (xx:xs, ee) + term <- trimInlinesF . mconcat <$> manyTill (choice inlineList) (try $ string "::") + (x, (xs, e)) <- descriptionsUntil (sourceColumn pos) (try (optional blankline >> indentWith indent >> continuation) <|> (([],) <$> end)) + let xx = (,) <$> term <*> sequence x + return (xx:xs, e) +-- | Parse a definition list. definitionListUntil :: PandocMonad m - => MuseParser m a + => MuseParser m a -- ^ Terminator parser -> MuseParser m (F Blocks, a) definitionListUntil end = try $ do many spaceChar pos <- getPosition let indent = sourceColumn pos - 1 guardDisabled Ext_amuse <|> guard (indent /= 0) -- Initial space is required by Amusewiki, but not Emacs Muse - (items, e) <- definitionListItemsUntil indent end - return (B.definitionList <$> sequence items, e) + first (fmap B.definitionList . sequence) <$> definitionListItemsUntil indent end anyListUntil :: PandocMonad m - => MuseParser m a + => MuseParser m a -- ^ Terminator parser -> MuseParser m (F Blocks, a) anyListUntil end = bulletListUntil end <|> orderedListUntil end <|> definitionListUntil end --- --- tables --- +-- *** Table parsers +-- | Internal Muse table representation. data MuseTable = MuseTable { museTableCaption :: Inlines , museTableHeaders :: [[Blocks]] @@ -663,10 +688,10 @@ data MuseTable = MuseTable , museTableFooters :: [[Blocks]] } -data MuseTableElement = MuseHeaderRow (F [Blocks]) - | MuseBodyRow (F [Blocks]) - | MuseFooterRow (F [Blocks]) - | MuseCaption (F Inlines) +data MuseTableElement = MuseHeaderRow [Blocks] + | MuseBodyRow [Blocks] + | MuseFooterRow [Blocks] + | MuseCaption Inlines museToPandocTable :: MuseTable -> Blocks museToPandocTable (MuseTable caption headers body footers) = @@ -676,73 +701,66 @@ museToPandocTable (MuseTable caption headers body footers) = headRow = if null headers then [] else head headers rows = (if null headers then [] else tail headers) ++ body ++ footers -museAppendElement :: MuseTable - -> MuseTableElement - -> F MuseTable -museAppendElement tbl element = +museAppendElement :: MuseTableElement + -> MuseTable + -> MuseTable +museAppendElement element tbl = case element of - MuseHeaderRow row -> do - row' <- row - return tbl{ museTableHeaders = museTableHeaders tbl ++ [row'] } - MuseBodyRow row -> do - row' <- row - return tbl{ museTableRows = museTableRows tbl ++ [row'] } - MuseFooterRow row-> do - row' <- row - return tbl{ museTableFooters = museTableFooters tbl ++ [row'] } - MuseCaption inlines -> do - inlines' <- inlines - return tbl{ museTableCaption = inlines' } + MuseHeaderRow row -> tbl{ museTableHeaders = row : museTableHeaders tbl } + MuseBodyRow row -> tbl{ museTableRows = row : museTableRows tbl } + MuseFooterRow row -> tbl{ museTableFooters = row : museTableFooters tbl } + MuseCaption inlines -> tbl{ museTableCaption = inlines } tableCell :: PandocMonad m => MuseParser m (F Blocks) tableCell = try $ fmap B.plain . trimInlinesF . mconcat <$> manyTill inline (lookAhead cellEnd) where cellEnd = try $ void (many1 spaceChar >> char '|') <|> eol -tableElements :: PandocMonad m => MuseParser m [MuseTableElement] -tableElements = tableParseElement `sepEndBy1` eol +tableElements :: PandocMonad m => MuseParser m (F [MuseTableElement]) +tableElements = sequence <$> (tableParseElement `sepEndBy1` eol) -elementsToTable :: [MuseTableElement] -> F MuseTable -elementsToTable = foldM museAppendElement emptyTable +elementsToTable :: [MuseTableElement] -> MuseTable +elementsToTable = foldr museAppendElement emptyTable where emptyTable = MuseTable mempty mempty mempty mempty +-- | Parse a table. table :: PandocMonad m => MuseParser m (F Blocks) -table = try $ do - rows <- tableElements - let tbl = elementsToTable rows - let pandocTbl = museToPandocTable <$> tbl :: F Blocks - return pandocTbl +table = try $ fmap (museToPandocTable . elementsToTable) <$> tableElements -tableParseElement :: PandocMonad m => MuseParser m MuseTableElement +tableParseElement :: PandocMonad m => MuseParser m (F MuseTableElement) tableParseElement = tableParseHeader <|> tableParseBody <|> tableParseFooter <|> tableParseCaption -tableParseRow :: PandocMonad m => Int -> MuseParser m (F [Blocks]) +tableParseRow :: PandocMonad m + => Int -- ^ Number of separator characters + -> MuseParser m (F [Blocks]) tableParseRow n = try $ do fields <- tableCell `sepBy2` fieldSep return $ sequence fields where p `sepBy2` sep = (:) <$> p <*> many1 (sep >> p) fieldSep = many1 spaceChar >> count n (char '|') >> (void (many1 spaceChar) <|> void (lookAhead newline)) -tableParseHeader :: PandocMonad m => MuseParser m MuseTableElement -tableParseHeader = MuseHeaderRow <$> tableParseRow 2 +-- | Parse a table header row. +tableParseHeader :: PandocMonad m => MuseParser m (F MuseTableElement) +tableParseHeader = fmap MuseHeaderRow <$> tableParseRow 2 -tableParseBody :: PandocMonad m => MuseParser m MuseTableElement -tableParseBody = MuseBodyRow <$> tableParseRow 1 +-- | Parse a table body row. +tableParseBody :: PandocMonad m => MuseParser m (F MuseTableElement) +tableParseBody = fmap MuseBodyRow <$> tableParseRow 1 -tableParseFooter :: PandocMonad m => MuseParser m MuseTableElement -tableParseFooter = MuseFooterRow <$> tableParseRow 3 +-- | Parse a table footer row. +tableParseFooter :: PandocMonad m => MuseParser m (F MuseTableElement) +tableParseFooter = fmap MuseFooterRow <$> tableParseRow 3 -tableParseCaption :: PandocMonad m => MuseParser m MuseTableElement +-- | Parse table caption. +tableParseCaption :: PandocMonad m => MuseParser m (F MuseTableElement) tableParseCaption = try $ do many spaceChar string "|+" - MuseCaption <$> (trimInlinesF . mconcat <$> many1Till inline (string "+|")) + fmap MuseCaption <$> (trimInlinesF . mconcat <$> many1Till inline (string "+|")) --- --- inline parsers --- +-- ** Inline parsers inlineList :: PandocMonad m => [MuseParser m (F Inlines)] inlineList = [ whitespace @@ -758,10 +776,12 @@ inlineList = [ whitespace , subscriptTag , strikeoutTag , verbatimTag + , classTag , nbsp , link , code , codeTag + , mathTag , inlineLiteralTag , str , symbol @@ -770,28 +790,30 @@ inlineList = [ whitespace inline :: PandocMonad m => MuseParser m (F Inlines) inline = endline <|> choice inlineList <?> "inline" +-- | Parse a soft break. endline :: PandocMonad m => MuseParser m (F Inlines) endline = try $ do newline notFollowedBy blankline - returnF B.softbreak + return $ return B.softbreak parseAnchor :: PandocMonad m => MuseParser m String parseAnchor = try $ do getPosition >>= \pos -> guard (sourceColumn pos == 1) char '#' - first <- letter - rest <- many (letter <|> digit) - skipMany spaceChar <|> void newline - return $ first:rest + (:) <$> letter <*> many (letter <|> digit <|> char '-') anchor :: PandocMonad m => MuseParser m (F Inlines) anchor = try $ do anchorId <- parseAnchor + skipMany spaceChar <|> void newline return $ return $ B.spanWith (anchorId, [], []) mempty +-- | Parse a footnote reference. footnote :: PandocMonad m => MuseParser m (F Inlines) footnote = try $ do + inLink <- museInLink <$> getState + guard $ not inLink ref <- noteMarker return $ do notes <- asksF museNotes @@ -799,7 +821,7 @@ footnote = try $ do Nothing -> return $ B.str $ "[" ++ ref ++ "]" Just (_pos, contents) -> do st <- askF - let contents' = runF contents st { museNotes = M.empty } + let contents' = runF contents st { museNotes = M.delete ref (museNotes st) } return $ B.note contents' whitespace :: PandocMonad m => MuseParser m (F Inlines) @@ -807,6 +829,7 @@ whitespace = try $ do skipMany1 spaceChar return $ return B.space +-- | Parse @\<br>@ tag. br :: PandocMonad m => MuseParser m (F Inlines) br = try $ do string "<br>" @@ -822,49 +845,68 @@ enclosedInlines :: (PandocMonad m, Show a, Show b) enclosedInlines start end = try $ trimInlinesF . mconcat <$> (enclosed (atStart start) end inline <* notFollowedBy (satisfy isLetter)) +-- | Parse an inline tag, such as @\<em>@ and @\<strong>@. inlineTag :: PandocMonad m - => (Inlines -> Inlines) - -> String + => String -- ^ Tag name -> MuseParser m (F Inlines) -inlineTag f tag = try $ do +inlineTag tag = try $ do htmlTag (~== TagOpen tag []) - res <- manyTill inline (void $ htmlTag (~== TagClose tag)) - return $ f <$> mconcat res - -strongTag :: PandocMonad m => MuseParser m (F Inlines) -strongTag = inlineTag B.strong "strong" + mconcat <$> manyTill inline (void $ htmlTag (~== TagClose tag)) +-- | Parse strong inline markup, indicated by @**@. strong :: PandocMonad m => MuseParser m (F Inlines) strong = fmap B.strong <$> emphasisBetween (string "**") +-- | Parse emphasis inline markup, indicated by @*@. emph :: PandocMonad m => MuseParser m (F Inlines) emph = fmap B.emph <$> emphasisBetween (char '*') +-- | Parse underline inline markup, indicated by @_@. +-- Supported only in Emacs Muse mode, not Text::Amuse. underlined :: PandocMonad m => MuseParser m (F Inlines) underlined = do guardDisabled Ext_amuse -- Supported only by Emacs Muse fmap underlineSpan <$> emphasisBetween (char '_') +-- | Parse @\<strong>@ tag. +strongTag :: PandocMonad m => MuseParser m (F Inlines) +strongTag = fmap B.strong <$> inlineTag "strong" + +-- | Parse @\<em>@ tag. emphTag :: PandocMonad m => MuseParser m (F Inlines) -emphTag = inlineTag B.emph "em" +emphTag = fmap B.emph <$> inlineTag "em" +-- | Parse @\<sup>@ tag. superscriptTag :: PandocMonad m => MuseParser m (F Inlines) -superscriptTag = inlineTag B.superscript "sup" +superscriptTag = fmap B.superscript <$> inlineTag "sup" +-- | Parse @\<sub>@ tag. subscriptTag :: PandocMonad m => MuseParser m (F Inlines) -subscriptTag = inlineTag B.subscript "sub" +subscriptTag = fmap B.subscript <$> inlineTag "sub" +-- | Parse @\<del>@ tag. strikeoutTag :: PandocMonad m => MuseParser m (F Inlines) -strikeoutTag = inlineTag B.strikeout "del" +strikeoutTag = fmap B.strikeout <$> inlineTag "del" +-- | Parse @\<verbatim>@ tag. verbatimTag :: PandocMonad m => MuseParser m (F Inlines) verbatimTag = return . B.text . snd <$> htmlElement "verbatim" +-- | Parse @\<class>@ tag. +classTag :: PandocMonad m => MuseParser m (F Inlines) +classTag = do + (TagOpen _ attrs, _) <- htmlTag (~== TagOpen "class" []) + res <- manyTill inline (void $ htmlTag (~== TagClose "class")) + let classes = maybe [] words $ lookup "name" attrs + return $ B.spanWith ("", classes, []) <$> mconcat res + +-- | Parse "~~" as nonbreaking space. nbsp :: PandocMonad m => MuseParser m (F Inlines) nbsp = try $ do string "~~" return $ return $ B.str "\160" +-- | Parse code markup, indicated by @\'=\'@ characters. code :: PandocMonad m => MuseParser m (F Inlines) code = try $ do atStart $ char '=' @@ -875,14 +917,18 @@ code = try $ do notFollowedBy $ satisfy isLetter return $ return $ B.code contents +-- | Parse @\<code>@ tag. codeTag :: PandocMonad m => MuseParser m (F Inlines) -codeTag = do - (attrs, content) <- htmlElement "code" - return $ return $ B.codeWith attrs content +codeTag = return . uncurry B.codeWith <$> htmlElement "code" +-- | Parse @\<math>@ tag. +-- @\<math>@ tag is an Emacs Muse extension enabled by @(require 'muse-latex2png)@ +mathTag :: PandocMonad m => MuseParser m (F Inlines) +mathTag = return . B.math . snd <$> htmlElement "math" + +-- | Parse inline @\<literal>@ tag as a raw inline. inlineLiteralTag :: PandocMonad m => MuseParser m (F Inlines) -inlineLiteralTag = do - guardDisabled Ext_amuse -- Text::Amuse does not support <literal> +inlineLiteralTag = (return . rawInline) <$> htmlElement "literal" where -- FIXME: Emacs Muse inserts <literal> without style into all output formats, but we assume HTML @@ -890,39 +936,35 @@ inlineLiteralTag = do rawInline (attrs, content) = B.rawInline (format attrs) content str :: PandocMonad m => MuseParser m (F Inlines) -str = do - result <- many1 alphaNum - updateLastStrPos - return $ return $ B.str result +str = return . B.str <$> many1 alphaNum <* updateLastStrPos symbol :: PandocMonad m => MuseParser m (F Inlines) symbol = return . B.str <$> count 1 nonspaceChar +-- | Parse a link or image. link :: PandocMonad m => MuseParser m (F Inlines) link = try $ do st <- getState guard $ not $ museInLink st setState $ st{ museInLink = True } - (url, title, content) <- linkText + (url, content) <- linkText updateState (\state -> state { museInLink = False }) return $ case stripPrefix "URL:" url of Nothing -> if isImageUrl url - then B.image url title <$> fromMaybe (return mempty) content - else B.link url title <$> fromMaybe (return $ B.str url) content - Just url' -> B.link url' title <$> fromMaybe (return $ B.str url') content + then B.image url "" <$> fromMaybe (return mempty) content + else B.link url "" <$> fromMaybe (return $ B.str url) content + Just url' -> B.link url' "" <$> fromMaybe (return $ B.str url') content where -- Taken from muse-image-regexp defined in Emacs Muse file lisp/muse-regexps.el imageExtensions = [".eps", ".gif", ".jpg", ".jpeg", ".pbm", ".png", ".tiff", ".xbm", ".xpm"] isImageUrl = (`elem` imageExtensions) . takeExtension linkContent :: PandocMonad m => MuseParser m (F Inlines) -linkContent = do - char '[' - trimInlinesF . mconcat <$> many1Till inline (string "]") +linkContent = char '[' >> trimInlinesF . mconcat <$> manyTill inline (string "]") -linkText :: PandocMonad m => MuseParser m (String, String, Maybe (F Inlines)) +linkText :: PandocMonad m => MuseParser m (String, Maybe (F Inlines)) linkText = do string "[[" - url <- many1Till anyChar $ char ']' + url <- manyTill anyChar $ char ']' content <- optionMaybe linkContent char ']' - return (url, "", content) + return (url, content) diff --git a/src/Text/Pandoc/Readers/Native.hs b/src/Text/Pandoc/Readers/Native.hs index 88f6bfe8f..ef200aa19 100644 --- a/src/Text/Pandoc/Readers/Native.hs +++ b/src/Text/Pandoc/Readers/Native.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {- Copyright (C) 2011-2018 John MacFarlane <jgm@berkeley.edu> @@ -30,6 +31,7 @@ Conversion of a string representation of a pandoc type (@Pandoc@, -} module Text.Pandoc.Readers.Native ( readNative ) where +import Prelude import Text.Pandoc.Definition import Text.Pandoc.Options (ReaderOptions) import Text.Pandoc.Shared (safeRead) diff --git a/src/Text/Pandoc/Readers/OPML.hs b/src/Text/Pandoc/Readers/OPML.hs index 82266748f..1a489ab94 100644 --- a/src/Text/Pandoc/Readers/OPML.hs +++ b/src/Text/Pandoc/Readers/OPML.hs @@ -1,5 +1,36 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoImplicitPrelude #-} +{- +Copyright (C) 2013-2018 John MacFarlane <jgm@berkeley.edu> + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- | + Module : Text.Pandoc.Readers.OPML + Copyright : Copyright (C) 2013-2018 John MacFarlane + License : GNU GPL, version 2 or above + + Maintainer : John MacFarlane <jgm@berkeley.edu> + Stability : alpha + Portability : portable + +Conversion of OPML to 'Pandoc' document. +-} + module Text.Pandoc.Readers.OPML ( readOPML ) where +import Prelude import Control.Monad.State.Strict import Data.Char (toUpper) import Data.Default diff --git a/src/Text/Pandoc/Readers/Odt.hs b/src/Text/Pandoc/Readers/Odt.hs index 875c18a85..30016e444 100644 --- a/src/Text/Pandoc/Readers/Odt.hs +++ b/src/Text/Pandoc/Readers/Odt.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE PatternGuards #-} {- @@ -32,6 +33,7 @@ Entry point to the odt reader. module Text.Pandoc.Readers.Odt ( readOdt ) where +import Prelude import Codec.Archive.Zip import qualified Text.XML.Light as XML diff --git a/src/Text/Pandoc/Readers/Odt/Arrows/State.hs b/src/Text/Pandoc/Readers/Odt/Arrows/State.hs index 73bed545e..971442613 100644 --- a/src/Text/Pandoc/Readers/Odt/Arrows/State.hs +++ b/src/Text/Pandoc/Readers/Odt/Arrows/State.hs @@ -1,4 +1,4 @@ - +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TupleSections #-} {- @@ -38,15 +38,13 @@ faster and easier to implement this way. module Text.Pandoc.Readers.Odt.Arrows.State where +import Prelude import Prelude hiding (foldl, foldr) import Control.Arrow import qualified Control.Category as Cat import Control.Monad -import Data.Foldable -import Data.Monoid - import Text.Pandoc.Readers.Odt.Arrows.Utils import Text.Pandoc.Readers.Odt.Generic.Fallible @@ -131,7 +129,7 @@ withSubStateF' unlift a = ArrowState go -- and one with any function. foldS :: (Foldable f, Monoid m) => ArrowState s x m -> ArrowState s (f x) m foldS a = ArrowState $ \(s,f) -> foldr a' (s,mempty) f - where a' x (s',m) = second (m <>) $ runArrowState a (s',x) + where a' x (s',m) = second (mappend m) $ runArrowState a (s',x) -- | Fold a state arrow through something 'Foldable'. Collect the results in a -- 'MonadPlus'. diff --git a/src/Text/Pandoc/Readers/Odt/Arrows/Utils.hs b/src/Text/Pandoc/Readers/Odt/Arrows/Utils.hs index ef8b2d18a..d3db3a9e2 100644 --- a/src/Text/Pandoc/Readers/Odt/Arrows/Utils.hs +++ b/src/Text/Pandoc/Readers/Odt/Arrows/Utils.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {- Copyright (C) 2015 Martin Linnemann <theCodingMarlin@googlemail.com> @@ -39,6 +40,7 @@ with an equivalent return value. -- We export everything module Text.Pandoc.Readers.Odt.Arrows.Utils where +import Prelude import Control.Arrow import Control.Monad (join) @@ -61,13 +63,13 @@ and6 :: (Arrow a) => a b c0->a b c1->a b c2->a b c3->a b c4->a b c5 -> a b (c0,c1,c2,c3,c4,c5 ) -and3 a b c = (and2 a b ) &&& c +and3 a b c = and2 a b &&& c >>^ \((z,y ) , x) -> (z,y,x ) -and4 a b c d = (and3 a b c ) &&& d +and4 a b c d = and3 a b c &&& d >>^ \((z,y,x ) , w) -> (z,y,x,w ) -and5 a b c d e = (and4 a b c d ) &&& e +and5 a b c d e = and4 a b c d &&& e >>^ \((z,y,x,w ) , v) -> (z,y,x,w,v ) -and6 a b c d e f = (and5 a b c d e ) &&& f +and6 a b c d e f = and5 a b c d e &&& f >>^ \((z,y,x,w,v ) , u) -> (z,y,x,w,v,u ) liftA2 :: (Arrow a) => (x -> y -> z) -> a b x -> a b y -> a b z diff --git a/src/Text/Pandoc/Readers/Odt/Base.hs b/src/Text/Pandoc/Readers/Odt/Base.hs index 51c2da788..5e731aefe 100644 --- a/src/Text/Pandoc/Readers/Odt/Base.hs +++ b/src/Text/Pandoc/Readers/Odt/Base.hs @@ -1,5 +1,3 @@ - - {- Copyright (C) 2015 Martin Linnemann <theCodingMarlin@googlemail.com> diff --git a/src/Text/Pandoc/Readers/Odt/ContentReader.hs b/src/Text/Pandoc/Readers/Odt/ContentReader.hs index 380f16c66..78881914d 100644 --- a/src/Text/Pandoc/Readers/Odt/ContentReader.hs +++ b/src/Text/Pandoc/Readers/Odt/ContentReader.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE Arrows #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RecordWildCards #-} @@ -39,6 +40,7 @@ module Text.Pandoc.Readers.Odt.ContentReader , read_body ) where +import Prelude import Control.Applicative hiding (liftA, liftA2, liftA3) import Control.Arrow @@ -520,7 +522,7 @@ matchingElement :: (Monoid e) matchingElement ns name reader = (ns, name, asResultAccumulator reader) where asResultAccumulator :: (ArrowChoice a, Monoid m) => a m m -> a m (Fallible m) - asResultAccumulator a = liftAsSuccess $ keepingTheValue a >>% (<>) + asResultAccumulator a = liftAsSuccess $ keepingTheValue a >>% mappend -- matchChildContent' :: (Monoid result) @@ -554,7 +556,7 @@ read_plain_text = fst ^&&& read_plain_text' >>% recover read_plain_text' = ( second ( arr extractText ) >>^ spreadChoice >>?! second text ) - >>?% (<>) + >>?% mappend -- extractText :: XML.Content -> Fallible String extractText (XML.Text cData) = succeedWith (XML.cdData cData) @@ -565,7 +567,7 @@ read_text_seq = matchingElement NsText "sequence" $ matchChildContent [] read_plain_text --- specifically. I honor that, although the current implementation of '(<>)' +-- specifically. I honor that, although the current implementation of 'mappend' -- for 'Inlines' in "Text.Pandoc.Builder" will collapse them again. -- The rational is to be prepared for future modifications. read_spaces :: InlineMatcher diff --git a/src/Text/Pandoc/Readers/Odt/Generic/Fallible.hs b/src/Text/Pandoc/Readers/Odt/Generic/Fallible.hs index f8ea5c605..1fb5b5477 100644 --- a/src/Text/Pandoc/Readers/Odt/Generic/Fallible.hs +++ b/src/Text/Pandoc/Readers/Odt/Generic/Fallible.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {- @@ -38,8 +39,7 @@ compatible instances of "ArrowChoice". -- We export everything module Text.Pandoc.Readers.Odt.Generic.Fallible where - -import Data.Monoid ((<>)) +import Prelude -- | Default for now. Will probably become a class at some point. type Failure = () @@ -90,7 +90,7 @@ collapseEither (Right (Right x)) = Right x -- (possibly combined) non-error. If both values represent an error, an error -- is returned. chooseMax :: (Monoid a, Monoid b) => Either a b -> Either a b -> Either a b -chooseMax = chooseMaxWith (<>) +chooseMax = chooseMaxWith mappend -- | If either of the values represents a non-error, the result is a -- (possibly combined) non-error. If both values represent an error, an error @@ -100,7 +100,7 @@ chooseMaxWith :: (Monoid a) => (b -> b -> b) -> Either a b -> Either a b chooseMaxWith (><) (Right a) (Right b) = Right $ a >< b -chooseMaxWith _ (Left a) (Left b) = Left $ a <> b +chooseMaxWith _ (Left a) (Left b) = Left $ a `mappend` b chooseMaxWith _ (Right a) _ = Right a chooseMaxWith _ _ (Right b) = Right b diff --git a/src/Text/Pandoc/Readers/Odt/Generic/Namespaces.hs b/src/Text/Pandoc/Readers/Odt/Generic/Namespaces.hs index 82ae3e20e..6d96897aa 100644 --- a/src/Text/Pandoc/Readers/Odt/Generic/Namespaces.hs +++ b/src/Text/Pandoc/Readers/Odt/Generic/Namespaces.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {- Copyright (C) 2015 Martin Linnemann <theCodingMarlin@googlemail.com> @@ -31,6 +32,7 @@ typesafe Haskell namespace identifiers and unsafe "real world" namespaces. module Text.Pandoc.Readers.Odt.Generic.Namespaces where +import Prelude import qualified Data.Map as M -- diff --git a/src/Text/Pandoc/Readers/Odt/Generic/SetMap.hs b/src/Text/Pandoc/Readers/Odt/Generic/SetMap.hs index afd7d616c..b0543b6d1 100644 --- a/src/Text/Pandoc/Readers/Odt/Generic/SetMap.hs +++ b/src/Text/Pandoc/Readers/Odt/Generic/SetMap.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {- Copyright (C) 2015 Martin Linnemann <theCodingMarlin@googlemail.com> @@ -30,6 +31,7 @@ A map of values to sets of values. module Text.Pandoc.Readers.Odt.Generic.SetMap where +import Prelude import qualified Data.Map as M import qualified Data.Set as S diff --git a/src/Text/Pandoc/Readers/Odt/Generic/Utils.hs b/src/Text/Pandoc/Readers/Odt/Generic/Utils.hs index 556517259..616d9290b 100644 --- a/src/Text/Pandoc/Readers/Odt/Generic/Utils.hs +++ b/src/Text/Pandoc/Readers/Odt/Generic/Utils.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TypeOperators #-} @@ -51,6 +52,7 @@ module Text.Pandoc.Readers.Odt.Generic.Utils , composition ) where +import Prelude import Control.Category (Category, (<<<), (>>>)) import qualified Control.Category as Cat (id) import Control.Monad (msum) diff --git a/src/Text/Pandoc/Readers/Odt/Generic/XMLConverter.hs b/src/Text/Pandoc/Readers/Odt/Generic/XMLConverter.hs index 428048427..81392e16b 100644 --- a/src/Text/Pandoc/Readers/Odt/Generic/XMLConverter.hs +++ b/src/Text/Pandoc/Readers/Odt/Generic/XMLConverter.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE Arrows #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE GADTs #-} @@ -67,6 +68,7 @@ module Text.Pandoc.Readers.Odt.Generic.XMLConverter , matchContent ) where +import Prelude import Control.Applicative hiding ( liftA, liftA2 ) import Control.Monad ( MonadPlus ) import Control.Arrow diff --git a/src/Text/Pandoc/Readers/Odt/Namespaces.hs b/src/Text/Pandoc/Readers/Odt/Namespaces.hs index 92e12931d..28865182f 100644 --- a/src/Text/Pandoc/Readers/Odt/Namespaces.hs +++ b/src/Text/Pandoc/Readers/Odt/Namespaces.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {- Copyright (C) 2015 Martin Linnemann <theCodingMarlin@googlemail.com> @@ -31,6 +32,7 @@ Namespaces used in odt files. module Text.Pandoc.Readers.Odt.Namespaces ( Namespace (..) ) where +import Prelude import Data.List (isPrefixOf) import qualified Data.Map as M (empty, insert) import Data.Maybe (fromMaybe, listToMaybe) diff --git a/src/Text/Pandoc/Readers/Odt/StyleReader.hs b/src/Text/Pandoc/Readers/Odt/StyleReader.hs index 58be8e4a3..e0444559b 100644 --- a/src/Text/Pandoc/Readers/Odt/StyleReader.hs +++ b/src/Text/Pandoc/Readers/Odt/StyleReader.hs @@ -1,5 +1,6 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE Arrows #-} - {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} @@ -57,6 +58,7 @@ module Text.Pandoc.Readers.Odt.StyleReader , readStylesAt ) where +import Prelude import Control.Applicative hiding (liftA, liftA2, liftA3) import Control.Arrow @@ -80,7 +82,6 @@ import Text.Pandoc.Readers.Odt.Generic.XMLConverter import Text.Pandoc.Readers.Odt.Base import Text.Pandoc.Readers.Odt.Namespaces - readStylesAt :: XML.Element -> Fallible Styles readStylesAt e = runConverter' readAllStyles mempty e @@ -183,13 +184,14 @@ data Styles = Styles deriving ( Show ) -- Styles from a monoid under union -instance Monoid Styles where - mempty = Styles M.empty M.empty M.empty - mappend (Styles sBn1 dSm1 lsBn1) - (Styles sBn2 dSm2 lsBn2) +instance Semigroup Styles where + (Styles sBn1 dSm1 lsBn1) <> (Styles sBn2 dSm2 lsBn2) = Styles (M.union sBn1 sBn2) (M.union dSm1 dSm2) (M.union lsBn1 lsBn2) +instance Monoid Styles where + mempty = Styles M.empty M.empty M.empty + mappend = (<>) -- Not all families from the specifications are implemented, only those we need. -- But there are none that are not mentioned here. diff --git a/src/Text/Pandoc/Readers/Org.hs b/src/Text/Pandoc/Readers/Org.hs index 292830bd2..75b99e079 100644 --- a/src/Text/Pandoc/Readers/Org.hs +++ b/src/Text/Pandoc/Readers/Org.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {- Copyright (C) 2014-2018 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> @@ -27,6 +28,7 @@ Conversion of org-mode formatted plain text to 'Pandoc' document. -} module Text.Pandoc.Readers.Org ( readOrg ) where +import Prelude import Text.Pandoc.Readers.Org.Blocks (blockList, meta) import Text.Pandoc.Readers.Org.ParserState (optionsToParserState) import Text.Pandoc.Readers.Org.Parsing (OrgParser, readWithM) diff --git a/src/Text/Pandoc/Readers/Org/BlockStarts.hs b/src/Text/Pandoc/Readers/Org/BlockStarts.hs index 424102cb0..5dbce01bd 100644 --- a/src/Text/Pandoc/Readers/Org/BlockStarts.hs +++ b/src/Text/Pandoc/Readers/Org/BlockStarts.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {- Copyright (C) 2014-2018 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> @@ -40,6 +41,7 @@ module Text.Pandoc.Readers.Org.BlockStarts , endOfBlock ) where +import Prelude import Control.Monad (void) import Text.Pandoc.Readers.Org.Parsing diff --git a/src/Text/Pandoc/Readers/Org/Blocks.hs b/src/Text/Pandoc/Readers/Org/Blocks.hs index fa016283c..888cd9307 100644 --- a/src/Text/Pandoc/Readers/Org/Blocks.hs +++ b/src/Text/Pandoc/Readers/Org/Blocks.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {- Copyright (C) 2014-2018 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> @@ -31,6 +32,7 @@ module Text.Pandoc.Readers.Org.Blocks , meta ) where +import Prelude import Text.Pandoc.Readers.Org.BlockStarts import Text.Pandoc.Readers.Org.DocumentTree (documentTree, headlineToBlocks) import Text.Pandoc.Readers.Org.Inlines @@ -51,7 +53,6 @@ import Data.Char (isSpace, toLower, toUpper) import Data.Default (Default) import Data.List (foldl', isPrefixOf) import Data.Maybe (fromMaybe, isJust, isNothing) -import Data.Monoid ((<>)) import qualified Text.Pandoc.Builder as B import qualified Text.Pandoc.Walk as Walk diff --git a/src/Text/Pandoc/Readers/Org/DocumentTree.hs b/src/Text/Pandoc/Readers/Org/DocumentTree.hs index f77778ec9..c9465581a 100644 --- a/src/Text/Pandoc/Readers/Org/DocumentTree.hs +++ b/src/Text/Pandoc/Readers/Org/DocumentTree.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {- Copyright (C) 2014-2018 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> @@ -32,11 +33,11 @@ module Text.Pandoc.Readers.Org.DocumentTree , headlineToBlocks ) where +import Prelude import Control.Arrow ((***)) import Control.Monad (guard, void) import Data.Char (toLower, toUpper) import Data.List (intersperse) -import Data.Monoid ((<>)) import Text.Pandoc.Builder (Blocks, Inlines) import Text.Pandoc.Class (PandocMonad) import Text.Pandoc.Definition diff --git a/src/Text/Pandoc/Readers/Org/ExportSettings.hs b/src/Text/Pandoc/Readers/Org/ExportSettings.hs index 6a70c50b9..d02eb37c5 100644 --- a/src/Text/Pandoc/Readers/Org/ExportSettings.hs +++ b/src/Text/Pandoc/Readers/Org/ExportSettings.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {- Copyright (C) 2016-2018 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> @@ -29,6 +30,7 @@ module Text.Pandoc.Readers.Org.ExportSettings ( exportSettings ) where +import Prelude import Text.Pandoc.Readers.Org.ParserState import Text.Pandoc.Readers.Org.Parsing diff --git a/src/Text/Pandoc/Readers/Org/Inlines.hs b/src/Text/Pandoc/Readers/Org/Inlines.hs index 3a12f38d0..7d1568b80 100644 --- a/src/Text/Pandoc/Readers/Org/Inlines.hs +++ b/src/Text/Pandoc/Readers/Org/Inlines.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {- Copyright (C) 2014-2018 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> @@ -33,6 +34,7 @@ module Text.Pandoc.Readers.Org.Inlines , linkTarget ) where +import Prelude import Text.Pandoc.Readers.Org.BlockStarts (endOfBlock, noteMarker) import Text.Pandoc.Readers.Org.ParserState import Text.Pandoc.Readers.Org.Parsing @@ -55,9 +57,6 @@ import Data.Char (isAlphaNum, isSpace) import Data.List (intersperse) import qualified Data.Map as M import Data.Maybe (fromMaybe) -import Data.Monoid ((<>)) -import Data.Traversable (sequence) -import Prelude hiding (sequence) -- -- Functions acting on the parser state diff --git a/src/Text/Pandoc/Readers/Org/Meta.hs b/src/Text/Pandoc/Readers/Org/Meta.hs index 6ad403fd8..965e33d94 100644 --- a/src/Text/Pandoc/Readers/Org/Meta.hs +++ b/src/Text/Pandoc/Readers/Org/Meta.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TupleSections #-} {- @@ -33,6 +34,7 @@ module Text.Pandoc.Readers.Org.Meta , metaLine ) where +import Prelude import Text.Pandoc.Readers.Org.BlockStarts import Text.Pandoc.Readers.Org.ExportSettings (exportSettings) import Text.Pandoc.Readers.Org.Inlines @@ -48,6 +50,7 @@ import Text.Pandoc.Shared (safeRead) import Control.Monad (mzero, void, when) import Data.Char (toLower) import Data.List (intersperse) +import Data.Maybe (fromMaybe) import qualified Data.Map as M import Network.HTTP (urlEncode) @@ -189,16 +192,12 @@ parseFormat = try $ replacePlain <|> replaceUrl <|> justAppend setEmphasisPreChar :: Maybe [Char] -> OrgParserState -> OrgParserState setEmphasisPreChar csMb st = - let preChars = case csMb of - Nothing -> orgStateEmphasisPreChars defaultOrgParserState - Just cs -> cs + let preChars = fromMaybe (orgStateEmphasisPostChars defaultOrgParserState) csMb in st { orgStateEmphasisPreChars = preChars } setEmphasisPostChar :: Maybe [Char] -> OrgParserState -> OrgParserState setEmphasisPostChar csMb st = - let postChars = case csMb of - Nothing -> orgStateEmphasisPostChars defaultOrgParserState - Just cs -> cs + let postChars = fromMaybe (orgStateEmphasisPostChars defaultOrgParserState) csMb in st { orgStateEmphasisPostChars = postChars } emphChars :: Monad m => OrgParser m (Maybe [Char]) diff --git a/src/Text/Pandoc/Readers/Org/ParserState.hs b/src/Text/Pandoc/Readers/Org/ParserState.hs index 6316766fa..4cb5bb626 100644 --- a/src/Text/Pandoc/Readers/Org/ParserState.hs +++ b/src/Text/Pandoc/Readers/Org/ParserState.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {- @@ -54,6 +55,7 @@ module Text.Pandoc.Readers.Org.ParserState , optionsToParserState ) where +import Prelude import Control.Monad.Reader (ReaderT, asks, local) import Data.Default (Default (..)) diff --git a/src/Text/Pandoc/Readers/Org/Parsing.hs b/src/Text/Pandoc/Readers/Org/Parsing.hs index 36420478b..e014de65e 100644 --- a/src/Text/Pandoc/Readers/Org/Parsing.hs +++ b/src/Text/Pandoc/Readers/Org/Parsing.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {- Copyright (C) 2014-2018 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> @@ -112,6 +113,7 @@ module Text.Pandoc.Readers.Org.Parsing , getPosition ) where +import Prelude import Text.Pandoc.Readers.Org.ParserState import Text.Pandoc.Parsing hiding (F, anyLine, blanklines, newline, diff --git a/src/Text/Pandoc/Readers/Org/Shared.hs b/src/Text/Pandoc/Readers/Org/Shared.hs index cba72cc07..07dbeca2a 100644 --- a/src/Text/Pandoc/Readers/Org/Shared.hs +++ b/src/Text/Pandoc/Readers/Org/Shared.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {- Copyright (C) 2014-2018 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> @@ -33,6 +34,7 @@ module Text.Pandoc.Readers.Org.Shared , translateLang ) where +import Prelude import Data.Char (isAlphaNum) import Data.List (isPrefixOf, isSuffixOf) diff --git a/src/Text/Pandoc/Readers/RST.hs b/src/Text/Pandoc/Readers/RST.hs index e88d997f0..71a38cf82 100644 --- a/src/Text/Pandoc/Readers/RST.hs +++ b/src/Text/Pandoc/Readers/RST.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -31,6 +32,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Conversion from reStructuredText to 'Pandoc' document. -} module Text.Pandoc.Readers.RST ( readRST ) where +import Prelude import Control.Arrow (second) import Control.Monad (forM_, guard, liftM, mplus, mzero, when) import Control.Monad.Except (throwError) @@ -40,7 +42,6 @@ import Data.List (deleteFirstsBy, elemIndex, intercalate, isInfixOf, isSuffixOf, nub, sort, transpose, union) import qualified Data.Map as M import Data.Maybe (fromMaybe, isJust) -import Data.Monoid ((<>)) import Data.Sequence (ViewR (..), viewr) import Data.Text (Text) import qualified Data.Text as T @@ -80,7 +81,7 @@ type RSTParser m = ParserT [Char] ParserState m --- bulletListMarkers :: [Char] -bulletListMarkers = "*+-" +bulletListMarkers = "*+-•‣⁃" underlineChars :: [Char] underlineChars = "!\"#$%&'()*+,-./:;<=>?@[\\]^_`{|}~" @@ -650,11 +651,15 @@ directive' = do skipMany spaceChar top <- many $ satisfy (/='\n') <|> try (char '\n' <* - notFollowedBy' (rawFieldListItem 3) <* - count 3 (char ' ') <* + notFollowedBy' (rawFieldListItem 1) <* + many1 (char ' ') <* notFollowedBy blankline) newline - fields <- many $ rawFieldListItem 3 + fields <- do + fieldIndent <- length <$> lookAhead (many (char ' ')) + if fieldIndent == 0 + then return [] + else many $ rawFieldListItem fieldIndent body <- option "" $ try $ blanklines >> indentedBlock optional blanklines let body' = body ++ "\n\n" @@ -1085,10 +1090,15 @@ targetURI :: Monad m => ParserT [Char] st m [Char] targetURI = do skipSpaces optional newline - contents <- many1 (try (many spaceChar >> newline >> - many1 spaceChar >> noneOf " \t\n") <|> noneOf "\n") + contents <- trim <$> + many1 (satisfy (/='\n') + <|> try (newline >> many1 spaceChar >> noneOf " \t\n")) blanklines - return $ escapeURI $ trim contents + case reverse contents of + -- strip backticks + '_':'`':xs -> return (dropWhile (=='`') (reverse xs) ++ "_") + '_':_ -> return contents + _ -> return (escapeURI contents) substKey :: PandocMonad m => RSTParser m () substKey = try $ do diff --git a/src/Text/Pandoc/Readers/TWiki.hs b/src/Text/Pandoc/Readers/TWiki.hs index 75e3f89eb..1f230ae7e 100644 --- a/src/Text/Pandoc/Readers/TWiki.hs +++ b/src/Text/Pandoc/Readers/TWiki.hs @@ -1,7 +1,7 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE RelaxedPolyRec #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RelaxedPolyRec #-} + -- RelaxedPolyRec needed for inlinesBetween on GHC < 7 {- Copyright (C) 2014 Alexander Sulfrian <alexander.sulfrian@fu-berlin.de> @@ -35,6 +35,7 @@ Conversion of twiki text to 'Pandoc' document. module Text.Pandoc.Readers.TWiki ( readTWiki ) where +import Prelude import Control.Monad import Control.Monad.Except (throwError) import Data.Char (isAlphaNum) diff --git a/src/Text/Pandoc/Readers/Textile.hs b/src/Text/Pandoc/Readers/Textile.hs index 30bb6a715..bc3bcaf26 100644 --- a/src/Text/Pandoc/Readers/Textile.hs +++ b/src/Text/Pandoc/Readers/Textile.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {- Copyright (C) 2010-2012 Paul Rivier <paul*rivier#demotera*com> | tr '*#' '.@' 2010-2018 John MacFarlane @@ -52,11 +53,11 @@ TODO : refactor common patterns across readers : module Text.Pandoc.Readers.Textile ( readTextile) where +import Prelude import Control.Monad (guard, liftM) import Control.Monad.Except (throwError) import Data.Char (digitToInt, isUpper) import Data.List (intercalate, intersperse, transpose) -import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as T import Text.HTML.TagSoup (Tag (..), fromAttrib) @@ -394,7 +395,7 @@ table = try $ do (toprow:rest) | any (fst . fst) toprow -> (toprow, rest) _ -> (mempty, rawrows) - let nbOfCols = max (length headers) (length $ head rows) + let nbOfCols = maximum $ map length (headers:rows) let aligns = map minimum $ transpose $ map (map (snd . fst)) (headers:rows) return $ B.table caption (zip aligns (replicate nbOfCols 0.0)) diff --git a/src/Text/Pandoc/Readers/TikiWiki.hs b/src/Text/Pandoc/Readers/TikiWiki.hs index a92f7bed2..5c7507248 100644 --- a/src/Text/Pandoc/Readers/TikiWiki.hs +++ b/src/Text/Pandoc/Readers/TikiWiki.hs @@ -1,13 +1,12 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RelaxedPolyRec #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RelaxedPolyRec #-} {- | Module : Text.Pandoc.Readers.TikiWiki Copyright : Copyright (C) 2017 Robin Lee Powell - License : GPLv2 + License : GNU GPL, version 2 or above Maintainer : Robin Lee Powell <robinleepowell@gmail.com> Stability : alpha @@ -19,6 +18,7 @@ Conversion of TikiWiki text to 'Pandoc' document. module Text.Pandoc.Readers.TikiWiki ( readTikiWiki ) where +import Prelude import Control.Monad import Control.Monad.Except (throwError) import qualified Data.Foldable as F diff --git a/src/Text/Pandoc/Readers/Txt2Tags.hs b/src/Text/Pandoc/Readers/Txt2Tags.hs index f4dda7a11..bed49fd46 100644 --- a/src/Text/Pandoc/Readers/Txt2Tags.hs +++ b/src/Text/Pandoc/Readers/Txt2Tags.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {- Copyright (C) 2014 Matthew Pickering <matthewtpickering@gmail.com> @@ -31,6 +32,7 @@ module Text.Pandoc.Readers.Txt2Tags ( readTxt2Tags ) where +import Prelude import Control.Monad (guard, void, when) import Control.Monad.Except (catchError, throwError) import Control.Monad.Reader (Reader, asks, runReader) @@ -38,7 +40,6 @@ import Data.Char (toLower) import Data.Default import Data.List (intercalate, transpose) import Data.Maybe (fromMaybe) -import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as T import Data.Time.Format (formatTime) @@ -46,7 +47,7 @@ import Text.Pandoc.Builder (Blocks, Inlines, trimInlines) import qualified Text.Pandoc.Builder as B import Text.Pandoc.Class (PandocMonad) import qualified Text.Pandoc.Class as P -import Text.Pandoc.Compat.Time (defaultTimeLocale) +import Data.Time (defaultTimeLocale) import Text.Pandoc.Definition import Text.Pandoc.Options import Text.Pandoc.Parsing hiding (space, spaces, uri) @@ -444,7 +445,7 @@ inlineMarkup p f c special = try $ do let end' = case drop 2 end of "" -> mempty xs -> special xs - return $ f (start' <> body' <> end') + return $ f (start' `mappend` body' `mappend` end') Nothing -> do -- Either bad or case such as ***** guard (l >= 5) let body' = replicate (l - 4) c diff --git a/src/Text/Pandoc/Readers/Vimwiki.hs b/src/Text/Pandoc/Readers/Vimwiki.hs index d717a1ba8..824a912c3 100644 --- a/src/Text/Pandoc/Readers/Vimwiki.hs +++ b/src/Text/Pandoc/Readers/Vimwiki.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE CPP #-} {- Copyright (C) 2017-2018 Yuchen Pei <me@ypei.me> @@ -63,12 +65,12 @@ Conversion of vimwiki text to 'Pandoc' document. module Text.Pandoc.Readers.Vimwiki ( readVimwiki ) where +import Prelude import Control.Monad (guard) import Control.Monad.Except (throwError) import Data.Default import Data.List (isInfixOf, isPrefixOf) import Data.Maybe -import Data.Monoid ((<>)) import Data.Text (Text, unpack) import Text.Pandoc.Builder (Blocks, Inlines, fromList, toList, trimInlines) import qualified Text.Pandoc.Builder as B (blockQuote, bulletList, code, diff --git a/src/Text/Pandoc/SelfContained.hs b/src/Text/Pandoc/SelfContained.hs index a1c5c919e..2aab015c2 100644 --- a/src/Text/Pandoc/SelfContained.hs +++ b/src/Text/Pandoc/SelfContained.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {- Copyright (C) 2011-2018 John MacFarlane <jgm@berkeley.edu> @@ -31,6 +32,7 @@ offline, by incorporating linked images, CSS, and scripts into the HTML using data URIs. -} module Text.Pandoc.SelfContained ( makeDataURI, makeSelfContained ) where +import Prelude import Codec.Compression.GZip as Gzip import Control.Applicative ((<|>)) import Control.Monad.Except (throwError) @@ -41,7 +43,6 @@ import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy as L import Data.Char (isAlphaNum, isAscii, toLower) import Data.List (isPrefixOf) -import Data.Monoid ((<>)) import Network.URI (escapeURIString) import System.FilePath (takeDirectory, takeExtension, (</>)) import Text.HTML.TagSoup diff --git a/src/Text/Pandoc/Shared.hs b/src/Text/Pandoc/Shared.hs index 52e1447db..26b01bc90 100644 --- a/src/Text/Pandoc/Shared.hs +++ b/src/Text/Pandoc/Shared.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} @@ -83,6 +84,7 @@ module Text.Pandoc.Shared ( -- * File handling inDirectory, collapseFilePath, + uriPathToPath, filteredFilesFromArchive, -- * URI handling schemes, @@ -100,6 +102,7 @@ module Text.Pandoc.Shared ( pandocVersion ) where +import Prelude import Codec.Archive.Zip import qualified Control.Exception as E import Control.Monad (MonadPlus (..), msum, unless) @@ -111,7 +114,6 @@ import Data.Data (Data, Typeable) import Data.List (find, intercalate, intersperse, stripPrefix) import qualified Data.Map as M import Data.Maybe (mapMaybe) -import Data.Monoid ((<>)) import Data.Sequence (ViewL (..), ViewR (..), viewl, viewr) import qualified Data.Set as Set import qualified Data.Text as T @@ -126,7 +128,7 @@ import Text.HTML.TagSoup (RenderOptions (..), Tag (..), renderOptions, renderTagsOptions) import Text.Pandoc.Builder (Blocks, Inlines, ToMetaValue (..)) import qualified Text.Pandoc.Builder as B -import Text.Pandoc.Compat.Time +import Data.Time import Text.Pandoc.Definition import Text.Pandoc.Generic (bottomUp) import Text.Pandoc.Pretty (charWidth) @@ -286,12 +288,7 @@ normalizeDate s = fmap (formatTime defaultTimeLocale "%F") where rejectBadYear day = case toGregorian day of (y, _, _) | y >= 1601 && y <= 9999 -> Just day _ -> Nothing - parsetimeWith = -#if MIN_VERSION_time(1,5,0) - parseTimeM True defaultTimeLocale -#else - parseTime defaultTimeLocale -#endif + parsetimeWith = parseTimeM True defaultTimeLocale formats = ["%x","%m/%d/%Y", "%D","%F", "%d %b %Y", "%e %B %Y", "%b. %e, %Y", "%B %e, %Y", "%Y%m%d", "%Y%m", "%Y"] @@ -447,7 +444,7 @@ instance Walkable Inline Element where elts' <- walkM f elts return $ Sec lev nums attr ils' elts' query f (Blk x) = query f x - query f (Sec _ _ _ ils elts) = query f ils <> query f elts + query f (Sec _ _ _ ils elts) = query f ils `mappend` query f elts instance Walkable Block Element where walk f (Blk x) = Blk (walk f x) @@ -458,7 +455,7 @@ instance Walkable Block Element where elts' <- walkM f elts return $ Sec lev nums attr ils' elts' query f (Blk x) = query f x - query f (Sec _ _ _ ils elts) = query f ils <> query f elts + query f (Sec _ _ _ ils elts) = query f ils `mappend` query f elts -- | Convert Pandoc inline list to plain text identifier. HTML @@ -639,6 +636,19 @@ collapseFilePath = Posix.joinPath . reverse . foldl go [] . splitDirectories isSingleton _ = Nothing checkPathSeperator = fmap isPathSeparator . isSingleton +-- Convert the path part of a file: URI to a regular path. +-- On windows, @/c:/foo@ should be @c:/foo@. +-- On linux, @/foo@ should be @/foo@. +uriPathToPath :: String -> FilePath +uriPathToPath path = +#ifdef _WINDOWS + case path of + '/':ps -> ps + ps -> ps +#else + path +#endif + -- -- File selection from the archive -- diff --git a/src/Text/Pandoc/Slides.hs b/src/Text/Pandoc/Slides.hs index 9d63555c2..2f7d83527 100644 --- a/src/Text/Pandoc/Slides.hs +++ b/src/Text/Pandoc/Slides.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {- Copyright (C) 2012-2018 John MacFarlane <jgm@berkeley.edu> @@ -29,6 +30,7 @@ Utility functions for splitting documents into slides for slide show formats (dzslides, revealjs, s5, slidy, slideous, beamer). -} module Text.Pandoc.Slides ( getSlideLevel, prepSlides ) where +import Prelude import Text.Pandoc.Definition -- | Find level of header that starts slides (defined as the least header diff --git a/src/Text/Pandoc/Templates.hs b/src/Text/Pandoc/Templates.hs index 4be0d081c..80e2b1fa4 100644 --- a/src/Text/Pandoc/Templates.hs +++ b/src/Text/Pandoc/Templates.hs @@ -1,7 +1,4 @@ -{-# LANGUAGE FlexibleInstances #-} - -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE OverloadedStrings #-} {- Copyright (C) 2009-2018 John MacFarlane <jgm@berkeley.edu> @@ -38,6 +35,7 @@ module Text.Pandoc.Templates ( module Text.DocTemplates , getDefaultTemplate ) where +import Prelude import Control.Monad.Except (throwError) import Data.Aeson (ToJSON (..)) import qualified Data.Text as T diff --git a/src/Text/Pandoc/Translations.hs b/src/Text/Pandoc/Translations.hs index 949618178..4a216af92 100644 --- a/src/Text/Pandoc/Translations.hs +++ b/src/Text/Pandoc/Translations.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {- @@ -45,6 +47,7 @@ module Text.Pandoc.Translations ( , readTranslations ) where +import Prelude import Data.Aeson.Types (typeMismatch) import qualified Data.HashMap.Strict as HM import qualified Data.Map as M @@ -80,7 +83,7 @@ data Term = deriving (Show, Eq, Ord, Generic, Enum, Read) newtype Translations = Translations (M.Map Term String) - deriving (Show, Generic, Monoid) + deriving (Show, Generic, Semigroup, Monoid) instance FromJSON Term where parseJSON (String t) = case safeRead (T.unpack t) of diff --git a/src/Text/Pandoc/UTF8.hs b/src/Text/Pandoc/UTF8.hs index 3f759958f..2bfda1ee8 100644 --- a/src/Text/Pandoc/UTF8.hs +++ b/src/Text/Pandoc/UTF8.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {- Copyright (C) 2010-2018 John MacFarlane <jgm@berkeley.edu> diff --git a/src/Text/Pandoc/UUID.hs b/src/Text/Pandoc/UUID.hs index 4d99324db..c1bae7038 100644 --- a/src/Text/Pandoc/UUID.hs +++ b/src/Text/Pandoc/UUID.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {- Copyright (C) 2010-2018 John MacFarlane <jgm@berkeley.edu> @@ -31,6 +32,7 @@ in RFC4122. See http://tools.ietf.org/html/rfc4122 module Text.Pandoc.UUID ( UUID(..), getRandomUUID, getUUID ) where +import Prelude import Data.Bits (clearBit, setBit) import Data.Word import System.Random (RandomGen, getStdGen, randoms) diff --git a/src/Text/Pandoc/Writers.hs b/src/Text/Pandoc/Writers.hs index 596a8680e..5d4a9122a 100644 --- a/src/Text/Pandoc/Writers.hs +++ b/src/Text/Pandoc/Writers.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {- Copyright (C) 2006-2018 John MacFarlane <jgm@berkeley.edu> @@ -82,6 +83,7 @@ module Text.Pandoc.Writers , getWriter ) where +import Prelude import Data.Aeson import qualified Data.ByteString.Lazy as BL import Data.List (intercalate) diff --git a/src/Text/Pandoc/Writers/AsciiDoc.hs b/src/Text/Pandoc/Writers/AsciiDoc.hs index f91fa8fa0..036185282 100644 --- a/src/Text/Pandoc/Writers/AsciiDoc.hs +++ b/src/Text/Pandoc/Writers/AsciiDoc.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {- Copyright (C) 2006-2018 John MacFarlane <jgm@berkeley.edu> @@ -37,6 +38,7 @@ that it has omitted the construct. AsciiDoc: <http://www.methods.co.nz/asciidoc/> -} module Text.Pandoc.Writers.AsciiDoc (writeAsciiDoc) where +import Prelude import Control.Monad.State.Strict import Data.Aeson (Result (..), Value (String), fromJSON, toJSON) import Data.Char (isPunctuation, isSpace) diff --git a/src/Text/Pandoc/Writers/CommonMark.hs b/src/Text/Pandoc/Writers/CommonMark.hs index 7a6eb2948..98c1101fa 100644 --- a/src/Text/Pandoc/Writers/CommonMark.hs +++ b/src/Text/Pandoc/Writers/CommonMark.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {- Copyright (C) 2015-2018 John MacFarlane <jgm@berkeley.edu> @@ -32,11 +33,12 @@ CommonMark: <http://commonmark.org> -} module Text.Pandoc.Writers.CommonMark (writeCommonMark) where +import Prelude import CMarkGFM import Control.Monad.State.Strict (State, get, modify, runState) import Data.Foldable (foldrM) import Data.List (transpose) -import Data.Monoid (Any (..), (<>)) +import Data.Monoid (Any (..)) import Data.Text (Text) import qualified Data.Text as T import Network.HTTP (urlEncode) @@ -114,7 +116,7 @@ blockToNodes _ (CodeBlock (_,classes,_) xs) ns = return blockToNodes opts (RawBlock fmt xs) ns | fmt == Format "html" && isEnabled Ext_raw_html opts = return (node (HTML_BLOCK (T.pack xs)) [] : ns) - | fmt == Format "latex" || fmt == Format "tex" && isEnabled Ext_raw_tex opts + | (fmt == Format "latex" || fmt == Format "tex") && isEnabled Ext_raw_tex opts = return (node (CUSTOM_BLOCK (T.pack xs) T.empty) [] : ns) | otherwise = return ns blockToNodes opts (BlockQuote bs) ns = do diff --git a/src/Text/Pandoc/Writers/ConTeXt.hs b/src/Text/Pandoc/Writers/ConTeXt.hs index f94c12d89..10e996bdb 100644 --- a/src/Text/Pandoc/Writers/ConTeXt.hs +++ b/src/Text/Pandoc/Writers/ConTeXt.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {- @@ -30,6 +31,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Conversion of 'Pandoc' format into ConTeXt. -} module Text.Pandoc.Writers.ConTeXt ( writeConTeXt ) where +import Prelude import Control.Monad.State.Strict import Data.Char (ord, isDigit) import Data.List (intercalate, intersperse) diff --git a/src/Text/Pandoc/Writers/Custom.hs b/src/Text/Pandoc/Writers/Custom.hs index 37b44b646..53b321c7c 100644 --- a/src/Text/Pandoc/Writers/Custom.hs +++ b/src/Text/Pandoc/Writers/Custom.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {- Copyright (C) 2012-2018 John MacFarlane <jgm@berkeley.edu> @@ -30,6 +31,7 @@ Conversion of 'Pandoc' documents to custom markup using a lua writer. -} module Text.Pandoc.Writers.Custom ( writeCustom ) where +import Prelude import Control.Arrow ((***)) import Control.Exception import Control.Monad (when) @@ -44,7 +46,7 @@ import Foreign.Lua.Api import Text.Pandoc.Class (PandocIO) import Text.Pandoc.Definition import Text.Pandoc.Error -import Text.Pandoc.Lua.Init (runPandocLua) +import Text.Pandoc.Lua.Init (runPandocLua, registerScriptPath) import Text.Pandoc.Lua.StackInstances () import Text.Pandoc.Lua.Util (addValue, dostring') import Text.Pandoc.Options @@ -106,6 +108,7 @@ writeCustom :: FilePath -> WriterOptions -> Pandoc -> PandocIO Text writeCustom luaFile opts doc@(Pandoc meta _) = do luaScript <- liftIO $ UTF8.readFile luaFile res <- runPandocLua $ do + registerScriptPath luaFile stat <- dostring' luaScript -- check for error in lua script (later we'll change the return type -- to handle this more gracefully): diff --git a/src/Text/Pandoc/Writers/Docbook.hs b/src/Text/Pandoc/Writers/Docbook.hs index 3034fade5..f6e814095 100644 --- a/src/Text/Pandoc/Writers/Docbook.hs +++ b/src/Text/Pandoc/Writers/Docbook.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {- @@ -30,6 +31,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Conversion of 'Pandoc' documents to Docbook XML. -} module Text.Pandoc.Writers.Docbook ( writeDocbook4, writeDocbook5 ) where +import Prelude import Control.Monad.Reader import Data.Char (toLower) import Data.Generics (everywhere, mkT) diff --git a/src/Text/Pandoc/Writers/Docx.hs b/src/Text/Pandoc/Writers/Docx.hs index 5ad6bf82b..1666c0562 100644 --- a/src/Text/Pandoc/Writers/Docx.hs +++ b/src/Text/Pandoc/Writers/Docx.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -32,6 +33,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Conversion of 'Pandoc' documents to docx. -} module Text.Pandoc.Writers.Docx ( writeDocx ) where +import Prelude import Codec.Archive.Zip import Control.Applicative ((<|>)) import Control.Monad.Except (catchError) @@ -51,7 +53,7 @@ import System.Random (randomR, StdGen, mkStdGen) import Text.Pandoc.BCP47 (getLang, renderLang) import Text.Pandoc.Class (PandocMonad, report, toLang) import qualified Text.Pandoc.Class as P -import Text.Pandoc.Compat.Time +import Data.Time import Text.Pandoc.Definition import Text.Pandoc.Generic import Text.Pandoc.Highlighting (highlight) @@ -123,7 +125,7 @@ data WriterState = WriterState{ , stComments :: [([(String,String)], [Inline])] , stSectionIds :: Set.Set String , stExternalLinks :: M.Map String String - , stImages :: M.Map FilePath (String, String, Maybe MimeType, Element, B.ByteString) + , stImages :: M.Map FilePath (String, String, Maybe MimeType, B.ByteString) , stLists :: [ListMarker] , stInsId :: Int , stDelId :: Int @@ -294,7 +296,7 @@ writeDocx opts doc@(Pandoc meta _) = do let imgs = M.elems $ stImages st -- create entries for images in word/media/... - let toImageEntry (_,path,_,_,img) = toEntry ("word/" ++ path) epochtime $ toLazy img + let toImageEntry (_,path,_,img) = toEntry ("word/" ++ path) epochtime $ toLazy img let imageEntries = map toImageEntry imgs let stdAttributes = @@ -326,7 +328,7 @@ writeDocx opts doc@(Pandoc meta _) = do -- [Content_Types].xml let mkOverrideNode (part', contentType') = mknode "Override" [("PartName",part'),("ContentType",contentType')] () - let mkImageOverride (_, imgpath, mbMimeType, _, _) = + let mkImageOverride (_, imgpath, mbMimeType, _) = mkOverrideNode ("/word/" ++ imgpath, fromMaybe "application/octet-stream" mbMimeType) let mkMediaOverride imgpath = @@ -407,7 +409,7 @@ writeDocx opts doc@(Pandoc meta _) = do 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",ident),("Target",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 @@ -708,12 +710,12 @@ mkLvl marker lvl = styleFor UpperRoman _ = "upperRoman" styleFor LowerRoman _ = "lowerRoman" styleFor Decimal _ = "decimal" - styleFor DefaultStyle 1 = "decimal" - styleFor DefaultStyle 2 = "lowerLetter" - styleFor DefaultStyle 3 = "lowerRoman" - styleFor DefaultStyle 4 = "decimal" - styleFor DefaultStyle 5 = "lowerLetter" - styleFor DefaultStyle 0 = "lowerRoman" + styleFor DefaultStyle 0 = "decimal" + styleFor DefaultStyle 1 = "lowerLetter" + styleFor DefaultStyle 2 = "lowerRoman" + styleFor DefaultStyle 3 = "decimal" + styleFor DefaultStyle 4 = "lowerLetter" + styleFor DefaultStyle 5 = "lowerRoman" styleFor DefaultStyle x = styleFor DefaultStyle (x `mod` 6) styleFor _ _ = "decimal" patternFor OneParen s = s ++ ")" @@ -1109,6 +1111,9 @@ inlineToOpenXML' _ (Str str) = formattedString str inlineToOpenXML' opts Space = inlineToOpenXML opts (Str " ") inlineToOpenXML' opts SoftBreak = inlineToOpenXML opts (Str " ") +inlineToOpenXML' opts (Span (_,["underline"],_) ils) = do + withTextProp (mknode "w:u" [("w:val","single")] ()) $ + inlinesToOpenXML opts ils inlineToOpenXML' _ (Span (ident,["comment-start"],kvs) ils) = do -- prefer the "id" in kvs, since that is the one produced by the docx -- reader. @@ -1275,87 +1280,103 @@ inlineToOpenXML' opts (Link _ txt (src,_)) = do return i return [ mknode "w:hyperlink" [("r:id",id')] contents ] inlineToOpenXML' opts (Image attr alt (src, title)) = do - -- first, check to see if we've already done this image pageWidth <- asks envPrintWidth imgs <- gets stImages - case M.lookup src imgs of - Just (_,_,_,elt,_) -> return [elt] - Nothing -> - catchError - (do (img, mt) <- P.fetchItem src - ident <- ("rId"++) `fmap` getUniqueId - let (xpt,ypt) = desiredSizeInPoints opts attr - (either (const def) id (imageSize opts img)) - -- 12700 emu = 1 pt - let (xemu,yemu) = fitToPage (xpt * 12700, ypt * 12700) - (pageWidth * 12700) - let cNvPicPr = mknode "pic:cNvPicPr" [] $ - mknode "a:picLocks" [("noChangeArrowheads","1") - ,("noChangeAspect","1")] () - let nvPicPr = mknode "pic:nvPicPr" [] - [ mknode "pic:cNvPr" - [("descr",src),("id","0"),("name","Picture")] () - , cNvPicPr ] - let blipFill = mknode "pic:blipFill" [] - [ mknode "a:blip" [("r:embed",ident)] () - , mknode "a:stretch" [] $ - mknode "a:fillRect" [] () ] - let xfrm = mknode "a:xfrm" [] - [ mknode "a:off" [("x","0"),("y","0")] () - , mknode "a:ext" [("cx",show xemu) - ,("cy",show yemu)] () ] - let prstGeom = mknode "a:prstGeom" [("prst","rect")] $ - mknode "a:avLst" [] () - let ln = mknode "a:ln" [("w","9525")] - [ mknode "a:noFill" [] () - , mknode "a:headEnd" [] () - , mknode "a:tailEnd" [] () ] - let spPr = mknode "pic:spPr" [("bwMode","auto")] - [xfrm, prstGeom, mknode "a:noFill" [] (), ln] - let graphic = mknode "a:graphic" [] $ - mknode "a:graphicData" - [("uri","http://schemas.openxmlformats.org/drawingml/2006/picture")] - [ mknode "pic:pic" [] - [ nvPicPr - , blipFill - , spPr ] ] - let imgElt = mknode "w:r" [] $ - mknode "w:drawing" [] $ - mknode "wp:inline" [] - [ mknode "wp:extent" [("cx",show xemu),("cy",show yemu)] () - , mknode "wp:effectExtent" - [("b","0"),("l","0"),("r","0"),("t","0")] () - , mknode "wp:docPr" [("descr",stringify alt) - ,("title", title) - ,("id","1") - ,("name","Picture")] () - , graphic ] - let imgext = case mt >>= extensionFromMimeType of - Just x -> '.':x - Nothing -> case imageType img of - Just Png -> ".png" - Just Jpeg -> ".jpeg" - Just Gif -> ".gif" - Just Pdf -> ".pdf" - Just Eps -> ".eps" - Just Svg -> ".svg" - Just Emf -> ".emf" - Nothing -> "" - if null imgext - then -- without an extension there is no rule for content type - inlinesToOpenXML opts alt -- return alt to avoid corrupted docx - else do - let imgpath = "media/" ++ ident ++ imgext - let mbMimeType = mt <|> getMimeType imgpath - -- insert mime type to use in constructing [Content_Types].xml - modify $ \st -> st{ stImages = - M.insert src (ident, imgpath, mbMimeType, imgElt, img) - $ stImages st } - return [imgElt]) - (\e -> do - report $ CouldNotFetchResource src (show e) - -- emit alt text - inlinesToOpenXML opts alt) + let + stImage = M.lookup src imgs + generateImgElt (ident, _, _, img) = + let + (xpt,ypt) = desiredSizeInPoints opts attr + (either (const def) id (imageSize opts img)) + -- 12700 emu = 1 pt + (xemu,yemu) = fitToPage (xpt * 12700, ypt * 12700) + (pageWidth * 12700) + cNvPicPr = mknode "pic:cNvPicPr" [] $ + mknode "a:picLocks" [("noChangeArrowheads","1") + ,("noChangeAspect","1")] () + nvPicPr = mknode "pic:nvPicPr" [] + [ mknode "pic:cNvPr" + [("descr",src),("id","0"),("name","Picture")] () + , cNvPicPr ] + blipFill = mknode "pic:blipFill" [] + [ mknode "a:blip" [("r:embed",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)] () ] + prstGeom = mknode "a:prstGeom" [("prst","rect")] $ + mknode "a:avLst" [] () + ln = mknode "a:ln" [("w","9525")] + [ mknode "a:noFill" [] () + , mknode "a:headEnd" [] () + , mknode "a:tailEnd" [] () ] + spPr = mknode "pic:spPr" [("bwMode","auto")] + [xfrm, prstGeom, mknode "a:noFill" [] (), ln] + graphic = mknode "a:graphic" [] $ + mknode "a:graphicData" + [("uri","http://schemas.openxmlformats.org/drawingml/2006/picture")] + [ mknode "pic:pic" [] + [ nvPicPr + , blipFill + , spPr + ] + ] + imgElt = mknode "w:r" [] $ + mknode "w:drawing" [] $ + mknode "wp:inline" [] + [ mknode "wp:extent" [("cx",show xemu),("cy",show yemu)] () + , mknode "wp:effectExtent" + [("b","0"),("l","0"),("r","0"),("t","0")] () + , mknode "wp:docPr" + [ ("descr", stringify alt) + , ("title", title) + , ("id","1") + , ("name","Picture") + ] () + , graphic + ] + in + imgElt + + case stImage of + Just imgData -> return [generateImgElt imgData] + Nothing -> ( do --try + (img, mt) <- P.fetchItem src + ident <- ("rId"++) `fmap` getUniqueId + + let + imgext = case mt >>= extensionFromMimeType of + Just x -> '.':x + Nothing -> case imageType img of + Just Png -> ".png" + Just Jpeg -> ".jpeg" + Just Gif -> ".gif" + Just Pdf -> ".pdf" + Just Eps -> ".eps" + Just Svg -> ".svg" + Just Emf -> ".emf" + Nothing -> "" + imgpath = "media/" ++ ident ++ imgext + mbMimeType = mt <|> getMimeType imgpath + + imgData = (ident, imgpath, mbMimeType, img) + + if null imgext + then -- without an extension there is no rule for content type + inlinesToOpenXML opts alt -- return alt to avoid corrupted docx + else do + -- insert mime type to use in constructing [Content_Types].xml + modify $ \st -> st { stImages = M.insert src imgData $ stImages st } + return [generateImgElt imgData] + ) + `catchError` ( \e -> do + report $ CouldNotFetchResource src (show e) + -- emit alt text + inlinesToOpenXML opts alt + ) br :: Element br = breakElement "textWrapping" @@ -1370,12 +1391,12 @@ breakElement kind = mknode "w:r" [] [mknode "w:br" [("w:type",kind)] () ] defaultFootnotes :: [Element] defaultFootnotes = [ mknode "w:footnote" [("w:type", "separator"), ("w:id", "-1")] - [ mknode "w:p" [] $ + [ mknode "w:p" [] [mknode "w:r" [] $ [ mknode "w:separator" [] ()]]] , mknode "w:footnote" [("w:type", "continuationSeparator"), ("w:id", "0")] - [ mknode "w:p" [] $ + [ mknode "w:p" [] [ mknode "w:r" [] $ [ mknode "w:continuationSeparator" [] ()]]]] diff --git a/src/Text/Pandoc/Writers/DokuWiki.hs b/src/Text/Pandoc/Writers/DokuWiki.hs index dda21d23d..189bf138e 100644 --- a/src/Text/Pandoc/Writers/DokuWiki.hs +++ b/src/Text/Pandoc/Writers/DokuWiki.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {- Copyright (C) 2008-2018 John MacFarlane <jgm@berkeley.edu> @@ -39,6 +40,7 @@ DokuWiki: <https://www.dokuwiki.org/dokuwiki> -} module Text.Pandoc.Writers.DokuWiki ( writeDokuWiki ) where +import Prelude import Control.Monad (zipWithM) import Control.Monad.Reader (ReaderT, ask, local, runReaderT) import Control.Monad.State.Strict (StateT, evalStateT) @@ -366,12 +368,16 @@ isSimpleBlockQuote bs = all isPlainOrPara bs vcat :: [String] -> String vcat = intercalate "\n" -backSlashLineBreaks :: String -> String -backSlashLineBreaks cs = reverse $ g $ reverse $ concatMap f cs - where f '\n' = "\\\\ " - f c = [c] - g (' ' : '\\':'\\': xs) = xs - g s = s +-- | For each string in the input list, convert all newlines to +-- dokuwiki escaped newlines. Then concat the list using double linebreaks. +backSlashLineBreaks :: [String] -> String +backSlashLineBreaks ls = vcatBackSlash $ map escape ls + where + vcatBackSlash = intercalate "\\\\ \\\\ " -- simulate paragraphs. + escape ['\n'] = "" -- remove trailing newlines + escape ('\n':cs) = "\\\\ " ++ escape cs + escape (c:cs) = c : escape cs + escape [] = [] -- Auxiliary functions for tables: @@ -400,7 +406,7 @@ blockListToDokuWiki opts blocks = do backSlash <- stBackSlashLB <$> ask let blocks' = consolidateRawBlocks blocks if backSlash - then (backSlashLineBreaks . vcat) <$> mapM (blockToDokuWiki opts) blocks' + then backSlashLineBreaks <$> mapM (blockToDokuWiki opts) blocks' else vcat <$> mapM (blockToDokuWiki opts) blocks' consolidateRawBlocks :: [Block] -> [Block] @@ -479,7 +485,11 @@ inlineToDokuWiki _ il@(RawInline f str) | f == Format "html" = return $ "<html>" ++ str ++ "</html>" | otherwise = "" <$ report (InlineNotRendered il) -inlineToDokuWiki _ LineBreak = return "\\\\\n" +inlineToDokuWiki _ LineBreak = do + backSlash <- stBackSlashLB <$> ask + return $ if backSlash + then "\n" + else "\\\\\n" inlineToDokuWiki opts SoftBreak = case writerWrapText opts of diff --git a/src/Text/Pandoc/Writers/EPUB.hs b/src/Text/Pandoc/Writers/EPUB.hs index 7b4853a24..f1ff8b482 100644 --- a/src/Text/Pandoc/Writers/EPUB.hs +++ b/src/Text/Pandoc/Writers/EPUB.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE PatternGuards #-} @@ -32,6 +33,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Conversion of 'Pandoc' documents to EPUB. -} module Text.Pandoc.Writers.EPUB ( writeEPUB2, writeEPUB3 ) where +import Prelude import Codec.Archive.Zip (Entry, addEntryToArchive, eRelativePath, emptyArchive, fromArchive, fromEntry, toEntry) import Control.Monad (mplus, unless, when, zipWithM) @@ -53,7 +55,7 @@ import Text.HTML.TagSoup (Tag (TagOpen), fromAttrib, parseTags) import Text.Pandoc.Builder (fromList, setMeta) import Text.Pandoc.Class (PandocMonad, report) import qualified Text.Pandoc.Class as P -import Text.Pandoc.Compat.Time +import Data.Time import Text.Pandoc.Definition import Text.Pandoc.Error import Text.Pandoc.Logging @@ -401,6 +403,12 @@ pandocToEPUB version opts doc@(Pandoc meta _) = do writeHtmlStringForEPUB version o metadata <- getEPUBMetadata opts meta + let plainTitle = case docTitle' meta of + [] -> case epubTitle metadata of + [] -> "UNTITLED" + (x:_) -> titleText x + x -> stringify x + -- stylesheet stylesheets <- case epubStylesheets metadata of [] -> (\x -> [B.fromChunks [x]]) <$> @@ -438,6 +446,7 @@ pandocToEPUB version opts doc@(Pandoc meta _) = do cpContent <- lift $ writeHtml opts'{ writerVariables = ("coverpage","true"): + ("pagetitle",plainTitle): cssvars True ++ vars } (Pandoc meta [RawBlock (Format "html") $ "<div id=\"cover-image\">\n<img src=\"../media/" ++ coverImage ++ "\" alt=\"cover image\" />\n</div>"]) imgContent <- lift $ P.readFileLazy img @@ -450,6 +459,7 @@ pandocToEPUB version opts doc@(Pandoc meta _) = do -- title page tpContent <- lift $ writeHtml opts'{ writerVariables = ("titlepage","true"): + ("pagetitle",plainTitle): cssvars True ++ vars } (Pandoc meta []) tpEntry <- mkEntry "text/title_page.xhtml" tpContent @@ -458,7 +468,7 @@ pandocToEPUB version opts doc@(Pandoc meta _) = do -- mediaRef <- P.newIORef [] Pandoc _ blocks <- walkM (transformInline opts') doc >>= walkM transformBlock - picEntries <- (mapMaybe (snd . snd)) <$> gets stMediaPaths + picEntries <- mapMaybe (snd . snd) <$> gets stMediaPaths -- handle fonts let matchingGlob f = do xs <- lift $ P.glob f @@ -602,11 +612,6 @@ pandocToEPUB version opts doc@(Pandoc meta _) = do $ eRelativePath ent), ("media-type", fromMaybe "" $ getMimeType $ eRelativePath ent)] $ () - let plainTitle = case docTitle' meta of - [] -> case epubTitle metadata of - [] -> "UNTITLED" - (x:_) -> titleText x - x -> stringify x let tocTitle = fromMaybe plainTitle $ metaValueToString <$> lookupMeta "toc-title" meta @@ -747,14 +752,18 @@ pandocToEPUB version opts doc@(Pandoc meta _) = do where titElements = parseXML titRendered titRendered = case P.runPure (writeHtmlStringForEPUB version - opts{ writerTemplate = Nothing } + opts{ writerTemplate = Nothing + , writerVariables = + ("pagetitle",plainTitle): + writerVariables opts} (Pandoc nullMeta - [Plain $ walk delink tit])) of + [Plain $ walk clean tit])) of Left _ -> TS.pack $ stringify tit Right x -> x - -- can't have a element inside a... - delink (Link _ ils _) = Span ("", [], []) ils - delink x = x + -- can't have <a> elements inside generated links... + clean (Link _ ils _) = Span ("", [], []) ils + clean (Note _) = Str "" + clean x = x let navtag = if epub3 then "nav" else "div" tocBlocks <- lift $ evalStateT (mapM (navPointNode navXhtmlFormatter) secs) 1 @@ -872,7 +881,7 @@ metadataElement version md currentTime = dcTag' n s = [dcTag n s] toIdentifierNode id' (Identifier txt scheme) | version == EPUB2 = [dcNode "identifier" ! - ([("id",id')] ++ maybe [] (\x -> [("opf:scheme", x)]) scheme) $ + (("id",id') : maybe [] (\x -> [("opf:scheme", x)]) scheme) $ txt] | otherwise = [dcNode "identifier" ! [("id",id')] $ txt] ++ maybe [] (\x -> [unode "meta" ! diff --git a/src/Text/Pandoc/Writers/FB2.hs b/src/Text/Pandoc/Writers/FB2.hs index e322c7d98..a46011a8f 100644 --- a/src/Text/Pandoc/Writers/FB2.hs +++ b/src/Text/Pandoc/Writers/FB2.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE PatternGuards #-} {- @@ -37,6 +38,7 @@ FictionBook is an XML-based e-book format. For more information see: -} module Text.Pandoc.Writers.FB2 (writeFB2) where +import Prelude import Control.Monad (zipWithM) import Control.Monad.Except (catchError) import Control.Monad.State.Strict (StateT, evalStateT, get, lift, liftM, modify) @@ -44,7 +46,7 @@ import Data.ByteString.Base64 (encode) import qualified Data.ByteString.Char8 as B8 import Data.Char (isAscii, isControl, isSpace, toLower) import Data.Either (lefts, rights) -import Data.List (intercalate, intersperse, isPrefixOf, stripPrefix) +import Data.List (intercalate, isPrefixOf, stripPrefix) import Data.Text (Text, pack) import Network.HTTP (urlEncode) import Text.XML.Light @@ -116,6 +118,9 @@ description meta' = do bt <- booktitle meta' let as = authors meta' dd <- docdate meta' + annotation <- case lookupMeta "abstract" meta' of + Just (MetaBlocks bs) -> (list . el "annotation") <$> cMapM blockToXml bs + _ -> pure mempty let lang = case lookupMeta "lang" meta' of Just (MetaInlines [Str s]) -> [el "lang" $ iso639 s] Just (MetaString s) -> [el "lang" $ iso639 s] @@ -130,7 +135,7 @@ description meta' = do Just (MetaString s) -> coverimage s _ -> return [] return $ el "description" - [ el "title-info" (genre : (bt ++ as ++ dd ++ lang)) + [ el "title-info" (genre : (bt ++ annotation ++ as ++ dd ++ lang)) , el "document-info" (el "program-used" "pandoc" : coverpage) ] @@ -178,7 +183,7 @@ renderSection :: PandocMonad m => Int -> ([Inline], [Block]) -> FBM m Content renderSection level (ttl, body) = do title <- if null ttl then return [] - else return . list . el "title" . formatTitle $ ttl + else list . el "title" <$> formatTitle ttl content <- if hasSubsections body then renderSections (level + 1) body else cMapM blockToXml body @@ -187,11 +192,9 @@ renderSection level (ttl, body) = do hasSubsections = any isHeaderBlock -- | Only <p> and <empty-line> are allowed within <title> in FB2. -formatTitle :: [Inline] -> [Content] +formatTitle :: PandocMonad m => [Inline] -> FBM m [Content] formatTitle inlines = - let lns = split isLineBreak inlines - lns' = map (el "p" . cMap plain) lns - in intersperse (el "empty-line" ()) lns' + cMapM (blockToXml . Para) $ split (== LineBreak) inlines split :: (a -> Bool) -> [a] -> [[a]] split _ [] = [] @@ -311,9 +314,6 @@ isMimeType s = footnoteID :: Int -> String footnoteID i = "n" ++ show i -linkID :: Int -> String -linkID i = "l" ++ show i - -- | Convert a block-level Pandoc's element to FictionBook XML representation. blockToXml :: PandocMonad m => Block -> FBM m [Content] blockToXml (Plain ss) = cMapM toXml ss -- FIXME: can lead to malformed FB2 @@ -365,10 +365,7 @@ blockToXml h@Header{} = do -- should not occur after hierarchicalize, except inside lists/blockquotes report $ BlockNotRendered h return [] -blockToXml HorizontalRule = return - [ el "empty-line" () - , el "p" (txt (replicate 10 '—')) - , el "empty-line" () ] +blockToXml HorizontalRule = return [ el "empty-line" () ] blockToXml (Table caption aligns _ headers rows) = do hd <- mkrow "th" headers aligns bd <- mapM (\r -> mkrow "td" r aligns) rows @@ -398,7 +395,7 @@ plainToPara [] = [] plainToPara (Plain inlines : rest) = Para inlines : plainToPara rest plainToPara (Para inlines : rest) = - Para inlines : Plain [LineBreak] : plainToPara rest + Para inlines : HorizontalRule : plainToPara rest -- HorizontalRule will be converted to <empty-line /> plainToPara (p:rest) = p : plainToPara rest -- Simulate increased indentation level. Will not really work @@ -449,29 +446,15 @@ toXml (Quoted DoubleQuote ss) = do toXml (Cite _ ss) = cMapM toXml ss -- FIXME: support citation styles toXml (Code _ s) = return [el "code" s] toXml Space = return [txt " "] -toXml SoftBreak = return [txt " "] -toXml LineBreak = return [el "empty-line" ()] +toXml SoftBreak = return [txt "\n"] +toXml LineBreak = return [txt "\n"] toXml (Math _ formula) = insertMath InlineImage formula toXml il@(RawInline _ _) = do report $ InlineNotRendered il return [] -- raw TeX and raw HTML are suppressed -toXml (Link _ text (url,ttl)) = do - fns <- footnotes `liftM` get - let n = 1 + length fns - let ln_id = linkID n - let ln_ref = list . el "sup" . txt $ "[" ++ show n ++ "]" +toXml (Link _ text (url,_)) = do ln_text <- cMapM toXml text - let ln_desc = - let ttl' = dropWhile isSpace ttl - in if null ttl' - then list . el "p" $ el "code" url - else list . el "p" $ [ txt (ttl' ++ ": "), el "code" url ] - modify (\s -> s { footnotes = (n, ln_id, ln_desc) : fns }) - return $ ln_text ++ - [ el "a" - ( [ attr ("l","href") ('#':ln_id) - , uattr "type" "note" ] - , ln_ref) ] + return [ el "a" ( [ attr ("l","href") url ], ln_text) ] toXml img@Image{} = insertImage InlineImage img toXml (Note bs) = do fns <- footnotes `liftM` get diff --git a/src/Text/Pandoc/Writers/HTML.hs b/src/Text/Pandoc/Writers/HTML.hs index 1647df7ea..646168c72 100644 --- a/src/Text/Pandoc/Writers/HTML.hs +++ b/src/Text/Pandoc/Writers/HTML.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -45,11 +46,11 @@ module Text.Pandoc.Writers.HTML ( writeRevealJs, tagWithAttributes ) where +import Prelude import Control.Monad.State.Strict import Data.Char (ord, toLower) import Data.List (intercalate, intersperse, isPrefixOf, partition) import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing) -import Data.Monoid ((<>)) import qualified Data.Set as Set import Data.String (fromString) import Data.Text (Text) @@ -259,10 +260,6 @@ pandocToHtml opts (Pandoc meta blocks) = do notes <- footnoteSection opts (reverse (stNotes st)) let thebody = blocks' >> notes let math = case writerHTMLMathMethod opts of - LaTeXMathML (Just url) -> - H.script ! A.src (toValue url) - ! A.type_ "text/javascript" - $ mempty MathJax url | slideVariant /= RevealJsSlides -> -- mathjax is handled via a special plugin in revealjs @@ -273,21 +270,15 @@ pandocToHtml opts (Pandoc meta blocks) = do preEscapedString "MathJax.Hub.Queue([\"Typeset\",MathJax.Hub]);" _ -> mempty - JsMath (Just url) -> - H.script ! A.src (toValue url) - ! A.type_ "text/javascript" - $ mempty - KaTeX url -> - (H.script ! - A.src (toValue $ url ++ "katex.min.js") $ mempty) <> - (H.script ! - A.src (toValue $ url ++ "contrib/auto-render.min.js") - $ mempty) <> - ( - H.script - "document.addEventListener(\"DOMContentLoaded\", function() {\n renderMathInElement(document.body);\n});") <> - (H.link ! A.rel "stylesheet" ! - A.href (toValue $ url ++ "katex.min.css")) + KaTeX url -> do + H.script ! + A.src (toValue $ url ++ "katex.min.js") $ mempty + H.script ! + A.src (toValue $ url ++ "contrib/auto-render.min.js") $ mempty + H.script + "document.addEventListener(\"DOMContentLoaded\", function() {\n renderMathInElement(document.body);\n});" + H.link ! A.rel "stylesheet" ! + A.href (toValue $ url ++ "katex.min.css") _ -> case lookup "mathml-script" (writerVariables opts) of Just s | not (stHtml5 st) -> @@ -363,7 +354,8 @@ defList :: PandocMonad m defList opts items = toList H.dl opts (items ++ [nl opts]) -- | Construct table of contents from list of elements. -tableOfContents :: PandocMonad m => WriterOptions -> [Element] -> StateT WriterState m (Maybe Html) +tableOfContents :: PandocMonad m => WriterOptions -> [Element] + -> StateT WriterState m (Maybe Html) tableOfContents _ [] = return Nothing tableOfContents opts sects = do contents <- mapM (elementToListItem opts) sects @@ -378,7 +370,8 @@ showSecNum = intercalate "." . map show -- | Converts an Element to a list item for a table of contents, -- retrieving the appropriate identifier from state. -elementToListItem :: PandocMonad m => WriterOptions -> Element -> StateT WriterState m (Maybe Html) +elementToListItem :: PandocMonad m => WriterOptions -> Element + -> StateT WriterState m (Maybe Html) -- Don't include the empty headers created in slide shows -- shows when an hrule is used to separate slides without a new title: elementToListItem _ (Sec _ _ _ [Str "\0"] _) = return Nothing @@ -390,7 +383,8 @@ elementToListItem opts (Sec lev num (id',classes,_) headerText subsecs) then (H.span ! A.class_ "toc-section-number" $ toHtml $ showSecNum num') >> preEscapedString " " else mempty - txt <- liftM (sectnum >>) $ inlineListToHtml opts $ walk deNote headerText + txt <- liftM (sectnum >>) $ + inlineListToHtml opts $ walk (deLink . deNote) headerText subHeads <- mapM (elementToListItem opts) subsecs >>= return . catMaybes subList <- if null subHeads then return mempty @@ -406,8 +400,13 @@ elementToListItem opts (Sec lev num (id',classes,_) headerText subsecs) $ toHtml txt) >> subList elementToListItem _ _ = return Nothing +deLink :: Inline -> Inline +deLink (Link _ ils _) = Span nullAttr ils +deLink x = x + -- | Convert an Element to Html. -elementToHtml :: PandocMonad m => Int -> WriterOptions -> Element -> StateT WriterState m Html +elementToHtml :: PandocMonad m => Int -> WriterOptions -> Element + -> StateT WriterState m Html elementToHtml _slideLevel opts (Blk block) = blockToHtml opts block elementToHtml slideLevel opts (Sec level num (id',classes,keyvals) title' elements) = do slideVariant <- gets stSlideVariant @@ -479,7 +478,12 @@ footnoteSection opts notes = do html5 <- gets stHtml5 slideVariant <- gets stSlideVariant let hrtag = if html5 then H5.hr else H.hr + epubVersion <- gets stEPUBVersion let container x + | html5 + , epubVersion == Just EPUB3 + = H5.section ! A.class_ "footnotes" + ! customAttribute "epub:type" "footnotes" $ x | html5 = H5.section ! A.class_ "footnotes" $ x | slideVariant /= NoSlides = H.div ! A.class_ "footnotes slide" $ x | otherwise = H.div ! A.class_ "footnotes" $ x @@ -962,8 +966,9 @@ inlineToHtml opts inline = do WrapNone -> preEscapedString " " WrapAuto -> preEscapedString " " WrapPreserve -> preEscapedString "\n" - LineBreak -> return $ (if html5 then H5.br else H.br) - <> strToHtml "\n" + LineBreak -> return $ do + if html5 then H5.br else H.br + strToHtml "\n" (Span (id',classes,kvs) ils) -> inlineListToHtml opts ils >>= addAttrs opts attr' . H.span @@ -1019,19 +1024,6 @@ inlineToHtml opts inline = do let mathClass = toValue $ ("math " :: String) ++ if t == InlineMath then "inline" else "display" case writerHTMLMathMethod opts of - LaTeXMathML _ -> - -- putting LaTeXMathML in container with class "LaTeX" prevents - -- non-math elements on the page from being treated as math by - -- the javascript - return $ H.span ! A.class_ "LaTeX" $ - case t of - InlineMath -> toHtml ("$" ++ str ++ "$") - DisplayMath -> toHtml ("$$" ++ str ++ "$$") - JsMath _ -> do - let m = preEscapedString str - return $ case t of - InlineMath -> H.span ! A.class_ mathClass $ m - DisplayMath -> H.div ! A.class_ mathClass $ m WebTeX url -> do let imtag = if html5 then H5.img else H.img let m = imtag ! A.style "vertical-align:middle" @@ -1042,10 +1034,6 @@ inlineToHtml opts inline = do return $ case t of InlineMath -> m DisplayMath -> brtag >> m >> brtag - GladTeX -> - return $ case t of - InlineMath -> preEscapedString $ "<EQ ENV=\"math\">" ++ str ++ "</EQ>" - DisplayMath -> preEscapedString $ "<EQ ENV=\"displaymath\">" ++ str ++ "</EQ>" MathML -> do let conf = useShortEmptyTags (const False) defaultConfigPP diff --git a/src/Text/Pandoc/Writers/Haddock.hs b/src/Text/Pandoc/Writers/Haddock.hs index 688c1f390..75b8c78dc 100644 --- a/src/Text/Pandoc/Writers/Haddock.hs +++ b/src/Text/Pandoc/Writers/Haddock.hs @@ -1,6 +1,7 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} + {- Copyright (C) 2014-2015, 2017-2018 John MacFarlane <jgm@berkeley.edu> @@ -33,9 +34,9 @@ Conversion of 'Pandoc' documents to haddock markup. Haddock: <http://www.haskell.org/haddock/doc/html/> -} module Text.Pandoc.Writers.Haddock (writeHaddock) where +import Prelude import Control.Monad.State.Strict import Data.Default -import Data.List (intersperse, transpose) import Data.Text (Text) import Text.Pandoc.Class (PandocMonad, report) import Text.Pandoc.Definition @@ -136,29 +137,15 @@ blockToHaddock _ (CodeBlock (_,_,_) str) = -- Nothing in haddock corresponds to block quotes: blockToHaddock opts (BlockQuote blocks) = blockListToHaddock opts blocks --- Haddock doesn't have tables. Use haddock tables in code. blockToHaddock opts (Table caption aligns widths headers rows) = do caption' <- inlineListToHaddock opts caption let caption'' = if null caption then empty else blankline <> caption' <> blankline - rawHeaders <- mapM (blockListToHaddock opts) headers - rawRows <- mapM (mapM (blockListToHaddock opts)) rows - let isSimple = all (==0) widths - let isPlainBlock (Plain _) = True - isPlainBlock _ = False - let hasBlocks = not (all isPlainBlock $ concat . concat $ headers:rows) - (nst,tbl) <- case True of - _ | isSimple -> (nest 2,) <$> - pandocTable opts (all null headers) aligns widths - rawHeaders rawRows - | not hasBlocks -> (nest 2,) <$> - pandocTable opts (all null headers) aligns widths - rawHeaders rawRows - | otherwise -> (id,) <$> - gridTable opts blockListToHaddock - (all null headers) aligns widths headers rows - return $ prefixed "> " (nst $ tbl $$ blankline $$ caption'') $$ blankline + tbl <- gridTable opts blockListToHaddock + (all null headers) (map (const AlignDefault) aligns) + widths headers rows + return $ prefixed "> " (tbl $$ blankline $$ caption'') $$ blankline blockToHaddock opts (BulletList items) = do contents <- mapM (bulletListItemToHaddock opts) items return $ cat contents <> blankline @@ -174,46 +161,6 @@ blockToHaddock opts (DefinitionList items) = do contents <- mapM (definitionListItemToHaddock opts) items return $ cat contents <> blankline -pandocTable :: PandocMonad m - => WriterOptions -> Bool -> [Alignment] -> [Double] - -> [Doc] -> [[Doc]] -> StateT WriterState m Doc -pandocTable opts headless aligns widths rawHeaders rawRows = do - let isSimple = all (==0) widths - let alignHeader alignment = case alignment of - AlignLeft -> lblock - AlignCenter -> cblock - AlignRight -> rblock - AlignDefault -> lblock - let numChars = maximum . map offset - let widthsInChars = if isSimple - then map ((+2) . numChars) - $ transpose (rawHeaders : rawRows) - else map - (floor . (fromIntegral (writerColumns opts) *)) - widths - let makeRow = hcat . intersperse (lblock 1 (text " ")) . - zipWith3 alignHeader aligns widthsInChars - let rows' = map makeRow rawRows - let head' = makeRow rawHeaders - let maxRowHeight = maximum $ map height (head':rows') - let underline = cat $ intersperse (text " ") $ - map (\width -> text (replicate width '-')) widthsInChars - let border - | maxRowHeight > 1 = text (replicate (sum widthsInChars + - length widthsInChars - 1) '-') - | headless = underline - | otherwise = empty - let head'' = if headless - then empty - else border <> cr <> head' - let body = if maxRowHeight > 1 - then vsep rows' - else vcat rows' - let bottom = if headless - then underline - else border - return $ head'' $$ underline $$ body $$ bottom - -- | Convert bullet list item (list of blocks) to haddock bulletListItemToHaddock :: PandocMonad m => WriterOptions -> [Block] -> StateT WriterState m Doc diff --git a/src/Text/Pandoc/Writers/ICML.hs b/src/Text/Pandoc/Writers/ICML.hs index a5d851e40..266d58007 100644 --- a/src/Text/Pandoc/Writers/ICML.hs +++ b/src/Text/Pandoc/Writers/ICML.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {- | @@ -16,6 +17,7 @@ InCopy is the companion word-processor to Adobe InDesign and ICML documents can into InDesign with File -> Place. -} module Text.Pandoc.Writers.ICML (writeICML) where +import Prelude import Control.Monad.Except (catchError) import Control.Monad.State.Strict import Data.List (intersperse, isInfixOf, isPrefixOf, stripPrefix) diff --git a/src/Text/Pandoc/Writers/JATS.hs b/src/Text/Pandoc/Writers/JATS.hs index 639961acd..fb3236bd9 100644 --- a/src/Text/Pandoc/Writers/JATS.hs +++ b/src/Text/Pandoc/Writers/JATS.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {- @@ -28,9 +29,10 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Conversion of 'Pandoc' documents to JATS XML. Reference: -https://jats.nlm.nih.gov/publishing/tag-library/1.1d3/element/mml-math.html +https://jats.nlm.nih.gov/publishing/tag-library -} module Text.Pandoc.Writers.JATS ( writeJATS ) where +import Prelude import Control.Monad.Reader import Data.Char (toLower) import Data.Generics (everywhere, mkT) @@ -139,7 +141,7 @@ deflistItemToJATS opts term defs = do term' <- inlinesToJATS opts term def' <- blocksToJATS opts $ concatMap (map plainToPara) defs return $ inTagsIndented "def-item" $ - inTagsIndented "term" term' $$ + inTagsSimple "term" term' $$ inTagsIndented "def" def' -- | Convert a list of lists of blocks to a list of JATS list items. @@ -156,7 +158,7 @@ listItemToJATS :: PandocMonad m listItemToJATS opts mbmarker item = do contents <- blocksToJATS opts item return $ inTagsIndented "list-item" $ - maybe empty (\lbl -> inTagsIndented "label" (text lbl)) mbmarker + maybe empty (\lbl -> inTagsSimple "label" (text lbl)) mbmarker $$ contents imageMimeType :: String -> [(String, String)] -> (String, String) @@ -250,7 +252,7 @@ blockToJATS _ (Para [Image (ident,_,kvs) _ (src, tit)]) = do "xlink:type"]] return $ selfClosingTag "graphic" attr blockToJATS opts (Para lst) = - inTagsIndented "p" <$> inlinesToJATS opts lst + inTagsSimple "p" <$> inlinesToJATS opts lst blockToJATS opts (LineBlock lns) = blockToJATS opts $ linesToPara lns blockToJATS opts (BlockQuote blocks) = @@ -326,10 +328,10 @@ tableItemToJATS :: PandocMonad m -> [Block] -> JATS m Doc tableItemToJATS opts isHeader [Plain item] = - inTags True (if isHeader then "th" else "td") [] <$> + inTags False (if isHeader then "th" else "td") [] <$> inlinesToJATS opts item tableItemToJATS opts isHeader item = - (inTags True (if isHeader then "th" else "td") [] . vcat) <$> + (inTags False (if isHeader then "th" else "td") [] . vcat) <$> mapM (blockToJATS opts) item -- | Convert a list of inline elements to JATS. diff --git a/src/Text/Pandoc/Writers/LaTeX.hs b/src/Text/Pandoc/Writers/LaTeX.hs index f61c878e5..2904bec06 100644 --- a/src/Text/Pandoc/Writers/LaTeX.hs +++ b/src/Text/Pandoc/Writers/LaTeX.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -34,6 +35,7 @@ module Text.Pandoc.Writers.LaTeX ( writeLaTeX , writeBeamer ) where +import Prelude import Control.Applicative ((<|>)) import Control.Monad.State.Strict import Data.Aeson (FromJSON, object, (.=)) @@ -411,15 +413,15 @@ elementToBeamer slideLevel (Sec lvl _num (ident,classes,kvs) tit elts) slideTitle <- if tit == [Str "\0"] -- marker for hrule then return [] - else - if null ident - then return $ latex "{" : tit ++ [latex "}"] - else do - ref <- toLabel ident - return $ latex ("{%\n\\protect\\hypertarget{" ++ - ref ++ "}{%\n") : tit ++ [latex "}}"] + else return $ latex "{" : tit ++ [latex "}"] + ref <- toLabel ident + let slideAnchor = if null ident + then [] + else [latex ("\n\\protect\\hypertarget{" ++ + ref ++ "}{}")] let slideStart = Para $ - RawInline "latex" ("\\begin{frame}" ++ options) : slideTitle + RawInline "latex" ("\\begin{frame}" ++ options) : + slideTitle ++ slideAnchor let slideEnd = RawBlock "latex" "\\end{frame}" -- now carve up slide into blocks if there are sections inside bs <- concat `fmap` mapM (elementToBeamer slideLevel) elts @@ -676,6 +678,7 @@ blockToLaTeX (OrderedList (start, numstyle, numdelim) lst) = do let enum = text $ "enum" ++ map toLower (toRomanNumeral oldlevel) let stylecommand | numstyle == DefaultStyle && numdelim == DefaultDelim = empty + | beamer && numstyle == Decimal && numdelim == Period = empty | beamer = brackets (todelim exemplar) | otherwise = "\\def" <> "\\label" <> enum <> braces (todelim $ tostyle enum) @@ -1033,7 +1036,7 @@ inlineToLaTeX (Code (_,classes,_) str) = do Nothing -> "" inNote <- gets stInNote when inNote $ modify $ \s -> s{ stVerbInNote = True } - let chr = case "!\"&'()*,-./:;?@_" \\ str of + let chr = case "!\"'()*,-./:;?@" \\ str of (c:_) -> c [] -> '!' let str' = escapeStringUsing (backslashEscapes "\\{}%~_&") str diff --git a/src/Text/Pandoc/Writers/Man.hs b/src/Text/Pandoc/Writers/Man.hs index 1be955fe3..912231a88 100644 --- a/src/Text/Pandoc/Writers/Man.hs +++ b/src/Text/Pandoc/Writers/Man.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {- Copyright (C) 2007-2018 John MacFarlane <jgm@berkeley.edu> @@ -30,6 +31,7 @@ Conversion of 'Pandoc' documents to groff man page format. -} module Text.Pandoc.Writers.Man ( writeMan) where +import Prelude import Control.Monad.State.Strict import Data.List (intercalate, intersperse, sort, stripPrefix) import qualified Data.Map as Map diff --git a/src/Text/Pandoc/Writers/Markdown.hs b/src/Text/Pandoc/Writers/Markdown.hs index cdd8f3b66..075858e5e 100644 --- a/src/Text/Pandoc/Writers/Markdown.hs +++ b/src/Text/Pandoc/Writers/Markdown.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -34,6 +35,7 @@ Conversion of 'Pandoc' documents to markdown-formatted plain text. Markdown: <http://daringfireball.net/projects/markdown/> -} module Text.Pandoc.Writers.Markdown (writeMarkdown, writePlain) where +import Prelude import Control.Monad.Reader import Control.Monad.State.Strict import Data.Char (chr, isPunctuation, isSpace, ord, isAlphaNum) @@ -730,7 +732,10 @@ pandocTable opts multiline headless aligns widths rawHeaders rawRows = do then empty else border <> cr <> head' let body = if multiline - then vsep rows' + then vsep rows' $$ + if length rows' < 2 + then blankline -- #4578 + else empty else vcat rows' let bottom = if headless then underline diff --git a/src/Text/Pandoc/Writers/Math.hs b/src/Text/Pandoc/Writers/Math.hs index 477f5a0b1..99d17d594 100644 --- a/src/Text/Pandoc/Writers/Math.hs +++ b/src/Text/Pandoc/Writers/Math.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} module Text.Pandoc.Writers.Math ( texMathToInlines , convertMath @@ -6,6 +7,7 @@ module Text.Pandoc.Writers.Math ) where +import Prelude import Text.Pandoc.Class import Text.Pandoc.Definition import Text.Pandoc.Logging diff --git a/src/Text/Pandoc/Writers/MediaWiki.hs b/src/Text/Pandoc/Writers/MediaWiki.hs index 2470d9200..df50028a0 100644 --- a/src/Text/Pandoc/Writers/MediaWiki.hs +++ b/src/Text/Pandoc/Writers/MediaWiki.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {- Copyright (C) 2008-2018 John MacFarlane <jgm@berkeley.edu> @@ -30,6 +31,7 @@ Conversion of 'Pandoc' documents to MediaWiki markup. MediaWiki: <http://www.mediawiki.org/wiki/MediaWiki> -} module Text.Pandoc.Writers.MediaWiki ( writeMediaWiki ) where +import Prelude import Control.Monad.Reader import Control.Monad.State.Strict import Data.List (intercalate) diff --git a/src/Text/Pandoc/Writers/Ms.hs b/src/Text/Pandoc/Writers/Ms.hs index 83d80cd4a..16a66c85b 100644 --- a/src/Text/Pandoc/Writers/Ms.hs +++ b/src/Text/Pandoc/Writers/Ms.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {- Copyright (C) 2007-2018 John MacFarlane <jgm@berkeley.edu> @@ -36,9 +37,10 @@ TODO: -} module Text.Pandoc.Writers.Ms ( writeMs ) where +import Prelude import Control.Monad.State.Strict -import Data.Char (isLower, isUpper, toUpper) -import Data.List (intercalate, intersperse, sort) +import Data.Char (isLower, isUpper, toUpper, ord) +import Data.List (intercalate, intersperse) import qualified Data.Map as Map import Data.Maybe (catMaybes, fromMaybe) import Data.Text (Text) @@ -46,6 +48,7 @@ import qualified Data.Text as T import Network.URI (escapeURIString, isAllowedInURI) import Skylighting import System.FilePath (takeExtension) +import Text.Pandoc.Asciify (toAsciiChar) import Text.Pandoc.Class (PandocMonad, report) import Text.Pandoc.Definition import Text.Pandoc.Highlighting @@ -65,6 +68,7 @@ data WriterState = WriterState { stHasInlineMath :: Bool , stNotes :: [Note] , stSmallCaps :: Bool , stHighlighting :: Bool + , stInHeader :: Bool , stFontFeatures :: Map.Map Char Bool } @@ -74,6 +78,7 @@ defaultWriterState = WriterState{ stHasInlineMath = False , stNotes = [] , stSmallCaps = False , stHighlighting = False + , stInHeader = False , stFontFeatures = Map.fromList [ ('I',False) , ('B',False) @@ -132,14 +137,12 @@ msEscapes = Map.fromList [ ('\160', "\\~") , ('\'', "\\[aq]") , ('`', "\\`") - , ('\8217', "'") , ('"', "\\[dq]") , ('\x2014', "\\[em]") , ('\x2013', "\\[en]") , ('\x2026', "\\&...") , ('~', "\\[ti]") , ('^', "\\[ha]") - , ('-', "\\-") , ('@', "\\@") , ('\\', "\\\\") ] @@ -216,11 +219,16 @@ blockToMs :: PandocMonad m -> Block -- ^ Block element -> MS m Doc blockToMs _ Null = return empty -blockToMs opts (Div _ bs) = do +blockToMs opts (Div (ident,_,_) bs) = do + let anchor = if null ident + then empty + else nowrap $ + text ".pdfhref M " + <> doubleQuotes (text (toAscii ident)) setFirstPara res <- blockListToMs opts bs setFirstPara - return res + return $ anchor $$ res blockToMs opts (Plain inlines) = liftM vcat $ mapM (inlineListToMs' opts) $ splitSentences inlines blockToMs opts (Para [Image attr alt (src,_tit)]) @@ -258,7 +266,9 @@ blockToMs _ HorizontalRule = do return $ text ".HLINE" blockToMs opts (Header level (ident,classes,_) inlines) = do setFirstPara + modify $ \st -> st{ stInHeader = True } contents <- inlineListToMs' opts $ map breakToSpace inlines + modify $ \st -> st{ stInHeader = False } let (heading, secnum) = if writerNumberSections opts && "unnumbered" `notElem` classes then (".NH", "\\*[SN]") @@ -266,7 +276,8 @@ blockToMs opts (Header level (ident,classes,_) inlines) = do let anchor = if null ident then empty else nowrap $ - text ".pdfhref M " <> doubleQuotes (text ident) + text ".pdfhref M " + <> doubleQuotes (text (toAscii ident)) let bookmark = text ".pdfhref O " <> text (show level ++ " ") <> doubleQuotes (text $ secnum ++ (if null secnum @@ -274,7 +285,7 @@ blockToMs opts (Header level (ident,classes,_) inlines) = do else " ") ++ escapeString (stringify inlines)) let backlink = nowrap (text ".pdfhref L -D " <> - doubleQuotes (text ident) <> space <> text "\\") <> cr <> + doubleQuotes (text (toAscii ident)) <> space <> text "\\") <> cr <> text " -- " let tocEntry = if writerTableOfContents opts && level <= writerTOCDepth opts @@ -513,7 +524,7 @@ inlineToMs opts (Link _ txt ('#':ident, _)) = do -- internal link contents <- inlineListToMs' opts $ map breakToSpace txt return $ text "\\c" <> cr <> nowrap (text ".pdfhref L -D " <> - doubleQuotes (text ident) <> text " -A " <> + doubleQuotes (text (toAscii ident)) <> text " -A " <> doubleQuotes (text "\\c") <> space <> text "\\") <> cr <> text " -- " <> doubleQuotes (nowrap contents) <> cr <> text "\\&" inlineToMs opts (Link _ txt (src, _)) = do @@ -552,8 +563,15 @@ handleNote opts bs = do fontChange :: PandocMonad m => MS m Doc fontChange = do features <- gets stFontFeatures - let filling = sort [c | (c,True) <- Map.toList features] - return $ text $ "\\f[" ++ filling ++ "]" + inHeader <- gets stInHeader + let filling = ['C' | fromMaybe False $ Map.lookup 'C' features] ++ + ['B' | inHeader || + fromMaybe False (Map.lookup 'B' features)] ++ + ['I' | fromMaybe False $ Map.lookup 'I' features] + return $ + if null filling + then text "\\f[R]" + else text $ "\\f[" ++ filling ++ "]" withFontFeature :: PandocMonad m => Char -> MS m Doc -> MS m Doc withFontFeature c action = do @@ -637,3 +655,11 @@ highlightCode opts attr str = Right h -> do modify (\st -> st{ stHighlighting = True }) return h + +-- This is used for PDF anchors. +toAscii :: String -> String +toAscii = concatMap + (\c -> case toAsciiChar c of + Nothing -> '_':'u':show (ord c) ++ "_" + Just '/' -> '_':'u':show (ord c) ++ "_" -- see #4515 + Just c' -> [c']) diff --git a/src/Text/Pandoc/Writers/Muse.hs b/src/Text/Pandoc/Writers/Muse.hs index 7f53e202d..3681fcc0d 100644 --- a/src/Text/Pandoc/Writers/Muse.hs +++ b/src/Text/Pandoc/Writers/Muse.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {- Copyright (C) 2017-2018 Alexander Krotov <ilabdsf@gmail.com> @@ -42,7 +43,11 @@ However, @\<literal style="html">@ tag is used for HTML raw blocks even though it is supported only in Emacs Muse. -} module Text.Pandoc.Writers.Muse (writeMuse) where +import Prelude +import Control.Monad.Reader import Control.Monad.State.Strict +import Data.Char (isSpace, isDigit, isAsciiUpper, isAsciiLower) +import Data.Default import Data.Text (Text) import Data.List (intersperse, transpose, isInfixOf) import System.FilePath (takeExtension) @@ -58,34 +63,54 @@ import Text.Pandoc.Writers.Shared import qualified Data.Set as Set type Notes = [[Block]] + +type Muse m = ReaderT WriterEnv (StateT WriterState m) + +data WriterEnv = + WriterEnv { envOptions :: WriterOptions + , envTopLevel :: Bool + , envInsideBlock :: Bool + , envInlineStart :: Bool + , envInsideLinkDescription :: Bool -- ^ Escape ] if True + , envAfterSpace :: Bool + , envOneLine :: Bool -- ^ True if newlines are not allowed + } + data WriterState = WriterState { stNotes :: Notes - , stOptions :: WriterOptions - , stTopLevel :: Bool - , stInsideBlock :: Bool , stIds :: Set.Set String } +instance Default WriterState + where def = WriterState { stNotes = [] + , stIds = Set.empty + } + +evalMuse :: PandocMonad m => Muse m a -> WriterEnv -> WriterState -> m a +evalMuse document env = evalStateT $ runReaderT document env + -- | Convert Pandoc to Muse. writeMuse :: PandocMonad m => WriterOptions -> Pandoc -> m Text writeMuse opts document = - let st = WriterState { stNotes = [] - , stOptions = opts - , stTopLevel = True - , stInsideBlock = False - , stIds = Set.empty - } - in evalStateT (pandocToMuse document) st + evalMuse (pandocToMuse document) env def + where env = WriterEnv { envOptions = opts + , envTopLevel = True + , envInsideBlock = False + , envInlineStart = True + , envInsideLinkDescription = False + , envAfterSpace = False + , envOneLine = False + } -- | Return Muse representation of document. pandocToMuse :: PandocMonad m => Pandoc - -> StateT WriterState m Text + -> Muse m Text pandocToMuse (Pandoc meta blocks) = do - opts <- gets stOptions + opts <- asks envOptions let colwidth = if writerWrapText opts == WrapAuto then Just $ writerColumns opts else Nothing @@ -96,7 +121,7 @@ pandocToMuse (Pandoc meta blocks) = do (fmap render' . inlineListToMuse) meta body <- blockListToMuse blocks - notes <- liftM (reverse . stNotes) get >>= notesToMuse + notes <- fmap (reverse . stNotes) get >>= notesToMuse let main = render colwidth $ body $+$ notes let context = defField "body" main metadata case writerTemplate opts of @@ -108,7 +133,7 @@ pandocToMuse (Pandoc meta blocks) = do catWithBlankLines :: PandocMonad m => [Block] -- ^ List of block elements -> Int -- ^ Number of blank lines - -> StateT WriterState m Doc + -> Muse m Doc catWithBlankLines (b : bs) n = do b' <- blockToMuse b bs' <- flatBlockListToMuse bs @@ -116,10 +141,10 @@ catWithBlankLines (b : bs) n = do catWithBlankLines _ _ = error "Expected at least one block" -- | Convert list of Pandoc block elements to Muse --- | without setting stTopLevel. +-- | without setting envTopLevel. flatBlockListToMuse :: PandocMonad m => [Block] -- ^ List of block elements - -> StateT WriterState m Doc + -> Muse m Doc flatBlockListToMuse bs@(BulletList _ : BulletList _ : _) = catWithBlankLines bs 2 flatBlockListToMuse bs@(OrderedList (_, style1, _) _ : OrderedList (_, style2, _) _ : _) = catWithBlankLines bs (if style1' == style2' then 2 else 0) @@ -135,36 +160,23 @@ flatBlockListToMuse [] = return mempty -- | Convert list of Pandoc block elements to Muse. blockListToMuse :: PandocMonad m => [Block] -- ^ List of block elements - -> StateT WriterState m Doc -blockListToMuse blocks = do - oldState <- get - modify $ \s -> s { stTopLevel = not $ stInsideBlock s - , stInsideBlock = True - } - result <- flatBlockListToMuse blocks - modify $ \s -> s { stTopLevel = stTopLevel oldState - , stInsideBlock = stInsideBlock oldState - } - return result + -> Muse m Doc +blockListToMuse = + local (\env -> env { envTopLevel = not (envInsideBlock env) + , envInsideBlock = True + }) . flatBlockListToMuse -- | Convert Pandoc block element to Muse. blockToMuse :: PandocMonad m => Block -- ^ Block element - -> StateT WriterState m Doc -blockToMuse (Plain inlines) = inlineListToMuse inlines + -> Muse m Doc +blockToMuse (Plain inlines) = inlineListToMuse' inlines blockToMuse (Para inlines) = do - contents <- inlineListToMuse inlines + contents <- inlineListToMuse' inlines return $ contents <> blankline blockToMuse (LineBlock lns) = do - let splitStanza [] = [] - splitStanza xs = case break (== mempty) xs of - (l, []) -> [l] - (l, _:r) -> l : splitStanza r - let joinWithLinefeeds = nowrap . mconcat . intersperse cr - let joinWithBlankLines = mconcat . intersperse blankline - let prettyfyStanza ls = joinWithLinefeeds <$> mapM inlineListToMuse ls - contents <- joinWithBlankLines <$> mapM prettyfyStanza (splitStanza lns) - return $ blankline $$ "<verse>" $$ contents $$ "</verse>" <> blankline + lns' <- local (\env -> env { envOneLine = True }) $ mapM inlineListToMuse lns + return $ nowrap $ vcat (map (text "> " <>) lns') <> blankline blockToMuse (CodeBlock (_,_,_) str) = return $ "<example>" $$ text str $$ "</example>" $$ blankline blockToMuse (RawBlock (Format format) str) = @@ -180,50 +192,48 @@ blockToMuse (BlockQuote blocks) = do blockToMuse (OrderedList (start, style, _) items) = do let markers = take (length items) $ orderedListMarkers (start, style, Period) - let maxMarkerLength = maximum $ map length markers - let markers' = map (\m -> let s = maxMarkerLength - length m - in m ++ replicate s ' ') markers - contents <- zipWithM orderedListItemToMuse markers' items + contents <- zipWithM orderedListItemToMuse markers items -- ensure that sublists have preceding blank line - topLevel <- gets stTopLevel + topLevel <- asks envTopLevel return $ cr $$ (if topLevel then nest 1 else id) (vcat contents) $$ blankline where orderedListItemToMuse :: PandocMonad m => String -- ^ marker for list item -> [Block] -- ^ list item (list of blocks) - -> StateT WriterState m Doc + -> Muse m Doc orderedListItemToMuse marker item = do - contents <- blockListToMuse item - return $ hang (length marker + 1) (text marker <> space) contents + contents <- blockListToMuse item + return $ hang (length marker + 1) (text marker <> space) contents blockToMuse (BulletList items) = do contents <- mapM bulletListItemToMuse items -- ensure that sublists have preceding blank line - topLevel <- gets stTopLevel + topLevel <- asks envTopLevel return $ cr $$ (if topLevel then nest 1 else id) (vcat contents) $$ blankline where bulletListItemToMuse :: PandocMonad m => [Block] - -> StateT WriterState m Doc + -> Muse m Doc bulletListItemToMuse item = do contents <- blockListToMuse item return $ hang 2 "- " contents blockToMuse (DefinitionList items) = do contents <- mapM definitionListItemToMuse items - return $ cr $$ nest 1 (vcat contents) $$ blankline + -- ensure that sublists have preceding blank line + topLevel <- asks envTopLevel + return $ cr $$ (if topLevel then nest 1 else id) (vcat contents) $$ blankline where definitionListItemToMuse :: PandocMonad m => ([Inline], [[Block]]) - -> StateT WriterState m Doc + -> Muse m Doc definitionListItemToMuse (label, defs) = do - label' <- inlineListToMuse label - contents <- liftM vcat $ mapM descriptionToMuse defs + label' <- local (\env -> env { envOneLine = True, envAfterSpace = True }) $ inlineListToMuse' label + contents <- vcat <$> mapM descriptionToMuse defs let ind = offset label' return $ hang ind label' contents descriptionToMuse :: PandocMonad m => [Block] - -> StateT WriterState m Doc + -> Muse m Doc descriptionToMuse desc = hang 4 " :: " <$> blockListToMuse desc blockToMuse (Header level (ident,_,_) inlines) = do - opts <- gets stOptions - contents <- inlineListToMuse inlines - + opts <- asks envOptions + contents <- local (\env -> env { envOneLine = True }) $ inlineListToMuse' inlines ids <- gets stIds let autoId = uniqueIdent inlines ids modify $ \st -> st{ stIds = Set.insert autoId ids } @@ -232,8 +242,7 @@ blockToMuse (Header level (ident,_,_) inlines) = do then empty else "#" <> text ident <> cr let header' = text $ replicate level '*' - return $ blankline <> nowrap (header' <> space <> contents) - $$ attr' <> blankline + return $ blankline <> attr' $$ nowrap (header' <> space <> contents) <> blankline -- https://www.gnu.org/software/emacs-muse/manual/muse.html#Horizontal-Rules-and-Anchors blockToMuse HorizontalRule = return $ blankline $$ "----" $$ blankline blockToMuse (Table caption _ _ headers rows) = do @@ -266,18 +275,18 @@ blockToMuse Null = return empty -- | Return Muse representation of notes. notesToMuse :: PandocMonad m => Notes - -> StateT WriterState m Doc -notesToMuse notes = liftM vsep (zipWithM noteToMuse [1 ..] notes) + -> Muse m Doc +notesToMuse notes = vsep <$> zipWithM noteToMuse [1 ..] notes -- | Return Muse representation of a note. noteToMuse :: PandocMonad m => Int -> [Block] - -> StateT WriterState m Doc -noteToMuse num note = do - contents <- blockListToMuse note - let marker = "[" ++ show num ++ "] " - return $ hang (length marker) (text marker) contents + -> Muse m Doc +noteToMuse num note = + hang (length marker) (text marker) <$> blockListToMuse note + where + marker = "[" ++ show num ++ "] " -- | Escape special characters for Muse. escapeString :: String -> String @@ -286,17 +295,74 @@ escapeString s = substitute "</verbatim>" "<</verbatim><verbatim>/verbatim>" s ++ "</verbatim>" +startsWithMarker :: (Char -> Bool) -> String -> Bool +startsWithMarker f (' ':xs) = startsWithMarker f xs +startsWithMarker f (x:xs) = + f x && (startsWithMarker f xs || startsWithDot xs) + where + startsWithDot ['.'] = True + startsWithDot ('.':c:_) = isSpace c + startsWithDot _ = False +startsWithMarker _ [] = False + -- | Escape special characters for Muse if needed. -conditionalEscapeString :: String -> String -conditionalEscapeString s = - if any (`elem` ("#*<=>[]|" :: String)) s || +containsFootnotes :: String -> Bool +containsFootnotes = p + where p ('[':xs) = q xs || p xs + p (_:xs) = p xs + p "" = False + q (x:xs) + | x `elem` ("123456789"::String) = r xs || p xs + | otherwise = p xs + q [] = False + r ('0':xs) = r xs || p xs + r xs = s xs || q xs || p xs + s (']':_) = True + s (_:xs) = p xs + s [] = False + +conditionalEscapeString :: Bool -> String -> String +conditionalEscapeString isInsideLinkDescription s = + if any (`elem` ("#*<=|" :: String)) s || "::" `isInfixOf` s || - "----" `isInfixOf` s || - "~~" `isInfixOf` s + "~~" `isInfixOf` s || + "[[" `isInfixOf` s || + ("]" `isInfixOf` s && isInsideLinkDescription) || + containsFootnotes s then escapeString s else s +-- Expand Math and Cite before normalizing inline list +preprocessInlineList :: PandocMonad m + => [Inline] + -> m [Inline] +preprocessInlineList (Math t str:xs) = (++) <$> texMathToInlines t str <*> preprocessInlineList xs +-- Amusewiki does not support <cite> tag, +-- and Emacs Muse citation support is limited +-- (https://www.gnu.org/software/emacs-muse/manual/html_node/Citations.html#Citation) +-- so just fallback to expanding inlines. +preprocessInlineList (Cite _ lst:xs) = (lst ++) <$> preprocessInlineList xs +preprocessInlineList (x:xs) = (x:) <$> preprocessInlineList xs +preprocessInlineList [] = return [] + +replaceSmallCaps :: Inline -> Inline +replaceSmallCaps (SmallCaps lst) = Emph lst +replaceSmallCaps x = x + +removeKeyValues :: Inline -> Inline +removeKeyValues (Code (i, cls, _) xs) = Code (i, cls, []) xs +-- Do not remove attributes from Link +-- Do not remove attributes, such as "width", from Image +removeKeyValues (Span (i, cls, _) xs) = Span (i, cls, []) xs +removeKeyValues x = x + normalizeInlineList :: [Inline] -> [Inline] +normalizeInlineList (Str "" : xs) + = normalizeInlineList xs +normalizeInlineList (x : Str "" : xs) + = normalizeInlineList (x:xs) +normalizeInlineList (Str x1 : Str x2 : xs) + = normalizeInlineList $ Str (x1 ++ x2) : xs normalizeInlineList (Emph x1 : Emph x2 : ils) = normalizeInlineList $ Emph (x1 ++ x2) : ils normalizeInlineList (Strong x1 : Strong x2 : ils) @@ -313,8 +379,7 @@ normalizeInlineList (Code _ x1 : Code _ x2 : ils) = normalizeInlineList $ Code nullAttr (x1 ++ x2) : ils normalizeInlineList (RawInline f1 x1 : RawInline f2 x2 : ils) | f1 == f2 = normalizeInlineList $ RawInline f1 (x1 ++ x2) : ils -normalizeInlineList (Span a1 x1 : Span a2 x2 : ils) | a1 == a2 - = normalizeInlineList $ Span a1 (x1 ++ x2) : ils +-- Do not join Span's during normalization normalizeInlineList (x:xs) = x : normalizeInlineList xs normalizeInlineList [] = [] @@ -324,17 +389,77 @@ fixNotes (Space : n@Note{} : rest) = Str " " : n : fixNotes rest fixNotes (SoftBreak : n@Note{} : rest) = Str " " : n : fixNotes rest fixNotes (x:xs) = x : fixNotes xs --- | Convert list of Pandoc inline elements to Muse. -inlineListToMuse :: PandocMonad m +urlEscapeBrackets :: String -> String +urlEscapeBrackets (']':xs) = '%':'5':'D':urlEscapeBrackets xs +urlEscapeBrackets (x:xs) = x:urlEscapeBrackets xs +urlEscapeBrackets [] = [] + +isHorizontalRule :: String -> Bool +isHorizontalRule s = length s >= 4 && all (== '-') s + +startsWithSpace :: String -> Bool +startsWithSpace (x:_) = isSpace x +startsWithSpace [] = False + +fixOrEscape :: Bool -> Inline -> Bool +fixOrEscape sp (Str "-") = sp +fixOrEscape sp (Str ";") = not sp +fixOrEscape _ (Str ">") = True +fixOrEscape sp (Str s) = (sp && (startsWithMarker isDigit s || + startsWithMarker isAsciiLower s || + startsWithMarker isAsciiUpper s)) + || isHorizontalRule s || startsWithSpace s +fixOrEscape _ Space = True +fixOrEscape _ SoftBreak = True +fixOrEscape _ _ = False + +-- | Convert list of Pandoc inline elements to Muse +renderInlineList :: PandocMonad m => [Inline] - -> StateT WriterState m Doc -inlineListToMuse lst = hcat <$> mapM inlineToMuse (fixNotes $ normalizeInlineList lst) + -> Muse m Doc +renderInlineList [] = do + start <- asks envInlineStart + pure $ if start then "<verbatim></verbatim>" else "" +renderInlineList (x:xs) = do + start <- asks envInlineStart + afterSpace <- asks envAfterSpace + topLevel <- asks envTopLevel + r <- inlineToMuse x + opts <- asks envOptions + let isNewline = (x == SoftBreak && writerWrapText opts == WrapPreserve) || x == LineBreak + lst' <- local (\env -> env { envInlineStart = isNewline + , envAfterSpace = x == Space || (not topLevel && isNewline) + }) $ renderInlineList xs + if start && fixOrEscape afterSpace x + then pure (text "<verbatim></verbatim>" <> r <> lst') + else pure (r <> lst') + +-- | Normalize and convert list of Pandoc inline elements to Muse. +inlineListToMuse'' :: PandocMonad m + => Bool + -> [Inline] + -> Muse m Doc +inlineListToMuse'' start lst = do + lst' <- (normalizeInlineList . fixNotes) <$> preprocessInlineList (map (removeKeyValues . replaceSmallCaps) lst) + topLevel <- asks envTopLevel + afterSpace <- asks envAfterSpace + local (\env -> env { envInlineStart = start + , envAfterSpace = afterSpace || (start && not topLevel) + }) $ renderInlineList lst' + +inlineListToMuse' :: PandocMonad m => [Inline] -> Muse m Doc +inlineListToMuse' = inlineListToMuse'' True + +inlineListToMuse :: PandocMonad m => [Inline] -> Muse m Doc +inlineListToMuse = inlineListToMuse'' False -- | Convert Pandoc inline element to Muse. inlineToMuse :: PandocMonad m => Inline - -> StateT WriterState m Doc -inlineToMuse (Str str) = return $ text $ conditionalEscapeString str + -> Muse m Doc +inlineToMuse (Str str) = do + insideLink <- asks envInsideLinkDescription + return $ text $ conditionalEscapeString insideLink str inlineToMuse (Emph lst) = do contents <- inlineListToMuse lst return $ "<em>" <> contents <> "</em>" @@ -350,60 +475,73 @@ inlineToMuse (Superscript lst) = do inlineToMuse (Subscript lst) = do contents <- inlineListToMuse lst return $ "<sub>" <> contents <> "</sub>" -inlineToMuse (SmallCaps lst) = inlineListToMuse lst +inlineToMuse SmallCaps {} = + fail "SmallCaps should be expanded before normalization" inlineToMuse (Quoted SingleQuote lst) = do contents <- inlineListToMuse lst return $ "‘" <> contents <> "’" inlineToMuse (Quoted DoubleQuote lst) = do contents <- inlineListToMuse lst return $ "“" <> contents <> "”" --- Amusewiki does not support <cite> tag, --- and Emacs Muse citation support is limited --- (https://www.gnu.org/software/emacs-muse/manual/html_node/Citations.html#Citation) --- so just fallback to expanding inlines. -inlineToMuse (Cite _ lst) = inlineListToMuse lst +inlineToMuse Cite {} = + fail "Citations should be expanded before normalization" inlineToMuse (Code _ str) = return $ "<code>" <> text (substitute "</code>" "<</code><code>/code>" str) <> "</code>" -inlineToMuse (Math t str) = - lift (texMathToInlines t str) >>= inlineListToMuse +inlineToMuse Math{} = + fail "Math should be expanded before normalization" inlineToMuse (RawInline (Format f) str) = return $ "<literal style=\"" <> text f <> "\">" <> text str <> "</literal>" -inlineToMuse LineBreak = return $ "<br>" <> cr +inlineToMuse LineBreak = do + oneline <- asks envOneLine + return $ if oneline then "<br>" else "<br>" <> cr inlineToMuse Space = return space inlineToMuse SoftBreak = do - wrapText <- gets $ writerWrapText . stOptions - return $ if wrapText == WrapPreserve then cr else space + oneline <- asks envOneLine + wrapText <- asks $ writerWrapText . envOptions + return $ if not oneline && wrapText == WrapPreserve then cr else space inlineToMuse (Link _ txt (src, _)) = case txt of [Str x] | escapeURI x == src -> return $ "[[" <> text (escapeLink x) <> "]]" - _ -> do contents <- inlineListToMuse txt + _ -> do contents <- local (\env -> env { envInsideLinkDescription = True }) $ inlineListToMuse txt return $ "[[" <> text (escapeLink src) <> "][" <> contents <> "]]" - where escapeLink lnk = if isImageUrl lnk then "URL:" ++ lnk else lnk + where escapeLink lnk = if isImageUrl lnk then "URL:" ++ urlEscapeBrackets lnk else urlEscapeBrackets lnk -- Taken from muse-image-regexp defined in Emacs Muse file lisp/muse-regexps.el imageExtensions = [".eps", ".gif", ".jpg", ".jpeg", ".pbm", ".png", ".tiff", ".xbm", ".xpm"] isImageUrl = (`elem` imageExtensions) . takeExtension inlineToMuse (Image attr alt (source,'f':'i':'g':':':title)) = inlineToMuse (Image attr alt (source,title)) -inlineToMuse (Image attr inlines (source, title)) = do - opts <- gets stOptions - alt <- inlineListToMuse inlines +inlineToMuse (Image attr@(_, classes, _) inlines (source, title)) = do + opts <- asks envOptions + alt <- local (\env -> env { envInsideLinkDescription = True }) $ inlineListToMuse inlines let title' = if null title then if null inlines then "" else "[" <> alt <> "]" - else "[" <> text title <> "]" + else "[" <> text (conditionalEscapeString True title) <> "]" let width = case dimension Width attr of Just (Percent x) | isEnabled Ext_amuse opts -> " " ++ show (round x :: Integer) _ -> "" - return $ "[[" <> text (source ++ width) <> "]" <> title' <> "]" + let leftalign = if "align-left" `elem` classes + then " l" + else "" + let rightalign = if "align-right" `elem` classes + then " r" + else "" + return $ "[[" <> text (urlEscapeBrackets source ++ width ++ leftalign ++ rightalign) <> "]" <> title' <> "]" inlineToMuse (Note contents) = do -- add to notes in state notes <- gets stNotes modify $ \st -> st { stNotes = contents:notes } let ref = show $ length notes + 1 return $ "[" <> text ref <> "]" -inlineToMuse (Span (_,name:_,_) inlines) = do +inlineToMuse (Span (anchor,names,_) inlines) = do contents <- inlineListToMuse inlines - return $ "<class name=\"" <> text name <> "\">" <> contents <> "</class>" -inlineToMuse (Span _ lst) = inlineListToMuse lst + let anchorDoc = if null anchor + then mempty + else text ('#':anchor) <> space + return $ anchorDoc <> (if null inlines && not (null anchor) + then mempty + else (if null names + then "<class>" + else "<class name=\"" <> text (head names) <> "\">") <> contents <> "</class>") diff --git a/src/Text/Pandoc/Writers/Native.hs b/src/Text/Pandoc/Writers/Native.hs index f852bad96..730e3800a 100644 --- a/src/Text/Pandoc/Writers/Native.hs +++ b/src/Text/Pandoc/Writers/Native.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {- Copyright (C) 2006-2018 John MacFarlane <jgm@berkeley.edu> @@ -30,6 +31,7 @@ Conversion of a 'Pandoc' document to a string representation. -} module Text.Pandoc.Writers.Native ( writeNative ) where +import Prelude import Data.List (intersperse) import Data.Text (Text) import Text.Pandoc.Class (PandocMonad) diff --git a/src/Text/Pandoc/Writers/ODT.hs b/src/Text/Pandoc/Writers/ODT.hs index 63a3f915a..7aecb3da5 100644 --- a/src/Text/Pandoc/Writers/ODT.hs +++ b/src/Text/Pandoc/Writers/ODT.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-} {- Copyright (C) 2008-2018 John MacFarlane <jgm@berkeley.edu> @@ -29,6 +30,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Conversion of 'Pandoc' documents to ODT. -} module Text.Pandoc.Writers.ODT ( writeODT ) where +import Prelude import Codec.Archive.Zip import Control.Monad.Except (catchError) import Control.Monad.State.Strict diff --git a/src/Text/Pandoc/Writers/OOXML.hs b/src/Text/Pandoc/Writers/OOXML.hs index 30d8d72dd..9e1c81964 100644 --- a/src/Text/Pandoc/Writers/OOXML.hs +++ b/src/Text/Pandoc/Writers/OOXML.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {- Copyright (C) 2012-2018 John MacFarlane <jgm@berkeley.edu> @@ -39,13 +40,13 @@ module Text.Pandoc.Writers.OOXML ( mknode , fitToPage ) where +import Prelude import Codec.Archive.Zip import Control.Monad.Reader 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 Data.Monoid ((<>)) import Text.Pandoc.Class (PandocMonad) import qualified Text.Pandoc.UTF8 as UTF8 import Text.XML.Light as XML diff --git a/src/Text/Pandoc/Writers/OPML.hs b/src/Text/Pandoc/Writers/OPML.hs index 29e1bc80c..6c48046a2 100644 --- a/src/Text/Pandoc/Writers/OPML.hs +++ b/src/Text/Pandoc/Writers/OPML.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE CPP #-} {- Copyright (C) 2013-2018 John MacFarlane <jgm@berkeley.edu> @@ -29,12 +30,13 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Conversion of 'Pandoc' documents to OPML XML. -} module Text.Pandoc.Writers.OPML ( writeOPML) where +import Prelude import Control.Monad.Except (throwError) import Data.Text (Text, unpack) import qualified Data.Text as T import qualified Text.Pandoc.Builder as B import Text.Pandoc.Class (PandocMonad) -import Text.Pandoc.Compat.Time +import Data.Time import Text.Pandoc.Definition import Text.Pandoc.Error import Text.Pandoc.Options @@ -75,12 +77,7 @@ showDateTimeRFC822 = formatTime defaultTimeLocale "%a, %d %b %Y %X %Z" convertDate :: [Inline] -> String convertDate ils = maybe "" showDateTimeRFC822 $ -#if MIN_VERSION_time(1,5,0) - parseTimeM True -#else - parseTime -#endif - defaultTimeLocale "%F" =<< normalizeDate (stringify ils) + parseTimeM True defaultTimeLocale "%F" =<< normalizeDate (stringify ils) -- | Convert an Element to OPML. elementToOPML :: PandocMonad m => WriterOptions -> Element -> m Doc diff --git a/src/Text/Pandoc/Writers/OpenDocument.hs b/src/Text/Pandoc/Writers/OpenDocument.hs index 17edc0cbd..514327e9a 100644 --- a/src/Text/Pandoc/Writers/OpenDocument.hs +++ b/src/Text/Pandoc/Writers/OpenDocument.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} @@ -32,6 +33,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Conversion of 'Pandoc' documents to OpenDocument XML. -} module Text.Pandoc.Writers.OpenDocument ( writeOpenDocument ) where +import Prelude import Control.Arrow ((***), (>>>)) import Control.Monad.State.Strict hiding (when) import Data.Char (chr) diff --git a/src/Text/Pandoc/Writers/Org.hs b/src/Text/Pandoc/Writers/Org.hs index 72def8e48..a71775e13 100644 --- a/src/Text/Pandoc/Writers/Org.hs +++ b/src/Text/Pandoc/Writers/Org.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {- Copyright (C) 2010-2015 Puneeth Chaganti <punchagan@gmail.com> @@ -35,6 +36,7 @@ Conversion of 'Pandoc' documents to Emacs Org-Mode. Org-Mode: <http://orgmode.org> -} module Text.Pandoc.Writers.Org (writeOrg) where +import Prelude import Control.Monad.State.Strict import Data.Char (isAlphaNum, toLower) import Data.List (intersect, intersperse, isPrefixOf, partition, transpose) @@ -166,8 +168,8 @@ blockToOrg (LineBlock lns) = do (l, _:r) -> l : splitStanza r let joinWithLinefeeds = nowrap . mconcat . intersperse cr let joinWithBlankLines = mconcat . intersperse blankline - let prettyfyStanza ls = joinWithLinefeeds <$> mapM inlineListToOrg ls - contents <- joinWithBlankLines <$> mapM prettyfyStanza (splitStanza lns) + let prettifyStanza ls = joinWithLinefeeds <$> mapM inlineListToOrg ls + contents <- joinWithBlankLines <$> mapM prettifyStanza (splitStanza lns) return $ blankline $$ "#+BEGIN_VERSE" $$ nest 2 contents $$ "#+END_VERSE" <> blankline blockToOrg (RawBlock "html" str) = diff --git a/src/Text/Pandoc/Writers/Powerpoint.hs b/src/Text/Pandoc/Writers/Powerpoint.hs index 645a4cb86..665fd3f57 100644 --- a/src/Text/Pandoc/Writers/Powerpoint.hs +++ b/src/Text/Pandoc/Writers/Powerpoint.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {- @@ -41,6 +42,7 @@ This is a wrapper around two modules: module Text.Pandoc.Writers.Powerpoint (writePowerpoint) where +import Prelude import Codec.Archive.Zip import Text.Pandoc.Definition import Text.Pandoc.Walk diff --git a/src/Text/Pandoc/Writers/Powerpoint/Output.hs b/src/Text/Pandoc/Writers/Powerpoint/Output.hs index b5138b514..865ef1efc 100644 --- a/src/Text/Pandoc/Writers/Powerpoint/Output.hs +++ b/src/Text/Pandoc/Writers/Powerpoint/Output.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE PatternGuards #-} {- @@ -34,6 +35,7 @@ Text.Pandoc.Writers.Powerpoint.Presentation) to a zip archive. module Text.Pandoc.Writers.Powerpoint.Output ( presentationToArchive ) where +import Prelude import Control.Monad.Except (throwError, catchError) import Control.Monad.Reader import Control.Monad.State @@ -41,7 +43,7 @@ import Codec.Archive.Zip import Data.Char (toUpper) import Data.List (intercalate, stripPrefix, nub, union, isPrefixOf, intersperse) import Data.Default -import Text.Pandoc.Compat.Time (formatTime, defaultTimeLocale) +import Data.Time (formatTime, defaultTimeLocale) import Data.Time.Clock (UTCTime) import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, posixSecondsToUTCTime) import System.FilePath.Posix (splitDirectories, splitExtension, takeExtension) @@ -56,7 +58,7 @@ import Text.Pandoc.MIME import qualified Data.ByteString.Lazy as BL import Text.Pandoc.Writers.OOXML import qualified Data.Map as M -import Data.Maybe (mapMaybe, listToMaybe, fromMaybe, isJust, maybeToList, catMaybes) +import Data.Maybe (mapMaybe, listToMaybe, fromMaybe, maybeToList, catMaybes) import Text.Pandoc.ImageSize import Control.Applicative ((<|>)) import System.FilePath.Glob @@ -281,8 +283,9 @@ makeSlideIdMap (Presentation _ slides) = makeSpeakerNotesMap :: Presentation -> M.Map Int Int makeSpeakerNotesMap (Presentation _ slides) = M.fromList $ (mapMaybe f $ slides `zip` [1..]) `zip` [1..] - where f (Slide _ _ Nothing, _) = Nothing - f (Slide _ _ (Just _), n) = Just n + where f (Slide _ _ notes, n) = if notes == mempty + then Nothing + else Just n presentationToArchive :: PandocMonad m => WriterOptions -> Presentation -> m Archive presentationToArchive opts pres = do @@ -322,13 +325,11 @@ presentationToArchive opts pres = do -- Check to see if the presentation has speaker notes. This will -- influence whether we import the notesMaster template. presHasSpeakerNotes :: Presentation -> Bool -presHasSpeakerNotes (Presentation _ slides) = any isJust $ map slideSpeakerNotes slides +presHasSpeakerNotes (Presentation _ slides) = not $ all (mempty ==) $ map slideSpeakerNotes slides curSlideHasSpeakerNotes :: PandocMonad m => P m Bool -curSlideHasSpeakerNotes = do - sldId <- asks envCurSlideId - notesIdMap <- asks envSpeakerNotesIdMap - return $ isJust $ M.lookup sldId notesIdMap +curSlideHasSpeakerNotes = + M.member <$> asks envCurSlideId <*> asks envSpeakerNotesIdMap -------------------------------------------------- @@ -339,17 +340,9 @@ getLayout layout = do (TitleSlide _) -> "ppt/slideLayouts/slideLayout3.xml" (ContentSlide _ _) -> "ppt/slideLayouts/slideLayout2.xml" (TwoColumnSlide _ _ _) -> "ppt/slideLayouts/slideLayout4.xml" + refArchive <- asks envRefArchive distArchive <- asks envDistArchive - root <- case findEntryByPath layoutpath distArchive of - Just e -> case parseXMLDoc $ UTF8.toStringLazy $ fromEntry e of - Just element -> return $ element - Nothing -> throwError $ - PandocSomeError $ - layoutpath ++ " corrupt in reference file" - Nothing -> throwError $ - PandocSomeError $ - layoutpath ++ " missing in reference file" - return root + parseXml refArchive distArchive layoutpath shapeHasId :: NameSpaces -> String -> Element -> Bool shapeHasId ns ident element @@ -930,6 +923,13 @@ graphicFrameToElements layout tbls caption = do return [graphicFrameElts, capElt] else return [graphicFrameElts] +getDefaultTableStyle :: PandocMonad m => P m (Maybe String) +getDefaultTableStyle = do + refArchive <- asks envRefArchive + distArchive <- asks envDistArchive + tblStyleLst <- parseXml refArchive distArchive "ppt/tableStyles.xml" + return $ findAttr (QName "def" Nothing Nothing) tblStyleLst + graphicToElement :: PandocMonad m => Integer -> Graphic -> P m Element graphicToElement tableWidth (Tbl tblPr hdrCells rows) = do let colWidths = if null hdrCells @@ -967,12 +967,19 @@ graphicToElement tableWidth (Tbl tblPr hdrCells rows) = do let mkgridcol w = mknode "a:gridCol" [("w", show ((12700 * w) :: Integer))] () let hasHeader = not (all null hdrCells) + + mbDefTblStyle <- getDefaultTableStyle + let tblPrElt = mknode "a:tblPr" + [ ("firstRow", if tblPrFirstRow tblPr then "1" else "0") + , ("bandRow", if tblPrBandRow tblPr then "1" else "0") + ] (case mbDefTblStyle of + Nothing -> [] + Just sty -> [mknode "a:tableStyleId" [] sty]) + return $ mknode "a:graphic" [] $ [mknode "a:graphicData" [("uri", "http://schemas.openxmlformats.org/drawingml/2006/table")] $ [mknode "a:tbl" [] $ - [ mknode "a:tblPr" [ ("firstRow", if tblPrFirstRow tblPr then "1" else "0") - , ("bandRow", if tblPrBandRow tblPr then "1" else "0") - ] () + [ tblPrElt , mknode "a:tblGrid" [] (if all (==0) colWidths then [] else map mkgridcol colWidths) @@ -994,6 +1001,14 @@ getShapeByPlaceHolderType ns spTreeElem phType filterChild findPhType spTreeElem | otherwise = Nothing +-- Like the above, but it tries a number of different placeholder types +getShapeByPlaceHolderTypes :: NameSpaces -> Element -> [String] -> Maybe Element +getShapeByPlaceHolderTypes _ _ [] = Nothing +getShapeByPlaceHolderTypes ns spTreeElem (s:ss) = + case getShapeByPlaceHolderType ns spTreeElem s of + Just element -> Just element + Nothing -> getShapeByPlaceHolderTypes ns spTreeElem ss + getShapeByPlaceHolderIndex :: NameSpaces -> Element -> String -> Maybe Element getShapeByPlaceHolderIndex ns spTreeElem phIdx | isElem ns "p" "spTree" spTreeElem = @@ -1008,12 +1023,12 @@ getShapeByPlaceHolderIndex ns spTreeElem phIdx | otherwise = Nothing -nonBodyTextToElement :: PandocMonad m => Element -> String -> [ParaElem] -> P m Element -nonBodyTextToElement layout phType paraElements +nonBodyTextToElement :: PandocMonad m => Element -> [String] -> [ParaElem] -> P m Element +nonBodyTextToElement layout phTypes paraElements | ns <- elemToNameSpaces layout , Just cSld <- findChild (elemName ns "p" "cSld") layout , Just spTree <- findChild (elemName ns "p" "spTree") cSld - , Just sp <- getShapeByPlaceHolderType ns spTree phType = do + , Just sp <- getShapeByPlaceHolderTypes ns spTree phTypes = do let hdrPara = Paragraph def paraElements element <- paragraphToElement hdrPara let txBody = mknode "p:txBody" [] $ @@ -1028,7 +1043,7 @@ contentToElement layout hdrShape shapes | ns <- elemToNameSpaces layout , Just cSld <- findChild (elemName ns "p" "cSld") layout , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do - element <- nonBodyTextToElement layout "title" hdrShape + element <- nonBodyTextToElement layout ["title"] hdrShape let hdrShapeElements = if null hdrShape then [] else [element] @@ -1046,7 +1061,7 @@ twoColumnToElement layout hdrShape shapesL shapesR | ns <- elemToNameSpaces layout , Just cSld <- findChild (elemName ns "p" "cSld") layout , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do - element <- nonBodyTextToElement layout "title" hdrShape + element <- nonBodyTextToElement layout ["title"] hdrShape let hdrShapeElements = if null hdrShape then [] else [element] @@ -1070,7 +1085,7 @@ titleToElement layout titleElems | ns <- elemToNameSpaces layout , Just cSld <- findChild (elemName ns "p" "cSld") layout , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do - element <- nonBodyTextToElement layout "title" titleElems + element <- nonBodyTextToElement layout ["title", "ctrTitle"] titleElems let titleShapeElements = if null titleElems then [] else [element] @@ -1084,15 +1099,15 @@ metadataToElement layout titleElems subtitleElems authorsElems dateElems , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do titleShapeElements <- if null titleElems then return [] - else sequence [nonBodyTextToElement layout "ctrTitle" titleElems] + else sequence [nonBodyTextToElement layout ["ctrTitle"] titleElems] let combinedAuthorElems = intercalate [Break] authorsElems subtitleAndAuthorElems = intercalate [Break, Break] [subtitleElems, combinedAuthorElems] subtitleShapeElements <- if null subtitleAndAuthorElems then return [] - else sequence [nonBodyTextToElement layout "subTitle" subtitleAndAuthorElems] + else sequence [nonBodyTextToElement layout ["subTitle"] subtitleAndAuthorElems] dateShapeElements <- if null dateElems then return [] - else sequence [nonBodyTextToElement layout "dt" dateElems] + else sequence [nonBodyTextToElement layout ["dt"] dateElems] return $ replaceNamedChildren ns "p" "sp" (titleShapeElements ++ subtitleShapeElements ++ dateShapeElements) spTree @@ -1144,18 +1159,9 @@ slideToElement (Slide _ l@(MetadataSlide titleElems subtitleElems authorElems da getNotesMaster :: PandocMonad m => P m Element getNotesMaster = do - let notesMasterPath = "ppt/notesMasters/notesMaster1.xml" + refArchive <- asks envRefArchive distArchive <- asks envDistArchive - root <- case findEntryByPath notesMasterPath distArchive of - Just e -> case parseXMLDoc $ UTF8.toStringLazy $ fromEntry e of - Just element -> return $ element - Nothing -> throwError $ - PandocSomeError $ - notesMasterPath ++ " corrupt in reference file" - Nothing -> throwError $ - PandocSomeError $ - notesMasterPath ++ " missing in reference file" - return root + parseXml refArchive distArchive "ppt/notesMasters/notesMaster1.xml" getSlideNumberFieldId :: PandocMonad m => Element -> P m String getSlideNumberFieldId notesMaster @@ -1256,42 +1262,40 @@ speakerNotesSlideNumber pgNum fieldId = ] slideToSpeakerNotesElement :: PandocMonad m => Slide -> P m (Maybe Element) -slideToSpeakerNotesElement slide - | Slide _ _ mbNotes <- slide - , Just (SpeakerNotes paras) <- mbNotes = do - master <- getNotesMaster - fieldId <- getSlideNumberFieldId master - num <- slideNum slide - let imgShape = speakerNotesSlideImage - sldNumShape = speakerNotesSlideNumber num fieldId - bodyShape <- speakerNotesBody paras - return $ Just $ - mknode "p:notes" - [ ("xmlns:a", "http://schemas.openxmlformats.org/drawingml/2006/main") - , ("xmlns:r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships") - , ("xmlns:p", "http://schemas.openxmlformats.org/presentationml/2006/main") - ] [ mknode "p:cSld" [] - [ mknode "p:spTree" [] - [ mknode "p:nvGrpSpPr" [] - [ mknode "p:cNvPr" [("id", "1"), ("name", "")] () - , mknode "p:cNvGrpSpPr" [] () - , mknode "p:nvPr" [] () - ] - , mknode "p:grpSpPr" [] - [ mknode "a:xfrm" [] - [ mknode "a:off" [("x", "0"), ("y", "0")] () - , mknode "a:ext" [("cx", "0"), ("cy", "0")] () - , mknode "a:chOff" [("x", "0"), ("y", "0")] () - , mknode "a:chExt" [("cx", "0"), ("cy", "0")] () - ] - ] - , imgShape - , bodyShape - , sldNumShape +slideToSpeakerNotesElement (Slide _ _ (SpeakerNotes [])) = return Nothing +slideToSpeakerNotesElement slide@(Slide _ _ (SpeakerNotes paras)) = do + master <- getNotesMaster + fieldId <- getSlideNumberFieldId master + num <- slideNum slide + let imgShape = speakerNotesSlideImage + sldNumShape = speakerNotesSlideNumber num fieldId + bodyShape <- speakerNotesBody paras + return $ Just $ + mknode "p:notes" + [ ("xmlns:a", "http://schemas.openxmlformats.org/drawingml/2006/main") + , ("xmlns:r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships") + , ("xmlns:p", "http://schemas.openxmlformats.org/presentationml/2006/main") + ] [ mknode "p:cSld" [] + [ mknode "p:spTree" [] + [ mknode "p:nvGrpSpPr" [] + [ mknode "p:cNvPr" [("id", "1"), ("name", "")] () + , mknode "p:cNvGrpSpPr" [] () + , mknode "p:nvPr" [] () ] + , mknode "p:grpSpPr" [] + [ mknode "a:xfrm" [] + [ mknode "a:off" [("x", "0"), ("y", "0")] () + , mknode "a:ext" [("cx", "0"), ("cy", "0")] () + , mknode "a:chOff" [("x", "0"), ("y", "0")] () + , mknode "a:chExt" [("cx", "0"), ("cy", "0")] () + ] ] + , imgShape + , bodyShape + , sldNumShape ] -slideToSpeakerNotesElement _ = return Nothing + ] + ] ----------------------------------------------------------------------- @@ -1466,23 +1470,22 @@ slideToSpeakerNotesEntry slide = do _ -> return Nothing slideToSpeakerNotesRelElement :: PandocMonad m => Slide -> P m (Maybe Element) -slideToSpeakerNotesRelElement slide - | Slide _ _ mbNotes <- slide - , Just _ <- mbNotes = do - idNum <- slideNum slide - return $ Just $ - mknode "Relationships" - [("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") - ] () - , mknode "Relationship" [ ("Id", "rId1") - , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/notesMaster") - , ("Target", "../notesMasters/notesMaster1.xml") - ] () - ] -slideToSpeakerNotesRelElement _ = return Nothing +slideToSpeakerNotesRelElement (Slide _ _ (SpeakerNotes [])) = return Nothing +slideToSpeakerNotesRelElement slide@(Slide _ _ _) = do + idNum <- slideNum slide + return $ Just $ + mknode "Relationships" + [("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") + ] () + , mknode "Relationship" [ ("Id", "rId1") + , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/notesMaster") + , ("Target", "../notesMasters/notesMaster1.xml") + ] () + ] + slideToSpeakerNotesRelEntry :: PandocMonad m => Slide -> P m (Maybe Entry) slideToSpeakerNotesRelEntry slide = do diff --git a/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs b/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs index ac7c86945..e14476b16 100644 --- a/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs +++ b/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs @@ -1,4 +1,6 @@ -{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {- Copyright (C) 2017-2018 Jesse Rosenthal <jrosenthal@jhu.edu> @@ -57,6 +59,7 @@ module Text.Pandoc.Writers.Powerpoint.Presentation ( documentToPresentation ) where +import Prelude import Control.Monad.Reader import Control.Monad.State import Data.List (intercalate) @@ -67,7 +70,7 @@ import Text.Pandoc.Slides (getSlideLevel) import Text.Pandoc.Options import Text.Pandoc.Logging import Text.Pandoc.Walk -import Text.Pandoc.Compat.Time (UTCTime) +import Data.Time (UTCTime) import qualified Text.Pandoc.Shared as Shared -- so we don't overlap "Element" import Text.Pandoc.Writers.Shared (metaValueToInlines) import qualified Data.Map as M @@ -110,7 +113,7 @@ data WriterState = WriterState { stNoteIds :: M.Map Int [Block] , stAnchorMap :: M.Map String SlideId , stSlideIdSet :: S.Set SlideId , stLog :: [LogMessage] - , stSpeakerNotesMap :: M.Map SlideId [[Paragraph]] + , stSpeakerNotes :: SpeakerNotes } deriving (Show, Eq) instance Default WriterState where @@ -119,7 +122,7 @@ instance Default WriterState where -- we reserve this s , stSlideIdSet = reservedSlideIds , stLog = [] - , stSpeakerNotesMap = mempty + , stSpeakerNotes = mempty } metadataSlideId :: SlideId @@ -183,7 +186,7 @@ data DocProps = DocProps { dcTitle :: Maybe String data Slide = Slide { slideId :: SlideId , slideLayout :: Layout - , slideSpeakerNotes :: Maybe SpeakerNotes + , slideSpeakerNotes :: SpeakerNotes } deriving (Show, Eq) newtype SlideId = SlideId String @@ -193,7 +196,7 @@ newtype SlideId = SlideId String -- designed mainly for one textbox, so we'll just put in the contents -- of that textbox, to avoid other shapes that won't work as well. newtype SpeakerNotes = SpeakerNotes {fromSpeakerNotes :: [Paragraph]} - deriving (Show, Eq) + deriving (Show, Eq, Monoid, Semigroup) data Layout = MetadataSlide { metadataSlideTitle :: [ParaElem] , metadataSlideSubtitle :: [ParaElem] @@ -229,7 +232,6 @@ data Paragraph = Paragraph { paraProps :: ParaProps , paraElems :: [ParaElem] } deriving (Show, Eq) - data BulletType = Bullet | AutoNumbering ListAttributes deriving (Show, Eq) @@ -374,9 +376,20 @@ inlineToParElems (Note blks) = do modify $ \st -> st { stNoteIds = M.insert curNoteId blks notes } local (\env -> env{envRunProps = (envRunProps env){rLink = Just $ InternalTarget endNotesSlideId}}) $ inlineToParElems $ Superscript [Str $ show curNoteId] -inlineToParElems (Span _ ils) = concatMapM inlineToParElems ils +inlineToParElems (Span _ ils) = inlinesToParElems ils +inlineToParElems (Quoted quoteType ils) = + inlinesToParElems $ [Str open] ++ ils ++ [Str close] + where (open, close) = case quoteType of + SingleQuote -> ("\x2018", "\x2019") + DoubleQuote -> ("\x201C", "\x201D") inlineToParElems (RawInline _ _) = return [] -inlineToParElems _ = return [] +inlineToParElems (Cite _ ils) = inlinesToParElems ils +-- Note: we shouldn't reach this, because images should be handled at +-- the shape level, but should that change in the future, we render +-- the alt text. +inlineToParElems (Image _ alt _) = inlinesToParElems alt + + isListType :: Block -> Bool isListType (OrderedList _ _) = True @@ -399,10 +412,7 @@ noteSize :: Pixels noteSize = 18 blockToParagraphs :: Block -> Pres [Paragraph] -blockToParagraphs (Plain ils) = do - parElems <- inlinesToParElems ils - pProps <- asks envParaProps - return [Paragraph pProps parElems] +blockToParagraphs (Plain ils) = blockToParagraphs (Para ils) blockToParagraphs (Para ils) = do parElems <- inlinesToParElems ils pProps <- asks envParaProps @@ -475,16 +485,6 @@ blockToParagraphs (DefinitionList entries) = do definition <- concatMapM (blockToParagraphs . BlockQuote) blksLst return $ term ++ definition concatMapM go entries -blockToParagraphs (Div (_, "notes" : [], _) blks) = - local (\env -> env{envInSpeakerNotes=True}) $ do - sldId <- asks envCurSlideId - spkNotesMap <- gets stSpeakerNotesMap - paras <- concatMapM blockToParagraphs blks - let spkNotesMap' = case M.lookup sldId spkNotesMap of - Just lst -> M.insert sldId (paras : lst) spkNotesMap - Nothing -> M.insert sldId [paras] spkNotesMap - modify $ \st -> st{stSpeakerNotesMap = spkNotesMap'} - return [] blockToParagraphs (Div _ blks) = concatMapM blockToParagraphs blks blockToParagraphs blk = do addLogMessage $ BlockNotRendered blk @@ -527,14 +527,9 @@ withAttr attr (Pic picPr url caption) = withAttr _ sp = sp blockToShape :: Block -> Pres Shape -blockToShape (Plain (il:_)) | Image attr ils (url, _) <- il = - (withAttr attr . Pic def url) <$> inlinesToParElems ils +blockToShape (Plain ils) = blockToShape (Para ils) blockToShape (Para (il:_)) | Image attr ils (url, _) <- il = (withAttr attr . Pic def url) <$> inlinesToParElems ils -blockToShape (Plain (il:_)) | Link _ (il':_) target <- il - , Image attr ils (url, _) <- il' = - (withAttr attr . Pic def {picPropLink = Just $ ExternalTarget target} url) <$> - inlinesToParElems ils blockToShape (Para (il:_)) | Link _ (il':_) target <- il , Image attr ils (url, _) <- il' = (withAttr attr . Pic def{picPropLink = Just $ ExternalTarget target} url) <$> @@ -558,20 +553,23 @@ blockToShape blk = do paras <- blockToParagraphs blk combineShapes :: [Shape] -> [Shape] combineShapes [] = [] -combineShapes[s] = [s] -combineShapes (pic@(Pic{}) : ss) = pic : combineShapes ss +combineShapes (pic@Pic{} : ss) = pic : combineShapes ss combineShapes (TextBox [] : ss) = combineShapes ss combineShapes (s : TextBox [] : ss) = combineShapes (s : ss) combineShapes (TextBox (p:ps) : TextBox (p':ps') : ss) = combineShapes $ TextBox ((p:ps) ++ (p':ps')) : ss combineShapes (s:ss) = s : combineShapes ss +isNotesDiv :: Block -> Bool +isNotesDiv (Div (_, ["notes"], _) _) = True +isNotesDiv _ = False + blocksToShapes :: [Block] -> Pres [Shape] blocksToShapes blks = combineShapes <$> mapM blockToShape blks isImage :: Inline -> Bool -isImage (Image{}) = True -isImage (Link _ (Image _ _ _ : _) _) = True +isImage Image{} = True +isImage (Link _ (Image{} : _) _) = True isImage _ = False splitBlocks' :: [Block] -> [[Block]] -> [Block] -> Pres [[Block]] @@ -589,64 +587,60 @@ splitBlocks' cur acc (h@(Header n _ _) : blks) = do splitBlocks' cur acc (Plain ils : blks) = splitBlocks' cur acc (Para ils : blks) splitBlocks' cur acc (Para (il:ils) : blks) | isImage il = do slideLevel <- asks envSlideLevel + let (nts, blks') = if null ils + then span isNotesDiv blks + else ([], blks) case cur of - [(Header n _ _)] | n == slideLevel -> + [Header n _ _] | n == slideLevel -> splitBlocks' [] - (acc ++ [cur ++ [Para [il]]]) - (if null ils then blks else Para ils : blks) + (acc ++ [cur ++ [Para [il]] ++ nts]) + (if null ils then blks' else Para ils : blks') _ -> splitBlocks' [] - (acc ++ (if null cur then [] else [cur]) ++ [[Para [il]]]) - (if null ils then blks else Para ils : blks) -splitBlocks' cur acc (tbl@(Table{}) : blks) = do + (acc ++ (if null cur then [] else [cur]) ++ [[Para [il]] ++ nts]) + (if null ils then blks' else Para ils : blks') +splitBlocks' cur acc (tbl@Table{} : blks) = do slideLevel <- asks envSlideLevel + let (nts, blks') = span isNotesDiv blks case cur of - [(Header n _ _)] | n == slideLevel -> - splitBlocks' [] (acc ++ [cur ++ [tbl]]) blks - _ -> splitBlocks' [] (acc ++ (if null cur then [] else [cur]) ++ [[tbl]]) blks + [Header n _ _] | n == slideLevel -> + splitBlocks' [] (acc ++ [cur ++ [tbl] ++ nts]) blks' + _ -> splitBlocks' [] (acc ++ (if null cur then [] else [cur]) ++ [[tbl] ++ nts]) blks' splitBlocks' cur acc (d@(Div (_, classes, _) _): blks) | "columns" `elem` classes = do slideLevel <- asks envSlideLevel + let (nts, blks') = span isNotesDiv blks case cur of - [(Header n _ _)] | n == slideLevel -> - splitBlocks' [] (acc ++ [cur ++ [d]]) blks - _ -> splitBlocks' [] (acc ++ (if null cur then [] else [cur]) ++ [[d]]) blks + [Header n _ _] | n == slideLevel -> + splitBlocks' [] (acc ++ [cur ++ [d] ++ nts]) blks' + _ -> splitBlocks' [] (acc ++ (if null cur then [] else [cur]) ++ [[d] ++ nts]) blks' splitBlocks' cur acc (blk : blks) = splitBlocks' (cur ++ [blk]) acc blks splitBlocks :: [Block] -> Pres [[Block]] splitBlocks = splitBlocks' [] [] -getSpeakerNotes :: Pres (Maybe SpeakerNotes) -getSpeakerNotes = do - sldId <- asks envCurSlideId - spkNtsMap <- gets stSpeakerNotesMap - return $ (SpeakerNotes . concat . reverse) <$> (M.lookup sldId spkNtsMap) - -blocksToSlide' :: Int -> [Block] -> Pres Slide -blocksToSlide' lvl (Header n (ident, _, _) ils : blks) +blocksToSlide' :: Int -> [Block] -> SpeakerNotes -> Pres Slide +blocksToSlide' lvl (Header n (ident, _, _) ils : blks) spkNotes | n < lvl = do registerAnchorId ident sldId <- asks envCurSlideId hdr <- inlinesToParElems ils - return $ Slide sldId TitleSlide {titleSlideHeader = hdr} Nothing + return $ Slide sldId TitleSlide {titleSlideHeader = hdr} spkNotes | n == lvl = do registerAnchorId ident hdr <- inlinesToParElems ils -- Now get the slide without the header, and then add the header -- in. - slide <- blocksToSlide' lvl blks + slide <- blocksToSlide' lvl blks spkNotes let layout = case slideLayout slide of ContentSlide _ cont -> ContentSlide hdr cont TwoColumnSlide _ contL contR -> TwoColumnSlide hdr contL contR layout' -> layout' return $ slide{slideLayout = layout} -blocksToSlide' _ (blk : blks) +blocksToSlide' _ (blk : blks) spkNotes | Div (_, classes, _) divBlks <- blk , "columns" `elem` classes , Div (_, clsL, _) blksL : Div (_, clsR, _) blksR : remaining <- divBlks , "column" `elem` clsL, "column" `elem` clsR = do - unless (null blks) - (mapM (addLogMessage . BlockNotRendered) blks >> return ()) - unless (null remaining) - (mapM (addLogMessage . BlockNotRendered) remaining >> return ()) + mapM_ (addLogMessage . BlockNotRendered) (blks ++ remaining) mbSplitBlksL <- splitBlocks blksL mbSplitBlksR <- splitBlocks blksR let blksL' = case mbSplitBlksL of @@ -664,8 +658,8 @@ blocksToSlide' _ (blk : blks) , twoColumnSlideLeft = shapesL , twoColumnSlideRight = shapesR } - Nothing -blocksToSlide' _ (blk : blks) = do + spkNotes +blocksToSlide' _ (blk : blks) spkNotes = do inNoteSlide <- asks envInNoteSlide shapes <- if inNoteSlide then forceFontSize noteSize $ blocksToShapes (blk : blks) @@ -677,8 +671,8 @@ blocksToSlide' _ (blk : blks) = do ContentSlide { contentSlideHeader = [] , contentSlideContent = shapes } - Nothing -blocksToSlide' _ [] = do + spkNotes +blocksToSlide' _ [] spkNotes = do sldId <- asks envCurSlideId return $ Slide @@ -686,14 +680,32 @@ blocksToSlide' _ [] = do ContentSlide { contentSlideHeader = [] , contentSlideContent = [] } - Nothing + spkNotes + +handleNotes :: Block -> Pres () +handleNotes (Div (_, ["notes"], _) blks) = + local (\env -> env{envInSpeakerNotes=True}) $ do + spNotes <- SpeakerNotes <$> concatMapM blockToParagraphs blks + modify $ \st -> st{stSpeakerNotes = (stSpeakerNotes st) <> spNotes} +handleNotes _ = return () + +handleAndFilterNotes' :: [Block] -> Pres [Block] +handleAndFilterNotes' blks = do + mapM_ handleNotes blks + return $ filter (not . isNotesDiv) blks + +handleAndFilterNotes :: [Block] -> Pres ([Block], SpeakerNotes) +handleAndFilterNotes blks = do + modify $ \st -> st{stSpeakerNotes = mempty} + blks' <- walkM handleAndFilterNotes' blks + spkNotes <- gets stSpeakerNotes + return (blks', spkNotes) blocksToSlide :: [Block] -> Pres Slide blocksToSlide blks = do + (blks', spkNotes) <- handleAndFilterNotes blks slideLevel <- asks envSlideLevel - sld <- blocksToSlide' slideLevel blks - spkNotes <- getSpeakerNotes - return $ sld{slideSpeakerNotes = spkNotes} + blocksToSlide' slideLevel blks' spkNotes makeNoteEntry :: Int -> [Block] -> [Block] makeNoteEntry n blks = @@ -719,15 +731,14 @@ makeEndNotesSlideBlocks = do anchorSet <- M.keysSet <$> gets stAnchorMap if M.null noteIds then return [] - else do let title = case lookupMeta "notes-title" meta of - Just val -> metaValueToInlines val - Nothing -> [Str "Notes"] - ident = Shared.uniqueIdent title anchorSet - hdr = Header slideLevel (ident, [], []) title - blks <- return $ - concatMap (\(n, bs) -> makeNoteEntry n bs) $ + else let title = case lookupMeta "notes-title" meta of + Just val -> metaValueToInlines val + Nothing -> [Str "Notes"] + ident = Shared.uniqueIdent title anchorSet + hdr = Header slideLevel (ident, [], []) title + blks = concatMap (\(n, bs) -> makeNoteEntry n bs) $ M.toList noteIds - return $ hdr : blks + in return $ hdr : blks getMetaSlide :: Pres (Maybe Slide) getMetaSlide = do @@ -753,7 +764,7 @@ getMetaSlide = do , metadataSlideAuthors = authors , metadataSlideDate = date } - Nothing + mempty -- adapted from the markdown writer elementToListItem :: Shared.Element -> Pres [Block] @@ -778,8 +789,7 @@ makeTOCSlide blks = local (\env -> env{envCurSlideId = tocSlideId}) $ do Just val -> metaValueToInlines val Nothing -> [Str "Table of Contents"] hdr = Header slideLevel nullAttr tocTitle - sld <- blocksToSlide [hdr, contents] - return sld + blocksToSlide [hdr, contents] combineParaElems' :: Maybe ParaElem -> [ParaElem] -> [ParaElem] combineParaElems' mbPElem [] = maybeToList mbPElem @@ -802,15 +812,9 @@ applyToParagraph f para = do return $ para {paraElems = paraElems'} applyToShape :: Monad m => (ParaElem -> m ParaElem) -> Shape -> m Shape -applyToShape f (Pic pPr fp pes) = do - pes' <- mapM f pes - return $ Pic pPr fp pes' -applyToShape f (GraphicFrame gfx pes) = do - pes' <- mapM f pes - return $ GraphicFrame gfx pes' -applyToShape f (TextBox paras) = do - paras' <- mapM (applyToParagraph f) paras - return $ TextBox paras' +applyToShape f (Pic pPr fp pes) = Pic pPr fp <$> mapM f pes +applyToShape f (GraphicFrame gfx pes) = GraphicFrame gfx <$> mapM f pes +applyToShape f (TextBox paras) = TextBox <$> mapM (applyToParagraph f) paras applyToLayout :: Monad m => (ParaElem -> m ParaElem) -> Layout -> m Layout applyToLayout f (MetadataSlide title subtitle authors date) = do @@ -819,9 +823,7 @@ applyToLayout f (MetadataSlide title subtitle authors date) = do authors' <- mapM (mapM f) authors date' <- mapM f date return $ MetadataSlide title' subtitle' authors' date' -applyToLayout f (TitleSlide title) = do - title' <- mapM f title - return $ TitleSlide title' +applyToLayout f (TitleSlide title) = TitleSlide <$> mapM f title applyToLayout f (ContentSlide hdr content) = do hdr' <- mapM f hdr content' <- mapM (applyToShape f) content @@ -835,11 +837,9 @@ applyToLayout f (TwoColumnSlide hdr contentL contentR) = do applyToSlide :: Monad m => (ParaElem -> m ParaElem) -> Slide -> m Slide applyToSlide f slide = do layout' <- applyToLayout f $ slideLayout slide - mbNotes' <- case slideSpeakerNotes slide of - Just (SpeakerNotes notes) -> (Just . SpeakerNotes) <$> - mapM (applyToParagraph f) notes - Nothing -> return Nothing - return slide{slideLayout = layout', slideSpeakerNotes = mbNotes'} + let paras = fromSpeakerNotes $ slideSpeakerNotes slide + notes' <- SpeakerNotes <$> mapM (applyToParagraph f) paras + return slide{slideLayout = layout', slideSpeakerNotes = notes'} replaceAnchor :: ParaElem -> Pres ParaElem replaceAnchor (Run rProps s) @@ -853,6 +853,40 @@ replaceAnchor (Run rProps s) return $ Run rProps' s replaceAnchor pe = return pe +emptyParaElem :: ParaElem -> Bool +emptyParaElem (Run _ s) = + null $ Shared.trim s +emptyParaElem (MathElem _ ts) = + null $ Shared.trim $ unTeXString ts +emptyParaElem _ = False + +emptyParagraph :: Paragraph -> Bool +emptyParagraph para = all emptyParaElem $ paraElems para + + +emptyShape :: Shape -> Bool +emptyShape (TextBox paras) = all emptyParagraph paras +emptyShape _ = False + +emptyLayout :: Layout -> Bool +emptyLayout layout = case layout of + MetadataSlide title subtitle authors date -> + all emptyParaElem title && + all emptyParaElem subtitle && + all (all emptyParaElem) authors && + all emptyParaElem date + TitleSlide hdr -> all emptyParaElem hdr + ContentSlide hdr shapes -> + all emptyParaElem hdr && + all emptyShape shapes + TwoColumnSlide hdr shapes1 shapes2 -> + all emptyParaElem hdr && + all emptyShape shapes1 && + all emptyShape shapes2 + +emptySlide :: Slide -> Bool +emptySlide (Slide _ layout notes) = (notes == mempty) && (emptyLayout layout) + blocksToPresentationSlides :: [Block] -> Pres [Slide] blocksToPresentationSlides blks = do opts <- asks envOpts @@ -893,7 +927,8 @@ blocksToPresentationSlides blks = do return [endNotesSlide] let slides = metadataslides ++ tocSlides ++ bodyslides ++ endNotesSlides - mapM (applyToSlide replaceAnchor) slides + slides' = filter (not . emptySlide) slides + mapM (applyToSlide replaceAnchor) slides' metaToDocProps :: Meta -> DocProps metaToDocProps meta = diff --git a/src/Text/Pandoc/Writers/RST.hs b/src/Text/Pandoc/Writers/RST.hs index 95cb46643..f82597c55 100644 --- a/src/Text/Pandoc/Writers/RST.hs +++ b/src/Text/Pandoc/Writers/RST.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {- Copyright (C) 2006-2018 John MacFarlane <jgm@berkeley.edu> @@ -30,7 +31,8 @@ Conversion of 'Pandoc' documents to reStructuredText. reStructuredText: <http://docutils.sourceforge.net/rst.html> -} -module Text.Pandoc.Writers.RST ( writeRST ) where +module Text.Pandoc.Writers.RST ( writeRST, flatten ) where +import Prelude import Control.Monad.State.Strict import Data.Char (isSpace, toLower) import Data.List (isPrefixOf, stripPrefix) @@ -46,6 +48,7 @@ import Text.Pandoc.Pretty import Text.Pandoc.Shared import Text.Pandoc.Templates (renderTemplate') import Text.Pandoc.Writers.Shared +import Text.Pandoc.Walk type Refs = [([Inline], Target)] @@ -260,7 +263,6 @@ blockToRST (Header level (name,classes,_) inlines) = do return $ nowrap $ hang 3 ".. " (rub $$ name' $$ cls) $$ blankline blockToRST (CodeBlock (_,classes,kvs) str) = do opts <- gets stOptions - let tabstop = writerTabStop opts let startnum = maybe "" (\x -> " " <> text x) $ lookup "startFrom" kvs let numberlines = if "numberLines" `elem` classes then " :number-lines:" <> startnum @@ -273,11 +275,10 @@ blockToRST (CodeBlock (_,classes,kvs) str) = do c `notElem` ["sourceCode","literate","numberLines"]] of [] -> "::" (lang:_) -> (".. code:: " <> text lang) $$ numberlines) - $+$ nest tabstop (text str) $$ blankline + $+$ nest 3 (text str) $$ blankline blockToRST (BlockQuote blocks) = do - tabstop <- gets $ writerTabStop . stOptions contents <- blockListToRST blocks - return $ nest tabstop contents <> blankline + return $ nest 3 contents <> blankline blockToRST (Table caption aligns widths headers rows) = do caption' <- inlineListToRST caption let blocksToDoc opts bs = do @@ -335,8 +336,7 @@ definitionListItemToRST :: PandocMonad m => ([Inline], [[Block]]) -> RST m Doc definitionListItemToRST (label, defs) = do label' <- inlineListToRST label contents <- liftM vcat $ mapM blockListToRST defs - tabstop <- gets $ writerTabStop . stOptions - return $ nowrap label' $$ nest tabstop (nestle contents <> cr) + return $ nowrap label' $$ nest 3 (nestle contents <> cr) -- | Format a list of lines as line block. linesToLineBlock :: PandocMonad m => [[Inline]] -> RST m Doc @@ -376,12 +376,27 @@ blockListToRST :: PandocMonad m -> RST m Doc blockListToRST = blockListToRST' False --- | Convert list of Pandoc inline elements to RST. -inlineListToRST :: PandocMonad m => [Inline] -> RST m Doc -inlineListToRST lst = - mapM inlineToRST (removeSpaceAfterDisplayMath $ insertBS lst) >>= - return . hcat - where -- remove spaces after displaymath, as they screw up indentation: +transformInlines :: [Inline] -> [Inline] +transformInlines = insertBS . + filter hasContents . + removeSpaceAfterDisplayMath . + concatMap (transformNested . flatten) + where -- empty inlines are not valid RST syntax + hasContents :: Inline -> Bool + hasContents (Str "") = False + hasContents (Emph []) = False + hasContents (Strong []) = False + hasContents (Strikeout []) = False + hasContents (Superscript []) = False + hasContents (Subscript []) = False + hasContents (SmallCaps []) = False + hasContents (Quoted _ []) = False + hasContents (Cite _ []) = False + hasContents (Span _ []) = False + hasContents (Link _ [] ("", "")) = False + hasContents (Image _ [] ("", "")) = False + hasContents _ = True + -- remove spaces after displaymath, as they screw up indentation: removeSpaceAfterDisplayMath (Math DisplayMath x : zs) = Math DisplayMath x : dropWhile (==Space) zs removeSpaceAfterDisplayMath (x:xs) = x : removeSpaceAfterDisplayMath xs @@ -399,6 +414,8 @@ inlineListToRST lst = x : insertBS (y : zs) insertBS (x:ys) = x : insertBS ys insertBS [] = [] + transformNested :: [Inline] -> [Inline] + transformNested = map (mapNested stripLeadingTrailingSpace) surroundComplex :: Inline -> Inline -> Bool surroundComplex (Str s@(_:_)) (Str s'@(_:_)) = case (last s, head s') of @@ -436,44 +453,122 @@ inlineListToRST lst = isComplex (Span _ (x:_)) = isComplex x isComplex _ = False +-- | Flattens nested inlines. Extracts nested inlines and goes through +-- them either collapsing them in the outer inline container or +-- pulling them out of it +flatten :: Inline -> [Inline] +flatten outer + | null contents = [outer] + | otherwise = combineAll contents + where contents = dropInlineParent outer + combineAll = foldl combine [] + + combine :: [Inline] -> Inline -> [Inline] + combine f i = + case (outer, i) of + -- quotes are not rendered using RST inlines, so we can keep + -- them and they will be readable and parsable + (Quoted _ _, _) -> keep f i + (_, Quoted _ _) -> keep f i + -- parent inlines would prevent links from being correctly + -- parsed, in this case we prioritise the content over the + -- style + (_, Link _ _ _) -> emerge f i + -- always give priority to strong text over emphasis + (Emph _, Strong _) -> emerge f i + -- drop all other nested styles + (_, _) -> collapse f i + + emerge f i = f <> [i] + keep f i = appendToLast f [i] + collapse f i = appendToLast f $ dropInlineParent i + + appendToLast :: [Inline] -> [Inline] -> [Inline] + appendToLast [] toAppend = [setInlineChildren outer toAppend] + appendToLast flattened toAppend + | isOuter lastFlat = init flattened <> [appendTo lastFlat toAppend] + | otherwise = flattened <> [setInlineChildren outer toAppend] + where lastFlat = last flattened + appendTo o i = mapNested (<> i) o + isOuter i = emptyParent i == emptyParent outer + emptyParent i = setInlineChildren i [] + +mapNested :: ([Inline] -> [Inline]) -> Inline -> Inline +mapNested f i = setInlineChildren i (f (dropInlineParent i)) + +dropInlineParent :: Inline -> [Inline] +dropInlineParent (Link _ i _) = i +dropInlineParent (Emph i) = i +dropInlineParent (Strong i) = i +dropInlineParent (Strikeout i) = i +dropInlineParent (Superscript i) = i +dropInlineParent (Subscript i) = i +dropInlineParent (SmallCaps i) = i +dropInlineParent (Cite _ i) = i +dropInlineParent (Image _ i _) = i +dropInlineParent (Span _ i) = i +dropInlineParent (Quoted _ i) = i +dropInlineParent i = [i] -- not a parent, like Str or Space + +setInlineChildren :: Inline -> [Inline] -> Inline +setInlineChildren (Link a _ t) i = Link a i t +setInlineChildren (Emph _) i = Emph i +setInlineChildren (Strong _) i = Strong i +setInlineChildren (Strikeout _) i = Strikeout i +setInlineChildren (Superscript _) i = Superscript i +setInlineChildren (Subscript _) i = Subscript i +setInlineChildren (SmallCaps _) i = SmallCaps i +setInlineChildren (Quoted q _) i = Quoted q i +setInlineChildren (Cite c _) i = Cite c i +setInlineChildren (Image a _ t) i = Image a i t +setInlineChildren (Span a _) i = Span a i +setInlineChildren leaf _ = leaf + +inlineListToRST :: PandocMonad m => [Inline] -> RST m Doc +inlineListToRST = writeInlines . walk transformInlines + +-- | Convert list of Pandoc inline elements to RST. +writeInlines :: PandocMonad m => [Inline] -> RST m Doc +writeInlines lst = mapM inlineToRST lst >>= return . hcat + -- | Convert Pandoc inline element to RST. inlineToRST :: PandocMonad m => Inline -> RST m Doc inlineToRST (Span (_,_,kvs) ils) = do - contents <- inlineListToRST ils + contents <- writeInlines ils return $ case lookup "role" kvs of Just role -> ":" <> text role <> ":`" <> contents <> "`" Nothing -> contents inlineToRST (Emph lst) = do - contents <- inlineListToRST lst + contents <- writeInlines lst return $ "*" <> contents <> "*" inlineToRST (Strong lst) = do - contents <- inlineListToRST lst + contents <- writeInlines lst return $ "**" <> contents <> "**" inlineToRST (Strikeout lst) = do - contents <- inlineListToRST lst + contents <- writeInlines lst return $ "[STRIKEOUT:" <> contents <> "]" inlineToRST (Superscript lst) = do - contents <- inlineListToRST lst + contents <- writeInlines lst return $ ":sup:`" <> contents <> "`" inlineToRST (Subscript lst) = do - contents <- inlineListToRST lst + contents <- writeInlines lst return $ ":sub:`" <> contents <> "`" -inlineToRST (SmallCaps lst) = inlineListToRST lst +inlineToRST (SmallCaps lst) = writeInlines lst inlineToRST (Quoted SingleQuote lst) = do - contents <- inlineListToRST lst + contents <- writeInlines lst opts <- gets stOptions if isEnabled Ext_smart opts then return $ "'" <> contents <> "'" else return $ "‘" <> contents <> "’" inlineToRST (Quoted DoubleQuote lst) = do - contents <- inlineListToRST lst + contents <- writeInlines lst opts <- gets stOptions if isEnabled Ext_smart opts then return $ "\"" <> contents <> "\"" else return $ "“" <> contents <> "”" inlineToRST (Cite _ lst) = - inlineListToRST lst + writeInlines lst inlineToRST (Code _ str) = do opts <- gets stOptions -- we trim the string because the delimiters must adjoin a @@ -524,7 +619,7 @@ inlineToRST (Link _ [Image attr alt (imgsrc,imgtit)] (src, _tit)) = do return $ "|" <> label <> "|" inlineToRST (Link _ txt (src, tit)) = do useReferenceLinks <- gets $ writerReferenceLinks . stOptions - linktext <- inlineListToRST $ B.toList . B.trimInlines . B.fromList $ txt + linktext <- writeInlines $ B.toList . B.trimInlines . B.fromList $ txt if useReferenceLinks then do refs <- gets stLinks case lookup txt refs of diff --git a/src/Text/Pandoc/Writers/RTF.hs b/src/Text/Pandoc/Writers/RTF.hs index 7006b58d1..3045c1c10 100644 --- a/src/Text/Pandoc/Writers/RTF.hs +++ b/src/Text/Pandoc/Writers/RTF.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-} {- Copyright (C) 2006-2018 John MacFarlane <jgm@berkeley.edu> @@ -30,6 +31,7 @@ Conversion of 'Pandoc' documents to RTF (rich text format). -} module Text.Pandoc.Writers.RTF ( writeRTF ) where +import Prelude import Control.Monad.Except (catchError, throwError) import Control.Monad import qualified Data.ByteString as B diff --git a/src/Text/Pandoc/Writers/Shared.hs b/src/Text/Pandoc/Writers/Shared.hs index ae4cc5cc5..2edce7deb 100644 --- a/src/Text/Pandoc/Writers/Shared.hs +++ b/src/Text/Pandoc/Writers/Shared.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {- Copyright (C) 2013-2018 John MacFarlane <jgm@berkeley.edu> @@ -41,8 +42,10 @@ module Text.Pandoc.Writers.Shared ( , unsmartify , gridTable , metaValueToInlines + , stripLeadingTrailingSpace ) where +import Prelude import Control.Monad (zipWithM) import Data.Aeson (FromJSON (..), Result (..), ToJSON (..), Value (Object), encode, fromJSON) @@ -240,40 +243,58 @@ gridTable :: Monad m -> [[[Block]]] -> m Doc gridTable opts blocksToDoc headless aligns widths headers rows = do + -- the number of columns will be used in case of even widths let numcols = maximum (length aligns : length widths : map length (headers:rows)) + -- handleGivenWidths wraps the given blocks in order for them to fit + -- in cells with given widths. the returned content can be + -- concatenated with borders and frames let handleGivenWidths widths' = do let widthsInChars' = map ( (\x -> if x < 1 then 1 else x) . (\x -> x - 3) . floor . (fromIntegral (writerColumns opts) *) ) widths' - rawHeaders' <- zipWithM blocksToDoc - (map (\w -> opts{writerColumns = - min (w - 2) (writerColumns opts)}) widthsInChars') - headers + -- replace page width (in columns) in the options with a + -- given width if smaller (adjusting by two) + useWidth w = opts{writerColumns = min (w - 2) (writerColumns opts)} + -- prepare options to use with header and row cells + columnOptions = map useWidth widthsInChars' + rawHeaders' <- zipWithM blocksToDoc columnOptions headers rawRows' <- mapM - (\cs -> zipWithM blocksToDoc - (map (\w -> opts{writerColumns = - min (w - 2) (writerColumns opts)}) widthsInChars') - cs) + (\cs -> zipWithM blocksToDoc columnOptions cs) rows return (widthsInChars', rawHeaders', rawRows') - let handleZeroWidths = do + -- handleFullWidths tries to wrap cells to the page width or even + -- more in cases where `--wrap=none`. thus the content here is left + -- as wide as possible + let handleFullWidths = do rawHeaders' <- mapM (blocksToDoc opts) headers rawRows' <- mapM (mapM (blocksToDoc opts)) rows let numChars [] = 0 numChars xs = maximum . map offset $ xs let widthsInChars' = map numChars $ transpose (rawHeaders' : rawRows') + return (widthsInChars', rawHeaders', rawRows') + -- handleZeroWidths calls handleFullWidths to check whether a wide + -- table would fit in the page. if the produced table is too wide, + -- it calculates even widths and passes the content to + -- handleGivenWidths + let handleZeroWidths = do + (widthsInChars', rawHeaders', rawRows') <- handleFullWidths if sum widthsInChars' > writerColumns opts then -- use even widths handleGivenWidths (replicate numcols (1.0 / fromIntegral numcols) :: [Double]) else return (widthsInChars', rawHeaders', rawRows') - (widthsInChars, rawHeaders, rawRows) <- if all (== 0) widths - then handleZeroWidths - else handleGivenWidths widths + -- render the contents of header and row cells differently depending + -- on command line options, widths given in this specific table, and + -- cells' contents + let handleWidths + | writerWrapText opts == WrapNone = handleFullWidths + | all (== 0) widths = handleZeroWidths + | otherwise = handleGivenWidths widths + (widthsInChars, rawHeaders, rawRows) <- handleWidths let hpipeBlocks blocks = hcat [beg, middle, end] where h = maximum (1 : map height blocks) sep' = lblock 3 $ vcat (replicate h (text " | ")) diff --git a/src/Text/Pandoc/Writers/TEI.hs b/src/Text/Pandoc/Writers/TEI.hs index 4936c743e..e461f5715 100644 --- a/src/Text/Pandoc/Writers/TEI.hs +++ b/src/Text/Pandoc/Writers/TEI.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {- @@ -30,6 +31,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Conversion of 'Pandoc' documents to Docbook XML. -} module Text.Pandoc.Writers.TEI (writeTEI) where +import Prelude import Data.Char (toLower) import Data.List (isPrefixOf, stripPrefix) import Data.Text (Text) diff --git a/src/Text/Pandoc/Writers/Texinfo.hs b/src/Text/Pandoc/Writers/Texinfo.hs index bf434642e..305b41206 100644 --- a/src/Text/Pandoc/Writers/Texinfo.hs +++ b/src/Text/Pandoc/Writers/Texinfo.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {- Copyright (C) 2008-2018 John MacFarlane @@ -31,6 +32,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Conversion of 'Pandoc' format into Texinfo. -} module Text.Pandoc.Writers.Texinfo ( writeTexinfo ) where +import Prelude import Control.Monad.Except (throwError) import Control.Monad.State.Strict import Data.Char (chr, ord) diff --git a/src/Text/Pandoc/Writers/Textile.hs b/src/Text/Pandoc/Writers/Textile.hs index f46eb43bc..0ed79d2df 100644 --- a/src/Text/Pandoc/Writers/Textile.hs +++ b/src/Text/Pandoc/Writers/Textile.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {- Copyright (C) 2010-2018 John MacFarlane <jgm@berkeley.edu> @@ -30,6 +31,7 @@ Conversion of 'Pandoc' documents to Textile markup. Textile: <http://thresholdstate.com/articles/4312/the-textile-reference-manual> -} module Text.Pandoc.Writers.Textile ( writeTextile ) where +import Prelude import Control.Monad.State.Strict import Data.Char (isSpace) import Data.List (intercalate) diff --git a/src/Text/Pandoc/Writers/ZimWiki.hs b/src/Text/Pandoc/Writers/ZimWiki.hs index dec1f9d4a..a583b07b1 100644 --- a/src/Text/Pandoc/Writers/ZimWiki.hs +++ b/src/Text/Pandoc/Writers/ZimWiki.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {- Copyright (C) 2008-2018 John MacFarlane <jgm@berkeley.edu> 2017-2018 Alex Ivkin @@ -32,6 +33,7 @@ http://zim-wiki.org/manual/Help/Wiki_Syntax.html -} module Text.Pandoc.Writers.ZimWiki ( writeZimWiki ) where +import Prelude import Control.Monad (zipWithM) import Control.Monad.State.Strict (StateT, evalStateT, gets, modify) import Data.Default (Default (..)) diff --git a/src/Text/Pandoc/XML.hs b/src/Text/Pandoc/XML.hs index 62874f0b9..add46bd6c 100644 --- a/src/Text/Pandoc/XML.hs +++ b/src/Text/Pandoc/XML.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {- Copyright (C) 2006-2018 John MacFarlane <jgm@berkeley.edu> @@ -36,6 +37,7 @@ module Text.Pandoc.XML ( escapeCharForXML, toEntities, fromEntities ) where +import Prelude import Data.Char (isAscii, isSpace, ord) import Data.Text (Text) import qualified Data.Text as T |