diff options
Diffstat (limited to 'src')
100 files changed, 3568 insertions, 2354 deletions
diff --git a/src/Text/Pandoc.hs b/src/Text/Pandoc.hs index 0da2a925c..dd2856674 100644 --- a/src/Text/Pandoc.hs +++ b/src/Text/Pandoc.hs @@ -2,7 +2,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} {- -Copyright (C) 2006-2017 John MacFarlane <jgm@berkeley.edu> +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 @@ -21,7 +21,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc - Copyright : Copyright (C) 2006-2017 John MacFarlane + Copyright : Copyright (C) 2006-2018 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> diff --git a/src/Text/Pandoc/App.hs b/src/Text/Pandoc/App.hs index 7c463d743..26c754cd6 100644 --- a/src/Text/Pandoc/App.hs +++ b/src/Text/Pandoc/App.hs @@ -4,7 +4,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {- -Copyright (C) 2006-2017 John MacFarlane <jgm@berkeley.edu> +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 @@ -23,7 +23,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.App - Copyright : Copyright (C) 2006-2017 John MacFarlane + Copyright : Copyright (C) 2006-2018 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley@edu> @@ -46,12 +46,11 @@ import qualified Control.Exception as E import Control.Monad import Control.Monad.Except (catchError, throwError) import Control.Monad.Trans -import Data.Aeson (defaultOptions, eitherDecode', encode) +import Data.Aeson (defaultOptions) import Data.Aeson.TH (deriveJSON) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as B import Data.Char (toLower, toUpper) -import Data.Foldable (foldrM) import Data.List (find, intercalate, isPrefixOf, isSuffixOf, sort) import qualified Data.Map as M import Data.Maybe (fromMaybe, isJust, isNothing) @@ -71,13 +70,11 @@ import Data.Aeson.Encode.Pretty (encodePretty', Config(..), keyOrder, defConfig, Indent(..), NumberFormat(..)) import Skylighting (Style, Syntax (..), defaultSyntaxMap, parseTheme, pygments) -import Skylighting.Parser (addSyntaxDefinition, missingIncludes, - parseSyntaxDefinition) +import Skylighting.Parser (addSyntaxDefinition, parseSyntaxDefinition) import System.Console.GetOpt -import System.Directory (Permissions (..), doesFileExist, findExecutable, - getAppUserDataDirectory, getPermissions) -import System.Environment (getArgs, getEnvironment, getProgName) -import System.Exit (ExitCode (..), exitSuccess) +import System.Directory (getAppUserDataDirectory) +import System.Environment (getArgs, getProgName) +import System.Exit (exitSuccess) import System.FilePath import System.IO (nativeNewline, stdout) import qualified System.IO as IO (Newline (..)) @@ -85,10 +82,9 @@ import System.IO.Error (isDoesNotExistError) import Text.Pandoc import Text.Pandoc.BCP47 (Lang (..), parseBCP47) import Text.Pandoc.Builder (setMeta, deleteMeta) +import Text.Pandoc.Filter (Filter (JSONFilter, LuaFilter), applyFilters) import Text.Pandoc.Highlighting (highlightingStyles) -import Text.Pandoc.Lua (LuaException (..), runLuaFilter) import Text.Pandoc.PDF (makePDF) -import Text.Pandoc.Process (pipeProcess) import Text.Pandoc.SelfContained (makeDataURI, makeSelfContained) import Text.Pandoc.Shared (eastAsianLineBreakFilter, stripEmptyParagraphs, headerShift, isURI, ordNub, safeRead, tabFilter) @@ -268,14 +264,6 @@ convertWithOpts opts = do syntaxMap <- foldM addSyntaxMap defaultSyntaxMap (optSyntaxDefinitions opts) - case missingIncludes (M.elems syntaxMap) of - [] -> return () - xs -> E.throwIO $ PandocSyntaxMapError $ - "Missing syntax definitions:\n" ++ - unlines (map - (\(syn,dep) -> (T.unpack syn ++ " requires " ++ - T.unpack dep ++ " through IncludeRules.")) xs) - -- We don't want to send output to the terminal if the user -- does 'pandoc -t docx input.txt'; though we allow them to -- force this with '-o -'. On posix systems, we detect @@ -547,48 +535,6 @@ type Transform = Pandoc -> Pandoc isTextFormat :: String -> Bool isTextFormat s = s `notElem` ["odt","docx","epub2","epub3","epub","pptx"] -externalFilter :: MonadIO m - => ReaderOptions -> FilePath -> [String] -> Pandoc -> m Pandoc -externalFilter ropts f args' d = liftIO $ do - exists <- doesFileExist f - isExecutable <- if exists - then executable <$> getPermissions f - else return True - let (f', args'') = if exists - then case map toLower (takeExtension f) of - _ | isExecutable -> ("." </> f, args') - ".py" -> ("python", f:args') - ".hs" -> ("runhaskell", f:args') - ".pl" -> ("perl", f:args') - ".rb" -> ("ruby", f:args') - ".php" -> ("php", f:args') - ".js" -> ("node", f:args') - ".r" -> ("Rscript", f:args') - _ -> (f, args') - else (f, args') - unless (exists && isExecutable) $ do - mbExe <- findExecutable f' - when (isNothing mbExe) $ - E.throwIO $ PandocFilterError f ("Could not find executable " ++ f') - env <- getEnvironment - let env' = Just - ( ("PANDOC_VERSION", pandocVersion) - : ("PANDOC_READER_OPTIONS", UTF8.toStringLazy (encode ropts)) - : env ) - (exitcode, outbs) <- E.handle filterException $ - pipeProcess env' f' args'' $ encode d - case exitcode of - ExitSuccess -> either (E.throwIO . PandocFilterError f) - return $ eitherDecode' outbs - ExitFailure ec -> E.throwIO $ PandocFilterError f - ("Filter returned error status " ++ show ec) - where filterException :: E.SomeException -> IO a - filterException e = E.throwIO $ PandocFilterError f (show e) - -data Filter = LuaFilter FilePath - | JSONFilter FilePath - deriving (Show) - -- | Data structure for command line options. data Opt = Opt { optTabStop :: Int -- ^ Number of spaces per tab @@ -833,50 +779,6 @@ defaultWriterName x = applyTransforms :: Monad m => [Transform] -> Pandoc -> m Pandoc applyTransforms transforms d = return $ foldr ($) d transforms - -- First we check to see if a filter is found. If not, and if it's - -- not an absolute path, we check to see whether it's in `userdir/filters`. - -- If not, we leave it unchanged. -expandFilterPath :: PandocMonad m => FilePath -> m FilePath -expandFilterPath fp = do - mbDatadir <- getUserDataDir - fpExists <- fileExists fp - if fpExists - then return fp - else case mbDatadir of - Just datadir | isRelative fp -> do - let filterPath = datadir </> "filters" </> fp - filterPathExists <- fileExists filterPath - if filterPathExists - then return filterPath - else return fp - _ -> return fp - -applyFilters :: ReaderOptions - -> [Filter] - -> [String] - -> Pandoc - -> PandocIO Pandoc -applyFilters ropts filters args d = do - foldrM ($) d $ map (applyFilter ropts args) filters - -applyFilter :: ReaderOptions - -> [String] - -> Filter - -> Pandoc - -> PandocIO Pandoc -applyFilter _ropts args (LuaFilter f) d = do - f' <- expandFilterPath f - let format = case args of - (x:_) -> x - _ -> error "Format not supplied for lua filter" - res <- runLuaFilter f' format d - case res of - Right x -> return x - Left (LuaException s) -> E.throw (PandocFilterError f s) -applyFilter ropts args (JSONFilter f) d = do - f' <- expandFilterPath f - liftIO $ externalFilter ropts f' args d - readSource :: FilePath -> PandocIO Text readSource "-" = liftIO (UTF8.toText <$> BS.getContents) readSource src = case parseURI src of @@ -1662,7 +1564,7 @@ usageMessage programName = usageInfo (programName ++ " [OPTIONS] [FILES]") copyrightMessage :: String copyrightMessage = intercalate "\n" [ "", - "Copyright (C) 2006-2017 John MacFarlane", + "Copyright (C) 2006-2018 John MacFarlane", "Web: http://pandoc.org", "This is free software; see the source for copying conditions.", "There is no warranty, not even for merchantability or fitness", @@ -1731,5 +1633,4 @@ deprecatedOption o msg = -- see https://github.com/jgm/pandoc/pull/4083 -- using generic deriving caused long compilation times $(deriveJSON defaultOptions ''LineEnding) -$(deriveJSON defaultOptions ''Filter) $(deriveJSON defaultOptions ''Opt) diff --git a/src/Text/Pandoc/Asciify.hs b/src/Text/Pandoc/Asciify.hs index 7125e5bcd..11d3eddac 100644 --- a/src/Text/Pandoc/Asciify.hs +++ b/src/Text/Pandoc/Asciify.hs @@ -1,5 +1,5 @@ {- -Copyright (C) 2013-2017 John MacFarlane <jgm@berkeley.edu> +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 @@ -18,7 +18,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.Asciify - Copyright : Copyright (C) 2013-2017 John MacFarlane + Copyright : Copyright (C) 2013-2018 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> diff --git a/src/Text/Pandoc/BCP47.hs b/src/Text/Pandoc/BCP47.hs index a9fb5c7a7..2dd825142 100644 --- a/src/Text/Pandoc/BCP47.hs +++ b/src/Text/Pandoc/BCP47.hs @@ -1,5 +1,5 @@ {- -Copyright (C) 2017 John MacFarlane <jgm@berkeley.edu> +Copyright (C) 2017–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 @@ -18,7 +18,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.BCP47 - Copyright : Copyright (C) 2017 John MacFarlane + Copyright : Copyright (C) 2017–2018 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> diff --git a/src/Text/Pandoc/CSV.hs b/src/Text/Pandoc/CSV.hs index e25b684f8..3415ae88f 100644 --- a/src/Text/Pandoc/CSV.hs +++ b/src/Text/Pandoc/CSV.hs @@ -1,5 +1,5 @@ {- -Copyright (C) 2017 John MacFarlane <jgm@berkeley.edu> +Copyright (C) 2017–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 @@ -18,7 +18,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.CSV - Copyright : Copyright (C) 2017 John MacFarlane <jgm@berkeley.edu> + Copyright : Copyright (C) 2017–2018 John MacFarlane <jgm@berkeley.edu> License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> Stability : alpha diff --git a/src/Text/Pandoc/Error.hs b/src/Text/Pandoc/Error.hs index 0c97ecbad..f78a31481 100644 --- a/src/Text/Pandoc/Error.hs +++ b/src/Text/Pandoc/Error.hs @@ -1,7 +1,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {- -Copyright (C) 2006-2017 John MacFarlane <jgm@berkeley.edu> +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 @@ -19,7 +19,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -} {- | Module : Text.Pandoc.Error - Copyright : Copyright (C) 2006-2017 John MacFarlane + Copyright : Copyright (C) 2006-2018 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> diff --git a/src/Text/Pandoc/Extensions.hs b/src/Text/Pandoc/Extensions.hs index 31fddb148..8f6d49ade 100644 --- a/src/Text/Pandoc/Extensions.hs +++ b/src/Text/Pandoc/Extensions.hs @@ -1,5 +1,5 @@ {- -Copyright (C) 2012-2017 John MacFarlane <jgm@berkeley.edu> +Copyright (C) 2012-2018 John MacFarlane <jgm@berkeley.edu> This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -22,7 +22,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.Extensions - Copyright : Copyright (C) 2012-2017 John MacFarlane + Copyright : Copyright (C) 2012-2018 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> @@ -133,6 +133,7 @@ data Extension = | Ext_multiline_tables -- ^ Pandoc-style multiline tables | Ext_native_divs -- ^ Use Div blocks for contents of <div> tags | Ext_native_spans -- ^ Use Span inlines for contents of <span> + | Ext_ntb -- ^ ConTeXt Natural Tables | Ext_old_dashes -- ^ -- = em, - before number = en | Ext_pandoc_title_block -- ^ Pandoc title block | Ext_pipe_tables -- ^ Pipe tables (as in PHP markdown extra) diff --git a/src/Text/Pandoc/Filter.hs b/src/Text/Pandoc/Filter.hs new file mode 100644 index 000000000..67b3a5f2c --- /dev/null +++ b/src/Text/Pandoc/Filter.hs @@ -0,0 +1,60 @@ +{- +Copyright (C) 2006-2017 John MacFarlane <jgm@berkeley.edu> + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} +{-# LANGUAGE TemplateHaskell #-} + +{- | + Module : Text.Pandoc.Filter + Copyright : Copyright (C) 2006-2017 John MacFarlane + License : GNU GPL, version 2 or above + + Maintainer : John MacFarlane <jgm@berkeley@edu> + Stability : alpha + Portability : portable + +Programmatically modifications of pandoc documents. +-} +module Text.Pandoc.Filter + ( Filter (..) + , applyFilters + ) where + +import Data.Aeson (defaultOptions) +import Data.Aeson.TH (deriveJSON) +import Data.Foldable (foldrM) +import Text.Pandoc.Class (PandocIO) +import Text.Pandoc.Definition (Pandoc) +import Text.Pandoc.Options (ReaderOptions) +import qualified Text.Pandoc.Filter.JSON as JSONFilter +import qualified Text.Pandoc.Filter.Lua as LuaFilter + +data Filter = LuaFilter FilePath + | JSONFilter FilePath + deriving (Show) + +applyFilters :: ReaderOptions + -> [Filter] + -> [String] + -> Pandoc + -> PandocIO Pandoc +applyFilters ropts filters args d = do + foldrM ($) d $ map applyFilter filters + where + applyFilter (JSONFilter f) = JSONFilter.apply ropts args f + applyFilter (LuaFilter f) = LuaFilter.apply ropts args f + +$(deriveJSON defaultOptions ''Filter) diff --git a/src/Text/Pandoc/Filter/JSON.hs b/src/Text/Pandoc/Filter/JSON.hs new file mode 100644 index 000000000..5772c2c41 --- /dev/null +++ b/src/Text/Pandoc/Filter/JSON.hs @@ -0,0 +1,97 @@ +{- +Copyright (C) 2006-2018 John MacFarlane <jgm@berkeley.edu> + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- | + Module : Text.Pandoc.Filter + Copyright : Copyright (C) 2006-2018 John MacFarlane + License : GNU GPL, version 2 or above + + Maintainer : John MacFarlane <jgm@berkeley@edu> + Stability : alpha + Portability : portable + +Programmatically modifications of pandoc documents via JSON filters. +-} +module Text.Pandoc.Filter.JSON (apply) where + +import Control.Monad (unless, when) +import Control.Monad.Trans (MonadIO (liftIO)) +import Data.Aeson (eitherDecode', encode) +import Data.Char (toLower) +import Data.Maybe (isNothing) +import System.Directory (executable, doesFileExist, findExecutable, + getPermissions) +import System.Environment (getEnvironment) +import System.Exit (ExitCode (..)) +import System.FilePath ((</>), takeExtension) +import Text.Pandoc.Class (PandocIO) +import Text.Pandoc.Error (PandocError (PandocFilterError)) +import Text.Pandoc.Definition (Pandoc) +import Text.Pandoc.Filter.Path (expandFilterPath) +import Text.Pandoc.Options (ReaderOptions) +import Text.Pandoc.Process (pipeProcess) +import Text.Pandoc.Shared (pandocVersion) +import qualified Control.Exception as E +import qualified Text.Pandoc.UTF8 as UTF8 + +apply :: ReaderOptions + -> [String] + -> FilePath + -> Pandoc + -> PandocIO Pandoc +apply ropts args f d = do + f' <- expandFilterPath f + liftIO $ externalFilter ropts f' args d + +externalFilter :: MonadIO m + => ReaderOptions -> FilePath -> [String] -> Pandoc -> m Pandoc +externalFilter ropts f args' d = liftIO $ do + exists <- doesFileExist f + isExecutable <- if exists + then executable <$> getPermissions f + else return True + let (f', args'') = if exists + then case map toLower (takeExtension f) of + _ | isExecutable -> ("." </> f, args') + ".py" -> ("python", f:args') + ".hs" -> ("runhaskell", f:args') + ".pl" -> ("perl", f:args') + ".rb" -> ("ruby", f:args') + ".php" -> ("php", f:args') + ".js" -> ("node", f:args') + ".r" -> ("Rscript", f:args') + _ -> (f, args') + else (f, args') + unless (exists && isExecutable) $ do + mbExe <- findExecutable f' + when (isNothing mbExe) $ + E.throwIO $ PandocFilterError f ("Could not find executable " ++ f') + env <- getEnvironment + let env' = Just + ( ("PANDOC_VERSION", pandocVersion) + : ("PANDOC_READER_OPTIONS", UTF8.toStringLazy (encode ropts)) + : env ) + (exitcode, outbs) <- E.handle filterException $ + pipeProcess env' f' args'' $ encode d + case exitcode of + ExitSuccess -> either (E.throwIO . PandocFilterError f) + return $ eitherDecode' outbs + ExitFailure ec -> E.throwIO $ PandocFilterError f + ("Filter returned error status " ++ show ec) + where filterException :: E.SomeException -> IO a + filterException e = E.throwIO $ PandocFilterError f (show e) diff --git a/src/Text/Pandoc/Filter/Lua.hs b/src/Text/Pandoc/Filter/Lua.hs new file mode 100644 index 000000000..597a31cbc --- /dev/null +++ b/src/Text/Pandoc/Filter/Lua.hs @@ -0,0 +1,53 @@ +{- +Copyright (C) 2006-2018 John MacFarlane <jgm@berkeley.edu> + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- | + Module : Text.Pandoc.Filter.Lua + Copyright : Copyright (C) 2006-2018 John MacFarlane + License : GNU GPL, version 2 or above + + Maintainer : John MacFarlane <jgm@berkeley@edu> + Stability : alpha + Portability : portable + +Apply Lua filters to modify a pandoc documents programmatically. +-} +module Text.Pandoc.Filter.Lua (apply) where + +import Control.Exception (throw) +import Text.Pandoc.Class (PandocIO) +import Text.Pandoc.Definition (Pandoc) +import Text.Pandoc.Error (PandocError (PandocFilterError)) +import Text.Pandoc.Filter.Path (expandFilterPath) +import Text.Pandoc.Lua (LuaException (..), runLuaFilter) +import Text.Pandoc.Options (ReaderOptions) + +apply :: ReaderOptions + -> [String] + -> FilePath + -> Pandoc + -> PandocIO Pandoc +apply ropts args f d = do + f' <- expandFilterPath f + let format = case args of + (x:_) -> x + _ -> error "Format not supplied for lua filter" + res <- runLuaFilter ropts f' format d + case res of + Right x -> return x + Left (LuaException s) -> throw (PandocFilterError f s) diff --git a/src/Text/Pandoc/Filter/Path.hs b/src/Text/Pandoc/Filter/Path.hs new file mode 100644 index 000000000..8074bcbb7 --- /dev/null +++ b/src/Text/Pandoc/Filter/Path.hs @@ -0,0 +1,53 @@ +{- +Copyright (C) 2006-2018 John MacFarlane <jgm@berkeley.edu> + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- | + Module : Text.Pandoc.Filter.Path + Copyright : Copyright (C) 2006-2018 John MacFarlane + License : GNU GPL, version 2 or above + + Maintainer : John MacFarlane <jgm@berkeley@edu> + Stability : alpha + Portability : portable + +Expand paths of filters, searching the data directory. +-} +module Text.Pandoc.Filter.Path + ( expandFilterPath + ) where + +import Text.Pandoc.Class (PandocMonad, fileExists, getUserDataDir) +import System.FilePath ((</>), isRelative) + + -- First we check to see if a filter is found. If not, and if it's + -- not an absolute path, we check to see whether it's in `userdir/filters`. + -- If not, we leave it unchanged. +expandFilterPath :: PandocMonad m => FilePath -> m FilePath +expandFilterPath fp = do + mbDatadir <- getUserDataDir + fpExists <- fileExists fp + if fpExists + then return fp + else case mbDatadir of + Just datadir | isRelative fp -> do + let filterPath = datadir </> "filters" </> fp + filterPathExists <- fileExists filterPath + if filterPathExists + then return filterPath + else return fp + _ -> return fp diff --git a/src/Text/Pandoc/Highlighting.hs b/src/Text/Pandoc/Highlighting.hs index 9c90b229e..113727750 100644 --- a/src/Text/Pandoc/Highlighting.hs +++ b/src/Text/Pandoc/Highlighting.hs @@ -1,5 +1,5 @@ {- -Copyright (C) 2008-2017 John MacFarlane <jgm@berkeley.edu> +Copyright (C) 2008-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 @@ -18,7 +18,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.Highlighting - Copyright : Copyright (C) 2008-2017 John MacFarlane + Copyright : Copyright (C) 2008-2018 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> diff --git a/src/Text/Pandoc/ImageSize.hs b/src/Text/Pandoc/ImageSize.hs index b4206b84b..65559e1ce 100644 --- a/src/Text/Pandoc/ImageSize.hs +++ b/src/Text/Pandoc/ImageSize.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings, ScopedTypeVariables, CPP #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-} {- - Copyright (C) 2011-2017 John MacFarlane <jgm@berkeley.edu> + Copyright (C) 2011-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 @@ -20,7 +20,7 @@ {- | Module : Text.Pandoc.ImageSize -Copyright : Copyright (C) 2011-2017 John MacFarlane +Copyright : Copyright (C) 2011-2018 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> @@ -83,6 +83,7 @@ data Dimension = Pixel Integer | Inch Double | Percent Double | Em Double + deriving Eq instance Show Dimension where show (Pixel a) = show a ++ "px" diff --git a/src/Text/Pandoc/Logging.hs b/src/Text/Pandoc/Logging.hs index 016e64f6c..b22c08467 100644 --- a/src/Text/Pandoc/Logging.hs +++ b/src/Text/Pandoc/Logging.hs @@ -20,7 +20,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -} {- | Module : Text.Pandoc.Logging - Copyright : Copyright (C) 2006-2017 John MacFarlane + Copyright : Copyright (C) 2006-2018 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> diff --git a/src/Text/Pandoc/Lua.hs b/src/Text/Pandoc/Lua.hs index d02963418..edf803b45 100644 --- a/src/Text/Pandoc/Lua.hs +++ b/src/Text/Pandoc/Lua.hs @@ -1,5 +1,5 @@ {- -Copyright © 2017 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> +Copyright © 2017–2018 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> 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 @@ -17,7 +17,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -} {- | Module : Text.Pandoc.Lua - Copyright : Copyright © 2017 Albert Krewinkel + Copyright : Copyright © 2017–2018 Albert Krewinkel License : GNU GPL, version 2 or above Maintainer : Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> @@ -39,21 +39,22 @@ import Text.Pandoc.Definition (Pandoc) import Text.Pandoc.Lua.Filter (LuaFilter, walkMWithLuaFilter) import Text.Pandoc.Lua.Init (runPandocLua) import Text.Pandoc.Lua.Util (popValue) +import Text.Pandoc.Options (ReaderOptions) import qualified Foreign.Lua as Lua -- | Run the Lua filter in @filterPath@ for a transformation to target -- format @format@. Pandoc uses Lua init files to setup the Lua -- interpreter. -runLuaFilter :: FilePath -> String +runLuaFilter :: ReaderOptions -> FilePath -> String -> Pandoc -> PandocIO (Either LuaException Pandoc) -runLuaFilter filterPath format doc = - runPandocLua (runLuaFilter' filterPath format doc) +runLuaFilter ropts filterPath format doc = + runPandocLua (runLuaFilter' ropts filterPath format doc) -runLuaFilter' :: FilePath -> String +runLuaFilter' :: ReaderOptions -> FilePath -> String -> Pandoc -> Lua Pandoc -runLuaFilter' filterPath format pd = do - -- store module in global "pandoc" +runLuaFilter' ropts filterPath format pd = do registerFormat + registerReaderOptions top <- Lua.gettop stat <- Lua.dofile filterPath if stat /= OK @@ -73,5 +74,9 @@ runLuaFilter' filterPath format pd = do push format Lua.setglobal "FORMAT" + registerReaderOptions = do + push ropts + Lua.setglobal "PANDOC_READER_OPTIONS" + runAll :: [LuaFilter] -> Pandoc -> Lua Pandoc runAll = foldr ((>=>) . walkMWithLuaFilter) return diff --git a/src/Text/Pandoc/Lua/Filter.hs b/src/Text/Pandoc/Lua/Filter.hs index 9e109bb52..cc2b9d47e 100644 --- a/src/Text/Pandoc/Lua/Filter.hs +++ b/src/Text/Pandoc/Lua/Filter.hs @@ -11,6 +11,7 @@ module Text.Pandoc.Lua.Filter ( LuaFilterFunction , inlineElementNames ) where import Control.Monad (mplus, unless, when, (>=>)) +import Control.Monad.Catch (finally) import Text.Pandoc.Definition import Data.Foldable (foldrM) import Data.Map (Map) @@ -22,6 +23,7 @@ import Text.Pandoc.Walk (walkM, Walkable) import Data.Data (Data, DataType, dataTypeConstrs, dataTypeName, dataTypeOf, showConstr, toConstr, tyconUQname) import Text.Pandoc.Lua.StackInstances() +import Text.Pandoc.Lua.Util (typeCheck) type FunctionMap = Map String LuaFilterFunction @@ -65,7 +67,7 @@ registerFilterFunction idx = do elementOrList :: FromLuaStack a => a -> Lua [a] elementOrList x = do - let topOfStack = Lua.StackIndex (-1) + let topOfStack = Lua.stackTop elementUnchanged <- Lua.isnil topOfStack if elementUnchanged then [x] <$ Lua.pop 1 @@ -73,7 +75,9 @@ elementOrList x = do mbres <- Lua.peekEither topOfStack case mbres of Right res -> [res] <$ Lua.pop 1 - Left _ -> Lua.toList topOfStack <* Lua.pop 1 + Left _ -> do + typeCheck Lua.stackTop Lua.TypeTable + Lua.toList topOfStack `finally` Lua.pop 1 -- | Try running a filter for the given element tryFilter :: (Data a, FromLuaStack a, ToLuaStack a) diff --git a/src/Text/Pandoc/Lua/Init.hs b/src/Text/Pandoc/Lua/Init.hs index 9b107e945..f3ee2caf1 100644 --- a/src/Text/Pandoc/Lua/Init.hs +++ b/src/Text/Pandoc/Lua/Init.hs @@ -1,5 +1,5 @@ {- -Copyright © 2017 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> +Copyright © 2017-2018 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> 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 @@ -17,7 +17,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -} {- | Module : Text.Pandoc.Lua - Copyright : Copyright © 2017 Albert Krewinkel + Copyright : Copyright © 2017-2018 Albert Krewinkel License : GNU GPL, version 2 or above Maintainer : Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> @@ -35,10 +35,13 @@ module Text.Pandoc.Lua.Init import Control.Monad.Trans (MonadIO (..)) import Data.IORef (newIORef, readIORef) +import Data.Version (Version (versionBranch)) import Foreign.Lua (Lua, LuaException (..)) import GHC.IO.Encoding (getForeignEncoding, setForeignEncoding, utf8) +import Paths_pandoc (version) import Text.Pandoc.Class (PandocIO, getCommonState, getUserDataDir, getMediaBag, setMediaBag) +import Text.Pandoc.Definition (pandocTypesVersion) import Text.Pandoc.Lua.Packages (LuaPackageParams (..), installPandocPackageSearcher) import Text.Pandoc.Lua.Util (loadScriptFromDataDir) @@ -75,5 +78,9 @@ initLuaState :: LuaPackageParams -> Lua () initLuaState luaPkgParams = do Lua.openlibs Lua.preloadTextModule "text" + Lua.push (versionBranch version) + Lua.setglobal "PANDOC_VERSION" + Lua.push (versionBranch pandocTypesVersion) + Lua.setglobal "PANDOC_API_VERSION" installPandocPackageSearcher luaPkgParams loadScriptFromDataDir (luaPkgDataDir luaPkgParams) "init.lua" diff --git a/src/Text/Pandoc/Lua/Module/MediaBag.hs b/src/Text/Pandoc/Lua/Module/MediaBag.hs index 33c441c99..7d942a452 100644 --- a/src/Text/Pandoc/Lua/Module/MediaBag.hs +++ b/src/Text/Pandoc/Lua/Module/MediaBag.hs @@ -1,5 +1,5 @@ {- -Copyright © 2017 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> +Copyright © 2017-2018 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> 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 @@ -17,7 +17,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -} {- | Module : Text.Pandoc.Lua.Module.MediaBag - Copyright : Copyright © 2017 Albert Krewinkel + Copyright : Copyright © 2017-2018 Albert Krewinkel License : GNU GPL, version 2 or above Maintainer : Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> @@ -32,11 +32,11 @@ module Text.Pandoc.Lua.Module.MediaBag import Control.Monad (zipWithM_) import Data.IORef (IORef, modifyIORef', readIORef) import Data.Maybe (fromMaybe) -import Foreign.Lua (Lua, NumResults, liftIO) +import Foreign.Lua (Lua, NumResults, Optional, liftIO) import Text.Pandoc.Class (CommonState (..), fetchItem, putCommonState, runIOorExplode, setMediaBag) import Text.Pandoc.Lua.StackInstances () -import Text.Pandoc.Lua.Util (OrNil (toMaybe), addFunction) +import Text.Pandoc.Lua.Util (addFunction) import Text.Pandoc.MIME (MimeType) import qualified Data.ByteString.Lazy as BL @@ -57,12 +57,12 @@ pushModule commonState mediaBagRef = do insertMediaFn :: IORef MB.MediaBag -> FilePath - -> OrNil MimeType + -> Optional MimeType -> BL.ByteString -> Lua NumResults -insertMediaFn mbRef fp nilOrMime contents = do +insertMediaFn mbRef fp optionalMime contents = do liftIO . modifyIORef' mbRef $ - MB.insertMedia fp (toMaybe nilOrMime) contents + MB.insertMedia fp (Lua.fromOptional optionalMime) contents return 0 lookupMediaFn :: IORef MB.MediaBag diff --git a/src/Text/Pandoc/Lua/Module/Pandoc.hs b/src/Text/Pandoc/Lua/Module/Pandoc.hs index 5b8714e07..f458d4773 100644 --- a/src/Text/Pandoc/Lua/Module/Pandoc.hs +++ b/src/Text/Pandoc/Lua/Module/Pandoc.hs @@ -1,5 +1,5 @@ {- -Copyright © 2017 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> +Copyright © 2017-2018 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> 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 @@ -18,7 +18,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {-# LANGUAGE FlexibleContexts #-} {- | Module : Text.Pandoc.Lua.Module.Pandoc - Copyright : Copyright © 2017 Albert Krewinkel + Copyright : Copyright © 2017-2018 Albert Krewinkel License : GNU GPL, version 2 or above Maintainer : Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> @@ -34,14 +34,13 @@ import Control.Monad (when) import Data.Default (Default (..)) import Data.Maybe (fromMaybe) import Data.Text (pack) -import Foreign.Lua (ToLuaStack, FromLuaStack, Lua, NumResults, liftIO) +import Foreign.Lua (ToLuaStack, FromLuaStack, Lua, NumResults, Optional, liftIO) import System.Exit (ExitCode (..)) import Text.Pandoc.Class (runIO) import Text.Pandoc.Definition (Block, Inline) import Text.Pandoc.Lua.Filter (walkInlines, walkBlocks, LuaFilter) import Text.Pandoc.Lua.StackInstances () -import Text.Pandoc.Lua.Util (OrNil (toMaybe), addFunction, addValue, - loadScriptFromDataDir, raiseError) +import Text.Pandoc.Lua.Util (addFunction, addValue, loadScriptFromDataDir) import Text.Pandoc.Walk (Walkable) import Text.Pandoc.Options (ReaderOptions (readerExtensions)) import Text.Pandoc.Process (pipeProcess) @@ -72,19 +71,19 @@ walkInline = walkElement walkBlock :: Block -> LuaFilter -> Lua Block walkBlock = walkElement -readDoc :: String -> OrNil String -> Lua NumResults +readDoc :: String -> Optional String -> Lua NumResults readDoc content formatSpecOrNil = do - let formatSpec = fromMaybe "markdown" (toMaybe formatSpecOrNil) + let formatSpec = fromMaybe "markdown" (Lua.fromOptional formatSpecOrNil) case getReader formatSpec of - Left s -> raiseError s -- Unknown reader + Left s -> Lua.raiseError s -- Unknown reader Right (reader, es) -> case reader of TextReader r -> do res <- liftIO $ runIO $ r def{ readerExtensions = es } (pack content) case res of Right pd -> (1 :: NumResults) <$ Lua.push pd -- success, push Pandoc - Left s -> raiseError (show s) -- error while reading - _ -> raiseError "Only string formats are supported at the moment." + Left s -> Lua.raiseError (show s) -- error while reading + _ -> Lua.raiseError "Only string formats are supported at the moment." -- | Pipes input through a command. pipeFn :: String @@ -95,7 +94,7 @@ pipeFn command args input = do (ec, output) <- liftIO $ pipeProcess Nothing command args input case ec of ExitSuccess -> 1 <$ Lua.push output - ExitFailure n -> raiseError (PipeError command n output) + ExitFailure n -> Lua.raiseError (PipeError command n output) data PipeError = PipeError { pipeErrorCommand :: String diff --git a/src/Text/Pandoc/Lua/Module/Utils.hs b/src/Text/Pandoc/Lua/Module/Utils.hs index c0d7397ce..f8eb96dc7 100644 --- a/src/Text/Pandoc/Lua/Module/Utils.hs +++ b/src/Text/Pandoc/Lua/Module/Utils.hs @@ -1,5 +1,5 @@ {- -Copyright © 2017 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> +Copyright © 2017-2018 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> 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 @@ -17,7 +17,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -} {- | Module : Text.Pandoc.Lua.Module.Utils - Copyright : Copyright © 2017 Albert Krewinkel + Copyright : Copyright © 2017-2018 Albert Krewinkel License : GNU GPL, version 2 or above Maintainer : Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> @@ -30,22 +30,26 @@ module Text.Pandoc.Lua.Module.Utils ) where import Control.Applicative ((<|>)) +import Data.Default (def) import Foreign.Lua (FromLuaStack, Lua, LuaInteger, NumResults) +import Text.Pandoc.Class (runIO, setUserDataDir) import Text.Pandoc.Definition (Pandoc, Meta, MetaValue, Block, Inline) import Text.Pandoc.Lua.StackInstances () -import Text.Pandoc.Lua.Util (OrNil (OrNil), addFunction) +import Text.Pandoc.Lua.Util (addFunction, popValue) import qualified Data.Digest.Pure.SHA as SHA import qualified Data.ByteString.Lazy as BSL import qualified Foreign.Lua as Lua +import qualified Text.Pandoc.Filter.JSON as JSONFilter import qualified Text.Pandoc.Shared as Shared -- | Push the "pandoc.utils" module to the lua stack. -pushModule :: Lua NumResults -pushModule = do +pushModule :: Maybe FilePath -> Lua NumResults +pushModule mbDatadir = do Lua.newtable addFunction "hierarchicalize" hierarchicalize addFunction "normalize_date" normalizeDate + addFunction "run_json_filter" (runJSONFilter mbDatadir) addFunction "sha1" sha1 addFunction "stringify" stringify addFunction "to_roman_numeral" toRomanNumeral @@ -59,8 +63,27 @@ hierarchicalize = return . Shared.hierarchicalize -- limit years to the range 1601-9999 (ISO 8601 accepts greater than -- or equal to 1583, but MS Word only accepts dates starting 1601). -- Returns nil instead of a string if the conversion failed. -normalizeDate :: String -> Lua (OrNil String) -normalizeDate = return . OrNil . Shared.normalizeDate +normalizeDate :: String -> Lua (Lua.Optional String) +normalizeDate = return . Lua.Optional . Shared.normalizeDate + +-- | Run a JSON filter on the given document. +runJSONFilter :: Maybe FilePath + -> Pandoc + -> FilePath + -> Lua.Optional [String] + -> Lua NumResults +runJSONFilter mbDatadir doc filterFile optArgs = do + args <- case Lua.fromOptional optArgs of + Just x -> return x + Nothing -> do + Lua.getglobal "FORMAT" + (:[]) <$> popValue + filterRes <- Lua.liftIO . runIO $ do + setUserDataDir mbDatadir + JSONFilter.apply def args filterFile doc + case filterRes of + Left err -> Lua.raiseError (show err) + Right d -> (1 :: NumResults) <$ Lua.push d -- | Calculate the hash of the given contents. sha1 :: BSL.ByteString diff --git a/src/Text/Pandoc/Lua/Packages.hs b/src/Text/Pandoc/Lua/Packages.hs index f26c17084..0169d0045 100644 --- a/src/Text/Pandoc/Lua/Packages.hs +++ b/src/Text/Pandoc/Lua/Packages.hs @@ -1,5 +1,5 @@ {- -Copyright © 2017 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> +Copyright © 2017-2018 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -19,7 +19,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {-# LANGUAGE FlexibleContexts #-} {- | Module : Text.Pandoc.Lua.Packages - Copyright : Copyright © 2017 Albert Krewinkel + Copyright : Copyright © 2017-2018 Albert Krewinkel License : GNU GPL, version 2 or above Maintainer : Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> @@ -78,7 +78,8 @@ pandocPackageSearcher luaPkgParams pkgName = "pandoc.mediabag" -> let st = luaPkgCommonState luaPkgParams mbRef = luaPkgMediaBag luaPkgParams in pushWrappedHsFun (MediaBag.pushModule st mbRef) - "pandoc.utils" -> pushWrappedHsFun Utils.pushModule + "pandoc.utils" -> let datadirMb = luaPkgDataDir luaPkgParams + in pushWrappedHsFun (Utils.pushModule datadirMb) _ -> searchPureLuaLoader where pushWrappedHsFun f = do diff --git a/src/Text/Pandoc/Lua/StackInstances.hs b/src/Text/Pandoc/Lua/StackInstances.hs index 119946b78..38404157c 100644 --- a/src/Text/Pandoc/Lua/StackInstances.hs +++ b/src/Text/Pandoc/Lua/StackInstances.hs @@ -1,6 +1,6 @@ {- -Copyright © 2012-2017 John MacFarlane <jgm@berkeley.edu> - 2017 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> +Copyright © 2012-2018 John MacFarlane <jgm@berkeley.edu> + 2017-2018 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> 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 @@ -16,13 +16,14 @@ You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {- | Module : Text.Pandoc.Lua.StackInstances - Copyright : © 2012-2017 John MacFarlane - © 2017 Albert Krewinkel + Copyright : © 2012-2018 John MacFarlane + © 2017-2018 Albert Krewinkel License : GNU GPL, version 2 or above Maintainer : Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> @@ -34,30 +35,43 @@ module Text.Pandoc.Lua.StackInstances () where import Control.Applicative ((<|>)) import Control.Monad (when) +import Control.Monad.Catch (finally) +import Data.Data (showConstr, toConstr) +import Data.Foldable (forM_) import Foreign.Lua (FromLuaStack (peek), Lua, LuaInteger, LuaNumber, StackIndex, ToLuaStack (push), Type (..), throwLuaError, tryLua) import Text.Pandoc.Definition -import Text.Pandoc.Lua.Util (adjustIndexBy, getTable, pushViaConstructor) +import Text.Pandoc.Extensions (Extensions) +import Text.Pandoc.Lua.Util (adjustIndexBy, getTable, pushViaConstructor, + typeCheck) +import Text.Pandoc.Options (ReaderOptions (..), TrackChanges) import Text.Pandoc.Shared (Element (Blk, Sec), safeRead) import qualified Foreign.Lua as Lua +import qualified Data.Set as Set import qualified Text.Pandoc.Lua.Util as LuaUtil +defineHowTo :: String -> Lua a -> Lua a +defineHowTo ctx op = op `Lua.modifyLuaError` (("Could not " ++ ctx ++ ": ") ++) + instance ToLuaStack Pandoc where push (Pandoc meta blocks) = pushViaConstructor "Pandoc" blocks meta instance FromLuaStack Pandoc where - peek idx = do + peek idx = defineHowTo "get Pandoc value" $ do + typeCheck idx Lua.TypeTable blocks <- getTable idx "blocks" - meta <- getTable idx "meta" + meta <- Lua.getfield idx "meta" *> (Lua.peek Lua.stackTop `finally` Lua.pop 1) return $ Pandoc meta blocks instance ToLuaStack Meta where push (Meta mmap) = pushViaConstructor "Meta" mmap instance FromLuaStack Meta where - peek idx = Meta <$> peek idx + peek idx = defineHowTo "get Meta value" $ do + typeCheck idx Lua.TypeTable + Meta <$> peek idx instance ToLuaStack MetaValue where push = pushMetaValue @@ -84,12 +98,12 @@ instance ToLuaStack Citation where instance FromLuaStack Citation where peek idx = do - id' <- getTable idx "citationId" - prefix <- getTable idx "citationPrefix" - suffix <- getTable idx "citationSuffix" - mode <- getTable idx "citationMode" - num <- getTable idx "citationNoteNum" - hash <- getTable idx "citationHash" + id' <- getTable idx "id" + prefix <- getTable idx "prefix" + suffix <- getTable idx "suffix" + mode <- getTable idx "mode" + num <- getTable idx "note_num" + hash <- getTable idx "hash" return $ Citation id' prefix suffix mode num hash instance ToLuaStack Alignment where @@ -154,7 +168,7 @@ pushMetaValue = \case -- | Interpret the value at the given stack index as meta value. peekMetaValue :: StackIndex -> Lua MetaValue -peekMetaValue idx = do +peekMetaValue idx = defineHowTo "get MetaValue" $ do -- Get the contents of an AST element. let elementContent :: FromLuaStack a => Lua a elementContent = peek idx @@ -203,7 +217,8 @@ pushBlock = \case -- | Return the value at the given index as block if possible. peekBlock :: StackIndex -> Lua Block -peekBlock idx = do +peekBlock idx = defineHowTo "get Block value" $ do + typeCheck idx Lua.TypeTable tag <- getTag idx case tag of "BlockQuote" -> BlockQuote <$> elementContent @@ -254,7 +269,8 @@ pushInline = \case -- | Return the value at the given index as inline if possible. peekInline :: StackIndex -> Lua Inline -peekInline idx = do +peekInline idx = defineHowTo "get Inline value" $ do + typeCheck idx Lua.TypeTable tag <- getTag idx case tag of "Cite" -> uncurry Cite <$> elementContent @@ -290,11 +306,7 @@ getTag idx = do hasMT <- Lua.getmetatable idx push "tag" if hasMT then Lua.rawget (-2) else Lua.rawget (idx `adjustIndexBy` 1) - r <- tryLua (peek (-1)) - Lua.settop top - case r of - Left (Lua.LuaException err) -> throwLuaError err - Right res -> return res + peek Lua.stackTop `finally` Lua.settop top withAttr :: (Attr -> a -> b) -> (LuaAttr, a) -> b withAttr f (attributes, x) = f (fromLuaAttr attributes) x @@ -307,7 +319,7 @@ instance ToLuaStack LuaAttr where pushViaConstructor "Attr" id' classes kv instance FromLuaStack LuaAttr where - peek idx = LuaAttr <$> peek idx + peek idx = defineHowTo "get Attr value" (LuaAttr <$> peek idx) -- -- Hierarchical elements @@ -332,3 +344,43 @@ instance ToLuaStack Element where Lua.push "__index" Lua.pushvalue (-2) Lua.rawset (-3) + + +-- +-- Reader Options +-- +instance ToLuaStack Extensions where + push exts = push (show exts) + +instance ToLuaStack TrackChanges where + push = push . showConstr . toConstr + +instance ToLuaStack a => ToLuaStack (Set.Set a) where + push set = do + Lua.newtable + forM_ set (`LuaUtil.addValue` True) + +instance ToLuaStack ReaderOptions where + push ro = do + let ReaderOptions + (extensions :: Extensions) + (standalone :: Bool) + (columns :: Int) + (tabStop :: Int) + (indentedCodeClasses :: [String]) + (abbreviations :: Set.Set String) + (defaultImageExtension :: String) + (trackChanges :: TrackChanges) + (stripComments :: Bool) + = ro + Lua.newtable + LuaUtil.addValue "extensions" extensions + LuaUtil.addValue "standalone" standalone + LuaUtil.addValue "columns" columns + LuaUtil.addValue "tabStop" tabStop + LuaUtil.addValue "indentedCodeClasses" indentedCodeClasses + LuaUtil.addValue "abbreviations" abbreviations + LuaUtil.addValue "defaultImageExtension" defaultImageExtension + LuaUtil.addValue "trackChanges" trackChanges + LuaUtil.addValue "stripComments" stripComments + diff --git a/src/Text/Pandoc/Lua/Util.hs b/src/Text/Pandoc/Lua/Util.hs index 2958bd734..a3af155c9 100644 --- a/src/Text/Pandoc/Lua/Util.hs +++ b/src/Text/Pandoc/Lua/Util.hs @@ -1,6 +1,6 @@ {- -Copyright © 2012-2017 John MacFarlane <jgm@berkeley.edu> - 2017 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> +Copyright © 2012-2018 John MacFarlane <jgm@berkeley.edu> + 2017-2018 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -19,8 +19,8 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {-# LANGUAGE FlexibleInstances #-} {- | Module : Text.Pandoc.Lua.Util - Copyright : © 2012–2017 John MacFarlane, - © 2017 Albert Krewinkel + Copyright : © 2012–2018 John MacFarlane, + © 2017-2018 Albert Krewinkel License : GNU GPL, version 2 or above Maintainer : Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> @@ -36,9 +36,9 @@ module Text.Pandoc.Lua.Util , getRawInt , setRawInt , addRawInt + , typeCheck , raiseError , popValue - , OrNil (..) , PushViaCall , pushViaCall , pushViaConstructor @@ -101,6 +101,14 @@ setRawInt idx key value = do addRawInt :: ToLuaStack a => Int -> a -> Lua () addRawInt = setRawInt (-1) +typeCheck :: StackIndex -> Lua.Type -> Lua () +typeCheck idx expected = do + actual <- Lua.ltype idx + when (actual /= expected) $ do + expName <- Lua.typename expected + actName <- Lua.typename actual + Lua.throwLuaError $ "expected " ++ expName ++ " but got " ++ actName ++ "." + raiseError :: ToLuaStack a => a -> Lua NumResults raiseError e = do Lua.push e @@ -115,21 +123,6 @@ popValue = do Left err -> Lua.throwLuaError err Right x -> return x --- | Newtype wrapper intended to be used for optional Lua values. Nesting this --- type is strongly discouraged and will likely lead to a wrong result. -newtype OrNil a = OrNil { toMaybe :: Maybe a } - -instance FromLuaStack a => FromLuaStack (OrNil a) where - peek idx = do - noValue <- Lua.isnoneornil idx - if noValue - then return (OrNil Nothing) - else OrNil . Just <$> Lua.peek idx - -instance ToLuaStack a => ToLuaStack (OrNil a) where - push (OrNil Nothing) = Lua.pushnil - push (OrNil (Just x)) = Lua.push x - -- | Helper class for pushing a single value to the stack via a lua function. -- See @pushViaCall@. class PushViaCall a where diff --git a/src/Text/Pandoc/MIME.hs b/src/Text/Pandoc/MIME.hs index eba8d512f..43abe9b2f 100644 --- a/src/Text/Pandoc/MIME.hs +++ b/src/Text/Pandoc/MIME.hs @@ -1,5 +1,5 @@ {- -Copyright (C) 2011-2017 John MacFarlane <jgm@berkeley.edu> +Copyright (C) 2011-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 @@ -18,7 +18,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.MIME - Copyright : Copyright (C) 2011-2017 John MacFarlane + Copyright : Copyright (C) 2011-2018 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> diff --git a/src/Text/Pandoc/MediaBag.hs b/src/Text/Pandoc/MediaBag.hs index 1c15d1cee..0d060fe1a 100644 --- a/src/Text/Pandoc/MediaBag.hs +++ b/src/Text/Pandoc/MediaBag.hs @@ -1,7 +1,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {- -Copyright (C) 2014-2015, 2017 John MacFarlane <jgm@berkeley.edu> +Copyright (C) 2014-2015, 2017–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 @@ -20,7 +20,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.MediaBag - Copyright : Copyright (C) 2014-2015, 2017 John MacFarlane + Copyright : Copyright (C) 2014-2015, 2017–2018 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> diff --git a/src/Text/Pandoc/Options.hs b/src/Text/Pandoc/Options.hs index 1fb838321..bd4ab252b 100644 --- a/src/Text/Pandoc/Options.hs +++ b/src/Text/Pandoc/Options.hs @@ -2,7 +2,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TemplateHaskell #-} {- -Copyright (C) 2012-2017 John MacFarlane <jgm@berkeley.edu> +Copyright (C) 2012-2018 John MacFarlane <jgm@berkeley.edu> This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -21,7 +21,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.Options - Copyright : Copyright (C) 2012-2017 John MacFarlane + Copyright : Copyright (C) 2012-2018 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> diff --git a/src/Text/Pandoc/PDF.hs b/src/Text/Pandoc/PDF.hs index beb3c569f..974934763 100644 --- a/src/Text/Pandoc/PDF.hs +++ b/src/Text/Pandoc/PDF.hs @@ -2,7 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {- -Copyright (C) 2012-2017 John MacFarlane <jgm@berkeley.edu> +Copyright (C) 2012-2018 John MacFarlane <jgm@berkeley.edu> This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -21,7 +21,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.PDF - Copyright : Copyright (C) 2012-2017 John MacFarlane + Copyright : Copyright (C) 2012-2018 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> diff --git a/src/Text/Pandoc/Parsing.hs b/src/Text/Pandoc/Parsing.hs index c86f6718a..f1b823965 100644 --- a/src/Text/Pandoc/Parsing.hs +++ b/src/Text/Pandoc/Parsing.hs @@ -6,7 +6,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeSynonymInstances #-} {- -Copyright (C) 2006-2017 John MacFarlane <jgm@berkeley.edu> +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 @@ -25,7 +25,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.Parsing - Copyright : Copyright (C) 2006-2017 John MacFarlane + Copyright : Copyright (C) 2006-2018 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> @@ -180,6 +180,7 @@ module Text.Pandoc.Parsing ( takeWhileP, sourceLine, setSourceColumn, setSourceLine, + incSourceColumn, newPos, Line, Column diff --git a/src/Text/Pandoc/Pretty.hs b/src/Text/Pandoc/Pretty.hs index f95bfa8e0..25c2373a6 100644 --- a/src/Text/Pandoc/Pretty.hs +++ b/src/Text/Pandoc/Pretty.hs @@ -1,7 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {- -Copyright (C) 2010-2017 John MacFarlane <jgm@berkeley.edu> +Copyright (C) 2010-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 @@ -20,7 +20,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111(-1)307 USA {- | Module : Text.Pandoc.Pretty - Copyright : Copyright (C) 2010-2017 John MacFarlane + Copyright : Copyright (C) 2010-2018 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> diff --git a/src/Text/Pandoc/Process.hs b/src/Text/Pandoc/Process.hs index b2a0c17f1..27807a8c8 100644 --- a/src/Text/Pandoc/Process.hs +++ b/src/Text/Pandoc/Process.hs @@ -1,5 +1,5 @@ {- -Copyright (C) 2013-2017 John MacFarlane <jgm@berkeley.edu> +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 @@ -18,7 +18,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.Process - Copyright : Copyright (C) 2013-2017 John MacFarlane + Copyright : Copyright (C) 2013-2018 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> diff --git a/src/Text/Pandoc/Readers.hs b/src/Text/Pandoc/Readers.hs index a8448952e..b9374ba06 100644 --- a/src/Text/Pandoc/Readers.hs +++ b/src/Text/Pandoc/Readers.hs @@ -2,7 +2,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} {- -Copyright (C) 2006-2017 John MacFarlane <jgm@berkeley.edu> +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 @@ -21,7 +21,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.Readers - Copyright : Copyright (C) 2006-2017 John MacFarlane + Copyright : Copyright (C) 2006-2018 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> diff --git a/src/Text/Pandoc/Readers/CommonMark.hs b/src/Text/Pandoc/Readers/CommonMark.hs index ea9747342..6fbc09c17 100644 --- a/src/Text/Pandoc/Readers/CommonMark.hs +++ b/src/Text/Pandoc/Readers/CommonMark.hs @@ -1,5 +1,5 @@ {- -Copyright (C) 2015-2017 John MacFarlane <jgm@berkeley.edu> +Copyright (C) 2015-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 @@ -18,7 +18,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.Readers.CommonMark - Copyright : Copyright (C) 2015-2017 John MacFarlane + Copyright : Copyright (C) 2015-2018 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> diff --git a/src/Text/Pandoc/Readers/Docx.hs b/src/Text/Pandoc/Readers/Docx.hs index f01a94550..21120824f 100644 --- a/src/Text/Pandoc/Readers/Docx.hs +++ b/src/Text/Pandoc/Readers/Docx.hs @@ -2,7 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {- -Copyright (C) 2014-2017 Jesse Rosenthal <jrosenthal@jhu.edu> +Copyright (C) 2014-2018 Jesse Rosenthal <jrosenthal@jhu.edu> This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -21,7 +21,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.Readers.Docx - Copyright : Copyright (C) 2014-2017 Jesse Rosenthal + Copyright : Copyright (C) 2014-2018 Jesse Rosenthal License : GNU GPL, version 2 or above Maintainer : Jesse Rosenthal <jrosenthal@jhu.edu> @@ -446,6 +446,11 @@ parPartToInlines' (PlainOMath exps) = return $ math $ writeTeX exps parPartToInlines' (SmartTag runs) = do smushInlines <$> mapM runToInlines runs +parPartToInlines' (Field info runs) = do + case info of + HyperlinkField url -> parPartToInlines' $ ExternalHyperLink url runs + UnknownField -> smushInlines <$> mapM runToInlines runs +parPartToInlines' NullParPart = return mempty isAnchorSpan :: Inline -> Bool isAnchorSpan (Span (_, classes, kvs) _) = diff --git a/src/Text/Pandoc/Readers/Docx/Fields.hs b/src/Text/Pandoc/Readers/Docx/Fields.hs new file mode 100644 index 000000000..69758b431 --- /dev/null +++ b/src/Text/Pandoc/Readers/Docx/Fields.hs @@ -0,0 +1,89 @@ +{- +Copyright (C) 2014-2018 Jesse Rosenthal <jrosenthal@jhu.edu> + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- | + Module : Text.Pandoc.Readers.Docx.Fields + Copyright : Copyright (C) 2014-2018 Jesse Rosenthal + License : GNU GPL, version 2 or above + + Maintainer : Jesse Rosenthal <jrosenthal@jhu.edu> + Stability : alpha + Portability : portable + +For parsing Field definitions in instText tags, as described in +ECMA-376-1:2016, §17.16.5 -} + +module Text.Pandoc.Readers.Docx.Fields ( FieldInfo(..) + , parseFieldInfo + ) where + +import Text.Parsec +import Text.Parsec.String (Parser) + +type URL = String + +data FieldInfo = HyperlinkField URL + | UnknownField + deriving (Show) + +parseFieldInfo :: String -> Either ParseError FieldInfo +parseFieldInfo = parse fieldInfo "" + +fieldInfo :: Parser FieldInfo +fieldInfo = + (try $ HyperlinkField <$> hyperlink) + <|> + return UnknownField + +escapedQuote :: Parser String +escapedQuote = string "\\\"" + +inQuotes :: Parser String +inQuotes = do + (try escapedQuote) <|> (anyChar >>= (\c -> return [c])) + +quotedString :: Parser String +quotedString = do + char '"' + concat <$> manyTill inQuotes (try (char '"')) + +unquotedString :: Parser String +unquotedString = manyTill anyChar (try (space)) + +fieldArgument :: Parser String +fieldArgument = quotedString <|> unquotedString + +-- there are other switches, but this is the only one I've seen in the wild so far, so it's the first one I'll implement. See §17.16.5.25 +hyperlinkSwitch :: Parser (String, String) +hyperlinkSwitch = do + sw <- string "\\l" + spaces + farg <- fieldArgument + return (sw, farg) + +hyperlink :: Parser URL +hyperlink = do + many space + string "HYPERLINK" + spaces + farg <- fieldArgument + switches <- (spaces *> many hyperlinkSwitch) + let url = case switches of + ("\\l", s) : _ -> farg ++ ('#': s) + _ -> farg + return url diff --git a/src/Text/Pandoc/Readers/Docx/Lists.hs b/src/Text/Pandoc/Readers/Docx/Lists.hs index 70eccd7d6..fa4870fff 100644 --- a/src/Text/Pandoc/Readers/Docx/Lists.hs +++ b/src/Text/Pandoc/Readers/Docx/Lists.hs @@ -1,5 +1,5 @@ {- -Copyright (C) 2014-2017 Jesse Rosenthal <jrosenthal@jhu.edu> +Copyright (C) 2014-2018 Jesse Rosenthal <jrosenthal@jhu.edu> This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -18,7 +18,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.Readers.Docx.Lists - Copyright : Copyright (C) 2014-2017 Jesse Rosenthal + Copyright : Copyright (C) 2014-2018 Jesse Rosenthal License : GNU GPL, version 2 or above Maintainer : Jesse Rosenthal <jrosenthal@jhu.edu> diff --git a/src/Text/Pandoc/Readers/Docx/Parse.hs b/src/Text/Pandoc/Readers/Docx/Parse.hs index 1fcbdf386..5f648666f 100644 --- a/src/Text/Pandoc/Readers/Docx/Parse.hs +++ b/src/Text/Pandoc/Readers/Docx/Parse.hs @@ -3,7 +3,7 @@ {-# LANGUAGE ViewPatterns #-} {- -Copyright (C) 2014-2017 Jesse Rosenthal <jrosenthal@jhu.edu> +Copyright (C) 2014-2018 Jesse Rosenthal <jrosenthal@jhu.edu> This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -22,7 +22,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.Readers.Docx.Parse - Copyright : Copyright (C) 2014-2017 Jesse Rosenthal + Copyright : Copyright (C) 2014-2018 Jesse Rosenthal License : GNU GPL, version 2 or above Maintainer : Jesse Rosenthal <jrosenthal@jhu.edu> @@ -54,6 +54,7 @@ module Text.Pandoc.Readers.Docx.Parse ( Docx(..) , TrackedChange(..) , ChangeType(..) , ChangeInfo(..) + , FieldInfo(..) , archiveToDocx , archiveToDocxWithWarnings ) where @@ -70,6 +71,7 @@ import qualified Data.Map as M import Data.Maybe import System.FilePath import Text.Pandoc.Readers.Docx.Util +import Text.Pandoc.Readers.Docx.Fields import Text.Pandoc.Shared (filteredFilesFromArchive, safeRead) import qualified Text.Pandoc.UTF8 as UTF8 import Text.TeXMath (Exp) @@ -90,10 +92,19 @@ data ReaderEnv = ReaderEnv { envNotes :: Notes } deriving Show -data ReaderState = ReaderState { stateWarnings :: [String] } +data ReaderState = ReaderState { stateWarnings :: [String] + , stateFldCharState :: FldCharState + } deriving Show -data DocxError = DocxError | WrongElem +data FldCharState = FldCharOpen + | FldCharFieldInfo FieldInfo + | FldCharContent FieldInfo [Run] + | FldCharClosed + deriving (Show) + +data DocxError = DocxError + | WrongElem deriving Show type D = ExceptT DocxError (ReaderT ReaderEnv (State ReaderState)) @@ -265,6 +276,9 @@ data ParPart = PlainRun Run | Chart -- placeholder for now | PlainOMath [Exp] | SmartTag [Run] + | Field FieldInfo [Run] + | NullParPart -- when we need to return nothing, but + -- not because of an error. deriving Show data Run = Run RunStyle [RunElem] @@ -328,7 +342,9 @@ archiveToDocxWithWarnings archive = do (styles, parstyles) = archiveToStyles archive rEnv = ReaderEnv notes comments numbering rels media Nothing styles parstyles InDocument - rState = ReaderState { stateWarnings = [] } + rState = ReaderState { stateWarnings = [] + , stateFldCharState = FldCharClosed + } (eitherDoc, st) = runD (archiveToDocument archive) rEnv rState case eitherDoc of Right doc -> Right (Docx doc, stateWarnings st) @@ -736,9 +752,77 @@ elemToParPart ns element , c_ns <- "http://schemas.openxmlformats.org/drawingml/2006/chart" , Just _ <- findElement (QName "chart" (Just c_ns) (Just "c")) drawingElem = return Chart +{- +The next one is a bit complicated. fldChar fields work by first +having a <w:fldChar fldCharType="begin"> in a run, then a run with +<w:instrText>, then a <w:fldChar fldCharType="separate"> run, then the +content runs, and finally a <w:fldChar fldCharType="end"> run. For +example (omissions and my comments in brackets): + + <w:r> + [...] + <w:fldChar w:fldCharType="begin"/> + </w:r> + <w:r> + [...] + <w:instrText xml:space="preserve"> HYPERLINK [hyperlink url] </w:instrText> + </w:r> + <w:r> + [...] + <w:fldChar w:fldCharType="separate"/> + </w:r> + <w:r w:rsidRPr=[...]> + [...] + <w:t>Foundations of Analysis, 2nd Edition</w:t> + </w:r> + <w:r> + [...] + <w:fldChar w:fldCharType="end"/> + </w:r> + +So we do this in a number of steps. If we encounter the fldchar begin +tag, we start open a fldchar state variable (see state above). We add +the instrtext to it as FieldInfo. Then we close that and start adding +the runs when we get to separate. Then when we get to end, we produce +the Field type with approriate FieldInfo and Runs. +-} elemToParPart ns element - | isElem ns "w" "r" element = - elemToRun ns element >>= (\r -> return $ PlainRun r) + | isElem ns "w" "r" element + , Just fldChar <- findChildByName ns "w" "fldChar" element + , Just fldCharType <- findAttrByName ns "w" "fldCharType" fldChar = do + fldCharState <- gets stateFldCharState + case fldCharState of + FldCharClosed | fldCharType == "begin" -> do + modify $ \st -> st {stateFldCharState = FldCharOpen} + return NullParPart + FldCharFieldInfo info | fldCharType == "separate" -> do + modify $ \st -> st {stateFldCharState = FldCharContent info []} + return NullParPart + FldCharContent info runs | fldCharType == "end" -> do + modify $ \st -> st {stateFldCharState = FldCharClosed} + return $ Field info $ reverse runs + _ -> throwError WrongElem +elemToParPart ns element + | isElem ns "w" "r" element + , Just instrText <- findChildByName ns "w" "instrText" element = do + fldCharState <- gets stateFldCharState + case fldCharState of + FldCharOpen -> do + info <- eitherToD $ parseFieldInfo $ strContent instrText + modify $ \st -> st{stateFldCharState = FldCharFieldInfo info} + return NullParPart + _ -> return NullParPart +elemToParPart ns element + | isElem ns "w" "r" element = do + run <- elemToRun ns element + -- we check to see if we have an open FldChar in state that we're + -- recording. + fldCharState <- gets stateFldCharState + case fldCharState of + FldCharContent info runs -> do + modify $ \st -> st{stateFldCharState = FldCharContent info (run : runs)} + return NullParPart + _ -> return $ PlainRun run elemToParPart ns element | Just change <- getTrackedChange ns element = do runs <- mapD (elemToRun ns) (elChildren element) diff --git a/src/Text/Pandoc/Readers/HTML.hs b/src/Text/Pandoc/Readers/HTML.hs index 65171d37a..f15bf1c96 100644 --- a/src/Text/Pandoc/Readers/HTML.hs +++ b/src/Text/Pandoc/Readers/HTML.hs @@ -4,7 +4,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} {- -Copyright (C) 2006-2017 John MacFarlane <jgm@berkeley.edu> +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 @@ -23,7 +23,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.Readers.HTML - Copyright : Copyright (C) 2006-2017 John MacFarlane + Copyright : Copyright (C) 2006-2018 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> @@ -531,15 +531,18 @@ pCol = try $ do skipMany pBlank optional $ pSatisfy (matchTagClose "col") skipMany pBlank - return $ case lookup "width" attribs of + let width = case lookup "width" attribs of Nothing -> case lookup "style" attribs of Just ('w':'i':'d':'t':'h':':':xs) | '%' `elem` xs -> - fromMaybe 0.0 $ safeRead ('0':'.':filter + fromMaybe 0.0 $ safeRead (filter (`notElem` (" \t\r\n%'\";" :: [Char])) xs) _ -> 0.0 Just x | not (null x) && last x == '%' -> - fromMaybe 0.0 $ safeRead ('0':'.':init x) + fromMaybe 0.0 $ safeRead (init x) _ -> 0.0 + if width > 0.0 + then return $ width / 100.0 + else return 0.0 pColgroup :: PandocMonad m => TagParser m [Double] pColgroup = try $ do diff --git a/src/Text/Pandoc/Readers/LaTeX.hs b/src/Text/Pandoc/Readers/LaTeX.hs index a0447962c..3408201eb 100644 --- a/src/Text/Pandoc/Readers/LaTeX.hs +++ b/src/Text/Pandoc/Readers/LaTeX.hs @@ -4,7 +4,7 @@ {-# LANGUAGE PatternGuards #-} {-# LANGUAGE ScopedTypeVariables #-} {- -Copyright (C) 2006-2017 John MacFarlane <jgm@berkeley.edu> +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 @@ -23,7 +23,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.Readers.LaTeX - Copyright : Copyright (C) 2006-2017 John MacFarlane + Copyright : Copyright (C) 2006-2018 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> @@ -272,10 +272,8 @@ rawLaTeXBlock = do lookAhead (try (char '\\' >> letter)) -- we don't want to apply newly defined latex macros to their own -- definitions: - (do (_, raw) <- rawLaTeXParser macroDef - (guardDisabled Ext_latex_macros >> return raw) <|> return "") - <|> (do (_, raw) <- rawLaTeXParser (environment <|> blockCommand) - applyMacros raw) + (snd <$> rawLaTeXParser macroDef) + <|> ((snd <$> rawLaTeXParser (environment <|> blockCommand)) >>= applyMacros) rawLaTeXInline :: (PandocMonad m, HasMacros s, HasReaderOptions s) => ParserT String s m String @@ -333,13 +331,16 @@ totoks pos t = -> (T.pack "\n", T.span isSpaceOrTab r2) _ -> (mempty, (mempty, r1)) + ws = "\\" <> w1 <> w2 <> w3 in case T.uncons r3 of Just ('\n', _) -> Tok pos (CtrlSeq " ") ("\\" <> w1) - : totoks (incSourceColumn pos 1) r1 + : totoks (incSourceColumn pos (T.length ws)) + r1 _ -> - Tok pos (CtrlSeq " ") ("\\" <> w1 <> w2 <> w3) - : totoks (incSourceColumn pos 1) r3 + Tok pos (CtrlSeq " ") ws + : totoks (incSourceColumn pos (T.length ws)) + r3 | otherwise -> Tok pos (CtrlSeq (T.singleton d)) (T.pack [c,d]) : totoks (incSourceColumn pos 2) rest' @@ -404,7 +405,7 @@ satisfyTok f = | otherwise = Nothing updatePos :: SourcePos -> Tok -> [Tok] -> SourcePos updatePos _spos _ (Tok pos _ _ : _) = pos - updatePos spos _ [] = spos + updatePos spos _ [] = incSourceColumn spos 1 doMacros :: PandocMonad m => Int -> LP m () doMacros n = do @@ -442,19 +443,22 @@ doMacros n = do Just o -> (:) <$> option o bracketedToks <*> count (numargs - 1) getarg - let addTok (Tok _ (Arg i) _) acc | i > 0 - , i <= numargs = - foldr addTok acc (args !! (i - 1)) + -- first boolean param is true if we're tokenizing + -- an argument (in which case we don't want to + -- expand #1 etc.) + let addTok False (Tok _ (Arg i) _) acc | i > 0 + , i <= numargs = + foldr (addTok True) acc (args !! (i - 1)) -- add space if needed after control sequence -- see #4007 - addTok (Tok _ (CtrlSeq x) txt) + addTok _ (Tok _ (CtrlSeq x) txt) acc@(Tok _ Word _ : _) | not (T.null txt) && (isLetter (T.last txt)) = Tok spos (CtrlSeq x) (txt <> " ") : acc - addTok t acc = setpos spos t : acc + addTok _ t acc = setpos spos t : acc ts' <- getInput - setInput $ foldr addTok ts' newtoks + setInput $ foldr (addTok False) ts' newtoks case expansionPoint of ExpandWhenUsed -> if n > 20 -- detect macro expansion loops @@ -2101,7 +2105,7 @@ environments = M.fromList resetCaption *> simpTable "longtable" False >>= addTableCaption) , ("table", env "table" $ resetCaption *> skipopts *> blocks >>= addTableCaption) - , ("tabular*", env "tabular" $ simpTable "tabular*" True) + , ("tabular*", env "tabular*" $ simpTable "tabular*" True) , ("tabularx", env "tabularx" $ simpTable "tabularx" True) , ("tabular", env "tabular" $ simpTable "tabular" False) , ("quote", blockQuote <$> env "quote" blocks) diff --git a/src/Text/Pandoc/Readers/LaTeX/Types.hs b/src/Text/Pandoc/Readers/LaTeX/Types.hs index b24b2ad0a..c9cbaa9b9 100644 --- a/src/Text/Pandoc/Readers/LaTeX/Types.hs +++ b/src/Text/Pandoc/Readers/LaTeX/Types.hs @@ -1,5 +1,5 @@ {- -Copyright (C) 2017 John MacFarlane <jgm@berkeley.edu> +Copyright (C) 2017-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 @@ -18,7 +18,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.Readers.LaTeX.Types - Copyright : Copyright (C) 2017 John MacFarlane + Copyright : Copyright (C) 2017-2018 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> diff --git a/src/Text/Pandoc/Readers/Markdown.hs b/src/Text/Pandoc/Readers/Markdown.hs index 4a09c2aad..94f04eee7 100644 --- a/src/Text/Pandoc/Readers/Markdown.hs +++ b/src/Text/Pandoc/Readers/Markdown.hs @@ -2,7 +2,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {- -Copyright (C) 2006-2017 John MacFarlane <jgm@berkeley.edu> +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 @@ -21,7 +21,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.Readers.Markdown - Copyright : Copyright (C) 2006-2017 John MacFarlane + Copyright : Copyright (C) 2006-2018 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> @@ -122,6 +122,13 @@ spnl = try $ do skipSpaces notFollowedBy (char '\n') +spnl' :: PandocMonad m => ParserT [Char] st m String +spnl' = try $ do + xs <- many spaceChar + ys <- option "" $ try $ (:) <$> newline + <*> (many spaceChar <* notFollowedBy (char '\n')) + return (xs ++ ys) + indentSpaces :: PandocMonad m => MarkdownParser m String indentSpaces = try $ do tabStop <- getOption readerTabStop @@ -148,19 +155,27 @@ litChar = escapedChar' -- | Parse a sequence of inline elements between square brackets, -- including inlines between balanced pairs of square brackets. inlinesInBalancedBrackets :: PandocMonad m => MarkdownParser m (F Inlines) -inlinesInBalancedBrackets = try $ char '[' >> go 1 - where go :: PandocMonad m => Int -> MarkdownParser m (F Inlines) - go 0 = return mempty - go openBrackets = - (mappend <$> (bracketedSpan <|> link <|> image) <*> - go openBrackets) - <|> ((if openBrackets > 1 - then (return (B.str "]") <>) - else id) <$> - (char ']' >> go (openBrackets - 1))) - <|> ((return (B.str "[") <>) <$> - (char '[' >> go (openBrackets + 1))) - <|> (mappend <$> inline <*> go openBrackets) +inlinesInBalancedBrackets = + try $ char '[' >> withRaw (go 1) >>= + parseFromString inlines . stripBracket . snd + where stripBracket [] = [] + stripBracket xs = if last xs == ']' then init xs else xs + go :: PandocMonad m => Int -> MarkdownParser m () + go 0 = return () + go openBrackets = do + (() <$ (escapedChar <|> + code <|> + rawHtmlInline <|> + rawLaTeXInline') >> go openBrackets) + <|> + (do char ']' + if openBrackets > 1 + then go (openBrackets - 1) + else return ()) + <|> + (char '[' >> go (openBrackets + 1)) + <|> + (anyChar >> go openBrackets) -- -- document structure @@ -1117,10 +1132,9 @@ rawTeXBlock = do lookAhead $ try $ char '\\' >> letter result <- (B.rawBlock "context" . trim . concat <$> many1 ((++) <$> (rawConTeXtEnvironment <|> conTeXtCommand) - <*> (blanklines <|> many spaceChar))) + <*> spnl')) <|> (B.rawBlock "latex" . trim . concat <$> - many1 ((++) <$> rawLaTeXBlock - <*> (blanklines <|> many spaceChar))) + many1 ((++) <$> rawLaTeXBlock <*> spnl')) return $ case B.toList result of [RawBlock _ cs] | all (`elem` [' ','\t','\n']) cs -> return mempty diff --git a/src/Text/Pandoc/Readers/MediaWiki.hs b/src/Text/Pandoc/Readers/MediaWiki.hs index a2b3346df..c19ef2f46 100644 --- a/src/Text/Pandoc/Readers/MediaWiki.hs +++ b/src/Text/Pandoc/Readers/MediaWiki.hs @@ -3,7 +3,7 @@ {-# LANGUAGE TypeSynonymInstances #-} -- RelaxedPolyRec needed for inlinesBetween on GHC < 7 {- - Copyright (C) 2012-2017 John MacFarlane <jgm@berkeley.edu> + Copyright (C) 2012-2018 John MacFarlane <jgm@berkeley.edu> This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -22,7 +22,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.Readers.MediaWiki - Copyright : Copyright (C) 2012-2017 John MacFarlane + Copyright : Copyright (C) 2012-2018 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> diff --git a/src/Text/Pandoc/Readers/Muse.hs b/src/Text/Pandoc/Readers/Muse.hs index d86b47e83..4c6d1278e 100644 --- a/src/Text/Pandoc/Readers/Muse.hs +++ b/src/Text/Pandoc/Readers/Muse.hs @@ -1,6 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {- - Copyright (C) 2017 Alexander Krotov <ilabdsf@gmail.com> + Copyright (C) 2017-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 @@ -19,7 +19,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.Readers.Muse - Copyright : Copyright (C) 2017 Alexander Krotov + Copyright : Copyright (C) 2017-2018 Alexander Krotov License : GNU GPL, version 2 or above Maintainer : Alexander Krotov <ilabdsf@gmail.com> @@ -42,7 +42,8 @@ module Text.Pandoc.Readers.Muse (readMuse) where import Control.Monad import Control.Monad.Except (throwError) import Data.Char (isLetter) -import Data.List (stripPrefix) +import Data.List (stripPrefix, intercalate) +import Data.List.Split (splitOn) import qualified Data.Map as M import Data.Maybe (fromMaybe) import Data.Text (Text, unpack) @@ -155,10 +156,8 @@ parseDirectiveKey = do parseEmacsDirective :: PandocMonad m => MuseParser m (String, F Inlines) parseEmacsDirective = do key <- parseDirectiveKey - space - spaces - raw <- manyTill anyChar eol - value <- parseFromString (trimInlinesF . mconcat <$> many inline) raw + spaceChar + value <- trimInlinesF . mconcat <$> manyTill (choice inlineList) eol return (key, value) parseAmuseDirective :: PandocMonad m => MuseParser m (String, F Inlines) @@ -187,17 +186,19 @@ directive = do -- block parsers -- -block :: PandocMonad m => MuseParser m (F Blocks) -block = do - res <- mempty <$ skipMany1 blankline - <|> blockElements - <|> para - skipMany blankline +parseBlock :: PandocMonad m => MuseParser m (F Blocks) +parseBlock = do + res <- blockElements <|> para + optionMaybe blankline trace (take 60 $ show $ B.toList $ runF res defaultParserState) return res +block :: PandocMonad m => MuseParser m (F Blocks) +block = parseBlock <* skipMany blankline + blockElements :: PandocMonad m => MuseParser m (F Blocks) -blockElements = choice [ comment +blockElements = choice [ mempty <$ blankline + , comment , separator , header , example @@ -221,7 +222,7 @@ blockElements = choice [ comment comment :: PandocMonad m => MuseParser m (F Blocks) comment = try $ do char ';' - optionMaybe (spaceChar >> (many $ noneOf "\n")) + optionMaybe (spaceChar >> many (noneOf "\n")) eol return mempty @@ -257,15 +258,26 @@ example = try $ do -- in case opening and/or closing tags are on separate lines. chop :: String -> String chop = lchop . rchop - where lchop s = case s of + +lchop :: String -> String +lchop s = case s of '\n':ss -> ss _ -> s - rchop = reverse . lchop . reverse + +rchop :: String -> String +rchop = reverse . lchop . reverse + +dropSpacePrefix :: [String] -> [String] +dropSpacePrefix lns = + map (drop maxIndent) lns + where flns = filter (not . all (== ' ')) lns + maxIndent = if null flns then maximum (map length lns) else length $ takeWhile (== ' ') $ foldl1 commonPrefix flns exampleTag :: PandocMonad m => MuseParser m (F Blocks) -exampleTag = do +exampleTag = try $ do + many spaceChar (attr, contents) <- htmlElement "example" - return $ return $ B.codeBlockWith attr $ chop contents + return $ return $ B.codeBlockWith attr $ rchop $ intercalate "\n" $ dropSpacePrefix $ splitOn "\n" $ lchop contents literal :: PandocMonad m => MuseParser m (F Blocks) literal = do @@ -309,7 +321,6 @@ verseLine = do verseLines :: PandocMonad m => MuseParser m (F Blocks) verseLines = do - optionMaybe blankline -- Skip blankline after opening tag on separate line lns <- many verseLine lns' <- mapM (parseFromString' (trimInlinesF . mconcat <$> many inline)) lns return $ B.lineBlock <$> sequence lns' @@ -317,7 +328,7 @@ verseLines = do verseTag :: PandocMonad m => MuseParser m (F Blocks) verseTag = do (_, content) <- htmlElement "verse" - parseFromString verseLines content + parseFromString verseLines (intercalate "\n" $ dropSpacePrefix $ splitOn "\n" $ lchop content) commentTag :: PandocMonad m => MuseParser m (F Blocks) commentTag = parseHtmlContent "comment" anyChar >> return mempty @@ -349,7 +360,7 @@ amuseNoteBlock = try $ do guardEnabled Ext_amuse pos <- getPosition ref <- noteMarker <* spaceChar - content <- listItemContents $ 3 + length ref + content <- listItemContents oldnotes <- stateNotes' <$> getState case M.lookup ref oldnotes of Just _ -> logMessage $ DuplicateNoteReference ref pos @@ -379,31 +390,28 @@ emacsNoteBlock = try $ do -- Verse markup -- -lineVerseLine :: PandocMonad m => MuseParser m String +lineVerseLine :: PandocMonad m => MuseParser m (F Inlines) lineVerseLine = try $ do - char '>' - white <- many1 (char ' ' >> pure '\160') - rest <- anyLine - return $ tail white ++ rest + string "> " + indent <- B.str <$> many (char ' ' >> pure '\160') + rest <- manyTill (choice inlineList) eol + return $ trimInlinesF $ mconcat (pure indent : rest) -blanklineVerseLine :: PandocMonad m => MuseParser m Char -blanklineVerseLine = try $ char '>' >> blankline +blanklineVerseLine :: PandocMonad m => MuseParser m (F Inlines) +blanklineVerseLine = try $ do + char '>' + blankline + pure mempty lineBlock :: PandocMonad m => MuseParser m (F Blocks) lineBlock = try $ do - lns <- many1 (pure <$> blanklineVerseLine <|> lineVerseLine) - lns' <- mapM (parseFromString' (trimInlinesF . mconcat <$> many inline)) lns - return $ B.lineBlock <$> sequence lns' + lns <- many1 (blanklineVerseLine <|> lineVerseLine) + return $ B.lineBlock <$> sequence lns -- -- lists -- -listLine :: PandocMonad m => Int -> MuseParser m String -listLine markerLength = try $ do - indentWith markerLength - manyTill anyChar eol - withListContext :: PandocMonad m => MuseParser m a -> MuseParser m a withListContext p = do state <- getState @@ -413,96 +421,71 @@ withListContext p = do updateState (\st -> st {stateParserContext = oldContext}) return parsed -listContinuation :: PandocMonad m => Int -> MuseParser m [String] -listContinuation markerLength = try $ do - result <- many1 $ listLine markerLength - blank <- option id ((++ [""]) <$ blankline) - return $ blank result - -listStart :: PandocMonad m => MuseParser m Int -> MuseParser m Int -listStart marker = try $ do - preWhitespace <- length <$> many spaceChar - st <- stateParserContext <$> getState - getPosition >>= \pos -> guard (st == ListItemState || sourceColumn pos /= 1) - markerLength <- marker - void spaceChar <|> eol - return $ preWhitespace + markerLength + 1 +listItemContents' :: PandocMonad m => Int -> MuseParser m (F Blocks) +listItemContents' col = do + first <- try $ withListContext parseBlock + rest <- many $ try (skipMany blankline >> indentWith col >> withListContext parseBlock) + return $ mconcat (first : rest) -dropSpacePrefix :: [String] -> [String] -dropSpacePrefix lns = - map (drop maxIndent) lns - where flns = filter (not . all (== ' ')) lns - maxIndent = if null flns then 0 else length $ takeWhile (== ' ') $ foldl1 commonPrefix flns - -listItemContents :: PandocMonad m => Int -> MuseParser m (F Blocks) -listItemContents markerLength = do - firstLine <- manyTill anyChar eol - restLines <- many $ listLine markerLength - blank <- option id ((++ [""]) <$ blankline) - let first = firstLine : blank restLines - rest <- many $ listContinuation markerLength - let allLines = concat (first : rest) - parseFromString (withListContext parseBlocks) $ unlines (dropSpacePrefix allLines) - -listItem :: PandocMonad m => MuseParser m Int -> MuseParser m (F Blocks) -listItem start = try $ do - markerLength <- start - listItemContents markerLength - -bulletListItems :: PandocMonad m => MuseParser m (F [Blocks]) -bulletListItems = sequence <$> many1 (listItem bulletListStart) +listItemContents :: PandocMonad m => MuseParser m (F Blocks) +listItemContents = do + pos <- getPosition + let col = sourceColumn pos - 1 + listItemContents' col -bulletListStart :: PandocMonad m => MuseParser m Int -bulletListStart = listStart (char '-' >> return 1) +listItem :: PandocMonad m => Int -> MuseParser m () -> MuseParser m (F Blocks) +listItem n p = try $ do + optionMaybe blankline + count n spaceChar + p + void spaceChar <|> lookAhead eol + listItemContents bulletList :: PandocMonad m => MuseParser m (F Blocks) -bulletList = do - listItems <- bulletListItems - return $ B.bulletList <$> listItems - -orderedListStart :: PandocMonad m - => ListNumberStyle - -> ListNumberDelim - -> MuseParser m Int -orderedListStart style delim = listStart (snd <$> withHorizDisplacement (orderedListMarker style delim)) +bulletList = try $ do + many spaceChar + pos <- getPosition + let col = sourceColumn pos + guard $ col /= 1 + char '-' + void spaceChar <|> lookAhead eol + first <- listItemContents + rest <- many $ listItem (col - 1) (void (char '-')) + return $ B.bulletList <$> sequence (first : rest) orderedList :: PandocMonad m => MuseParser m (F Blocks) orderedList = try $ do - p@(_, style, delim) <- lookAhead (many spaceChar *> anyOrderedListMarker <* (eol <|> void spaceChar)) + many spaceChar + pos <- getPosition + let col = sourceColumn pos + guard $ col /= 1 + p@(_, style, delim) <- anyOrderedListMarker guard $ style `elem` [Decimal, LowerAlpha, UpperAlpha, LowerRoman, UpperRoman] guard $ delim == Period - items <- sequence <$> many1 (listItem $ orderedListStart style delim) - return $ B.orderedListWith p <$> items - -definitionListItem :: PandocMonad m => MuseParser m (F (Inlines, [Blocks])) -definitionListItem = try $ do - rawTerm <- termParser - term <- parseFromString (trimInlinesF . mconcat <$> many inline) rawTerm - many1 spaceChar - string "::" - firstLine <- manyTill anyChar eol - restLines <- manyTill anyLine endOfListItemElement - let lns = dropWhile (== ' ') firstLine : dropSpacePrefix restLines - lineContent <- parseFromString (withListContext parseBlocks) $ unlines lns - pure $ do lineContent' <- lineContent + void spaceChar <|> lookAhead eol + first <- listItemContents + rest <- many $ listItem (col - 1) (void (orderedListMarker style delim)) + return $ B.orderedListWith p <$> sequence (first : rest) + +definitionListItem :: PandocMonad m => Int -> MuseParser m (F (Inlines, [Blocks])) +definitionListItem n = try $ do + count n spaceChar + pos <- getPosition + term <- trimInlinesF . mconcat <$> manyTill (choice inlineList) (string "::") + void spaceChar <|> lookAhead eol + contents <- listItemContents' $ sourceColumn pos + pure $ do lineContent' <- contents term' <- term pure (term', [lineContent']) - where - termParser = (guardDisabled Ext_amuse <|> void spaceChar) >> -- Initial space is required by Amusewiki, but not Emacs Muse - many spaceChar >> - many1Till (noneOf "\n") (lookAhead (void (try (spaceChar >> string "::")))) - endOfInput = lookAhead $ try $ skipMany blankline >> skipSpaces >> eof - twoBlankLines = try $ blankline >> skipMany1 blankline - newDefinitionListItem = try $ void termParser - endOfListItemElement = lookAhead $ endOfInput <|> newDefinitionListItem <|> twoBlankLines - -definitionListItems :: PandocMonad m => MuseParser m (F [(Inlines, [Blocks])]) -definitionListItems = sequence <$> many1 definitionListItem definitionList :: PandocMonad m => MuseParser m (F Blocks) -definitionList = do - listItems <- definitionListItems - return $ B.definitionList <$> listItems +definitionList = try $ do + many spaceChar + pos <- getPosition + (guardDisabled Ext_amuse) <|> (guard (sourceColumn pos /= 1)) -- Initial space is required by Amusewiki, but not Emacs Muse + first <- definitionListItem 0 + rest <- many $ try (optionMaybe blankline >> definitionListItem (sourceColumn pos - 1)) + return $ B.definitionList <$> sequence (first : rest) -- -- tables @@ -590,16 +573,14 @@ tableParseCaption :: PandocMonad m => MuseParser m MuseTableElement tableParseCaption = try $ do many spaceChar string "|+" - contents <- trimInlinesF . mconcat <$> many1Till inline (lookAhead $ string "+|") - string "+|" - return $ MuseCaption contents + MuseCaption <$> (trimInlinesF . mconcat <$> many1Till inline (string "+|")) -- -- inline parsers -- inlineList :: PandocMonad m => [MuseParser m (F Inlines)] -inlineList = [ endline +inlineList = [ whitespace , br , anchor , footnote @@ -617,13 +598,12 @@ inlineList = [ endline , code , codeTag , inlineLiteralTag - , whitespace , str , symbol ] inline :: PandocMonad m => MuseParser m (F Inlines) -inline = choice inlineList <?> "inline" +inline = choice [endline, linebreak] <|> choice inlineList <?> "inline" endline :: PandocMonad m => MuseParser m (F Inlines) endline = try $ do @@ -657,23 +637,23 @@ footnote = try $ do let contents' = runF contents st { stateNotes' = M.empty } return $ B.note contents' +linebreak :: PandocMonad m => MuseParser m (F Inlines) +linebreak = try $ do + skipMany spaceChar + newline + notFollowedBy newline + return $ return B.space + whitespace :: PandocMonad m => MuseParser m (F Inlines) -whitespace = fmap return (lb <|> regsp) - where lb = try $ skipMany spaceChar >> linebreak >> return B.space - regsp = try $ skipMany1 spaceChar >> return B.space +whitespace = try $ do + skipMany1 spaceChar + return $ return B.space br :: PandocMonad m => MuseParser m (F Inlines) br = try $ do string "<br>" return $ return B.linebreak -linebreak :: PandocMonad m => MuseParser m (F Inlines) -linebreak = newline >> notFollowedBy newline >> (lastNewline <|> innerNewline) - where lastNewline = do - eof - return $ return mempty - innerNewline = return $ return B.space - emphasisBetween :: (PandocMonad m, Show a) => MuseParser m a -> MuseParser m (F Inlines) emphasisBetween c = try $ enclosedInlines c c @@ -724,28 +704,23 @@ verbatimTag = do return $ return $ B.text content nbsp :: PandocMonad m => MuseParser m (F Inlines) -nbsp = do - guardDisabled Ext_amuse -- Supported only by Emacs Muse +nbsp = try $ do string "~~" return $ return $ B.str "\160" code :: PandocMonad m => MuseParser m (F Inlines) code = try $ do - pos <- getPosition - sp <- if sourceColumn pos == 1 - then pure mempty - else skipMany1 spaceChar >> pure B.space - char '=' + atStart $ char '=' contents <- many1Till (noneOf "\n\r" <|> (newline <* notFollowedBy newline)) $ char '=' guard $ not $ null contents guard $ head contents `notElem` " \t\n" guard $ last contents `notElem` " \t\n" notFollowedBy $ satisfy isLetter - return $ return (sp B.<> B.code contents) + return $ return $ B.code contents codeTag :: PandocMonad m => MuseParser m (F Inlines) codeTag = do - (attrs, content) <- parseHtmlContentWithAttrs "code" anyChar + (attrs, content) <- htmlElement "code" return $ return $ B.codeWith attrs content inlineLiteralTag :: PandocMonad m => MuseParser m (F Inlines) @@ -786,8 +761,7 @@ link = try $ do linkContent :: PandocMonad m => MuseParser m (F Inlines) linkContent = do char '[' - res <- many1Till anyChar $ char ']' - parseFromString (mconcat <$> many1 inline) res + trimInlinesF . mconcat <$> many1Till inline (string "]") linkText :: PandocMonad m => MuseParser m (String, String, Maybe (F Inlines)) linkText = do diff --git a/src/Text/Pandoc/Readers/Native.hs b/src/Text/Pandoc/Readers/Native.hs index ce33e080b..88f6bfe8f 100644 --- a/src/Text/Pandoc/Readers/Native.hs +++ b/src/Text/Pandoc/Readers/Native.hs @@ -1,5 +1,5 @@ {- -Copyright (C) 2011-2017 John MacFarlane <jgm@berkeley.edu> +Copyright (C) 2011-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 @@ -18,7 +18,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.Readers.Native - Copyright : Copyright (C) 2011-2017 John MacFarlane + Copyright : Copyright (C) 2011-2018 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> diff --git a/src/Text/Pandoc/Readers/Org.hs b/src/Text/Pandoc/Readers/Org.hs index eaccc251c..292830bd2 100644 --- a/src/Text/Pandoc/Readers/Org.hs +++ b/src/Text/Pandoc/Readers/Org.hs @@ -1,5 +1,5 @@ {- -Copyright (C) 2014-2017 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> +Copyright (C) 2014-2018 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> 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 @@ -18,7 +18,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.Readers.Org - Copyright : Copyright (C) 2014-2017 Albert Krewinkel + Copyright : Copyright (C) 2014-2018 Albert Krewinkel License : GNU GPL, version 2 or above Maintainer : Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> diff --git a/src/Text/Pandoc/Readers/Org/BlockStarts.hs b/src/Text/Pandoc/Readers/Org/BlockStarts.hs index 7937c0ef7..424102cb0 100644 --- a/src/Text/Pandoc/Readers/Org/BlockStarts.hs +++ b/src/Text/Pandoc/Readers/Org/BlockStarts.hs @@ -1,5 +1,5 @@ {- -Copyright (C) 2014-2017 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> +Copyright (C) 2014-2018 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> 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 @@ -18,7 +18,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.Readers.Org.BlockStarts - Copyright : Copyright (C) 2014-2017 Albert Krewinkel + Copyright : Copyright (C) 2014-2018 Albert Krewinkel License : GNU GPL, version 2 or above Maintainer : Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> diff --git a/src/Text/Pandoc/Readers/Org/Blocks.hs b/src/Text/Pandoc/Readers/Org/Blocks.hs index a930652af..c5a7d8e10 100644 --- a/src/Text/Pandoc/Readers/Org/Blocks.hs +++ b/src/Text/Pandoc/Readers/Org/Blocks.hs @@ -1,5 +1,5 @@ {- -Copyright (C) 2014-2017 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> +Copyright (C) 2014-2018 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -19,7 +19,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {-# LANGUAGE RecordWildCards #-} {- | Module : Text.Pandoc.Readers.Org.Blocks - Copyright : Copyright (C) 2014-2017 Albert Krewinkel + Copyright : Copyright (C) 2014-2018 Albert Krewinkel License : GNU GPL, version 2 or above Maintainer : Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> diff --git a/src/Text/Pandoc/Readers/Org/DocumentTree.hs b/src/Text/Pandoc/Readers/Org/DocumentTree.hs index 3b90c9336..f77778ec9 100644 --- a/src/Text/Pandoc/Readers/Org/DocumentTree.hs +++ b/src/Text/Pandoc/Readers/Org/DocumentTree.hs @@ -1,5 +1,5 @@ {- -Copyright (C) 2014-2017 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> +Copyright (C) 2014-2018 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> 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 @@ -20,7 +20,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {-# LANGUAGE ViewPatterns #-} {- | Module : Text.Pandoc.Readers.Org.DocumentTree - Copyright : Copyright (C) 2014-2017 Albert Krewinkel + Copyright : Copyright (C) 2014-2018 Albert Krewinkel License : GNU GPL, version 2 or above Maintainer : Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> diff --git a/src/Text/Pandoc/Readers/Org/ExportSettings.hs b/src/Text/Pandoc/Readers/Org/ExportSettings.hs index 36258aeba..6a70c50b9 100644 --- a/src/Text/Pandoc/Readers/Org/ExportSettings.hs +++ b/src/Text/Pandoc/Readers/Org/ExportSettings.hs @@ -1,5 +1,5 @@ {- -Copyright (C) 2014-2017 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> +Copyright (C) 2016-2018 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> 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 @@ -18,7 +18,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.Readers.Org.ExportSettings - Copyright : © 2016–2017 Albert Krewinkel + Copyright : © 2016–2018 Albert Krewinkel License : GNU GPL, version 2 or above Maintainer : Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> diff --git a/src/Text/Pandoc/Readers/Org/Inlines.hs b/src/Text/Pandoc/Readers/Org/Inlines.hs index f3649af66..670f8ace0 100644 --- a/src/Text/Pandoc/Readers/Org/Inlines.hs +++ b/src/Text/Pandoc/Readers/Org/Inlines.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {- -Copyright (C) 2014-2017 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> +Copyright (C) 2014-2018 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -19,7 +19,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.Readers.Org.Inlines - Copyright : Copyright (C) 2014-2017 Albert Krewinkel + Copyright : Copyright (C) 2014-2018 Albert Krewinkel License : GNU GPL, version 2 or above Maintainer : Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> diff --git a/src/Text/Pandoc/Readers/Org/Meta.hs b/src/Text/Pandoc/Readers/Org/Meta.hs index d22902eae..0a690028d 100644 --- a/src/Text/Pandoc/Readers/Org/Meta.hs +++ b/src/Text/Pandoc/Readers/Org/Meta.hs @@ -1,7 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TupleSections #-} {- -Copyright (C) 2014-2017 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> +Copyright (C) 2014-2018 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> 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 @@ -20,7 +20,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.Readers.Org.Meta - Copyright : Copyright (C) 2014-2017 Albert Krewinkel + Copyright : Copyright (C) 2014-2018 Albert Krewinkel License : GNU GPL, version 2 or above Maintainer : Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> diff --git a/src/Text/Pandoc/Readers/Org/ParserState.hs b/src/Text/Pandoc/Readers/Org/ParserState.hs index e0045fcd5..e2acce5bf 100644 --- a/src/Text/Pandoc/Readers/Org/ParserState.hs +++ b/src/Text/Pandoc/Readers/Org/ParserState.hs @@ -1,7 +1,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {- -Copyright (C) 2014-2017 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> +Copyright (C) 2014-2018 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> 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 @@ -20,7 +20,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.Readers.Org.ParserState - Copyright : Copyright (C) 2014-2017 Albert Krewinkel + Copyright : Copyright (C) 2014-2018 Albert Krewinkel License : GNU GPL, version 2 or above Maintainer : Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> diff --git a/src/Text/Pandoc/Readers/Org/Parsing.hs b/src/Text/Pandoc/Readers/Org/Parsing.hs index 3273c92e4..36420478b 100644 --- a/src/Text/Pandoc/Readers/Org/Parsing.hs +++ b/src/Text/Pandoc/Readers/Org/Parsing.hs @@ -1,5 +1,5 @@ {- -Copyright (C) 2014-2017 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> +Copyright (C) 2014-2018 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> 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 @@ -18,7 +18,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.Readers.Org.Parsing - Copyright : Copyright (C) 2014-2017 Albert Krewinkel + Copyright : Copyright (C) 2014-2018 Albert Krewinkel License : GNU GPL, version 2 or above Maintainer : Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> diff --git a/src/Text/Pandoc/Readers/Org/Shared.hs b/src/Text/Pandoc/Readers/Org/Shared.hs index 580e9194f..cba72cc07 100644 --- a/src/Text/Pandoc/Readers/Org/Shared.hs +++ b/src/Text/Pandoc/Readers/Org/Shared.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {- -Copyright (C) 2014-2017 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> +Copyright (C) 2014-2018 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -19,7 +19,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.Readers.Org.Shared - Copyright : Copyright (C) 2014-2017 Albert Krewinkel + Copyright : Copyright (C) 2014-2018 Albert Krewinkel License : GNU GPL, version 2 or above Maintainer : Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> diff --git a/src/Text/Pandoc/Readers/RST.hs b/src/Text/Pandoc/Readers/RST.hs index 9f259d958..49cc3018c 100644 --- a/src/Text/Pandoc/Readers/RST.hs +++ b/src/Text/Pandoc/Readers/RST.hs @@ -2,7 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {- -Copyright (C) 2006-2017 John MacFarlane <jgm@berkeley.edu> +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 @@ -21,7 +21,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.Readers.RST - Copyright : Copyright (C) 2006-2017 John MacFarlane + Copyright : Copyright (C) 2006-2018 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> @@ -972,11 +972,16 @@ extractCaption = do legend <- optional blanklines >> (mconcat <$> many block) return (capt,legend) --- divide string by blanklines +-- divide string by blanklines, and surround with +-- \begin{aligned}...\end{aligned} if needed. toChunks :: String -> [String] toChunks = dropWhile null - . map (trim . unlines) + . map (addAligned . trim . unlines) . splitBy (all (`elem` (" \t" :: String))) . lines + -- we put this in an aligned environment if it contains \\, see #4254 + where addAligned s = if "\\\\" `isInfixOf` s + then "\\begin{aligned}\n" ++ s ++ "\n\\end{aligned}" + else s codeblock :: [String] -> Maybe String -> String -> String -> RSTParser m Blocks codeblock classes numberLines lang body = @@ -1157,9 +1162,19 @@ anchor = try $ do refs <- referenceNames blanklines b <- block - -- put identifier on next block: let addDiv ref = B.divWith (ref, [], []) - return $ foldr addDiv b refs + let emptySpanWithId id' = Span (id',[],[]) [] + -- put identifier on next block: + case B.toList b of + [Header lev (_,classes,kvs) txt] -> + case reverse refs of + [] -> return b + (r:rs) -> return $ B.singleton $ + Header lev (r,classes,kvs) + (txt ++ map emptySpanWithId rs) + -- we avoid generating divs for headers, + -- because it hides them from promoteHeader, see #4240 + _ -> return $ foldr addDiv b refs headerBlock :: PandocMonad m => RSTParser m [Char] headerBlock = do diff --git a/src/Text/Pandoc/Readers/Textile.hs b/src/Text/Pandoc/Readers/Textile.hs index a3b4f2ff1..46d6301e4 100644 --- a/src/Text/Pandoc/Readers/Textile.hs +++ b/src/Text/Pandoc/Readers/Textile.hs @@ -1,6 +1,6 @@ {- Copyright (C) 2010-2012 Paul Rivier <paul*rivier#demotera*com> | tr '*#' '.@' - 2010-2017 John MacFarlane + 2010-2018 John MacFarlane This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -20,7 +20,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.Readers.Textile Copyright : Copyright (C) 2010-2012 Paul Rivier - 2010-2017 John MacFarlane + 2010-2018 John MacFarlane License : GNU GPL, version 2 or above Maintainer : Paul Rivier <paul*rivier#demotera*com> diff --git a/src/Text/Pandoc/Readers/Vimwiki.hs b/src/Text/Pandoc/Readers/Vimwiki.hs index 5575b3687..162fb371e 100644 --- a/src/Text/Pandoc/Readers/Vimwiki.hs +++ b/src/Text/Pandoc/Readers/Vimwiki.hs @@ -1,5 +1,5 @@ {- - Copyright (C) 2017 Yuchen Pei <me@ypei.me> + Copyright (C) 2017-2018 Yuchen Pei <me@ypei.me> 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 @@ -18,7 +18,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.Readers.Vimwiki - Copyright : Copyright (C) 2017 Yuchen Pei + Copyright : Copyright (C) 2017-2018 Yuchen Pei License : GNU GPL, version 2 or above Maintainer : Yuchen Pei <me@ypei.me> diff --git a/src/Text/Pandoc/SelfContained.hs b/src/Text/Pandoc/SelfContained.hs index 7cdd6f6e1..a1c5c919e 100644 --- a/src/Text/Pandoc/SelfContained.hs +++ b/src/Text/Pandoc/SelfContained.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {- -Copyright (C) 2011-2017 John MacFarlane <jgm@berkeley.edu> +Copyright (C) 2011-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 @@ -19,7 +19,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.SelfContained - Copyright : Copyright (C) 2011-2017 John MacFarlane + Copyright : Copyright (C) 2011-2018 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> diff --git a/src/Text/Pandoc/Shared.hs b/src/Text/Pandoc/Shared.hs index 005603191..583c7a63f 100644 --- a/src/Text/Pandoc/Shared.hs +++ b/src/Text/Pandoc/Shared.hs @@ -6,7 +6,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} {- -Copyright (C) 2006-2017 John MacFarlane <jgm@berkeley.edu> +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 @@ -25,7 +25,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.Shared - Copyright : Copyright (C) 2006-2017 John MacFarlane + Copyright : Copyright (C) 2006-2018 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> diff --git a/src/Text/Pandoc/Slides.hs b/src/Text/Pandoc/Slides.hs index 27e7d3d76..9d63555c2 100644 --- a/src/Text/Pandoc/Slides.hs +++ b/src/Text/Pandoc/Slides.hs @@ -1,5 +1,5 @@ {- -Copyright (C) 2012-2017 John MacFarlane <jgm@berkeley.edu> +Copyright (C) 2012-2018 John MacFarlane <jgm@berkeley.edu> This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -18,7 +18,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.Slides - Copyright : Copyright (C) 2012-2017 John MacFarlane + Copyright : Copyright (C) 2012-2018 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> diff --git a/src/Text/Pandoc/Templates.hs b/src/Text/Pandoc/Templates.hs index d4524c333..4be0d081c 100644 --- a/src/Text/Pandoc/Templates.hs +++ b/src/Text/Pandoc/Templates.hs @@ -3,7 +3,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeSynonymInstances #-} {- -Copyright (C) 2009-2017 John MacFarlane <jgm@berkeley.edu> +Copyright (C) 2009-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 @@ -22,7 +22,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.Templates - Copyright : Copyright (C) 2009-2017 John MacFarlane + Copyright : Copyright (C) 2009-2018 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> diff --git a/src/Text/Pandoc/Translations.hs b/src/Text/Pandoc/Translations.hs index 00529c1de..949618178 100644 --- a/src/Text/Pandoc/Translations.hs +++ b/src/Text/Pandoc/Translations.hs @@ -1,7 +1,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {- -Copyright (C) 2017 John MacFarlane <jgm@berkeley.edu> +Copyright (C) 2017-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 @@ -20,7 +20,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.Translations - Copyright : Copyright (C) 2017 John MacFarlane + Copyright : Copyright (C) 2017-2018 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> diff --git a/src/Text/Pandoc/UTF8.hs b/src/Text/Pandoc/UTF8.hs index 663f30d92..3f759958f 100644 --- a/src/Text/Pandoc/UTF8.hs +++ b/src/Text/Pandoc/UTF8.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {- -Copyright (C) 2010-2017 John MacFarlane <jgm@berkeley.edu> +Copyright (C) 2010-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 @@ -19,7 +19,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.UTF8 - Copyright : Copyright (C) 2010-2017 John MacFarlane + Copyright : Copyright (C) 2010-2018 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> diff --git a/src/Text/Pandoc/UUID.hs b/src/Text/Pandoc/UUID.hs index 1527ce435..4d99324db 100644 --- a/src/Text/Pandoc/UUID.hs +++ b/src/Text/Pandoc/UUID.hs @@ -1,5 +1,5 @@ {- -Copyright (C) 2010-2017 John MacFarlane <jgm@berkeley.edu> +Copyright (C) 2010-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 @@ -18,7 +18,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.UUID - Copyright : Copyright (C) 2010-2017 John MacFarlane + Copyright : Copyright (C) 2010-2018 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> diff --git a/src/Text/Pandoc/Writers.hs b/src/Text/Pandoc/Writers.hs index b336c1f1a..596a8680e 100644 --- a/src/Text/Pandoc/Writers.hs +++ b/src/Text/Pandoc/Writers.hs @@ -1,5 +1,5 @@ {- -Copyright (C) 2006-2017 John MacFarlane <jgm@berkeley.edu> +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 @@ -21,7 +21,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc - Copyright : Copyright (C) 2006-2017 John MacFarlane + Copyright : Copyright (C) 2006-2018 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> diff --git a/src/Text/Pandoc/Writers/AsciiDoc.hs b/src/Text/Pandoc/Writers/AsciiDoc.hs index 3231e1e30..a6906eb68 100644 --- a/src/Text/Pandoc/Writers/AsciiDoc.hs +++ b/src/Text/Pandoc/Writers/AsciiDoc.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {- -Copyright (C) 2006-2017 John MacFarlane <jgm@berkeley.edu> +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 @@ -19,7 +19,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.Writers.AsciiDoc - Copyright : Copyright (C) 2006-2017 John MacFarlane + Copyright : Copyright (C) 2006-2018 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> diff --git a/src/Text/Pandoc/Writers/CommonMark.hs b/src/Text/Pandoc/Writers/CommonMark.hs index 8d1eb04d1..7a6eb2948 100644 --- a/src/Text/Pandoc/Writers/CommonMark.hs +++ b/src/Text/Pandoc/Writers/CommonMark.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {- -Copyright (C) 2015-2017 John MacFarlane <jgm@berkeley.edu> +Copyright (C) 2015-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 @@ -19,7 +19,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.Writers.CommonMark - Copyright : Copyright (C) 2015-2017 John MacFarlane + Copyright : Copyright (C) 2015-2018 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> diff --git a/src/Text/Pandoc/Writers/ConTeXt.hs b/src/Text/Pandoc/Writers/ConTeXt.hs index f0f4cd00e..64b7d2c53 100644 --- a/src/Text/Pandoc/Writers/ConTeXt.hs +++ b/src/Text/Pandoc/Writers/ConTeXt.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {- -Copyright (C) 2007-2017 John MacFarlane <jgm@berkeley.edu> +Copyright (C) 2007-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 @@ -20,7 +20,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.Writers.ConTeXt - Copyright : Copyright (C) 2007-2017 John MacFarlane + Copyright : Copyright (C) 2007-2018 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> @@ -55,6 +55,8 @@ data WriterState = , stOptions :: WriterOptions -- writer options } +data Tabl = Xtb | Ntb deriving (Show, Eq) + orderedListStyles :: [Char] orderedListStyles = cycle "narg" @@ -252,33 +254,77 @@ blockToConTeXt HorizontalRule = return $ "\\thinrule" <> blankline -- If this is ever executed, provide a default for the reference identifier. blockToConTeXt (Header level attr lst) = sectionHeader attr level lst blockToConTeXt (Table caption aligns widths heads rows) = do - let colDescriptor colWidth alignment = (case alignment of - AlignLeft -> 'l' - AlignRight -> 'r' - AlignCenter -> 'c' - AlignDefault -> 'l'): - if colWidth == 0 - then "|" - else ("p(" ++ printf "%.2f" colWidth ++ "\\textwidth)|") - let colDescriptors = "|" ++ concat ( - zipWith colDescriptor widths aligns) - headers <- if all null heads - then return empty - else liftM ($$ "\\HL") $ tableRowToConTeXt heads + opts <- gets stOptions + let tabl = if isEnabled Ext_ntb opts + then Ntb + else Xtb captionText <- inlineListToConTeXt caption - rows' <- mapM tableRowToConTeXt rows - return $ "\\placetable" <> (if null caption - then brackets "none" - else empty) - <> braces captionText $$ - "\\starttable" <> brackets (text colDescriptors) $$ - "\\HL" $$ headers $$ - vcat rows' $$ "\\HL" $$ "\\stoptable" <> blankline - -tableRowToConTeXt :: PandocMonad m => [[Block]] -> WM m Doc -tableRowToConTeXt cols = do - cols' <- mapM blockListToConTeXt cols - return $ vcat (map ("\\NC " <>) cols') $$ "\\NC\\AR" + headers <- if all null heads + then return empty + else tableRowToConTeXt tabl aligns widths heads + rows' <- mapM (tableRowToConTeXt tabl aligns widths) rows + body <- tableToConTeXt tabl headers rows' + return $ "\\startplacetable" <> brackets ( + if null caption + then "location=none" + else "caption=" <> braces captionText + ) $$ body $$ "\\stopplacetable" <> blankline + +tableToConTeXt :: PandocMonad m => Tabl -> Doc -> [Doc] -> WM m Doc +tableToConTeXt Xtb heads rows = + return $ "\\startxtable" $$ + (if isEmpty heads + then empty + else "\\startxtablehead[head]" $$ heads $$ "\\stopxtablehead") $$ + (if null rows + then empty + else "\\startxtablebody[body]" $$ vcat (init rows) $$ "\\stopxtablebody" $$ + "\\startxtablefoot[foot]" $$ last rows $$ "\\stopxtablefoot") $$ + "\\stopxtable" +tableToConTeXt Ntb heads rows = + return $ "\\startTABLE" $$ + (if isEmpty heads + then empty + else "\\startTABLEhead" $$ heads $$ "\\stopTABLEhead") $$ + (if null rows + then empty + else "\\startTABLEbody" $$ vcat (init rows) $$ "\\stopTABLEbody" $$ + "\\startTABLEfoot" $$ last rows $$ "\\stopTABLEfoot") $$ + "\\stopTABLE" + +tableRowToConTeXt :: PandocMonad m => Tabl -> [Alignment] -> [Double] -> [[Block]] -> WM m Doc +tableRowToConTeXt Xtb aligns widths cols = do + cells <- mapM (tableColToConTeXt Xtb) $ zip3 aligns widths cols + return $ "\\startxrow" $$ vcat cells $$ "\\stopxrow" +tableRowToConTeXt Ntb aligns widths cols = do + cells <- mapM (tableColToConTeXt Ntb) $ zip3 aligns widths cols + return $ vcat cells $$ "\\NC\\NR" + +tableColToConTeXt :: PandocMonad m => Tabl -> (Alignment, Double, [Block]) -> WM m Doc +tableColToConTeXt tabl (align, width, blocks) = do + cellContents <- blockListToConTeXt blocks + let colwidth = if width == 0 + then empty + else "width=" <> braces (text (printf "%.2f\\textwidth" width)) + let halign = alignToConTeXt align + let options = (if keys == empty + then empty + else brackets keys) <> space + where keys = hcat $ intersperse "," $ filter (empty /=) [halign, colwidth] + tableCellToConTeXt tabl options cellContents + +tableCellToConTeXt :: PandocMonad m => Tabl -> Doc -> Doc -> WM m Doc +tableCellToConTeXt Xtb options cellContents = + return $ "\\startxcell" <> options <> cellContents <> " \\stopxcell" +tableCellToConTeXt Ntb options cellContents = + return $ "\\NC" <> options <> cellContents + +alignToConTeXt :: Alignment -> Doc +alignToConTeXt align = case align of + AlignLeft -> "align=right" + AlignRight -> "align=left" + AlignCenter -> "align=middle" + AlignDefault -> empty listItemToConTeXt :: PandocMonad m => [Block] -> WM m Doc listItemToConTeXt list = blockListToConTeXt list >>= diff --git a/src/Text/Pandoc/Writers/Custom.hs b/src/Text/Pandoc/Writers/Custom.hs index a33196cbe..37b44b646 100644 --- a/src/Text/Pandoc/Writers/Custom.hs +++ b/src/Text/Pandoc/Writers/Custom.hs @@ -1,6 +1,6 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} -{- Copyright (C) 2012-2017 John MacFarlane <jgm@berkeley.edu> +{- Copyright (C) 2012-2018 John MacFarlane <jgm@berkeley.edu> This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -19,7 +19,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.Writers.Custom - Copyright : Copyright (C) 2012-2017 John MacFarlane + Copyright : Copyright (C) 2012-2018 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> diff --git a/src/Text/Pandoc/Writers/Docbook.hs b/src/Text/Pandoc/Writers/Docbook.hs index 74a1249a4..3034fade5 100644 --- a/src/Text/Pandoc/Writers/Docbook.hs +++ b/src/Text/Pandoc/Writers/Docbook.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {- -Copyright (C) 2006-2017 John MacFarlane <jgm@berkeley.edu> +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 @@ -20,7 +20,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.Writers.Docbook - Copyright : Copyright (C) 2006-2017 John MacFarlane + Copyright : Copyright (C) 2006-2018 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> diff --git a/src/Text/Pandoc/Writers/Docx.hs b/src/Text/Pandoc/Writers/Docx.hs index 6343b314e..adf5f232a 100644 --- a/src/Text/Pandoc/Writers/Docx.hs +++ b/src/Text/Pandoc/Writers/Docx.hs @@ -1,10 +1,9 @@ - {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} {- -Copyright (C) 2012-2017 John MacFarlane <jgm@berkeley.edu> +Copyright (C) 2012-2018 John MacFarlane <jgm@berkeley.edu> This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -23,7 +22,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.Writers.Docx - Copyright : Copyright (C) 2012-2017 John MacFarlane + Copyright : Copyright (C) 2012-2018 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> @@ -65,7 +64,7 @@ import Text.Pandoc.Readers.Docx.StyleMap import Text.Pandoc.Shared hiding (Element) import Text.Pandoc.Walk import Text.Pandoc.Writers.Math -import Text.Pandoc.Writers.Shared (fixDisplayMath) +import Text.Pandoc.Writers.Shared (fixDisplayMath, metaValueToInlines) import Text.Printf (printf) import Text.TeXMath import Text.XML.Light as XML @@ -196,15 +195,6 @@ isValidChar (ord -> c) | 0x10000 <= c && c <= 0x10FFFF = True | otherwise = False -metaValueToInlines :: MetaValue -> [Inline] -metaValueToInlines (MetaString s) = [Str s] -metaValueToInlines (MetaInlines ils) = ils -metaValueToInlines (MetaBlocks bs) = query return bs -metaValueToInlines (MetaBool b) = [Str $ show b] -metaValueToInlines _ = [] - - - writeDocx :: (PandocMonad m) => WriterOptions -- ^ Writer options -> Pandoc -- ^ Document to convert diff --git a/src/Text/Pandoc/Writers/DokuWiki.hs b/src/Text/Pandoc/Writers/DokuWiki.hs index e52cc75ad..dda21d23d 100644 --- a/src/Text/Pandoc/Writers/DokuWiki.hs +++ b/src/Text/Pandoc/Writers/DokuWiki.hs @@ -1,5 +1,5 @@ {- -Copyright (C) 2008-2017 John MacFarlane <jgm@berkeley.edu> +Copyright (C) 2008-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 @@ -18,7 +18,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.Writers.DokuWiki - Copyright : Copyright (C) 2008-2017 John MacFarlane + Copyright : Copyright (C) 2008-2018 John MacFarlane License : GNU GPL, version 2 or above Maintainer : Clare Macrae <clare.macrae@googlemail.com> diff --git a/src/Text/Pandoc/Writers/EPUB.hs b/src/Text/Pandoc/Writers/EPUB.hs index 2ed397d36..7b4853a24 100644 --- a/src/Text/Pandoc/Writers/EPUB.hs +++ b/src/Text/Pandoc/Writers/EPUB.hs @@ -3,7 +3,7 @@ {-# LANGUAGE PatternGuards #-} {-# LANGUAGE ScopedTypeVariables #-} {- -Copyright (C) 2010-2017 John MacFarlane <jgm@berkeley.edu> +Copyright (C) 2010-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 @@ -22,7 +22,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.Writers.EPUB - Copyright : Copyright (C) 2010-2017 John MacFarlane + Copyright : Copyright (C) 2010-2018 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> diff --git a/src/Text/Pandoc/Writers/FB2.hs b/src/Text/Pandoc/Writers/FB2.hs index 0a4130ca4..b1e8c8575 100644 --- a/src/Text/Pandoc/Writers/FB2.hs +++ b/src/Text/Pandoc/Writers/FB2.hs @@ -2,7 +2,7 @@ {- Copyright (c) 2011-2012 Sergey Astanin - 2012-2017 John MacFarlane + 2012-2018 John MacFarlane This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -22,7 +22,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.Writers.FB2 Copyright : Copyright (C) 2011-2012 Sergey Astanin - 2012-2017 John MacFarlane + 2012-2018 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane diff --git a/src/Text/Pandoc/Writers/HTML.hs b/src/Text/Pandoc/Writers/HTML.hs index 7ff7284cc..5d5c88dd9 100644 --- a/src/Text/Pandoc/Writers/HTML.hs +++ b/src/Text/Pandoc/Writers/HTML.hs @@ -3,7 +3,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} {- -Copyright (C) 2006-2017 John MacFarlane <jgm@berkeley.edu> +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 @@ -22,7 +22,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.Writers.HTML - Copyright : Copyright (C) 2006-2017 John MacFarlane + Copyright : Copyright (C) 2006-2018 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> @@ -1150,7 +1150,7 @@ blockListToNote :: PandocMonad m => WriterOptions -> String -> [Block] -> StateT blockListToNote opts ref blocks = -- If last block is Para or Plain, include the backlink at the end of -- that block. Otherwise, insert a new Plain block with the backlink. - let backlink = [Link ("",["footnote-back"],[]) [Str "↩"] ("#" ++ writerIdentifierPrefix opts ++ "fnref" ++ ref,[])] + let backlink = [Link ("",["footnote-back"],[]) [Str "↩"] ("#" ++ "fnref" ++ ref,[])] blocks' = if null blocks then [] else let lastBlock = last blocks diff --git a/src/Text/Pandoc/Writers/Haddock.hs b/src/Text/Pandoc/Writers/Haddock.hs index caa4b9031..9ed3be6cf 100644 --- a/src/Text/Pandoc/Writers/Haddock.hs +++ b/src/Text/Pandoc/Writers/Haddock.hs @@ -2,7 +2,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {- -Copyright (C) 2014-2015, 2017 John MacFarlane <jgm@berkeley.edu> +Copyright (C) 2014-2015, 2017-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 diff --git a/src/Text/Pandoc/Writers/ICML.hs b/src/Text/Pandoc/Writers/ICML.hs index ba274fb59..80d2fcbef 100644 --- a/src/Text/Pandoc/Writers/ICML.hs +++ b/src/Text/Pandoc/Writers/ICML.hs @@ -4,7 +4,7 @@ {- | Module : Text.Pandoc.Writers.ICML - Copyright : Copyright (C) 2013-2017 github.com/mb21 + Copyright : Copyright (C) 2013-2018 github.com/mb21 License : GNU GPL, version 2 or above Stability : alpha diff --git a/src/Text/Pandoc/Writers/JATS.hs b/src/Text/Pandoc/Writers/JATS.hs index e9e380a6c..639961acd 100644 --- a/src/Text/Pandoc/Writers/JATS.hs +++ b/src/Text/Pandoc/Writers/JATS.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {- -Copyright (C) 2006-2017 John MacFarlane <jgm@berkeley.edu> +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 @@ -19,7 +19,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -} {- | Module : Text.Pandoc.Writers.JATS - Copyright : Copyright (C) 2017 John MacFarlane + Copyright : Copyright (C) 2017-2018 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> diff --git a/src/Text/Pandoc/Writers/LaTeX.hs b/src/Text/Pandoc/Writers/LaTeX.hs index 87ce65586..de2cc3480 100644 --- a/src/Text/Pandoc/Writers/LaTeX.hs +++ b/src/Text/Pandoc/Writers/LaTeX.hs @@ -2,7 +2,7 @@ {-# LANGUAGE PatternGuards #-} {-# LANGUAGE ScopedTypeVariables #-} {- -Copyright (C) 2006-2017 John MacFarlane <jgm@berkeley.edu> +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 @@ -21,7 +21,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.Writers.LaTeX - Copyright : Copyright (C) 2006-2017 John MacFarlane + Copyright : Copyright (C) 2006-2018 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> @@ -749,9 +749,9 @@ tableRowToLaTeX header aligns widths cols = do isSimple [] = True isSimple _ = False -- simple tables have to have simple cells: - let widths' = if not (all isSimple cols) + let widths' = if all (== 0) widths && not (all isSimple cols) then replicate (length aligns) - (0.97 / fromIntegral (length aligns)) + (scaleFactor / fromIntegral (length aligns)) else map (scaleFactor *) widths cells <- mapM (tableCellToLaTeX header) $ zip3 widths' aligns cols return $ hsep (intersperse "&" cells) <> "\\tabularnewline" @@ -1015,7 +1015,7 @@ inlineToLaTeX (Code (_,classes,_) str) = do let chr = case "!\"&'()*,-./:;?@_" \\ str of (c:_) -> c [] -> '!' - let str' = escapeStringUsing (backslashEscapes "\\{}%~_") str + let str' = escapeStringUsing (backslashEscapes "\\{}%~_&") str -- we always put lstinline in a dummy 'passthrough' command -- (defined in the default template) so that we don't have -- to change the way we escape characters depending on whether diff --git a/src/Text/Pandoc/Writers/Man.hs b/src/Text/Pandoc/Writers/Man.hs index 34b5c0ece..c1427b15c 100644 --- a/src/Text/Pandoc/Writers/Man.hs +++ b/src/Text/Pandoc/Writers/Man.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {- -Copyright (C) 2007-2017 John MacFarlane <jgm@berkeley.edu> +Copyright (C) 2007-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 @@ -19,7 +19,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.Writers.Man - Copyright : Copyright (C) 2007-2017 John MacFarlane + Copyright : Copyright (C) 2007-2018 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> diff --git a/src/Text/Pandoc/Writers/Markdown.hs b/src/Text/Pandoc/Writers/Markdown.hs index 13572c466..c8b3a1526 100644 --- a/src/Text/Pandoc/Writers/Markdown.hs +++ b/src/Text/Pandoc/Writers/Markdown.hs @@ -3,7 +3,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {- -Copyright (C) 2006-2017 John MacFarlane <jgm@berkeley.edu> +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 @@ -22,7 +22,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.Writers.Markdown - Copyright : Copyright (C) 2006-2017 John MacFarlane + Copyright : Copyright (C) 2006-2018 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> @@ -701,7 +701,7 @@ pandocTable opts multiline headless aligns widths rawHeaders rawRows = do let columns = transpose (rawHeaders : rawRows) -- minimal column width without wrapping a single word let relWidth w col = - max (floor $ fromIntegral (writerColumns opts) * w) + max (floor $ fromIntegral (writerColumns opts - 1) * w) (if writerWrapText opts == WrapAuto then minNumChars col else numChars col) diff --git a/src/Text/Pandoc/Writers/MediaWiki.hs b/src/Text/Pandoc/Writers/MediaWiki.hs index 839f16cea..2470d9200 100644 --- a/src/Text/Pandoc/Writers/MediaWiki.hs +++ b/src/Text/Pandoc/Writers/MediaWiki.hs @@ -1,5 +1,5 @@ {- -Copyright (C) 2008-2017 John MacFarlane <jgm@berkeley.edu> +Copyright (C) 2008-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 @@ -18,7 +18,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.Writers.MediaWiki - Copyright : Copyright (C) 2008-2017 John MacFarlane + Copyright : Copyright (C) 2008-2018 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> diff --git a/src/Text/Pandoc/Writers/Ms.hs b/src/Text/Pandoc/Writers/Ms.hs index 30633cec6..83d80cd4a 100644 --- a/src/Text/Pandoc/Writers/Ms.hs +++ b/src/Text/Pandoc/Writers/Ms.hs @@ -1,5 +1,5 @@ {- -Copyright (C) 2007-2017 John MacFarlane <jgm@berkeley.edu> +Copyright (C) 2007-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 @@ -18,7 +18,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.Writers.Ms - Copyright : Copyright (C) 2007-2017 John MacFarlane + Copyright : Copyright (C) 2007-2018 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> diff --git a/src/Text/Pandoc/Writers/Muse.hs b/src/Text/Pandoc/Writers/Muse.hs index ff393e574..7c4865da8 100644 --- a/src/Text/Pandoc/Writers/Muse.hs +++ b/src/Text/Pandoc/Writers/Muse.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {- -Copyright (C) 2017 Alexander Krotov <ilabdsf@gmail.com> +Copyright (C) 2017-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 @@ -19,7 +19,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.Writers.Muse - Copyright : Copyright (C) 2017 Alexander Krotov + Copyright : Copyright (C) 2017-2018 Alexander Krotov License : GNU GPL, version 2 or above Maintainer : Alexander Krotov <ilabdsf@gmail.com> @@ -212,10 +212,13 @@ blockToMuse (DefinitionList items) = do -> StateT WriterState m Doc definitionListItemToMuse (label, defs) = do label' <- inlineListToMuse label - contents <- liftM vcat $ mapM blockListToMuse defs - let label'' = label' <> " :: " - let ind = offset label'' - return $ hang ind label'' contents + contents <- liftM vcat $ mapM descriptionToMuse defs + let ind = offset label' + return $ hang ind label' contents + descriptionToMuse :: PandocMonad m + => [Block] + -> StateT WriterState m Doc + descriptionToMuse desc = (hang 4 " :: ") <$> blockListToMuse desc blockToMuse (Header level (ident,_,_) inlines) = do opts <- gets stOptions contents <- inlineListToMuse inlines diff --git a/src/Text/Pandoc/Writers/Native.hs b/src/Text/Pandoc/Writers/Native.hs index 1fb685985..f852bad96 100644 --- a/src/Text/Pandoc/Writers/Native.hs +++ b/src/Text/Pandoc/Writers/Native.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {- -Copyright (C) 2006-2017 John MacFarlane <jgm@berkeley.edu> +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 @@ -19,7 +19,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.Writers.Native - Copyright : Copyright (C) 2006-2017 John MacFarlane + Copyright : Copyright (C) 2006-2018 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> diff --git a/src/Text/Pandoc/Writers/ODT.hs b/src/Text/Pandoc/Writers/ODT.hs index 08b4206e3..63a3f915a 100644 --- a/src/Text/Pandoc/Writers/ODT.hs +++ b/src/Text/Pandoc/Writers/ODT.hs @@ -1,6 +1,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {- -Copyright (C) 2008-2017 John MacFarlane <jgm@berkeley.edu> +Copyright (C) 2008-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 @@ -19,7 +19,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.Writers.ODT - Copyright : Copyright (C) 2008-2017 John MacFarlane + Copyright : Copyright (C) 2008-2018 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> diff --git a/src/Text/Pandoc/Writers/OOXML.hs b/src/Text/Pandoc/Writers/OOXML.hs index aa4979653..2a9b9bc84 100644 --- a/src/Text/Pandoc/Writers/OOXML.hs +++ b/src/Text/Pandoc/Writers/OOXML.hs @@ -1,54 +1,54 @@ +{- +Copyright (C) 2012-2018 John MacFarlane <jgm@berkeley.edu> + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- | + Module : Text.Pandoc.Writers.OOXML + Copyright : Copyright (C) 2012-2018 John MacFarlane + License : GNU GPL, version 2 or above + + Maintainer : John MacFarlane <jgm@berkeley.edu> + Stability : alpha + Portability : portable + +Functions common to OOXML writers (Docx and Powerpoint) +-} module Text.Pandoc.Writers.OOXML ( mknode - , nodename - , toLazy - , renderXml - , parseXml - , elemToNameSpaces - , elemName - , isElem - , NameSpaces - , fitToPage - ) where + , nodename + , toLazy + , renderXml + , parseXml + , elemToNameSpaces + , elemName + , isElem + , NameSpaces + , fitToPage + ) where + import Codec.Archive.Zip ---import Control.Applicative ((<|>)) --- import Control.Monad.Except (catchError) import Control.Monad.Reader --- import Control.Monad.State import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy.Char8 as BL8 --- import Data.Char (isSpace, ord, toLower) --- import Data.List (intercalate, isPrefixOf, isSuffixOf) --- import qualified Data.Map as M import Data.Maybe (mapMaybe) import Data.Monoid ((<>)) --- import qualified Data.Set as Set --- import qualified Data.Text as T --- import Data.Time.Clock.POSIX --- import Skylighting --- import System.Random (randomR) import Text.Pandoc.Class (PandocMonad) --- import qualified Text.Pandoc.Class as P --- import Text.Pandoc.Compat.Time --- import Text.Pandoc.Definition --- import Text.Pandoc.Generic --- import Text.Pandoc.Highlighting (highlight) --- import Text.Pandoc.ImageSize --- import Text.Pandoc.Logging --- import Text.Pandoc.MIME (MimeType, extensionFromMimeType, getMimeType, --- getMimeTypeDef) --- import Text.Pandoc.Options --- import Text.Pandoc.Readers.Docx.StyleMap --- import Text.Pandoc.Shared hiding (Element) import qualified Text.Pandoc.UTF8 as UTF8 --- import Text.Pandoc.Walk --- import Text.Pandoc.Writers.Math --- import Text.Pandoc.Writers.Shared (fixDisplayMath) --- import Text.Printf (printf) --- import Text.TeXMath import Text.XML.Light as XML --- import Text.XML.Light.Cursor as XMLC - mknode :: Node t => String -> [(String,String)] -> t -> Element mknode s attrs = @@ -106,4 +106,3 @@ fitToPage (x, y) pageWidth | x > fromIntegral pageWidth = (pageWidth, floor $ ((fromIntegral pageWidth) / x) * y) | otherwise = (floor x, floor y) - diff --git a/src/Text/Pandoc/Writers/OPML.hs b/src/Text/Pandoc/Writers/OPML.hs index 3a2467c65..29e1bc80c 100644 --- a/src/Text/Pandoc/Writers/OPML.hs +++ b/src/Text/Pandoc/Writers/OPML.hs @@ -1,6 +1,6 @@ {-# LANGUAGE CPP #-} {- -Copyright (C) 2013-2017 John MacFarlane <jgm@berkeley.edu> +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 @@ -19,7 +19,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.Writers.OPML - Copyright : Copyright (C) 2013-2017 John MacFarlane + Copyright : Copyright (C) 2013-2018 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> diff --git a/src/Text/Pandoc/Writers/OpenDocument.hs b/src/Text/Pandoc/Writers/OpenDocument.hs index dc7d14d05..e0097f507 100644 --- a/src/Text/Pandoc/Writers/OpenDocument.hs +++ b/src/Text/Pandoc/Writers/OpenDocument.hs @@ -2,7 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {- -Copyright (C) 2008-2017 Andrea Rossato <andrea.rossato@ing.unitn.it> +Copyright (C) 2008-2018 Andrea Rossato <andrea.rossato@ing.unitn.it> and John MacFarlane. This program is free software; you can redistribute it and/or modify @@ -22,7 +22,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.Writers.OpenDocument - Copyright : Copyright (C) 2008-2017 Andrea Rossato and John MacFarlane + Copyright : Copyright (C) 2008-2018 Andrea Rossato and John MacFarlane License : GNU GPL, version 2 or above Maintainer : Andrea Rossato <andrea.rossato@ing.unitn.it> diff --git a/src/Text/Pandoc/Writers/Org.hs b/src/Text/Pandoc/Writers/Org.hs index 43b5b59ee..72def8e48 100644 --- a/src/Text/Pandoc/Writers/Org.hs +++ b/src/Text/Pandoc/Writers/Org.hs @@ -1,8 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} {- Copyright (C) 2010-2015 Puneeth Chaganti <punchagan@gmail.com> - 2010-2017 John MacFarlane <jgm@berkeley.edu> - 2016-2017 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> + 2010-2018 John MacFarlane <jgm@berkeley.edu> + 2016-2018 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> 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 @@ -22,8 +22,8 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.Writers.Org Copyright : © 2010-2015 Puneeth Chaganti <punchagan@gmail.com> - 2010-2017 John MacFarlane <jgm@berkeley.edu> - 2016-2017 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> + 2010-2018 John MacFarlane <jgm@berkeley.edu> + 2016-2018 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> License : GNU GPL, version 2 or above Maintainer : Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> diff --git a/src/Text/Pandoc/Writers/Powerpoint.hs b/src/Text/Pandoc/Writers/Powerpoint.hs index ab3b2eabf..acb33f582 100644 --- a/src/Text/Pandoc/Writers/Powerpoint.hs +++ b/src/Text/Pandoc/Writers/Powerpoint.hs @@ -1,7 +1,7 @@ -{-# LANGUAGE PatternGuards, MultiWayIf, OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} {- -Copyright (C) 2017 Jesse Rosenthal <jrosenthal@jhu.edu> +Copyright (C) 2017-2018 Jesse Rosenthal <jrosenthal@jhu.edu> This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -20,51 +20,36 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.Writers.Powerpoint - Copyright : Copyright (C) 2017 Jesse Rosenthal + Copyright : Copyright (C) 2017-2018 Jesse Rosenthal License : GNU GPL, version 2 or above Maintainer : Jesse Rosenthal <jrosenthal@jhu.edu> Stability : alpha Portability : portable -Conversion of 'Pandoc' documents to powerpoint (pptx). +Conversion of 'Pandoc' documents to powerpoint (pptx). -} + +{- +This is a wrapper around two modules: + + - Text.Pandoc.Writers.Powerpoint.Presentation (which converts a + pandoc document into a Presentation datatype), and + + - Text.Pandoc.Writers.Powerpoint.Output (which converts a + Presentation into a zip archive, which can be output). -} module Text.Pandoc.Writers.Powerpoint (writePowerpoint) where -import Control.Monad.Except (throwError) -import Control.Monad.Reader -import Control.Monad.State import Codec.Archive.Zip -import Data.List (intercalate, stripPrefix, isPrefixOf, nub) --- import Control.Monad (mplus) -import Data.Default -import Data.Time.Clock (UTCTime) -import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, posixSecondsToUTCTime) -import System.FilePath.Posix (splitDirectories, splitExtension) -import Text.XML.Light import Text.Pandoc.Definition -import qualified Text.Pandoc.UTF8 as UTF8 -import Text.Pandoc.Class (PandocMonad) -import Text.Pandoc.Error (PandocError(..)) -import qualified Text.Pandoc.Class as P -import Text.Pandoc.Options -import Text.Pandoc.MIME -import Text.Pandoc.Logging -import qualified Data.ByteString.Lazy as BL --- import qualified Data.ByteString.Lazy.Char8 as BL8 --- import qualified Text.Pandoc.UTF8 as UTF8 import Text.Pandoc.Walk +import Text.Pandoc.Class (PandocMonad, report) +import Text.Pandoc.Options (WriterOptions) import Text.Pandoc.Writers.Shared (fixDisplayMath) -import Text.Pandoc.Writers.OOXML -import qualified Data.Map as M -import Data.Maybe (mapMaybe, listToMaybe) -import Text.Pandoc.ImageSize -import Control.Applicative ((<|>)) - -import Text.TeXMath -import Text.Pandoc.Writers.Math (convertMath) - +import Text.Pandoc.Writers.Powerpoint.Presentation (documentToPresentation) +import Text.Pandoc.Writers.Powerpoint.Output (presentationToArchive) +import qualified Data.ByteString.Lazy as BL writePowerpoint :: (PandocMonad m) => WriterOptions -- ^ Writer options @@ -72,1675 +57,7 @@ writePowerpoint :: (PandocMonad m) -> m BL.ByteString writePowerpoint opts (Pandoc meta blks) = do let blks' = walk fixDisplayMath blks - distArchive <- (toArchive . BL.fromStrict) <$> - P.readDefaultDataFile "reference.pptx" - refArchive <- case writerReferenceDoc opts of - Just f -> toArchive <$> P.readFileLazy f - Nothing -> (toArchive . BL.fromStrict) <$> - P.readDataFile "reference.pptx" - - utctime <- P.getCurrentTime - - let env = def { envMetadata = meta - , envRefArchive = refArchive - , envDistArchive = distArchive - , envUTCTime = utctime - , envOpts = opts - , envSlideLevel = case writerSlideLevel opts of - Just n -> n - Nothing -> 2 - } - runP env def $ do pres <- blocksToPresentation blks' - archv <- presentationToArchive pres - return $ fromArchive archv - -concatMapM :: (Monad m) => (a -> m [b]) -> [a] -> m [b] -concatMapM f xs = liftM concat (mapM f xs) - -data WriterEnv = WriterEnv { envMetadata :: Meta - , envRunProps :: RunProps - , envParaProps :: ParaProps - , envSlideLevel :: Int - , envRefArchive :: Archive - , envDistArchive :: Archive - , envUTCTime :: UTCTime - , envOpts :: WriterOptions - , envPresentationSize :: PresentationSize - , envSlideHasHeader :: Bool - , envInList :: Bool - , envInNoteSlide :: Bool - } - deriving (Show) - -instance Default WriterEnv where - def = WriterEnv { envMetadata = mempty - , envRunProps = def - , envParaProps = def - , envSlideLevel = 2 - , envRefArchive = emptyArchive - , envDistArchive = emptyArchive - , envUTCTime = posixSecondsToUTCTime 0 - , envOpts = def - , envPresentationSize = def - , envSlideHasHeader = False - , envInList = False - , envInNoteSlide = False - } - -data MediaInfo = MediaInfo { mInfoFilePath :: FilePath - , mInfoLocalId :: Int - , mInfoGlobalId :: Int - , mInfoMimeType :: Maybe MimeType - , mInfoExt :: Maybe String - , mInfoCaption :: Bool - } deriving (Show, Eq) - -data WriterState = WriterState { stCurSlideId :: Int - -- the difference between the number at - -- the end of the slide file name and - -- the rId number - , stSlideIdOffset :: Int - , stLinkIds :: M.Map Int (M.Map Int (URL, String)) - -- (FP, Local ID, Global ID, Maybe Mime) - , stMediaIds :: M.Map Int [MediaInfo] - , stMediaGlobalIds :: M.Map FilePath Int - , stNoteIds :: M.Map Int [Block] - } deriving (Show, Eq) - -instance Default WriterState where - def = WriterState { stCurSlideId = 0 - , stSlideIdOffset = 1 - , stLinkIds = mempty - , stMediaIds = mempty - , stMediaGlobalIds = mempty - , stNoteIds = mempty - } - -type P m = ReaderT WriterEnv (StateT WriterState m) - -runP :: Monad m => WriterEnv -> WriterState -> P m a -> m a -runP env st p = evalStateT (runReaderT p env) st - -type Pixels = Integer - -data Presentation = Presentation PresentationSize [Slide] - deriving (Show) - -data PresentationSize = PresentationSize { presSizeWidth :: Pixels - , presSizeRatio :: PresentationRatio - } - deriving (Show, Eq) - -data PresentationRatio = Ratio4x3 - | Ratio16x9 - | Ratio16x10 - deriving (Show, Eq) - --- Note that right now we're only using Ratio4x3. -getPageHeight :: PresentationSize -> Pixels -getPageHeight sz = case presSizeRatio sz of - Ratio4x3 -> floor (((fromInteger (presSizeWidth sz)) / 4) * 3 :: Double) - Ratio16x9 -> floor (((fromInteger (presSizeWidth sz)) / 16) * 9 :: Double) - Ratio16x10 -> floor (((fromInteger (presSizeWidth sz)) / 16) * 10 :: Double) - -instance Default PresentationSize where - def = PresentationSize 720 Ratio4x3 - -data Slide = MetadataSlide { metadataSlideTitle :: [ParaElem] - , metadataSlideSubtitle :: [ParaElem] - , metadataSlideAuthors :: [[ParaElem]] - , metadataSlideDate :: [ParaElem] - } - | TitleSlide { titleSlideHeader :: [ParaElem]} - | ContentSlide { contentSlideHeader :: [ParaElem] - , contentSlideContent :: [Shape] - } - deriving (Show, Eq) - -data SlideElement = SlideElement Pixels Pixels Pixels Pixels Shape - deriving (Show, Eq) - -data Shape = Pic FilePath Text.Pandoc.Definition.Attr [ParaElem] - | GraphicFrame [Graphic] [ParaElem] - | TextBox [Paragraph] - deriving (Show, Eq) - -type Cell = [Paragraph] - -data TableProps = TableProps { tblPrFirstRow :: Bool - , tblPrBandRow :: Bool - } deriving (Show, Eq) - -type ColWidth = Integer - -data Graphic = Tbl TableProps [ColWidth] [Cell] [[Cell]] - deriving (Show, Eq) - - -data Paragraph = Paragraph { paraProps :: ParaProps - , paraElems :: [ParaElem] - } deriving (Show, Eq) - -data HeaderType = TitleHeader | SlideHeader | InternalHeader Int - deriving (Show, Eq) - --- type StartingAt = Int - --- data AutoNumType = ArabicNum --- | AlphaUpperNum --- | AlphaLowerNum --- | RomanUpperNum --- | RomanLowerNum --- deriving (Show, Eq) - --- data AutoNumDelim = PeriodDelim --- | OneParenDelim --- | TwoParensDelim --- deriving (Show, Eq) - -autoNumberingToType :: ListAttributes -> String -autoNumberingToType (_, numStyle, numDelim) = - typeString ++ delimString - where - typeString = case numStyle of - Decimal -> "arabic" - UpperAlpha -> "alphaUc" - LowerAlpha -> "alphaLc" - UpperRoman -> "romanUc" - LowerRoman -> "romanLc" - _ -> "arabic" - delimString = case numDelim of - Period -> "Period" - OneParen -> "ParenR" - TwoParens -> "ParenBoth" - _ -> "Period" - -data BulletType = Bullet - | AutoNumbering ListAttributes - deriving (Show, Eq) - -data Algnment = AlgnLeft | AlgnRight | AlgnCenter - deriving (Show, Eq) - -data ParaProps = ParaProps { pPropHeaderType :: Maybe HeaderType - , pPropMarginLeft :: Maybe Pixels - , pPropMarginRight :: Maybe Pixels - , pPropLevel :: Int - , pPropBullet :: Maybe BulletType - , pPropAlign :: Maybe Algnment - } deriving (Show, Eq) - -instance Default ParaProps where - def = ParaProps { pPropHeaderType = Nothing - , pPropMarginLeft = Just 0 - , pPropMarginRight = Just 0 - , pPropLevel = 0 - , pPropBullet = Nothing - , pPropAlign = Nothing - } - -newtype TeXString = TeXString {unTeXString :: String} - deriving (Eq, Show) - -data ParaElem = Break - | Run RunProps String - -- It would be more elegant to have native TeXMath - -- Expressions here, but this allows us to use - -- `convertmath` from T.P.Writers.Math. Will perhaps - -- revisit in the future. - | MathElem MathType TeXString - deriving (Show, Eq) - -data Strikethrough = NoStrike | SingleStrike | DoubleStrike - deriving (Show, Eq) - -data Capitals = NoCapitals | SmallCapitals | AllCapitals - deriving (Show, Eq) - -type URL = String - -data RunProps = RunProps { rPropBold :: Bool - , rPropItalics :: Bool - , rStrikethrough :: Maybe Strikethrough - , rBaseline :: Maybe Int - , rCap :: Maybe Capitals - , rLink :: Maybe (URL, String) - , rPropCode :: Bool - , rPropBlockQuote :: Bool - , rPropForceSize :: Maybe Pixels - } deriving (Show, Eq) - -instance Default RunProps where - def = RunProps { rPropBold = False - , rPropItalics = False - , rStrikethrough = Nothing - , rBaseline = Nothing - , rCap = Nothing - , rLink = Nothing - , rPropCode = False - , rPropBlockQuote = False - , rPropForceSize = Nothing - } - --------------------------------------------------- - -inlinesToParElems :: Monad m => [Inline] -> P m [ParaElem] -inlinesToParElems ils = concatMapM inlineToParElems ils - -inlineToParElems :: Monad m => Inline -> P m [ParaElem] -inlineToParElems (Str s) = do - pr <- asks envRunProps - return [Run pr s] -inlineToParElems (Emph ils) = - local (\r -> r{envRunProps = (envRunProps r){rPropItalics=True}}) $ - inlinesToParElems ils -inlineToParElems (Strong ils) = - local (\r -> r{envRunProps = (envRunProps r){rPropBold=True}}) $ - inlinesToParElems ils -inlineToParElems (Strikeout ils) = - local (\r -> r{envRunProps = (envRunProps r){rStrikethrough=Just SingleStrike}}) $ - inlinesToParElems ils -inlineToParElems (Superscript ils) = - local (\r -> r{envRunProps = (envRunProps r){rBaseline=Just 30000}}) $ - inlinesToParElems ils -inlineToParElems (Subscript ils) = - local (\r -> r{envRunProps = (envRunProps r){rBaseline=Just (-25000)}}) $ - inlinesToParElems ils -inlineToParElems (SmallCaps ils) = - local (\r -> r{envRunProps = (envRunProps r){rCap = Just SmallCapitals}}) $ - inlinesToParElems ils -inlineToParElems Space = inlineToParElems (Str " ") -inlineToParElems SoftBreak = inlineToParElems (Str " ") -inlineToParElems LineBreak = return [Break] -inlineToParElems (Link _ ils (url, title)) = do - local (\r ->r{envRunProps = (envRunProps r){rLink = Just (url, title)}}) $ - inlinesToParElems ils -inlineToParElems (Code _ str) = do - local (\r ->r{envRunProps = def{rPropCode = True}}) $ - inlineToParElems $ Str str -inlineToParElems (Math mathtype str) = - return [MathElem mathtype (TeXString str)] -inlineToParElems (Note blks) = do - notes <- gets stNoteIds - let maxNoteId = case M.keys notes of - [] -> 0 - lst -> maximum lst - curNoteId = maxNoteId + 1 - modify $ \st -> st { stNoteIds = M.insert curNoteId blks notes } - inlineToParElems $ Superscript [Str $ show curNoteId] -inlineToParElems (Span _ ils) = concatMapM inlineToParElems ils -inlineToParElems (RawInline _ _) = return [] -inlineToParElems _ = return [] - -isListType :: Block -> Bool -isListType (OrderedList _ _) = True -isListType (BulletList _) = True -isListType (DefinitionList _) = True -isListType _ = False - -blockToParagraphs :: PandocMonad m => Block -> P m [Paragraph] -blockToParagraphs (Plain ils) = do - parElems <- inlinesToParElems ils - pProps <- asks envParaProps - return [Paragraph pProps parElems] -blockToParagraphs (Para ils) = do - parElems <- inlinesToParElems ils - pProps <- asks envParaProps - return [Paragraph pProps parElems] -blockToParagraphs (LineBlock ilsList) = do - parElems <- inlinesToParElems $ intercalate [LineBreak] ilsList - pProps <- asks envParaProps - return [Paragraph pProps parElems] --- TODO: work out the attributes -blockToParagraphs (CodeBlock attr str) = - local (\r -> r{envParaProps = def{pPropMarginLeft = Just 100}}) $ - blockToParagraphs $ Para [Code attr str] --- We can't yet do incremental lists, but we should render a --- (BlockQuote List) as a list to maintain compatibility with other --- formats. -blockToParagraphs (BlockQuote (blk : blks)) | isListType blk = do - ps <- blockToParagraphs blk - ps' <- blockToParagraphs $ BlockQuote blks - return $ ps ++ ps' -blockToParagraphs (BlockQuote blks) = - local (\r -> r{ envParaProps = (envParaProps r){pPropMarginLeft = Just 100} - , envRunProps = (envRunProps r){rPropForceSize = Just blockQuoteSize}})$ - concatMapM blockToParagraphs blks --- TODO: work out the format -blockToParagraphs (RawBlock _ _) = return [] - -- parElems <- inlinesToParElems [Str str] - -- paraProps <- asks envParaProps - -- return [Paragraph paraProps parElems] --- TODO: work out the format -blockToParagraphs (Header n _ ils) = do - slideLevel <- asks envSlideLevel - parElems <- inlinesToParElems ils - -- For the time being we're not doing headers inside of bullets, but - -- we might change that. - let headerType = case n `compare` slideLevel of - LT -> TitleHeader - EQ -> SlideHeader - GT -> InternalHeader (n - slideLevel) - return [Paragraph def{pPropHeaderType = Just headerType} parElems] -blockToParagraphs (BulletList blksLst) = do - pProps <- asks envParaProps - let lvl = pPropLevel pProps - local (\env -> env{ envInList = True - , envParaProps = pProps{ pPropLevel = lvl + 1 - , pPropBullet = Just Bullet - , pPropMarginLeft = Nothing - }}) $ - concatMapM multiParBullet blksLst -blockToParagraphs (OrderedList listAttr blksLst) = do - pProps <- asks envParaProps - let lvl = pPropLevel pProps - local (\env -> env{ envInList = True - , envParaProps = pProps{ pPropLevel = lvl + 1 - , pPropBullet = Just (AutoNumbering listAttr) - , pPropMarginLeft = Nothing - }}) $ - concatMapM multiParBullet blksLst -blockToParagraphs (DefinitionList entries) = do - let go :: PandocMonad m => ([Inline], [[Block]]) -> P m [Paragraph] - go (ils, blksLst) = do - term <-blockToParagraphs $ Para [Strong ils] - -- For now, we'll treat each definition term as a - -- blockquote. We can extend this further later. - definition <- concatMapM (blockToParagraphs . BlockQuote) blksLst - return $ term ++ definition - concatMapM go entries -blockToParagraphs (Div _ blks) = concatMapM blockToParagraphs blks --- TODO -blockToParagraphs blk = do - P.report $ BlockNotRendered blk - return [] - --- Make sure the bullet env gets turned off after the first para. -multiParBullet :: PandocMonad m => [Block] -> P m [Paragraph] -multiParBullet [] = return [] -multiParBullet (b:bs) = do - pProps <- asks envParaProps - p <- blockToParagraphs b - ps <- local (\env -> env{envParaProps = pProps{pPropBullet = Nothing}}) $ - concatMapM blockToParagraphs bs - return $ p ++ ps - -cellToParagraphs :: PandocMonad m => Alignment -> TableCell -> P m [Paragraph] -cellToParagraphs algn tblCell = do - paras <- mapM (blockToParagraphs) tblCell - let alignment = case algn of - AlignLeft -> Just AlgnLeft - AlignRight -> Just AlgnRight - AlignCenter -> Just AlgnCenter - AlignDefault -> Nothing - paras' = map (map (\p -> p{paraProps = (paraProps p){pPropAlign = alignment}})) paras - return $ concat paras' - -rowToParagraphs :: PandocMonad m => [Alignment] -> [TableCell] -> P m [[Paragraph]] -rowToParagraphs algns tblCells = do - -- We have to make sure we have the right number of alignments - let pairs = zip (algns ++ repeat AlignDefault) tblCells - mapM (\(a, tc) -> cellToParagraphs a tc) pairs - -blockToShape :: PandocMonad m => Block -> P m Shape -blockToShape (Plain (il:_)) | Image attr ils (url, _) <- il = - Pic url attr <$> (inlinesToParElems ils) -blockToShape (Para (il:_)) | Image attr ils (url, _) <- il = - Pic url attr <$> (inlinesToParElems ils) -blockToShape (Table caption algn _ hdrCells rows) = do - caption' <- inlinesToParElems caption - pageWidth <- presSizeWidth <$> asks envPresentationSize - hdrCells' <- rowToParagraphs algn hdrCells - rows' <- mapM (rowToParagraphs algn) rows - let tblPr = if null hdrCells - then TableProps { tblPrFirstRow = False - , tblPrBandRow = True - } - else TableProps { tblPrFirstRow = True - , tblPrBandRow = True - } - colWidths = if null hdrCells - then case rows of - r : _ | not (null r) -> replicate (length r) $ - (pageWidth - (2 * hardcodedTableMargin))`div` (toInteger $ length r) - -- satisfy the compiler. This is the same as - -- saying that rows is empty, but the compiler - -- won't understand that `[]` exhausts the - -- alternatives. - _ -> [] - else replicate (length hdrCells) $ - (pageWidth - (2 * hardcodedTableMargin)) `div` (toInteger $ length hdrCells) - - return $ GraphicFrame [Tbl tblPr colWidths hdrCells' rows'] caption' -blockToShape blk = TextBox <$> blockToParagraphs blk - -blocksToShapes :: PandocMonad m => [Block] -> P m [Shape] -blocksToShapes blks = combineShapes <$> mapM blockToShape blks - -splitBlocks' :: Monad m => [Block] -> [[Block]] -> [Block] -> P m [[Block]] -splitBlocks' cur acc [] = return $ acc ++ (if null cur then [] else [cur]) -splitBlocks' cur acc (HorizontalRule : blks) = - splitBlocks' [] (acc ++ (if null cur then [] else [cur])) blks -splitBlocks' cur acc (h@(Header n _ _) : blks) = do - slideLevel <- asks envSlideLevel - case compare n slideLevel of - LT -> splitBlocks' [] (acc ++ (if null cur then [] else [cur]) ++ [[h]]) blks - EQ -> splitBlocks' [h] (acc ++ (if null cur then [] else [cur])) blks - GT -> splitBlocks' (cur ++ [h]) acc blks -splitBlocks' cur acc ((Para (img@(Image _ _ _):ils)) : blks) = do - slideLevel <- asks envSlideLevel - case cur of - (Header n _ _) : [] | n == slideLevel -> - splitBlocks' [] - (acc ++ [cur ++ [Para [img]]]) - (if null ils then blks else (Para ils) : blks) - _ -> splitBlocks' [] - (acc ++ (if null cur then [] else [cur]) ++ [[Para [img]]]) - (if null ils then blks else (Para ils) : blks) -splitBlocks' cur acc ((Plain (img@(Image _ _ _):ils)) : blks) = do - slideLevel <- asks envSlideLevel - case cur of - (Header n _ _) : [] | n == slideLevel -> - splitBlocks' [] - (acc ++ [cur ++ [Para [img]]]) - (if null ils then blks else (Plain ils) : blks) - _ -> splitBlocks' [] - (acc ++ (if null cur then [] else [cur]) ++ [[Para [img]]]) - (if null ils then blks else (Plain ils) : blks) -splitBlocks' cur acc (tbl@(Table _ _ _ _ _) : blks) = do - slideLevel <- asks envSlideLevel - case cur of - (Header n _ _) : [] | n == slideLevel -> - splitBlocks' [] (acc ++ [cur ++ [tbl]]) blks - _ -> splitBlocks' [] (acc ++ (if null cur then [] else [cur]) ++ [[tbl]]) blks -splitBlocks' cur acc (blk : blks) = splitBlocks' (cur ++ [blk]) acc blks - -splitBlocks :: Monad m => [Block] -> P m [[Block]] -splitBlocks = splitBlocks' [] [] - -blocksToSlide' :: PandocMonad m => Int -> [Block] -> P m Slide -blocksToSlide' lvl ((Header n _ ils) : blks) - | n < lvl = do - hdr <- inlinesToParElems ils - return $ TitleSlide {titleSlideHeader = hdr} - | n == lvl = do - hdr <- inlinesToParElems ils - inNoteSlide <- asks envInNoteSlide - shapes <- if inNoteSlide - then forceFontSize noteSize $ blocksToShapes blks - else blocksToShapes blks - return $ ContentSlide { contentSlideHeader = hdr - , contentSlideContent = shapes - } -blocksToSlide' _ (blk : blks) = do - inNoteSlide <- asks envInNoteSlide - shapes <- if inNoteSlide - then forceFontSize noteSize $ blocksToShapes (blk : blks) - else blocksToShapes (blk : blks) - return $ ContentSlide { contentSlideHeader = [] - , contentSlideContent = shapes - } -blocksToSlide' _ [] = return $ ContentSlide { contentSlideHeader = [] - , contentSlideContent = [] - } - -blocksToSlide :: PandocMonad m => [Block] -> P m Slide -blocksToSlide blks = do - slideLevel <- asks envSlideLevel - blocksToSlide' slideLevel blks - -makeNoteEntry :: Int -> [Block] -> [Block] -makeNoteEntry n blks = - let enum = Str (show n ++ ".") - in - case blks of - (Para ils : blks') -> (Para $ enum : Space : ils) : blks' - _ -> (Para [enum]) : blks - -forceFontSize :: PandocMonad m => Pixels -> P m a -> P m a -forceFontSize px x = do - rpr <- asks envRunProps - local (\r -> r {envRunProps = rpr{rPropForceSize = Just px}}) x - --- Right now, there's no logic for making more than one slide, but I --- want to leave the option open to make multiple slides if we figure --- out how to guess at how much space the text of the notes will take --- up (or if we allow a way for it to be manually controlled). Plus a --- list will make it easier to put together in the final --- `blocksToPresentation` function (since we can just add an empty --- list without checking the state). -makeNotesSlides :: PandocMonad m => P m [Slide] -makeNotesSlides = local (\env -> env{envInNoteSlide=True}) $ do - noteIds <- gets stNoteIds - if M.null noteIds - then return [] - else do let hdr = Header 2 nullAttr [Str "Notes"] - blks <- return $ - concatMap (\(n, bs) -> makeNoteEntry n bs) $ - M.toList noteIds - sld <- blocksToSlide $ hdr : blks - return [sld] - -getMetaSlide :: PandocMonad m => P m (Maybe Slide) -getMetaSlide = do - meta <- asks envMetadata - title <- inlinesToParElems $ docTitle meta - subtitle <- inlinesToParElems $ - case lookupMeta "subtitle" meta of - Just (MetaString s) -> [Str s] - Just (MetaInlines ils) -> ils - Just (MetaBlocks [Plain ils]) -> ils - Just (MetaBlocks [Para ils]) -> ils - _ -> [] - authors <- mapM inlinesToParElems $ docAuthors meta - date <- inlinesToParElems $ docDate meta - if null title && null subtitle && null authors && null date - then return Nothing - else return $ Just $ MetadataSlide { metadataSlideTitle = title - , metadataSlideSubtitle = subtitle - , metadataSlideAuthors = authors - , metadataSlideDate = date - } - -blocksToPresentation :: PandocMonad m => [Block] -> P m Presentation -blocksToPresentation blks = do - blksLst <- splitBlocks blks - slides <- mapM blocksToSlide blksLst - noteSlides <- makeNotesSlides - let slides' = slides ++ noteSlides - metadataslide <- getMetaSlide - presSize <- asks envPresentationSize - return $ case metadataslide of - Just metadataslide' -> Presentation presSize $ metadataslide' : slides' - Nothing -> Presentation presSize slides' - --------------------------------------------------------------------- - -copyFileToArchive :: PandocMonad m => Archive -> FilePath -> P m Archive -copyFileToArchive arch fp = do - refArchive <- asks envRefArchive - distArchive <- asks envDistArchive - case findEntryByPath fp refArchive `mplus` findEntryByPath fp distArchive of - Nothing -> fail $ fp ++ " missing in reference file" - Just e -> return $ addEntryToArchive e arch - -getMediaFiles :: PandocMonad m => P m [FilePath] -getMediaFiles = do - refArchive <- asks envRefArchive - distArchive <- asks envDistArchive - let allEntries = nub $ filesInArchive refArchive ++ filesInArchive distArchive - return $ filter (isPrefixOf "ppt/media") allEntries - - -copyFileToArchiveIfExists :: PandocMonad m => Archive -> FilePath -> P m Archive -copyFileToArchiveIfExists arch fp = do - refArchive <- asks envRefArchive - distArchive <- asks envDistArchive - case findEntryByPath fp refArchive `mplus` findEntryByPath fp distArchive of - Nothing -> return $ arch - Just e -> return $ addEntryToArchive e arch - -inheritedFiles :: [FilePath] -inheritedFiles = [ "_rels/.rels" - , "docProps/app.xml" - , "docProps/core.xml" - , "ppt/slideLayouts/slideLayout4.xml" - , "ppt/slideLayouts/_rels/slideLayout9.xml.rels" - , "ppt/slideLayouts/_rels/slideLayout2.xml.rels" - , "ppt/slideLayouts/_rels/slideLayout10.xml.rels" - , "ppt/slideLayouts/_rels/slideLayout1.xml.rels" - , "ppt/slideLayouts/_rels/slideLayout3.xml.rels" - , "ppt/slideLayouts/_rels/slideLayout5.xml.rels" - , "ppt/slideLayouts/_rels/slideLayout7.xml.rels" - , "ppt/slideLayouts/_rels/slideLayout8.xml.rels" - , "ppt/slideLayouts/_rels/slideLayout11.xml.rels" - , "ppt/slideLayouts/_rels/slideLayout4.xml.rels" - , "ppt/slideLayouts/_rels/slideLayout6.xml.rels" - , "ppt/slideLayouts/slideLayout2.xml" - , "ppt/slideLayouts/slideLayout8.xml" - , "ppt/slideLayouts/slideLayout11.xml" - , "ppt/slideLayouts/slideLayout3.xml" - , "ppt/slideLayouts/slideLayout6.xml" - , "ppt/slideLayouts/slideLayout9.xml" - , "ppt/slideLayouts/slideLayout5.xml" - , "ppt/slideLayouts/slideLayout7.xml" - , "ppt/slideLayouts/slideLayout1.xml" - , "ppt/slideLayouts/slideLayout10.xml" - -- , "ppt/_rels/presentation.xml.rels" - , "ppt/theme/theme1.xml" - , "ppt/presProps.xml" - -- , "ppt/slides/_rels/slide1.xml.rels" - -- , "ppt/slides/_rels/slide2.xml.rels" - -- This is the one we're - -- going to build - -- , "ppt/slides/slide2.xml" - -- , "ppt/slides/slide1.xml" - , "ppt/viewProps.xml" - , "ppt/tableStyles.xml" - , "ppt/slideMasters/_rels/slideMaster1.xml.rels" - , "ppt/slideMasters/slideMaster1.xml" - -- , "ppt/presentation.xml" - -- , "[Content_Types].xml" - ] - --- Here are some that might not be there. We won't fail if they're not -possibleInheritedFiles :: [FilePath] -possibleInheritedFiles = [ "ppt/theme/_rels/theme1.xml.rels" ] - -presentationToArchive :: PandocMonad m => Presentation -> P m Archive -presentationToArchive p@(Presentation _ slides) = do - newArch <- foldM copyFileToArchive emptyArchive inheritedFiles - mediaDir <- getMediaFiles - newArch' <- foldM copyFileToArchiveIfExists newArch $ - possibleInheritedFiles ++ mediaDir - -- presentation entry and rels. We have to do the rels first to make - -- sure we know the correct offset for the rIds. - presEntry <- presentationToPresEntry p - presRelsEntry <- presentationToRelsEntry p - slideEntries <- mapM (\(s, n) -> slideToEntry s n) $ zip slides [1..] - slideRelEntries <- mapM (\(s,n) -> slideToSlideRelEntry s n) $ zip slides [1..] - -- These have to come after everything, because they need the info - -- built up in the state. - mediaEntries <- makeMediaEntries - contentTypesEntry <- presentationToContentTypes p >>= contentTypesToEntry - -- fold everything into our inherited archive and return it. - return $ foldr addEntryToArchive newArch' $ - slideEntries ++ - slideRelEntries ++ - mediaEntries ++ - [contentTypesEntry, presEntry, presRelsEntry] - --------------------------------------------------- - -combineShapes :: [Shape] -> [Shape] -combineShapes [] = [] -combineShapes (s : []) = [s] -combineShapes (pic@(Pic _ _ _) : ss) = pic : combineShapes ss -combineShapes ((TextBox []) : ss) = combineShapes ss -combineShapes (s : TextBox [] : ss) = combineShapes (s : ss) -combineShapes (s@(TextBox (p:ps)) : s'@(TextBox (p':ps')) : ss) - | pPropHeaderType (paraProps p) == Just TitleHeader || - pPropHeaderType (paraProps p) == Just SlideHeader = - TextBox [p] : (combineShapes $ TextBox ps : s' : ss) - | pPropHeaderType (paraProps p') == Just TitleHeader || - pPropHeaderType (paraProps p') == Just SlideHeader = - s : TextBox [p'] : (combineShapes $ TextBox ps' : ss) - | otherwise = combineShapes $ TextBox ((p:ps) ++ (p':ps')) : ss -combineShapes (s:ss) = s : combineShapes ss - --------------------------------------------------- - -getLayout :: PandocMonad m => Slide -> P m Element -getLayout slide = do - let layoutpath = case slide of - (MetadataSlide _ _ _ _) -> "ppt/slideLayouts/slideLayout1.xml" - (TitleSlide _) -> "ppt/slideLayouts/slideLayout3.xml" - (ContentSlide _ _) -> "ppt/slideLayouts/slideLayout2.xml" - 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 - -- let ns = elemToNameSpaces root - -- case findChild (elemName ns "p" "cSld") root of - -- Just element' -> return element' - -- Nothing -> throwError $ - -- PandocSomeError $ - -- layoutpath ++ " not correctly formed layout file" - -shapeHasName :: NameSpaces -> String -> Element -> Bool -shapeHasName ns name element - | Just nvSpPr <- findChild (elemName ns "p" "nvSpPr") element - , Just cNvPr <- findChild (elemName ns "p" "cNvPr") nvSpPr - , Just nm <- findAttr (QName "name" Nothing Nothing) cNvPr = - nm == name - | otherwise = False - --- getContentTitleShape :: NameSpaces -> Element -> Maybe Element --- getContentTitleShape ns spTreeElem --- | isElem ns "p" "spTree" spTreeElem = --- filterChild (\e -> (isElem ns "p" "sp" e) && (shapeHasName ns "Title 1" e)) spTreeElem --- | otherwise = Nothing - --- getSubtitleShape :: NameSpaces -> Element -> Maybe Element --- getSubtitleShape ns spTreeElem --- | isElem ns "p" "spTree" spTreeElem = --- filterChild (\e -> (isElem ns "p" "sp" e) && (shapeHasName ns "Subtitle 2" e)) spTreeElem --- | otherwise = Nothing - --- getDateShape :: NameSpaces -> Element -> Maybe Element --- getDateShape ns spTreeElem --- | isElem ns "p" "spTree" spTreeElem = --- filterChild (\e -> (isElem ns "p" "sp" e) && (shapeHasName ns "Date Placeholder 3" e)) spTreeElem --- | otherwise = Nothing - -getContentShape :: NameSpaces -> Element -> Maybe Element -getContentShape ns spTreeElem - | isElem ns "p" "spTree" spTreeElem = - filterChild (\e -> (isElem ns "p" "sp" e) && (shapeHasName ns "Content Placeholder 2" e)) spTreeElem - | otherwise = Nothing - - --- cursorHasName :: QName -> XMLC.Cursor -> Bool --- cursorHasName nm cur = case XMLC.current cur of --- Elem element -> case XMLC.tagName $ XMLC.getTag element of --- nm -> True --- _ -> False --- _ -> False - --- fillInTxBody :: NameSpaces -> [Paragraph] -> Element -> Element --- fillInTxBody ns paras txBodyElem --- | isElem ns "p" "txBody" txBodyElem = --- replaceNamedChildren ns "a" "p" (map paragraphToElement paras) txBodyElem --- | otherwise = txBodyElem - --- fillInShape :: NameSpaces -> Shape -> Element -> Element --- fillInShape ns shape spElem --- | TextBox paras <- shape --- , isElemn ns "p" "sp" spElem = --- replaceNamedChildren ns "p" "txBody" (fillInTxBody ns paras sp - - --- fillInShape :: NameSpaces -> Element -> Shape -> Element --- fillInShape ns spElem (TextBox paras) = fillInParagraphs ns spElem paras --- fillInShape _ spElem pic = spElem - -contentIsElem :: NameSpaces -> String -> String -> Content -> Bool -contentIsElem ns prefix name (Elem element) = isElem ns prefix name element -contentIsElem _ _ _ _ = False - -replaceNamedChildren :: NameSpaces -> String -> String -> [Element] -> Element -> Element -replaceNamedChildren ns prefix name newKids element = - let content = elContent element - content' = filter (\c -> not (contentIsElem ns prefix name c)) content - in - element{elContent = content' ++ map Elem newKids} - - ----------------------------------------------------------------- - -registerLink :: PandocMonad m => (URL, String) -> P m Int -registerLink link = do - curSlideId <- gets stCurSlideId - linkReg <- gets stLinkIds - mediaReg <- gets stMediaIds - let maxLinkId = case M.lookup curSlideId linkReg of - Just mp -> case M.keys mp of - [] -> 1 - ks -> maximum ks - Nothing -> 1 - maxMediaId = case M.lookup curSlideId mediaReg of - Just [] -> 1 - Just mInfos -> maximum $ map mInfoLocalId mInfos - Nothing -> 1 - maxId = max maxLinkId maxMediaId - slideLinks = case M.lookup curSlideId linkReg of - Just mp -> M.insert (maxId + 1) link mp - Nothing -> M.singleton (maxId + 1) link - modify $ \st -> st{ stLinkIds = M.insert curSlideId slideLinks linkReg} - return $ maxId + 1 - -registerMedia :: PandocMonad m => FilePath -> [ParaElem] -> P m MediaInfo -registerMedia fp caption = do - curSlideId <- gets stCurSlideId - linkReg <- gets stLinkIds - mediaReg <- gets stMediaIds - globalIds <- gets stMediaGlobalIds - let maxLinkId = case M.lookup curSlideId linkReg of - Just mp -> case M.keys mp of - [] -> 1 - ks -> maximum ks - Nothing -> 1 - maxMediaId = case M.lookup curSlideId mediaReg of - Just [] -> 1 - Just mInfos -> maximum $ map mInfoLocalId mInfos - Nothing -> 1 - maxLocalId = max maxLinkId maxMediaId - - maxGlobalId = case M.elems globalIds of - [] -> 0 - ids -> maximum ids - - (imgBytes, mbMt) <- P.fetchItem fp - let imgExt = (mbMt >>= extensionFromMimeType >>= (\x -> return $ '.':x)) - <|> - case imageType imgBytes of - Just Png -> Just ".png" - Just Jpeg -> Just ".jpeg" - Just Gif -> Just ".gif" - Just Pdf -> Just ".pdf" - Just Eps -> Just ".eps" - Just Svg -> Just ".svg" - Nothing -> Nothing - - let newGlobalId = case M.lookup fp globalIds of - Just ident -> ident - Nothing -> maxGlobalId + 1 - - let newGlobalIds = M.insert fp newGlobalId globalIds - - let mediaInfo = MediaInfo { mInfoFilePath = fp - , mInfoLocalId = maxLocalId + 1 - , mInfoGlobalId = newGlobalId - , mInfoMimeType = mbMt - , mInfoExt = imgExt - , mInfoCaption = (not . null) caption - } - - let slideMediaInfos = case M.lookup curSlideId mediaReg of - Just minfos -> mediaInfo : minfos - Nothing -> [mediaInfo] - - - modify $ \st -> st{ stMediaIds = M.insert curSlideId slideMediaInfos mediaReg - , stMediaGlobalIds = newGlobalIds - } - return mediaInfo - -makeMediaEntry :: PandocMonad m => MediaInfo -> P m Entry -makeMediaEntry mInfo = do - epochtime <- (floor . utcTimeToPOSIXSeconds) <$> asks envUTCTime - (imgBytes, _) <- P.fetchItem (mInfoFilePath mInfo) - let ext = case mInfoExt mInfo of - Just e -> e - Nothing -> "" - let fp = "ppt/media/image" ++ (show $ mInfoGlobalId mInfo) ++ ext - return $ toEntry fp epochtime $ BL.fromStrict imgBytes - -makeMediaEntries :: PandocMonad m => P m [Entry] -makeMediaEntries = do - mediaInfos <- gets stMediaIds - let allInfos = mconcat $ M.elems mediaInfos - mapM makeMediaEntry allInfos - --- | Scales the image to fit the page --- sizes are passed in emu -fitToPage' :: (Double, Double) -- image size in emu - -> Integer -- pageWidth - -> Integer -- pageHeight - -> (Integer, Integer) -- imagesize -fitToPage' (x, y) pageWidth pageHeight - -- Fixes width to the page width and scales the height - | x <= fromIntegral pageWidth && y <= fromIntegral pageHeight = - (floor x, floor y) - | x / fromIntegral pageWidth > y / fromIntegral pageWidth = - (pageWidth, floor $ ((fromIntegral pageWidth) / x) * y) - | otherwise = - (floor $ ((fromIntegral pageHeight) / y) * x, pageHeight) - -positionImage :: (Double, Double) -> Integer -> Integer -> (Integer, Integer) -positionImage (x, y) pageWidth pageHeight = - let (x', y') = fitToPage' (x, y) pageWidth pageHeight - in - ((pageWidth - x') `div` 2, (pageHeight - y') `div` 2) - -getMaster :: PandocMonad m => P m Element -getMaster = do - refArchive <- asks envRefArchive - distArchive <- asks envDistArchive - parseXml refArchive distArchive "ppt/slideMasters/slideMaster1.xml" - --- We want to get the header dimensions, so we can make sure that the --- image goes underneath it. We only use this in a content slide if it --- has a header. - -getHeaderSize :: PandocMonad m => P m ((Integer, Integer), (Integer, Integer)) -getHeaderSize = do - master <- getMaster - let ns = elemToNameSpaces master - sps = [master] >>= - findChildren (elemName ns "p" "cSld") >>= - findChildren (elemName ns "p" "spTree") >>= - findChildren (elemName ns "p" "sp") - mbXfrm = - listToMaybe (filter (shapeHasName ns "Title Placeholder 1") sps) >>= - findChild (elemName ns "p" "spPr") >>= - findChild (elemName ns "a" "xfrm") - xoff = mbXfrm >>= - findChild (elemName ns "a" "off") >>= - findAttr (QName "x" Nothing Nothing) >>= - (listToMaybe . (\s -> reads s :: [(Integer, String)])) - yoff = mbXfrm >>= - findChild (elemName ns "a" "off") >>= - findAttr (QName "y" Nothing Nothing) >>= - (listToMaybe . (\s -> reads s :: [(Integer, String)])) - xext = mbXfrm >>= - findChild (elemName ns "a" "ext") >>= - findAttr (QName "cx" Nothing Nothing) >>= - (listToMaybe . (\s -> reads s :: [(Integer, String)])) - yext = mbXfrm >>= - findChild (elemName ns "a" "ext") >>= - findAttr (QName "cy" Nothing Nothing) >>= - (listToMaybe . (\s -> reads s :: [(Integer, String)])) - off = case xoff of - Just (xoff', _) | Just (yoff',_) <- yoff -> (xoff', yoff') - _ -> (1043490, 1027664) - ext = case xext of - Just (xext', _) | Just (yext',_) <- yext -> (xext', yext') - _ -> (7024744, 1143000) - return $ (off, ext) - - --- Hard-coded for now -captionPosition :: ((Integer, Integer), (Integer, Integer)) -captionPosition = ((457200, 6061972), (8229600, 527087)) - -createCaption :: PandocMonad m => [ParaElem] -> P m Element -createCaption paraElements = do - let para = Paragraph def{pPropAlign = Just AlgnCenter} paraElements - elements <- mapM paragraphToElement [para] - let ((x, y), (cx, cy)) = captionPosition - let txBody = mknode "p:txBody" [] $ - [mknode "a:bodyPr" [] (), mknode "a:lstStyle" [] ()] ++ elements - return $ - mknode "p:sp" [] [ mknode "p:nvSpPr" [] - [ mknode "p:cNvPr" [("id","1"), ("name","TextBox 3")] () - , mknode "p:cNvSpPr" [("txBox", "1")] () - , mknode "p:nvPr" [] () - ] - , mknode "p:spPr" [] - [ mknode "a:xfrm" [] - [ mknode "a:off" [("x", show x), ("y", show y)] () - , mknode "a:ext" [("cx", show cx), ("cy", show cy)] () - ] - , mknode "a:prstGeom" [("prst", "rect")] - [ mknode "a:avLst" [] () - ] - , mknode "a:noFill" [] () - ] - , txBody - ] - --- Largely lifted from inlineToOpenXML' in T.P.W.Docx. Can't be easily --- abstracted because of some different namespaces and monads. TODO. -makePicElement :: PandocMonad m - => MediaInfo - -> Text.Pandoc.Definition.Attr - -> P m Element -makePicElement mInfo attr = do - opts <- asks envOpts - pageWidth <- presSizeWidth <$> asks envPresentationSize - pageHeight <- getPageHeight <$> asks envPresentationSize - hasHeader <- asks envSlideHasHeader - let hasCaption = mInfoCaption mInfo - (imgBytes, _) <- P.fetchItem (mInfoFilePath mInfo) - -- We're not using x exts - ((hXoff, hYoff), (_, hYext)) <- if hasHeader - then getHeaderSize - else return ((0, 0), (0, 0)) - - let ((capX, capY), (_, _)) = if hasCaption - then captionPosition - else ((0,0), (0,0)) - let (xpt,ypt) = desiredSizeInPoints opts attr - (either (const def) id (imageSize opts imgBytes)) - -- 12700 emu = 1 pt - let (xemu,yemu) = fitToPage' (xpt * 12700, ypt * 12700) - ((pageWidth * 12700) - (2 * hXoff) - (2 * capX)) - ((if hasCaption then capY else (pageHeight * 12700)) - (hYoff + hYext)) - (xoff, yoff) = positionImage (xpt * 12700, ypt * 12700) (pageWidth * 12700) (pageHeight * 12700) - xoff' = if hasHeader then xoff + hXoff else xoff - xoff'' = if hasCaption then xoff' + capX else xoff' - yoff' = if hasHeader then hYoff + hYext else yoff - -- let (xemu,yemu)=((floor $ xpt * 12700), (floor $ ypt * 12700)) - let cNvPicPr = mknode "p:cNvPicPr" [] $ - mknode "a:picLocks" [("noGrp","1") - ,("noChangeAspect","1")] () - let nvPicPr = mknode "p:nvPicPr" [] - [ mknode "p:cNvPr" - [("descr", mInfoFilePath mInfo),("id","0"),("name","Picture 1")] () - , cNvPicPr - , mknode "p:nvPr" [] ()] - let blipFill = mknode "p:blipFill" [] - [ mknode "a:blip" [("r:embed", "rId" ++ (show $ mInfoLocalId mInfo))] () - , mknode "a:stretch" [] $ - mknode "a:fillRect" [] () ] - let xfrm = mknode "a:xfrm" [] - [ mknode "a:off" [("x",show xoff''), ("y",show yoff')] () - , mknode "a:ext" [("cx",show xemu) - ,("cy",show yemu)] () ] - let prstGeom = mknode "a:prstGeom" [("prst","rect")] $ - mknode "a:avLst" [] () - let ln = mknode "a:ln" [("w","9525")] - [ mknode "a:noFill" [] () - , mknode "a:headEnd" [] () - , mknode "a:tailEnd" [] () ] - let spPr = mknode "p:spPr" [("bwMode","auto")] - [xfrm, prstGeom, mknode "a:noFill" [] (), ln] - return $ - mknode "p:pic" [] - [ nvPicPr - , blipFill - , spPr ] - --- Currently hardcoded, until I figure out how to make it dynamic. -blockQuoteSize :: Pixels -blockQuoteSize = 20 - -noteSize :: Pixels -noteSize = 18 - -paraElemToElement :: PandocMonad m => ParaElem -> P m Element -paraElemToElement Break = return $ mknode "a:br" [] () -paraElemToElement (Run rpr s) = do - let attrs = - if rPropCode rpr - then [] - else (case rPropForceSize rpr of - Just n -> [("sz", (show $ n * 100))] - Nothing -> []) ++ - (if rPropBold rpr then [("b", "1")] else []) ++ - (if rPropItalics rpr then [("i", "1")] else []) ++ - (case rStrikethrough rpr of - Just NoStrike -> [("strike", "noStrike")] - Just SingleStrike -> [("strike", "sngStrike")] - Just DoubleStrike -> [("strike", "dblStrike")] - Nothing -> []) ++ - (case rBaseline rpr of - Just n -> [("baseline", show n)] - Nothing -> []) ++ - (case rCap rpr of - Just NoCapitals -> [("cap", "none")] - Just SmallCapitals -> [("cap", "small")] - Just AllCapitals -> [("cap", "all")] - Nothing -> []) ++ - [] - linkProps <- case rLink rpr of - Just link -> do idNum <- registerLink link - return [mknode "a:hlinkClick" - [("r:id", "rId" ++ show idNum)] - () - ] - Nothing -> return [] - let propContents = if rPropCode rpr - then [mknode "a:latin" [("typeface", "Courier")] ()] - else linkProps - return $ mknode "a:r" [] [ mknode "a:rPr" attrs propContents - , mknode "a:t" [] s - ] -paraElemToElement (MathElem mathType texStr) = do - res <- convertMath writeOMML mathType (unTeXString texStr) - case res of - Right r -> return $ mknode "a14:m" [] $ addMathInfo r - Left (Str s) -> paraElemToElement (Run def s) - Left _ -> throwError $ PandocShouldNeverHappenError "non-string math fallback" - --- This is a bit of a kludge -- really requires adding an option to --- TeXMath, but since that's a different package, we'll do this one --- step at a time. -addMathInfo :: Element -> Element -addMathInfo element = - let mathspace = Attr { attrKey = (QName "m" Nothing (Just "xmlns")) - , attrVal = "http://schemas.openxmlformats.org/officeDocument/2006/math" - } - in add_attr mathspace element - --- We look through the element to see if it contains an a14:m --- element. If so, we surround it. This is a bit ugly, but it seems --- more dependable than looking through shapes for math. Plus this is --- an xml implementation detail, so it seems to make sense to do it at --- the xml level. -surroundWithMathAlternate :: Element -> Element -surroundWithMathAlternate element = - case findElement (QName "m" Nothing (Just "a14")) element of - Just _ -> - mknode "mc:AlternateContent" - [("xmlns:mc", "http://schemas.openxmlformats.org/markup-compatibility/2006") - ] [ mknode "mc:Choice" - [ ("xmlns:a14", "http://schemas.microsoft.com/office/drawing/2010/main") - , ("Requires", "a14")] [ element ] - ] - Nothing -> element - -paragraphToElement :: PandocMonad m => Paragraph -> P m Element -paragraphToElement par = do - let - attrs = [("lvl", show $ pPropLevel $ paraProps par)] ++ - (case pPropMarginLeft (paraProps par) of - Just px -> [("marL", show $ 12700 * px), ("indent", "0")] - Nothing -> [] - ) ++ - (case pPropAlign (paraProps par) of - Just AlgnLeft -> [("algn", "l")] - Just AlgnRight -> [("algn", "r")] - Just AlgnCenter -> [("algn", "ctr")] - Nothing -> [] - ) - props = [] ++ - (case pPropBullet $ paraProps par of - Just Bullet -> [] - Just (AutoNumbering attrs') -> - [mknode "a:buAutoNum" [("type", autoNumberingToType attrs')] ()] - Nothing -> [mknode "a:buNone" [] ()] - ) - paras <- mapM paraElemToElement (paraElems par) - return $ mknode "a:p" [] $ [mknode "a:pPr" attrs props] ++ paras - -shapeToElement :: PandocMonad m => Element -> Shape -> P m Element -shapeToElement layout (TextBox paras) - | ns <- elemToNameSpaces layout - , Just cSld <- findChild (elemName ns "p" "cSld") layout - , Just spTree <- findChild (elemName ns "p" "spTree") cSld - , Just sp <- getContentShape ns spTree = do - elements <- mapM paragraphToElement paras - let txBody = mknode "p:txBody" [] $ - [mknode "a:bodyPr" [] (), mknode "a:lstStyle" [] ()] ++ elements - emptySpPr = mknode "p:spPr" [] () - return $ - surroundWithMathAlternate $ - replaceNamedChildren ns "p" "txBody" [txBody] $ - replaceNamedChildren ns "p" "spPr" [emptySpPr] $ - sp - -- XXX: TODO - | otherwise = return $ mknode "p:sp" [] () --- XXX: TODO -shapeToElement layout (Pic fp attr alt) = do - mInfo <- registerMedia fp alt - case mInfoExt mInfo of - Just _ -> makePicElement mInfo attr - Nothing -> shapeToElement layout $ TextBox [Paragraph def alt] -shapeToElement _ (GraphicFrame tbls _) = do - elements <- mapM graphicToElement tbls - return $ mknode "p:graphicFrame" [] $ - [ mknode "p:nvGraphicFramePr" [] $ - [ mknode "p:cNvPr" [("id", "6"), ("name", "Content Placeholder 5")] () - , mknode "p:cNvGraphicFramePr" [] $ - [mknode "a:graphicFrameLocks" [("noGrp", "1")] ()] - , mknode "p:nvPr" [] $ - [mknode "p:ph" [("idx", "1")] ()] - ] - , mknode "p:xfrm" [] $ - [ mknode "a:off" [("x", "457200"), ("y", "1600200")] () - , mknode "a:ext" [("cx", "8029388"), ("cy", "3644152")] () - ] - ] ++ elements - -shapeToElements :: PandocMonad m => Element -> Shape -> P m [Element] -shapeToElements layout shp = do - case shp of - (Pic _ _ alt) | (not . null) alt -> do - element <- shapeToElement layout shp - caption <- createCaption alt - return [element, caption] - (GraphicFrame _ cptn) | (not . null) cptn -> do - element <- shapeToElement layout shp - caption <- createCaption cptn - return [element, caption] - _ -> do - element <- shapeToElement layout shp - return [element] - -shapesToElements :: PandocMonad m => Element -> [Shape] -> P m [Element] -shapesToElements layout shps = do - concat <$> mapM (shapeToElements layout) shps - -hardcodedTableMargin :: Integer -hardcodedTableMargin = 36 - - -graphicToElement :: PandocMonad m => Graphic -> P m Element -graphicToElement (Tbl tblPr colWidths hdrCells rows) = do - let cellToOpenXML paras = do elements <- mapM paragraphToElement paras - return $ - [mknode "a:txBody" [] $ - ([ mknode "a:bodyPr" [] () - , mknode "a:lstStyle" [] ()] - ++ elements)] - headers' <- mapM cellToOpenXML hdrCells - rows' <- mapM (mapM cellToOpenXML) rows - let borderProps = mknode "a:tcPr" [] () - let emptyCell = [mknode "a:p" [] [mknode "a:pPr" [] ()]] - let mkcell border contents = mknode "a:tc" [] - $ (if null contents - then emptyCell - else contents) ++ [ borderProps | border ] - let mkrow border cells = mknode "a:tr" [("h", "0")] $ map (mkcell border) cells - -- let textwidth = 14400 -- 5.5 in in twips, 1/20 pt - -- let fullrow = 14400 -- 100% specified in pct - -- let rowwidth = fullrow * sum colWidths - - let mkgridcol w = mknode "a:gridCol" - [("w", show ((12700 * w) :: Integer))] () - let hasHeader = not (all null hdrCells) - return $ mknode "a:graphic" [] $ - [mknode "a:graphicData" [("uri", "http://schemas.openxmlformats.org/drawingml/2006/table")] $ - [mknode "a:tbl" [] $ - [ mknode "a:tblPr" [ ("firstRow", if tblPrFirstRow tblPr then "1" else "0") - , ("bandRow", if tblPrBandRow tblPr then "1" else "0") - ] () - , mknode "a:tblGrid" [] (if all (==0) colWidths - then [] - else map mkgridcol colWidths) - ] - ++ [ mkrow True headers' | hasHeader ] ++ map (mkrow False) rows' - ] - ] - -getShapeByName :: NameSpaces -> Element -> String -> Maybe Element -getShapeByName ns spTreeElem name - | isElem ns "p" "spTree" spTreeElem = - filterChild (\e -> (isElem ns "p" "sp" e) && (shapeHasName ns name e)) spTreeElem - | otherwise = Nothing - -nonBodyTextToElement :: PandocMonad m => Element -> String -> [ParaElem] -> P m Element -nonBodyTextToElement layout shapeName paraElements - | ns <- elemToNameSpaces layout - , Just cSld <- findChild (elemName ns "p" "cSld") layout - , Just spTree <- findChild (elemName ns "p" "spTree") cSld - , Just sp <- getShapeByName ns spTree shapeName = do - let hdrPara = Paragraph def paraElements - element <- paragraphToElement hdrPara - let txBody = mknode "p:txBody" [] $ - [mknode "a:bodyPr" [] (), mknode "a:lstStyle" [] ()] ++ - [element] - return $ replaceNamedChildren ns "p" "txBody" [txBody] sp - -- XXX: TODO - | otherwise = return $ mknode "p:sp" [] () - - --- hdrToElement :: Element -> [ParaElem] -> Element --- hdrToElement layout paraElems --- | ns <- elemToNameSpaces layout --- , Just cSld <- findChild (elemName ns "p" "cSld") layout --- , Just spTree <- findChild (elemName ns "p" "spTree") cSld --- , Just sp <- getContentTitleShape ns spTree = --- let hdrPara = Paragraph def paraElems --- txBody = mknode "p:txBody" [] $ --- [mknode "a:bodyPr" [] (), mknode "a:lstStyle" [] ()] ++ --- [paragraphToElement hdrPara] --- in --- replaceNamedChildren ns "p" "txBody" [txBody] sp --- -- XXX: TODO --- | otherwise = mknode "p:sp" [] () --- -- XXX: TODO --- hdrToElement _ _ = mknode "p:sp" [] () - -contentToElement :: PandocMonad m => Element -> [ParaElem] -> [Shape] -> P m Element -contentToElement layout hdrShape shapes - | ns <- elemToNameSpaces layout - , Just cSld <- findChild (elemName ns "p" "cSld") layout - , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do - element <- nonBodyTextToElement layout "Title 1" hdrShape - let hdrShapeElements = if null hdrShape - then [] - else [element] - contentElements <- shapesToElements layout shapes - return $ - replaceNamedChildren ns "p" "sp" - (hdrShapeElements ++ contentElements) - spTree -contentToElement _ _ _ = return $ mknode "p:sp" [] () - -titleToElement :: PandocMonad m => Element -> [ParaElem] -> P m Element -titleToElement layout titleElems - | ns <- elemToNameSpaces layout - , Just cSld <- findChild (elemName ns "p" "cSld") layout - , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do - element <- nonBodyTextToElement layout "Title 1" titleElems - let titleShapeElements = if null titleElems - then [] - else [element] - return $ replaceNamedChildren ns "p" "sp" titleShapeElements spTree -titleToElement _ _ = return $ mknode "p:sp" [] () - -metadataToElement :: PandocMonad m => Element -> [ParaElem] -> [ParaElem] -> [[ParaElem]] -> [ParaElem] -> P m Element -metadataToElement layout titleElems subtitleElems authorsElems dateElems - | ns <- elemToNameSpaces layout - , Just cSld <- findChild (elemName ns "p" "cSld") layout - , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do - titleShapeElements <- if null titleElems - then return [] - else sequence [nonBodyTextToElement layout "Title 1" titleElems] - let combinedAuthorElems = intercalate [Break] authorsElems - subtitleAndAuthorElems = intercalate [Break, Break] [subtitleElems, combinedAuthorElems] - subtitleShapeElements <- if null subtitleAndAuthorElems - then return [] - else sequence [nonBodyTextToElement layout "Subtitle 2" subtitleAndAuthorElems] - dateShapeElements <- if null dateElems - then return [] - else sequence [nonBodyTextToElement layout "Date Placeholder 3" dateElems] - return $ replaceNamedChildren ns "p" "sp" - (titleShapeElements ++ subtitleShapeElements ++ dateShapeElements) - spTree -metadataToElement _ _ _ _ _ = return $ mknode "p:sp" [] () - -slideToElement :: PandocMonad m => Slide -> P m Element -slideToElement s@(ContentSlide hdrElems shapes) = do - layout <- getLayout s - spTree <- local (\env -> if null hdrElems - then env - else env{envSlideHasHeader=True}) $ - contentToElement layout hdrElems shapes - return $ mknode "p:sld" - [ ("xmlns:a", "http://schemas.openxmlformats.org/drawingml/2006/main"), - ("xmlns:r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships"), - ("xmlns:p", "http://schemas.openxmlformats.org/presentationml/2006/main") - ] [mknode "p:cSld" [] [spTree]] -slideToElement s@(TitleSlide hdrElems) = do - layout <- getLayout s - spTree <- titleToElement layout hdrElems - return $ mknode "p:sld" - [ ("xmlns:a", "http://schemas.openxmlformats.org/drawingml/2006/main"), - ("xmlns:r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships"), - ("xmlns:p", "http://schemas.openxmlformats.org/presentationml/2006/main") - ] [mknode "p:cSld" [] [spTree]] -slideToElement s@(MetadataSlide titleElems subtitleElems authorElems dateElems) = do - layout <- getLayout s - spTree <- metadataToElement layout titleElems subtitleElems authorElems dateElems - return $ mknode "p:sld" - [ ("xmlns:a", "http://schemas.openxmlformats.org/drawingml/2006/main"), - ("xmlns:r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships"), - ("xmlns:p", "http://schemas.openxmlformats.org/presentationml/2006/main") - ] [mknode "p:cSld" [] [spTree]] - ------------------------------------------------------------------------ - -slideToFilePath :: Slide -> Int -> FilePath -slideToFilePath _ idNum = "slide" ++ (show $ idNum) ++ ".xml" - -slideToSlideId :: Monad m => Slide -> Int -> P m String -slideToSlideId _ idNum = do - n <- gets stSlideIdOffset - return $ "rId" ++ (show $ idNum + n) - - -data Relationship = Relationship { relId :: Int - , relType :: MimeType - , relTarget :: FilePath - } deriving (Show, Eq) - -elementToRel :: Element -> Maybe Relationship -elementToRel element - | elName element == QName "Relationship" (Just "http://schemas.openxmlformats.org/package/2006/relationships") Nothing = - do rId <- findAttr (QName "Id" Nothing Nothing) element - numStr <- stripPrefix "rId" rId - num <- case reads numStr :: [(Int, String)] of - (n, _) : _ -> Just n - [] -> Nothing - type' <- findAttr (QName "Type" Nothing Nothing) element - target <- findAttr (QName "Target" Nothing Nothing) element - return $ Relationship num type' target - | otherwise = Nothing - -slideToPresRel :: Monad m => Slide -> Int -> P m Relationship -slideToPresRel slide idNum = do - n <- gets stSlideIdOffset - let rId = idNum + n - fp = "slides/" ++ slideToFilePath slide idNum - return $ Relationship { relId = rId - , relType = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide" - , relTarget = fp - } - -getRels :: PandocMonad m => P m [Relationship] -getRels = do - refArchive <- asks envRefArchive - distArchive <- asks envDistArchive - relsElem <- parseXml refArchive distArchive "ppt/_rels/presentation.xml.rels" - let globalNS = "http://schemas.openxmlformats.org/package/2006/relationships" - let relElems = findChildren (QName "Relationship" (Just globalNS) Nothing) relsElem - return $ mapMaybe elementToRel relElems - -presentationToRels :: PandocMonad m => Presentation -> P m [Relationship] -presentationToRels (Presentation _ slides) = do - mySlideRels <- mapM (\(s, n) -> slideToPresRel s n) $ zip slides [1..] - rels <- getRels - let relsWithoutSlides = filter (\r -> relType r /= "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide") rels - -- We want to make room for the slides in the id space. The slides - -- will start at Id2 (since Id1 is for the slide master). There are - -- two slides in the data file, but that might change in the future, - -- so we will do this: - -- - -- 1. We look to see what the minimum relWithoutSlide id (greater than 1) is. - -- 2. We add the difference between this and the number of slides to - -- all relWithoutSlide rels (unless they're 1) - - let minRelNotOne = case filter (1<) $ map relId relsWithoutSlides of - [] -> 0 -- doesn't matter in this case, since - -- there will be nothing to map the - -- function over - l -> minimum l - - modifyRelNum :: Int -> Int - modifyRelNum 1 = 1 - modifyRelNum n = n - minRelNotOne + 2 + length slides - - relsWithoutSlides' = map (\r -> r{relId = modifyRelNum $ relId r}) relsWithoutSlides - - return $ mySlideRels ++ relsWithoutSlides' - -relToElement :: Relationship -> Element -relToElement rel = mknode "Relationship" [ ("Id", "rId" ++ (show $ relId rel)) - , ("Type", relType rel) - , ("Target", relTarget rel) ] () - -relsToElement :: [Relationship] -> Element -relsToElement rels = mknode "Relationships" - [("xmlns", "http://schemas.openxmlformats.org/package/2006/relationships")] - (map relToElement rels) - -presentationToRelsEntry :: PandocMonad m => Presentation -> P m Entry -presentationToRelsEntry pres = do - rels <- presentationToRels pres - elemToEntry "ppt/_rels/presentation.xml.rels" $ relsToElement rels - -elemToEntry :: PandocMonad m => FilePath -> Element -> P m Entry -elemToEntry fp element = do - epochtime <- (floor . utcTimeToPOSIXSeconds) <$> asks envUTCTime - return $ toEntry fp epochtime $ renderXml element - -slideToEntry :: PandocMonad m => Slide -> Int -> P m Entry -slideToEntry slide idNum = do - modify $ \st -> st{stCurSlideId = idNum} - element <- slideToElement slide - elemToEntry ("ppt/slides/" ++ slideToFilePath slide idNum) element - -slideToSlideRelEntry :: PandocMonad m => Slide -> Int -> P m Entry -slideToSlideRelEntry slide idNum = do - element <- slideToSlideRelElement slide idNum - elemToEntry ("ppt/slides/_rels/" ++ slideToFilePath slide idNum ++ ".rels") element - -linkRelElement :: Int -> (URL, String) -> Element -linkRelElement idNum (url, _) = - mknode "Relationship" [ ("Id", "rId" ++ show idNum) - , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/hyperlink") - , ("Target", url) - , ("TargetMode", "External") - ] () - -linkRelElements :: M.Map Int (URL, String) -> [Element] -linkRelElements mp = map (\(n, lnk) -> linkRelElement n lnk) (M.toList mp) - -mediaRelElement :: MediaInfo -> Element -mediaRelElement mInfo = - let ext = case mInfoExt mInfo of - Just e -> e - Nothing -> "" - in - mknode "Relationship" [ ("Id", "rId" ++ (show $ mInfoLocalId mInfo)) - , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/image") - , ("Target", "../media/image" ++ (show $ mInfoGlobalId mInfo) ++ ext) - ] () - -slideToSlideRelElement :: PandocMonad m => Slide -> Int -> P m Element -slideToSlideRelElement slide idNum = do - let target = case slide of - (MetadataSlide _ _ _ _) -> "../slideLayouts/slideLayout1.xml" - (TitleSlide _) -> "../slideLayouts/slideLayout3.xml" - (ContentSlide _ _) -> "../slideLayouts/slideLayout2.xml" - - linkIds <- gets stLinkIds - mediaIds <- gets stMediaIds - - let linkRels = case M.lookup idNum linkIds of - Just mp -> linkRelElements mp - Nothing -> [] - mediaRels = case M.lookup idNum mediaIds of - Just mInfos -> map mediaRelElement mInfos - Nothing -> [] - - return $ - mknode "Relationships" - [("xmlns", "http://schemas.openxmlformats.org/package/2006/relationships")] - ([mknode "Relationship" [ ("Id", "rId1") - , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slideLayout") - , ("Target", target)] () - ] ++ linkRels ++ mediaRels) - --- slideToSlideRelEntry :: PandocMonad m => Slide -> Int -> P m Entry --- slideToSlideRelEntry slide idNum = do --- let fp = "ppt/slides/_rels/slide" ++ (show idNum) ++ ".xml.rels" --- elemToEntry fp $ slideToSlideRelElement slide - -slideToSldIdElement :: PandocMonad m => Slide -> Int -> P m Element -slideToSldIdElement slide idNum = do - let id' = show $ idNum + 255 - rId <- slideToSlideId slide idNum - return $ mknode "p:sldId" [("id", id'), ("r:id", rId)] () - -presentationToSldIdLst :: PandocMonad m => Presentation -> P m Element -presentationToSldIdLst (Presentation _ slides) = do - ids <- mapM (\(s,n) -> slideToSldIdElement s n) (zip slides [1..]) - return $ mknode "p:sldIdLst" [] ids - -presentationToPresentationElement :: PandocMonad m => Presentation -> P m Element -presentationToPresentationElement pres = do - refArchive <- asks envRefArchive - distArchive <- asks envDistArchive - element <- parseXml refArchive distArchive "ppt/presentation.xml" - sldIdLst <- presentationToSldIdLst pres - - let modifySldIdLst :: Content -> Content - modifySldIdLst (Elem e) = case elName e of - (QName "sldIdLst" _ _) -> Elem sldIdLst - _ -> Elem e - modifySldIdLst ct = ct - - newContent = map modifySldIdLst $ elContent element - - return $ element{elContent = newContent} - -presentationToPresEntry :: PandocMonad m => Presentation -> P m Entry -presentationToPresEntry pres = presentationToPresentationElement pres >>= - elemToEntry "ppt/presentation.xml" - - - - -defaultContentTypeToElem :: DefaultContentType -> Element -defaultContentTypeToElem dct = - mknode "Default" - [("Extension", defContentTypesExt dct), - ("ContentType", defContentTypesType dct)] - () - -overrideContentTypeToElem :: OverrideContentType -> Element -overrideContentTypeToElem oct = - mknode "Override" - [("PartName", overrideContentTypesPart oct), - ("ContentType", overrideContentTypesType oct)] - () - -contentTypesToElement :: ContentTypes -> Element -contentTypesToElement ct = - let ns = "http://schemas.openxmlformats.org/package/2006/content-types" - in - mknode "Types" [("xmlns", ns)] $ - (map defaultContentTypeToElem $ contentTypesDefaults ct) ++ - (map overrideContentTypeToElem $ contentTypesOverrides ct) - -data DefaultContentType = DefaultContentType - { defContentTypesExt :: String - , defContentTypesType:: MimeType - } - deriving (Show, Eq) - -data OverrideContentType = OverrideContentType - { overrideContentTypesPart :: FilePath - , overrideContentTypesType :: MimeType - } - deriving (Show, Eq) - -data ContentTypes = ContentTypes { contentTypesDefaults :: [DefaultContentType] - , contentTypesOverrides :: [OverrideContentType] - } - deriving (Show, Eq) - -contentTypesToEntry :: PandocMonad m => ContentTypes -> P m Entry -contentTypesToEntry ct = elemToEntry "[Content_Types].xml" $ contentTypesToElement ct - -pathToOverride :: FilePath -> Maybe OverrideContentType -pathToOverride fp = OverrideContentType ("/" ++ fp) <$> (getContentType fp) - -mediaContentType :: MediaInfo -> Maybe DefaultContentType -mediaContentType mInfo - | Just ('.' : ext) <- mInfoExt mInfo = - Just $ DefaultContentType { defContentTypesExt = ext - , defContentTypesType = - case mInfoMimeType mInfo of - Just mt -> mt - Nothing -> "application/octet-stream" - } - | otherwise = Nothing - -presentationToContentTypes :: PandocMonad m => Presentation -> P m ContentTypes -presentationToContentTypes (Presentation _ slides) = do - mediaInfos <- (mconcat . M.elems) <$> gets stMediaIds - let defaults = [ DefaultContentType "xml" "application/xml" - , DefaultContentType "rels" "application/vnd.openxmlformats-package.relationships+xml" - ] - mediaDefaults = nub $ mapMaybe mediaContentType mediaInfos - inheritedOverrides = mapMaybe pathToOverride inheritedFiles - presOverride = mapMaybe pathToOverride ["ppt/presentation.xml"] - slideOverrides = - mapMaybe - (\(s, n) -> - pathToOverride $ "ppt/slides/" ++ slideToFilePath s n) - (zip slides [1..]) - -- propOverride = mapMaybe pathToOverride ["docProps/core.xml"] - return $ ContentTypes - (defaults ++ mediaDefaults) - (inheritedOverrides ++ presOverride ++ slideOverrides) - --- slideToElement :: Element -> Slide -> Element --- slideToElement layout (ContentSlide _ shapes) = --- let sps = map (shapeToElement layout) shapes - -presML :: String -presML = "application/vnd.openxmlformats-officedocument.presentationml" - -noPresML :: String -noPresML = "application/vnd.openxmlformats-officedocument" - -getContentType :: FilePath -> Maybe MimeType -getContentType fp - | fp == "ppt/presentation.xml" = Just $ presML ++ ".presentation.main+xml" - | fp == "ppt/presProps.xml" = Just $ presML ++ ".presProps+xml" - | fp == "ppt/viewProps.xml" = Just $ presML ++ ".viewProps+xml" - | fp == "ppt/tableStyles.xml" = Just $ presML ++ ".tableStyles+xml" - | fp == "docProps/core.xml" = Just $ "application/vnd.openxmlformats-package.core-properties+xml" - | fp == "docProps/app.xml" = Just $ noPresML ++ ".extended-properties+xml" - | "ppt" : "slideMasters" : f : [] <- splitDirectories fp - , (_, ".xml") <- splitExtension f = - Just $ presML ++ ".slideMaster+xml" - | "ppt" : "slides" : f : [] <- splitDirectories fp - , (_, ".xml") <- splitExtension f = - Just $ presML ++ ".slide+xml" - | "ppt" : "notesMasters" : f : [] <- splitDirectories fp - , (_, ".xml") <- splitExtension f = - Just $ presML ++ ".notesMaster+xml" - | "ppt" : "notesSlides" : f : [] <- splitDirectories fp - , (_, ".xml") <- splitExtension f = - Just $ presML ++ ".notesSlide+xml" - | "ppt" : "theme" : f : [] <- splitDirectories fp - , (_, ".xml") <- splitExtension f = - Just $ noPresML ++ ".theme+xml" - | "ppt" : "slideLayouts" : _ : [] <- splitDirectories fp= - Just $ presML ++ ".slideLayout+xml" - | otherwise = Nothing + let (pres, logMsgs) = documentToPresentation opts (Pandoc meta blks') + mapM_ report logMsgs + archv <- presentationToArchive opts pres + return $ fromArchive archv diff --git a/src/Text/Pandoc/Writers/Powerpoint/Output.hs b/src/Text/Pandoc/Writers/Powerpoint/Output.hs new file mode 100644 index 000000000..d30819d47 --- /dev/null +++ b/src/Text/Pandoc/Writers/Powerpoint/Output.hs @@ -0,0 +1,1494 @@ +{-# LANGUAGE PatternGuards #-} + +{- +Copyright (C) 2017-2018 Jesse Rosenthal <jrosenthal@jhu.edu> + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- | + Module : Text.Pandoc.Writers.Powerpoint.Output + Copyright : Copyright (C) 2017-2018 Jesse Rosenthal + License : GNU GPL, version 2 or above + + Maintainer : Jesse Rosenthal <jrosenthal@jhu.edu> + Stability : alpha + Portability : portable + +Conversion of Presentation datatype (defined in +Text.Pandoc.Writers.Powerpoint.Presentation) to a zip archive. +-} + +module Text.Pandoc.Writers.Powerpoint.Output ( presentationToArchive + ) where + +import Control.Monad.Except (throwError, catchError) +import Control.Monad.Reader +import Control.Monad.State +import Codec.Archive.Zip +import Data.Char (toUpper) +import Data.List (intercalate, stripPrefix, nub, union, isPrefixOf) +import Data.Default +import Text.Pandoc.Compat.Time (formatTime, defaultTimeLocale) +import Data.Time.Clock (UTCTime) +import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, posixSecondsToUTCTime) +import System.FilePath.Posix (splitDirectories, splitExtension, takeExtension) +import Text.XML.Light +import Text.Pandoc.Definition +import qualified Text.Pandoc.UTF8 as UTF8 +import Text.Pandoc.Class (PandocMonad) +import Text.Pandoc.Error (PandocError(..)) +import qualified Text.Pandoc.Class as P +import Text.Pandoc.Options +import Text.Pandoc.MIME +import qualified Data.ByteString.Lazy as BL +import Text.Pandoc.Writers.OOXML +import qualified Data.Map as M +import Data.Maybe (mapMaybe, listToMaybe, fromMaybe) +import Text.Pandoc.ImageSize +import Control.Applicative ((<|>)) +import System.FilePath.Glob +import Text.TeXMath +import Text.Pandoc.Writers.Math (convertMath) +import Text.Pandoc.Writers.Powerpoint.Presentation +import Skylighting (fromColor) + +-- This populates the global ids map with images already in the +-- template, so the ids won't be used by images introduced by the +-- user. +initialGlobalIds :: Archive -> Archive -> M.Map FilePath Int +initialGlobalIds refArchive distArchive = + let archiveFiles = filesInArchive refArchive `union` filesInArchive distArchive + mediaPaths = filter (isPrefixOf "ppt/media/image") archiveFiles + + go :: FilePath -> Maybe (FilePath, Int) + go fp = do + s <- stripPrefix "ppt/media/image" $ fst $ splitExtension fp + (n, _) <- listToMaybe $ reads s + return (fp, n) + in + M.fromList $ mapMaybe go mediaPaths + +getPresentationSize :: Archive -> Archive -> Maybe (Integer, Integer) +getPresentationSize refArchive distArchive = do + entry <- findEntryByPath "ppt/presentation.xml" refArchive `mplus` + findEntryByPath "ppt/presentation.xml" distArchive + presElement <- parseXMLDoc $ UTF8.toStringLazy $ fromEntry entry + let ns = elemToNameSpaces presElement + sldSize <- findChild (elemName ns "p" "sldSz") presElement + cxS <- findAttr (QName "cx" Nothing Nothing) sldSize + cyS <- findAttr (QName "cy" Nothing Nothing) sldSize + (cx, _) <- listToMaybe $ reads cxS :: Maybe (Integer, String) + (cy, _) <- listToMaybe $ reads cyS :: Maybe (Integer, String) + return (cx `div` 12700, cy `div` 12700) + +data WriterEnv = WriterEnv { envRefArchive :: Archive + , envDistArchive :: Archive + , envUTCTime :: UTCTime + , envOpts :: WriterOptions + , envPresentationSize :: (Integer, Integer) + , envSlideHasHeader :: Bool + , envInList :: Bool + , envInNoteSlide :: Bool + , envCurSlideId :: Int + -- the difference between the number at + -- the end of the slide file name and + -- the rId number + , envSlideIdOffset :: Int + , envContentType :: ContentType + , envSlideIdMap :: M.Map SlideId Int + } + deriving (Show) + +instance Default WriterEnv where + def = WriterEnv { envRefArchive = emptyArchive + , envDistArchive = emptyArchive + , envUTCTime = posixSecondsToUTCTime 0 + , envOpts = def + , envPresentationSize = (720, 540) + , envSlideHasHeader = False + , envInList = False + , envInNoteSlide = False + , envCurSlideId = 1 + , envSlideIdOffset = 1 + , envContentType = NormalContent + , envSlideIdMap = mempty + } + +data ContentType = NormalContent + | TwoColumnLeftContent + | TwoColumnRightContent + deriving (Show, Eq) + +data MediaInfo = MediaInfo { mInfoFilePath :: FilePath + , mInfoLocalId :: Int + , mInfoGlobalId :: Int + , mInfoMimeType :: Maybe MimeType + , mInfoExt :: Maybe String + , mInfoCaption :: Bool + } deriving (Show, Eq) + +data WriterState = WriterState { stLinkIds :: M.Map Int (M.Map Int LinkTarget) + -- (FP, Local ID, Global ID, Maybe Mime) + , stMediaIds :: M.Map Int [MediaInfo] + , stMediaGlobalIds :: M.Map FilePath Int + } deriving (Show, Eq) + +instance Default WriterState where + def = WriterState { stLinkIds = mempty + , stMediaIds = mempty + , stMediaGlobalIds = mempty + } + +type P m = ReaderT WriterEnv (StateT WriterState m) + +runP :: Monad m => WriterEnv -> WriterState -> P m a -> m a +runP env st p = evalStateT (runReaderT p env) st + +-------------------------------------------------------------------- + +copyFileToArchive :: PandocMonad m => Archive -> FilePath -> P m Archive +copyFileToArchive arch fp = do + refArchive <- asks envRefArchive + distArchive <- asks envDistArchive + case findEntryByPath fp refArchive `mplus` findEntryByPath fp distArchive of + Nothing -> fail $ fp ++ " missing in reference file" + Just e -> return $ addEntryToArchive e arch + +inheritedPatterns :: [Pattern] +inheritedPatterns = map compile [ "docProps/app.xml" + , "ppt/slideLayouts/slideLayout*.xml" + , "ppt/slideLayouts/_rels/slideLayout*.xml.rels" + , "ppt/slideMasters/slideMaster1.xml" + , "ppt/slideMasters/_rels/slideMaster1.xml.rels" + , "ppt/theme/theme1.xml" + , "ppt/theme/_rels/theme1.xml.rels" + , "ppt/presProps.xml" + , "ppt/viewProps.xml" + , "ppt/tableStyles.xml" + , "ppt/media/image*" + ] + +patternToFilePaths :: PandocMonad m => Pattern -> P m [FilePath] +patternToFilePaths pat = do + refArchive <- asks envRefArchive + distArchive <- asks envDistArchive + + let archiveFiles = filesInArchive refArchive `union` filesInArchive distArchive + return $ filter (match pat) archiveFiles + +patternsToFilePaths :: PandocMonad m => [Pattern] -> P m [FilePath] +patternsToFilePaths pats = concat <$> mapM patternToFilePaths pats + +-- Here are the files we'll require to make a Powerpoint document. If +-- any of these are missing, we should error out of our build. +requiredFiles :: [FilePath] +requiredFiles = [ "docProps/app.xml" + , "ppt/presProps.xml" + , "ppt/slideLayouts/slideLayout1.xml" + , "ppt/slideLayouts/_rels/slideLayout1.xml.rels" + , "ppt/slideLayouts/slideLayout2.xml" + , "ppt/slideLayouts/_rels/slideLayout2.xml.rels" + , "ppt/slideLayouts/slideLayout3.xml" + , "ppt/slideLayouts/_rels/slideLayout3.xml.rels" + , "ppt/slideLayouts/slideLayout4.xml" + , "ppt/slideLayouts/_rels/slideLayout4.xml.rels" + , "ppt/slideMasters/slideMaster1.xml" + , "ppt/slideMasters/_rels/slideMaster1.xml.rels" + , "ppt/theme/theme1.xml" + , "ppt/viewProps.xml" + , "ppt/tableStyles.xml" + ] + + +presentationToArchiveP :: PandocMonad m => Presentation -> P m Archive +presentationToArchiveP p@(Presentation docProps slides) = do + filePaths <- patternsToFilePaths inheritedPatterns + + -- make sure all required files are available: + let missingFiles = filter (\fp -> not (fp `elem` filePaths)) requiredFiles + unless (null missingFiles) + (throwError $ + PandocSomeError $ + "The following required files are missing:\n" ++ + (unlines $ map (" " ++) missingFiles) + ) + + newArch' <- foldM copyFileToArchive emptyArchive filePaths + -- we make a docProps/core.xml entry out of the presentation docprops + docPropsEntry <- docPropsToEntry docProps + -- we make this ourself in case there's something unexpected in the + -- one in the reference doc. + relsEntry <- topLevelRelsEntry + -- presentation entry and rels. We have to do the rels first to make + -- sure we know the correct offset for the rIds. + presEntry <- presentationToPresEntry p + presRelsEntry <- presentationToRelsEntry p + slideEntries <- mapM slideToEntry slides + slideRelEntries <- mapM slideToSlideRelEntry slides + -- These have to come after everything, because they need the info + -- built up in the state. + mediaEntries <- makeMediaEntries + contentTypesEntry <- presentationToContentTypes p >>= contentTypesToEntry + -- fold everything into our inherited archive and return it. + return $ foldr addEntryToArchive newArch' $ + slideEntries ++ + slideRelEntries ++ + mediaEntries ++ + [contentTypesEntry, docPropsEntry, relsEntry, presEntry, presRelsEntry] + +makeSlideIdMap :: Presentation -> M.Map SlideId Int +makeSlideIdMap (Presentation _ slides) = + M.fromList $ (map slideId slides) `zip` [1..] + +presentationToArchive :: PandocMonad m => WriterOptions -> Presentation -> m Archive +presentationToArchive opts pres = do + distArchive <- (toArchive . BL.fromStrict) <$> + P.readDefaultDataFile "reference.pptx" + refArchive <- case writerReferenceDoc opts of + Just f -> toArchive <$> P.readFileLazy f + Nothing -> (toArchive . BL.fromStrict) <$> + P.readDataFile "reference.pptx" + + utctime <- P.getCurrentTime + + presSize <- case getPresentationSize refArchive distArchive of + Just sz -> return sz + Nothing -> throwError $ + PandocSomeError $ + "Could not determine presentation size" + + let env = def { envRefArchive = refArchive + , envDistArchive = distArchive + , envUTCTime = utctime + , envOpts = opts + , envPresentationSize = presSize + , envSlideIdMap = makeSlideIdMap pres + } + + let st = def { stMediaGlobalIds = initialGlobalIds refArchive distArchive + } + + runP env st $ presentationToArchiveP pres + + + +-------------------------------------------------- + +-------------------------------------------------- + +getLayout :: PandocMonad m => Layout -> P m Element +getLayout layout = do + let layoutpath = case layout of + (MetadataSlide _ _ _ _) -> "ppt/slideLayouts/slideLayout1.xml" + (TitleSlide _) -> "ppt/slideLayouts/slideLayout3.xml" + (ContentSlide _ _) -> "ppt/slideLayouts/slideLayout2.xml" + (TwoColumnSlide _ _ _) -> "ppt/slideLayouts/slideLayout4.xml" + distArchive <- asks envDistArchive + root <- case findEntryByPath layoutpath distArchive of + Just e -> case parseXMLDoc $ UTF8.toStringLazy $ fromEntry e of + Just element -> return $ element + Nothing -> throwError $ + PandocSomeError $ + layoutpath ++ " corrupt in reference file" + Nothing -> throwError $ + PandocSomeError $ + layoutpath ++ " missing in reference file" + return root + +shapeHasName :: NameSpaces -> String -> Element -> Bool +shapeHasName ns name element + | Just nvSpPr <- findChild (elemName ns "p" "nvSpPr") element + , Just cNvPr <- findChild (elemName ns "p" "cNvPr") nvSpPr + , Just nm <- findAttr (QName "name" Nothing Nothing) cNvPr = + nm == name + | otherwise = False + +shapeHasId :: NameSpaces -> String -> Element -> Bool +shapeHasId ns ident element + | Just nvSpPr <- findChild (elemName ns "p" "nvSpPr") element + , Just cNvPr <- findChild (elemName ns "p" "cNvPr") nvSpPr + , Just nm <- findAttr (QName "id" Nothing Nothing) cNvPr = + nm == ident + | otherwise = False + +-- The content shape in slideLayout2 (Title/Content) has id=3 In +-- slideLayout4 (two column) the left column is id=3, and the right +-- column is id=4. +getContentShape :: PandocMonad m => NameSpaces -> Element -> P m Element +getContentShape ns spTreeElem + | isElem ns "p" "spTree" spTreeElem = do + contentType <- asks envContentType + let ident = case contentType of + NormalContent -> "3" + TwoColumnLeftContent -> "3" + TwoColumnRightContent -> "4" + case filterChild + (\e -> (isElem ns "p" "sp" e) && (shapeHasId ns ident e)) + spTreeElem + of + Just e -> return e + Nothing -> throwError $ + PandocSomeError $ + "Could not find shape for Powerpoint content" +getContentShape _ _ = throwError $ + PandocSomeError $ + "Attempted to find content on non shapeTree" + +getShapeDimensions :: NameSpaces + -> Element + -> Maybe ((Integer, Integer), (Integer, Integer)) +getShapeDimensions ns element + | isElem ns "p" "sp" element = do + spPr <- findChild (elemName ns "p" "spPr") element + xfrm <- findChild (elemName ns "a" "xfrm") spPr + off <- findChild (elemName ns "a" "off") xfrm + xS <- findAttr (QName "x" Nothing Nothing) off + yS <- findAttr (QName "y" Nothing Nothing) off + ext <- findChild (elemName ns "a" "ext") xfrm + cxS <- findAttr (QName "cx" Nothing Nothing) ext + cyS <- findAttr (QName "cy" Nothing Nothing) ext + (x, _) <- listToMaybe $ reads xS + (y, _) <- listToMaybe $ reads yS + (cx, _) <- listToMaybe $ reads cxS + (cy, _) <- listToMaybe $ reads cyS + return $ ((x `div` 12700, y `div` 12700), (cx `div` 12700, cy `div` 12700)) + | otherwise = Nothing + + +getMasterShapeDimensionsById :: String + -> Element + -> Maybe ((Integer, Integer), (Integer, Integer)) +getMasterShapeDimensionsById ident master = do + let ns = elemToNameSpaces master + cSld <- findChild (elemName ns "p" "cSld") master + spTree <- findChild (elemName ns "p" "spTree") cSld + sp <- filterChild (\e -> (isElem ns "p" "sp" e) && (shapeHasId ns ident e)) spTree + getShapeDimensions ns sp + +getContentShapeSize :: PandocMonad m + => NameSpaces + -> Element + -> Element + -> P m ((Integer, Integer), (Integer, Integer)) +getContentShapeSize ns layout master + | isElem ns "p" "sldLayout" layout + , Just cSld <- findChild (elemName ns "p" "cSld") layout + , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do + sp <- getContentShape ns spTree + case getShapeDimensions ns sp of + Just sz -> return sz + Nothing -> do let mbSz = + findChild (elemName ns "p" "nvSpPr") sp >>= + findChild (elemName ns "p" "cNvPr") >>= + findAttr (QName "id" Nothing Nothing) >>= + flip getMasterShapeDimensionsById master + case mbSz of + Just sz' -> return sz' + Nothing -> throwError $ + PandocSomeError $ + "Couldn't find necessary content shape size" +getContentShapeSize _ _ _ = throwError $ + PandocSomeError $ + "Attempted to find content shape size in non-layout" + +replaceNamedChildren :: NameSpaces + -> String + -> String + -> [Element] + -> Element + -> Element +replaceNamedChildren ns prefix name newKids element = + element { elContent = concat $ fun True $ elContent element } + where + fun :: Bool -> [Content] -> [[Content]] + fun _ [] = [] + fun switch ((Elem e) : conts) | isElem ns prefix name e = + if switch + then (map Elem $ newKids) : fun False conts + else fun False conts + fun switch (cont : conts) = [cont] : fun switch conts + +---------------------------------------------------------------- + +registerLink :: PandocMonad m => LinkTarget -> P m Int +registerLink link = do + curSlideId <- asks envCurSlideId + linkReg <- gets stLinkIds + mediaReg <- gets stMediaIds + let maxLinkId = case M.lookup curSlideId linkReg of + Just mp -> case M.keys mp of + [] -> 1 + ks -> maximum ks + Nothing -> 1 + maxMediaId = case M.lookup curSlideId mediaReg of + Just [] -> 1 + Just mInfos -> maximum $ map mInfoLocalId mInfos + Nothing -> 1 + maxId = max maxLinkId maxMediaId + slideLinks = case M.lookup curSlideId linkReg of + Just mp -> M.insert (maxId + 1) link mp + Nothing -> M.singleton (maxId + 1) link + modify $ \st -> st{ stLinkIds = M.insert curSlideId slideLinks linkReg} + return $ maxId + 1 + +registerMedia :: PandocMonad m => FilePath -> [ParaElem] -> P m MediaInfo +registerMedia fp caption = do + curSlideId <- asks envCurSlideId + linkReg <- gets stLinkIds + mediaReg <- gets stMediaIds + globalIds <- gets stMediaGlobalIds + let maxLinkId = case M.lookup curSlideId linkReg of + Just mp -> case M.keys mp of + [] -> 1 + ks -> maximum ks + Nothing -> 1 + maxMediaId = case M.lookup curSlideId mediaReg of + Just [] -> 1 + Just mInfos -> maximum $ map mInfoLocalId mInfos + Nothing -> 1 + maxLocalId = max maxLinkId maxMediaId + + maxGlobalId = case M.elems globalIds of + [] -> 0 + ids -> maximum ids + + (imgBytes, mbMt) <- P.fetchItem fp + let imgExt = (mbMt >>= extensionFromMimeType >>= (\x -> return $ '.':x)) + <|> + case imageType imgBytes of + Just Png -> Just ".png" + Just Jpeg -> Just ".jpeg" + Just Gif -> Just ".gif" + Just Pdf -> Just ".pdf" + Just Eps -> Just ".eps" + Just Svg -> Just ".svg" + Nothing -> Nothing + + let newGlobalId = case M.lookup fp globalIds of + Just ident -> ident + Nothing -> maxGlobalId + 1 + + let newGlobalIds = M.insert fp newGlobalId globalIds + + let mediaInfo = MediaInfo { mInfoFilePath = fp + , mInfoLocalId = maxLocalId + 1 + , mInfoGlobalId = newGlobalId + , mInfoMimeType = mbMt + , mInfoExt = imgExt + , mInfoCaption = (not . null) caption + } + + let slideMediaInfos = case M.lookup curSlideId mediaReg of + Just minfos -> mediaInfo : minfos + Nothing -> [mediaInfo] + + + modify $ \st -> st{ stMediaIds = M.insert curSlideId slideMediaInfos mediaReg + , stMediaGlobalIds = newGlobalIds + } + return mediaInfo + +makeMediaEntry :: PandocMonad m => MediaInfo -> P m Entry +makeMediaEntry mInfo = do + epochtime <- (floor . utcTimeToPOSIXSeconds) <$> asks envUTCTime + (imgBytes, _) <- P.fetchItem (mInfoFilePath mInfo) + let ext = case mInfoExt mInfo of + Just e -> e + Nothing -> "" + let fp = "ppt/media/image" ++ (show $ mInfoGlobalId mInfo) ++ ext + return $ toEntry fp epochtime $ BL.fromStrict imgBytes + +makeMediaEntries :: PandocMonad m => P m [Entry] +makeMediaEntries = do + mediaInfos <- gets stMediaIds + let allInfos = mconcat $ M.elems mediaInfos + mapM makeMediaEntry allInfos + +-- -- | Scales the image to fit the page +-- -- sizes are passed in emu +-- fitToPage' :: (Double, Double) -- image size in emu +-- -> Integer -- pageWidth +-- -> Integer -- pageHeight +-- -> (Integer, Integer) -- imagesize +-- fitToPage' (x, y) pageWidth pageHeight +-- -- Fixes width to the page width and scales the height +-- | x <= fromIntegral pageWidth && y <= fromIntegral pageHeight = +-- (floor x, floor y) +-- | x / fromIntegral pageWidth > y / fromIntegral pageWidth = +-- (pageWidth, floor $ ((fromIntegral pageWidth) / x) * y) +-- | otherwise = +-- (floor $ ((fromIntegral pageHeight) / y) * x, pageHeight) + +-- positionImage :: (Double, Double) -> Integer -> Integer -> (Integer, Integer) +-- positionImage (x, y) pageWidth pageHeight = +-- let (x', y') = fitToPage' (x, y) pageWidth pageHeight +-- in +-- ((pageWidth - x') `div` 2, (pageHeight - y') `div` 2) + +getMaster :: PandocMonad m => P m Element +getMaster = do + refArchive <- asks envRefArchive + distArchive <- asks envDistArchive + parseXml refArchive distArchive "ppt/slideMasters/slideMaster1.xml" + +-- We want to get the header dimensions, so we can make sure that the +-- image goes underneath it. We only use this in a content slide if it +-- has a header. + +-- getHeaderSize :: PandocMonad m => P m ((Integer, Integer), (Integer, Integer)) +-- getHeaderSize = do +-- master <- getMaster +-- let ns = elemToNameSpaces master +-- sps = [master] >>= +-- findChildren (elemName ns "p" "cSld") >>= +-- findChildren (elemName ns "p" "spTree") >>= +-- findChildren (elemName ns "p" "sp") +-- mbXfrm = +-- listToMaybe (filter (shapeHasName ns "Title Placeholder 1") sps) >>= +-- findChild (elemName ns "p" "spPr") >>= +-- findChild (elemName ns "a" "xfrm") +-- xoff = mbXfrm >>= +-- findChild (elemName ns "a" "off") >>= +-- findAttr (QName "x" Nothing Nothing) >>= +-- (listToMaybe . (\s -> reads s :: [(Integer, String)])) +-- yoff = mbXfrm >>= +-- findChild (elemName ns "a" "off") >>= +-- findAttr (QName "y" Nothing Nothing) >>= +-- (listToMaybe . (\s -> reads s :: [(Integer, String)])) +-- xext = mbXfrm >>= +-- findChild (elemName ns "a" "ext") >>= +-- findAttr (QName "cx" Nothing Nothing) >>= +-- (listToMaybe . (\s -> reads s :: [(Integer, String)])) +-- yext = mbXfrm >>= +-- findChild (elemName ns "a" "ext") >>= +-- findAttr (QName "cy" Nothing Nothing) >>= +-- (listToMaybe . (\s -> reads s :: [(Integer, String)])) +-- off = case xoff of +-- Just (xoff', _) | Just (yoff',_) <- yoff -> (xoff', yoff') +-- _ -> (1043490, 1027664) +-- ext = case xext of +-- Just (xext', _) | Just (yext',_) <- yext -> (xext', yext') +-- _ -> (7024744, 1143000) +-- return $ (off, ext) + +-- Hard-coded for now +-- captionPosition :: ((Integer, Integer), (Integer, Integer)) +-- captionPosition = ((457200, 6061972), (8229600, 527087)) + +captionHeight :: Integer +captionHeight = 40 + +createCaption :: PandocMonad m + => ((Integer, Integer), (Integer, Integer)) + -> [ParaElem] + -> P m Element +createCaption contentShapeDimensions paraElements = do + let para = Paragraph def{pPropAlign = Just AlgnCenter} paraElements + elements <- mapM paragraphToElement [para] + let ((x, y), (cx, cy)) = contentShapeDimensions + let txBody = mknode "p:txBody" [] $ + [mknode "a:bodyPr" [] (), mknode "a:lstStyle" [] ()] ++ elements + return $ + mknode "p:sp" [] [ mknode "p:nvSpPr" [] + [ mknode "p:cNvPr" [("id","1"), ("name","TextBox 3")] () + , mknode "p:cNvSpPr" [("txBox", "1")] () + , mknode "p:nvPr" [] () + ] + , mknode "p:spPr" [] + [ mknode "a:xfrm" [] + [ mknode "a:off" [("x", show $ 12700 * x), + ("y", show $ 12700 * (y + cy - captionHeight))] () + , mknode "a:ext" [("cx", show $ 12700 * cx), + ("cy", show $ 12700 * captionHeight)] () + ] + , mknode "a:prstGeom" [("prst", "rect")] + [ mknode "a:avLst" [] () + ] + , mknode "a:noFill" [] () + ] + , txBody + ] + +makePicElements :: PandocMonad m + => Element + -> PicProps + -> MediaInfo + -> [ParaElem] + -> P m [Element] +makePicElements layout picProps mInfo alt = do + opts <- asks envOpts + (pageWidth, pageHeight) <- asks envPresentationSize + -- hasHeader <- asks envSlideHasHeader + let hasCaption = mInfoCaption mInfo + (imgBytes, _) <- P.fetchItem (mInfoFilePath mInfo) + let (pxX, pxY) = case imageSize opts imgBytes of + Right sz -> sizeInPixels $ sz + Left _ -> sizeInPixels $ def + master <- getMaster + let ns = elemToNameSpaces layout + ((x, y), (cx, cytmp)) <- getContentShapeSize ns layout master + `catchError` + (\_ -> return ((0, 0), (pageWidth, pageHeight))) + + let cy = if hasCaption then cytmp - captionHeight else cytmp + + let imgRatio = fromIntegral pxX / fromIntegral pxY :: Double + boxRatio = fromIntegral cx / fromIntegral cy :: Double + (dimX, dimY) = if imgRatio > boxRatio + then (fromIntegral cx, fromIntegral cx / imgRatio) + else (fromIntegral cy * imgRatio, fromIntegral cy) + + (dimX', dimY') = (round dimX * 12700, round dimY * 12700) :: (Integer, Integer) + (xoff, yoff) = (fromIntegral x + (fromIntegral cx - dimX) / 2, + fromIntegral y + (fromIntegral cy - dimY) / 2) + (xoff', yoff') = (round xoff * 12700, round yoff * 12700) :: (Integer, Integer) + + let cNvPicPr = mknode "p:cNvPicPr" [] $ + mknode "a:picLocks" [("noGrp","1") + ,("noChangeAspect","1")] () + -- cNvPr will contain the link information so we do that separately, + -- and register the link if necessary. + let cNvPrAttr = [("descr", mInfoFilePath mInfo), ("id","0"),("name","Picture 1")] + cNvPr <- case picPropLink picProps of + Just link -> do idNum <- registerLink link + return $ mknode "p:cNvPr" cNvPrAttr $ + mknode "a:hlinkClick" [("r:id", "rId" ++ show idNum)] () + Nothing -> return $ mknode "p:cNvPr" cNvPrAttr () + let nvPicPr = mknode "p:nvPicPr" [] + [ cNvPr + , cNvPicPr + , mknode "p:nvPr" [] ()] + let blipFill = mknode "p:blipFill" [] + [ mknode "a:blip" [("r:embed", "rId" ++ (show $ mInfoLocalId mInfo))] () + , mknode "a:stretch" [] $ + mknode "a:fillRect" [] () ] + let xfrm = mknode "a:xfrm" [] + [ mknode "a:off" [("x",show xoff'), ("y",show yoff')] () + , mknode "a:ext" [("cx",show dimX') + ,("cy",show dimY')] () ] + let prstGeom = mknode "a:prstGeom" [("prst","rect")] $ + mknode "a:avLst" [] () + let ln = mknode "a:ln" [("w","9525")] + [ mknode "a:noFill" [] () + , mknode "a:headEnd" [] () + , mknode "a:tailEnd" [] () ] + let spPr = mknode "p:spPr" [("bwMode","auto")] + [xfrm, prstGeom, mknode "a:noFill" [] (), ln] + + let picShape = mknode "p:pic" [] + [ nvPicPr + , blipFill + , spPr ] + + -- And now, maybe create the caption: + if hasCaption + then do cap <- createCaption ((x, y), (cx, cytmp)) alt + return [picShape, cap] + else return [picShape] + + +paraElemToElement :: PandocMonad m => ParaElem -> P m Element +paraElemToElement Break = return $ mknode "a:br" [] () +paraElemToElement (Run rpr s) = do + let sizeAttrs = case rPropForceSize rpr of + Just n -> [("sz", (show $ n * 100))] + Nothing -> if rPropCode rpr + -- hardcoded size for code for now + then [("sz", "1800")] + else [] + attrs = sizeAttrs ++ + (if rPropBold rpr then [("b", "1")] else []) ++ + (if rPropItalics rpr then [("i", "1")] else []) ++ + (if rPropUnderline rpr then [("u", "sng")] else []) ++ + (case rStrikethrough rpr of + Just NoStrike -> [("strike", "noStrike")] + Just SingleStrike -> [("strike", "sngStrike")] + Just DoubleStrike -> [("strike", "dblStrike")] + Nothing -> []) ++ + (case rBaseline rpr of + Just n -> [("baseline", show n)] + Nothing -> []) ++ + (case rCap rpr of + Just NoCapitals -> [("cap", "none")] + Just SmallCapitals -> [("cap", "small")] + Just AllCapitals -> [("cap", "all")] + Nothing -> []) ++ + [] + linkProps <- case rLink rpr of + Just link -> do + idNum <- registerLink link + -- first we have to make sure that if it's an + -- anchor, it's in the anchor map. If not, there's + -- no link. + return $ case link of + InternalTarget _ -> + let linkAttrs = + [ ("r:id", "rId" ++ show idNum) + , ("action", "ppaction://hlinksldjump") + ] + in [mknode "a:hlinkClick" linkAttrs ()] + -- external + ExternalTarget _ -> + let linkAttrs = + [ ("r:id", "rId" ++ show idNum) + ] + in [mknode "a:hlinkClick" linkAttrs ()] + Nothing -> return [] + let colorContents = case rSolidFill rpr of + Just color -> + case fromColor color of + '#':hx -> [mknode "a:solidFill" [] + [mknode "a:srgbClr" [("val", map toUpper hx)] ()] + ] + _ -> [] + Nothing -> [] + let codeContents = if rPropCode rpr + then [mknode "a:latin" [("typeface", "Courier")] ()] + else [] + let propContents = linkProps ++ colorContents ++ codeContents + return $ mknode "a:r" [] [ mknode "a:rPr" attrs $ propContents + , mknode "a:t" [] s + ] +paraElemToElement (MathElem mathType texStr) = do + res <- convertMath writeOMML mathType (unTeXString texStr) + case res of + Right r -> return $ mknode "a14:m" [] $ addMathInfo r + Left (Str s) -> paraElemToElement (Run def s) + Left _ -> throwError $ PandocShouldNeverHappenError "non-string math fallback" + +-- This is a bit of a kludge -- really requires adding an option to +-- TeXMath, but since that's a different package, we'll do this one +-- step at a time. +addMathInfo :: Element -> Element +addMathInfo element = + let mathspace = Attr { attrKey = (QName "m" Nothing (Just "xmlns")) + , attrVal = "http://schemas.openxmlformats.org/officeDocument/2006/math" + } + in add_attr mathspace element + +-- We look through the element to see if it contains an a14:m +-- element. If so, we surround it. This is a bit ugly, but it seems +-- more dependable than looking through shapes for math. Plus this is +-- an xml implementation detail, so it seems to make sense to do it at +-- the xml level. +surroundWithMathAlternate :: Element -> Element +surroundWithMathAlternate element = + case findElement (QName "m" Nothing (Just "a14")) element of + Just _ -> + mknode "mc:AlternateContent" + [("xmlns:mc", "http://schemas.openxmlformats.org/markup-compatibility/2006") + ] [ mknode "mc:Choice" + [ ("xmlns:a14", "http://schemas.microsoft.com/office/drawing/2010/main") + , ("Requires", "a14")] [ element ] + ] + Nothing -> element + +paragraphToElement :: PandocMonad m => Paragraph -> P m Element +paragraphToElement par = do + let + attrs = [("lvl", show $ pPropLevel $ paraProps par)] ++ + (case pPropMarginLeft (paraProps par) of + Just px -> [("marL", show $ 12700 * px), ("indent", "0")] + Nothing -> [] + ) ++ + (case pPropAlign (paraProps par) of + Just AlgnLeft -> [("algn", "l")] + Just AlgnRight -> [("algn", "r")] + Just AlgnCenter -> [("algn", "ctr")] + Nothing -> [] + ) + props = [] ++ + (case pPropSpaceBefore $ paraProps par of + Just px -> [mknode "a:spcBef" [] [ + mknode "a:spcPts" [("val", show $ 100 * px)] () + ] + ] + Nothing -> [] + ) ++ + (case pPropBullet $ paraProps par of + Just Bullet -> [] + Just (AutoNumbering attrs') -> + [mknode "a:buAutoNum" [("type", autoNumberingToType attrs')] ()] + Nothing -> [mknode "a:buNone" [] ()] + ) + paras <- mapM paraElemToElement (paraElems par) + return $ mknode "a:p" [] $ [mknode "a:pPr" attrs props] ++ paras + +shapeToElement :: PandocMonad m => Element -> Shape -> P m Element +shapeToElement layout (TextBox paras) + | ns <- elemToNameSpaces layout + , Just cSld <- findChild (elemName ns "p" "cSld") layout + , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do + sp <- getContentShape ns spTree + elements <- mapM paragraphToElement paras + let txBody = mknode "p:txBody" [] $ + [mknode "a:bodyPr" [] (), mknode "a:lstStyle" [] ()] ++ elements + emptySpPr = mknode "p:spPr" [] () + return $ + surroundWithMathAlternate $ + replaceNamedChildren ns "p" "txBody" [txBody] $ + replaceNamedChildren ns "p" "spPr" [emptySpPr] $ + sp +-- GraphicFrame and Pic should never reach this. +shapeToElement _ _ = return $ mknode "p:sp" [] () + +shapeToElements :: PandocMonad m => Element -> Shape -> P m [Element] +shapeToElements layout (Pic picProps fp alt) = do + mInfo <- registerMedia fp alt + case mInfoExt mInfo of + Just _ -> do + makePicElements layout picProps mInfo alt + Nothing -> shapeToElements layout $ TextBox [Paragraph def alt] +shapeToElements layout (GraphicFrame tbls cptn) = + graphicFrameToElements layout tbls cptn +shapeToElements layout shp = do + element <- shapeToElement layout shp + return [element] + +shapesToElements :: PandocMonad m => Element -> [Shape] -> P m [Element] +shapesToElements layout shps = do + concat <$> mapM (shapeToElements layout) shps + +graphicFrameToElements :: PandocMonad m => Element -> [Graphic] -> [ParaElem] -> P m [Element] +graphicFrameToElements layout tbls caption = do + -- get the sizing + master <- getMaster + (pageWidth, pageHeight) <- asks envPresentationSize + let ns = elemToNameSpaces layout + ((x, y), (cx, cytmp)) <- getContentShapeSize ns layout master + `catchError` + (\_ -> return ((0, 0), (pageWidth, pageHeight))) + + let cy = if (not $ null caption) then cytmp - captionHeight else cytmp + + elements <- mapM (graphicToElement cx) tbls + let graphicFrameElts = + mknode "p:graphicFrame" [] $ + [ mknode "p:nvGraphicFramePr" [] $ + [ mknode "p:cNvPr" [("id", "6"), ("name", "Content Placeholder 5")] () + , mknode "p:cNvGraphicFramePr" [] $ + [mknode "a:graphicFrameLocks" [("noGrp", "1")] ()] + , mknode "p:nvPr" [] $ + [mknode "p:ph" [("idx", "1")] ()] + ] + , mknode "p:xfrm" [] $ + [ mknode "a:off" [("x", show $ 12700 * x), ("y", show $ 12700 * y)] () + , mknode "a:ext" [("cx", show $ 12700 * cx), ("cy", show $ 12700 * cy)] () + ] + ] ++ elements + + if (not $ null caption) + then do capElt <- createCaption ((x, y), (cx, cytmp)) caption + return [graphicFrameElts, capElt] + else return [graphicFrameElts] + +graphicToElement :: PandocMonad m => Integer -> Graphic -> P m Element +graphicToElement tableWidth (Tbl tblPr hdrCells rows) = do + let colWidths = if null hdrCells + then case rows of + r : _ | not (null r) -> replicate (length r) $ + (tableWidth `div` (toInteger $ length r)) + -- satisfy the compiler. This is the same as + -- saying that rows is empty, but the compiler + -- won't understand that `[]` exhausts the + -- alternatives. + _ -> [] + else replicate (length hdrCells) $ + (tableWidth `div` (toInteger $ length hdrCells)) + + let cellToOpenXML paras = + do elements <- mapM paragraphToElement paras + let elements' = if null elements + then [mknode "a:p" [] [mknode "a:endParaRPr" [] ()]] + else elements + return $ + [mknode "a:txBody" [] $ + ([ mknode "a:bodyPr" [] () + , mknode "a:lstStyle" [] ()] + ++ elements')] + headers' <- mapM cellToOpenXML hdrCells + rows' <- mapM (mapM cellToOpenXML) rows + let borderProps = mknode "a:tcPr" [] () + let emptyCell = [mknode "a:p" [] [mknode "a:pPr" [] ()]] + let mkcell border contents = mknode "a:tc" [] + $ (if null contents + then emptyCell + else contents) ++ [ borderProps | border ] + let mkrow border cells = mknode "a:tr" [("h", "0")] $ map (mkcell border) cells + + let mkgridcol w = mknode "a:gridCol" + [("w", show ((12700 * w) :: Integer))] () + let hasHeader = not (all null hdrCells) + return $ mknode "a:graphic" [] $ + [mknode "a:graphicData" [("uri", "http://schemas.openxmlformats.org/drawingml/2006/table")] $ + [mknode "a:tbl" [] $ + [ mknode "a:tblPr" [ ("firstRow", if tblPrFirstRow tblPr then "1" else "0") + , ("bandRow", if tblPrBandRow tblPr then "1" else "0") + ] () + , mknode "a:tblGrid" [] (if all (==0) colWidths + then [] + else map mkgridcol colWidths) + ] + ++ [ mkrow True headers' | hasHeader ] ++ map (mkrow False) rows' + ] + ] + +getShapeByName :: NameSpaces -> Element -> String -> Maybe Element +getShapeByName ns spTreeElem name + | isElem ns "p" "spTree" spTreeElem = + filterChild (\e -> (isElem ns "p" "sp" e) && (shapeHasName ns name e)) spTreeElem + | otherwise = Nothing + +-- getShapeById :: NameSpaces -> Element -> String -> Maybe Element +-- getShapeById ns spTreeElem ident +-- | isElem ns "p" "spTree" spTreeElem = +-- filterChild (\e -> (isElem ns "p" "sp" e) && (shapeHasId ns ident e)) spTreeElem +-- | otherwise = Nothing + +nonBodyTextToElement :: PandocMonad m => Element -> String -> [ParaElem] -> P m Element +nonBodyTextToElement layout shapeName paraElements + | ns <- elemToNameSpaces layout + , Just cSld <- findChild (elemName ns "p" "cSld") layout + , Just spTree <- findChild (elemName ns "p" "spTree") cSld + , Just sp <- getShapeByName ns spTree shapeName = do + let hdrPara = Paragraph def paraElements + element <- paragraphToElement hdrPara + let txBody = mknode "p:txBody" [] $ + [mknode "a:bodyPr" [] (), mknode "a:lstStyle" [] ()] ++ + [element] + return $ replaceNamedChildren ns "p" "txBody" [txBody] sp + -- XXX: TODO + | otherwise = return $ mknode "p:sp" [] () + +contentToElement :: PandocMonad m => Element -> [ParaElem] -> [Shape] -> P m Element +contentToElement layout hdrShape shapes + | ns <- elemToNameSpaces layout + , Just cSld <- findChild (elemName ns "p" "cSld") layout + , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do + element <- nonBodyTextToElement layout "Title 1" hdrShape + let hdrShapeElements = if null hdrShape + then [] + else [element] + contentElements <- local + (\env -> env {envContentType = NormalContent}) + (shapesToElements layout shapes) + return $ + replaceNamedChildren ns "p" "sp" + (hdrShapeElements ++ contentElements) + spTree +contentToElement _ _ _ = return $ mknode "p:sp" [] () + +twoColumnToElement :: PandocMonad m => Element -> [ParaElem] -> [Shape] -> [Shape] -> P m Element +twoColumnToElement layout hdrShape shapesL shapesR + | ns <- elemToNameSpaces layout + , Just cSld <- findChild (elemName ns "p" "cSld") layout + , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do + element <- nonBodyTextToElement layout "Title 1" hdrShape + let hdrShapeElements = if null hdrShape + then [] + else [element] + contentElementsL <- local + (\env -> env {envContentType =TwoColumnLeftContent}) + (shapesToElements layout shapesL) + contentElementsR <- local + (\env -> env {envContentType =TwoColumnRightContent}) + (shapesToElements layout shapesR) + -- let contentElementsL' = map (setIdx ns "1") contentElementsL + -- contentElementsR' = map (setIdx ns "2") contentElementsR + return $ + replaceNamedChildren ns "p" "sp" + (hdrShapeElements ++ contentElementsL ++ contentElementsR) + spTree +twoColumnToElement _ _ _ _= return $ mknode "p:sp" [] () + + +titleToElement :: PandocMonad m => Element -> [ParaElem] -> P m Element +titleToElement layout titleElems + | ns <- elemToNameSpaces layout + , Just cSld <- findChild (elemName ns "p" "cSld") layout + , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do + element <- nonBodyTextToElement layout "Title 1" titleElems + let titleShapeElements = if null titleElems + then [] + else [element] + return $ replaceNamedChildren ns "p" "sp" titleShapeElements spTree +titleToElement _ _ = return $ mknode "p:sp" [] () + +metadataToElement :: PandocMonad m => Element -> [ParaElem] -> [ParaElem] -> [[ParaElem]] -> [ParaElem] -> P m Element +metadataToElement layout titleElems subtitleElems authorsElems dateElems + | ns <- elemToNameSpaces layout + , Just cSld <- findChild (elemName ns "p" "cSld") layout + , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do + titleShapeElements <- if null titleElems + then return [] + else sequence [nonBodyTextToElement layout "Title 1" titleElems] + let combinedAuthorElems = intercalate [Break] authorsElems + subtitleAndAuthorElems = intercalate [Break, Break] [subtitleElems, combinedAuthorElems] + subtitleShapeElements <- if null subtitleAndAuthorElems + then return [] + else sequence [nonBodyTextToElement layout "Subtitle 2" subtitleAndAuthorElems] + dateShapeElements <- if null dateElems + then return [] + else sequence [nonBodyTextToElement layout "Date Placeholder 3" dateElems] + return $ replaceNamedChildren ns "p" "sp" + (titleShapeElements ++ subtitleShapeElements ++ dateShapeElements) + spTree +metadataToElement _ _ _ _ _ = return $ mknode "p:sp" [] () + +slideToElement :: PandocMonad m => Slide -> P m Element +slideToElement (Slide _ l@(ContentSlide hdrElems shapes) _ )= do + layout <- getLayout l + spTree <- local (\env -> if null hdrElems + then env + else env{envSlideHasHeader=True}) $ + contentToElement layout hdrElems shapes + return $ mknode "p:sld" + [ ("xmlns:a", "http://schemas.openxmlformats.org/drawingml/2006/main"), + ("xmlns:r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships"), + ("xmlns:p", "http://schemas.openxmlformats.org/presentationml/2006/main") + ] [mknode "p:cSld" [] [spTree]] +slideToElement (Slide _ l@(TwoColumnSlide hdrElems shapesL shapesR) _) = do + layout <- getLayout l + spTree <- local (\env -> if null hdrElems + then env + else env{envSlideHasHeader=True}) $ + twoColumnToElement layout hdrElems shapesL shapesR + return $ mknode "p:sld" + [ ("xmlns:a", "http://schemas.openxmlformats.org/drawingml/2006/main"), + ("xmlns:r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships"), + ("xmlns:p", "http://schemas.openxmlformats.org/presentationml/2006/main") + ] [mknode "p:cSld" [] [spTree]] +slideToElement (Slide _ l@(TitleSlide hdrElems) _) = do + layout <- getLayout l + spTree <- titleToElement layout hdrElems + return $ mknode "p:sld" + [ ("xmlns:a", "http://schemas.openxmlformats.org/drawingml/2006/main"), + ("xmlns:r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships"), + ("xmlns:p", "http://schemas.openxmlformats.org/presentationml/2006/main") + ] [mknode "p:cSld" [] [spTree]] +slideToElement (Slide _ l@(MetadataSlide titleElems subtitleElems authorElems dateElems) _) = do + layout <- getLayout l + spTree <- metadataToElement layout titleElems subtitleElems authorElems dateElems + return $ mknode "p:sld" + [ ("xmlns:a", "http://schemas.openxmlformats.org/drawingml/2006/main"), + ("xmlns:r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships"), + ("xmlns:p", "http://schemas.openxmlformats.org/presentationml/2006/main") + ] [mknode "p:cSld" [] [spTree]] + +----------------------------------------------------------------------- + +getSlideIdNum :: PandocMonad m => SlideId -> P m Int +getSlideIdNum sldId = do + slideIdMap <- asks envSlideIdMap + case M.lookup sldId slideIdMap of + Just n -> return n + Nothing -> throwError $ + PandocShouldNeverHappenError $ + "Slide Id " ++ (show sldId) ++ " not found." + +slideNum :: PandocMonad m => Slide -> P m Int +slideNum slide = getSlideIdNum $ slideId slide + +idNumToFilePath :: Int -> FilePath +idNumToFilePath idNum = "slide" ++ (show $ idNum) ++ ".xml" + +slideToFilePath :: PandocMonad m => Slide -> P m FilePath +slideToFilePath slide = do + idNum <- slideNum slide + return $ "slide" ++ (show $ idNum) ++ ".xml" + +slideToRelId :: PandocMonad m => Slide -> P m String +slideToRelId slide = do + n <- slideNum slide + offset <- asks envSlideIdOffset + return $ "rId" ++ (show $ n + offset) + + +data Relationship = Relationship { relId :: Int + , relType :: MimeType + , relTarget :: FilePath + } deriving (Show, Eq) + +elementToRel :: Element -> Maybe Relationship +elementToRel element + | elName element == QName "Relationship" (Just "http://schemas.openxmlformats.org/package/2006/relationships") Nothing = + do rId <- findAttr (QName "Id" Nothing Nothing) element + numStr <- stripPrefix "rId" rId + num <- case reads numStr :: [(Int, String)] of + (n, _) : _ -> Just n + [] -> Nothing + type' <- findAttr (QName "Type" Nothing Nothing) element + target <- findAttr (QName "Target" Nothing Nothing) element + return $ Relationship num type' target + | otherwise = Nothing + +slideToPresRel :: PandocMonad m => Slide -> P m Relationship +slideToPresRel slide = do + idNum <- slideNum slide + n <- asks envSlideIdOffset + let rId = idNum + n + fp = "slides/" ++ idNumToFilePath idNum + return $ Relationship { relId = rId + , relType = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide" + , relTarget = fp + } + +getRels :: PandocMonad m => P m [Relationship] +getRels = do + refArchive <- asks envRefArchive + distArchive <- asks envDistArchive + relsElem <- parseXml refArchive distArchive "ppt/_rels/presentation.xml.rels" + let globalNS = "http://schemas.openxmlformats.org/package/2006/relationships" + let relElems = findChildren (QName "Relationship" (Just globalNS) Nothing) relsElem + return $ mapMaybe elementToRel relElems + +presentationToRels :: PandocMonad m => Presentation -> P m [Relationship] +presentationToRels (Presentation _ slides) = do + mySlideRels <- mapM slideToPresRel slides + rels <- getRels + let relsWithoutSlides = filter (\r -> relType r /= "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide") rels + -- We want to make room for the slides in the id space. The slides + -- will start at Id2 (since Id1 is for the slide master). There are + -- two slides in the data file, but that might change in the future, + -- so we will do this: + -- + -- 1. We look to see what the minimum relWithoutSlide id (greater than 1) is. + -- 2. We add the difference between this and the number of slides to + -- all relWithoutSlide rels (unless they're 1) + + let minRelNotOne = case filter (1<) $ map relId relsWithoutSlides of + [] -> 0 -- doesn't matter in this case, since + -- there will be nothing to map the + -- function over + l -> minimum l + + modifyRelNum :: Int -> Int + modifyRelNum 1 = 1 + modifyRelNum n = n - minRelNotOne + 2 + length slides + + relsWithoutSlides' = map (\r -> r{relId = modifyRelNum $ relId r}) relsWithoutSlides + + return $ mySlideRels ++ relsWithoutSlides' + +-- We make this ourselves, in case there's a thumbnail in the one from +-- the template. +topLevelRels :: [Relationship] +topLevelRels = + [ Relationship { relId = 1 + , relType = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/officeDocument" + , relTarget = "ppt/presentation.xml" + } + , Relationship { relId = 2 + , relType = "http://schemas.openxmlformats.org/package/2006/relationships/metadata/core-properties" + , relTarget = "docProps/core.xml" + } + , Relationship { relId = 3 + , relType = "http://schemas.openxmlformats.org/package/2006/relationships/metadata/extended-properties" + , relTarget = "docProps/app.xml" + } + ] + +topLevelRelsEntry :: PandocMonad m => P m Entry +topLevelRelsEntry = elemToEntry "_rels/.rels" $ relsToElement topLevelRels + +relToElement :: Relationship -> Element +relToElement rel = mknode "Relationship" [ ("Id", "rId" ++ (show $ relId rel)) + , ("Type", relType rel) + , ("Target", relTarget rel) ] () + +relsToElement :: [Relationship] -> Element +relsToElement rels = mknode "Relationships" + [("xmlns", "http://schemas.openxmlformats.org/package/2006/relationships")] + (map relToElement rels) + +presentationToRelsEntry :: PandocMonad m => Presentation -> P m Entry +presentationToRelsEntry pres = do + rels <- presentationToRels pres + elemToEntry "ppt/_rels/presentation.xml.rels" $ relsToElement rels + +elemToEntry :: PandocMonad m => FilePath -> Element -> P m Entry +elemToEntry fp element = do + epochtime <- (floor . utcTimeToPOSIXSeconds) <$> asks envUTCTime + return $ toEntry fp epochtime $ renderXml element + +slideToEntry :: PandocMonad m => Slide -> P m Entry +slideToEntry slide = do + idNum <- slideNum slide + local (\env -> env{envCurSlideId = idNum}) $ do + element <- slideToElement slide + elemToEntry ("ppt/slides/" ++ idNumToFilePath idNum) element + +slideToSlideRelEntry :: PandocMonad m => Slide -> P m Entry +slideToSlideRelEntry slide = do + idNum <- slideNum slide + element <- slideToSlideRelElement slide + elemToEntry ("ppt/slides/_rels/" ++ idNumToFilePath idNum ++ ".rels") element + +linkRelElement :: PandocMonad m => Int -> LinkTarget -> P m Element +linkRelElement rIdNum (InternalTarget targetId) = do + targetIdNum <- getSlideIdNum targetId + return $ + mknode "Relationship" [ ("Id", "rId" ++ show rIdNum) + , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide") + , ("Target", "slide" ++ show targetIdNum ++ ".xml") + ] () +linkRelElement rIdNum (ExternalTarget (url, _)) = do + return $ + mknode "Relationship" [ ("Id", "rId" ++ show rIdNum) + , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/hyperlink") + , ("Target", url) + , ("TargetMode", "External") + ] () + +linkRelElements :: PandocMonad m => M.Map Int LinkTarget -> P m [Element] +linkRelElements mp = mapM (\(n, lnk) -> linkRelElement n lnk) (M.toList mp) + +mediaRelElement :: MediaInfo -> Element +mediaRelElement mInfo = + let ext = case mInfoExt mInfo of + Just e -> e + Nothing -> "" + in + mknode "Relationship" [ ("Id", "rId" ++ (show $ mInfoLocalId mInfo)) + , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/image") + , ("Target", "../media/image" ++ (show $ mInfoGlobalId mInfo) ++ ext) + ] () + +slideToSlideRelElement :: PandocMonad m => Slide -> P m Element +slideToSlideRelElement slide = do + idNum <- slideNum slide + let target = case slide of + (Slide _ (MetadataSlide _ _ _ _) _) -> "../slideLayouts/slideLayout1.xml" + (Slide _ (TitleSlide _) _) -> "../slideLayouts/slideLayout3.xml" + (Slide _ (ContentSlide _ _) _) -> "../slideLayouts/slideLayout2.xml" + (Slide _ (TwoColumnSlide _ _ _) _) -> "../slideLayouts/slideLayout4.xml" + + linkIds <- gets stLinkIds + mediaIds <- gets stMediaIds + + linkRels <- case M.lookup idNum linkIds of + Just mp -> linkRelElements mp + Nothing -> return [] + let mediaRels = case M.lookup idNum mediaIds of + Just mInfos -> map mediaRelElement mInfos + Nothing -> [] + + return $ + mknode "Relationships" + [("xmlns", "http://schemas.openxmlformats.org/package/2006/relationships")] + ([mknode "Relationship" [ ("Id", "rId1") + , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slideLayout") + , ("Target", target)] () + ] ++ linkRels ++ mediaRels) + +slideToSldIdElement :: PandocMonad m => Slide -> P m Element +slideToSldIdElement slide = do + n <- slideNum slide + let id' = show $ n + 255 + rId <- slideToRelId slide + return $ mknode "p:sldId" [("id", id'), ("r:id", rId)] () + +presentationToSldIdLst :: PandocMonad m => Presentation -> P m Element +presentationToSldIdLst (Presentation _ slides) = do + ids <- mapM slideToSldIdElement slides + return $ mknode "p:sldIdLst" [] ids + +presentationToPresentationElement :: PandocMonad m => Presentation -> P m Element +presentationToPresentationElement pres = do + refArchive <- asks envRefArchive + distArchive <- asks envDistArchive + element <- parseXml refArchive distArchive "ppt/presentation.xml" + sldIdLst <- presentationToSldIdLst pres + + let modifySldIdLst :: Content -> Content + modifySldIdLst (Elem e) = case elName e of + (QName "sldIdLst" _ _) -> Elem sldIdLst + _ -> Elem e + modifySldIdLst ct = ct + + newContent = map modifySldIdLst $ elContent element + + return $ element{elContent = newContent} + +presentationToPresEntry :: PandocMonad m => Presentation -> P m Entry +presentationToPresEntry pres = presentationToPresentationElement pres >>= + elemToEntry "ppt/presentation.xml" + +-- adapted from the Docx writer +docPropsElement :: PandocMonad m => DocProps -> P m Element +docPropsElement docProps = do + utctime <- asks envUTCTime + let keywords = case dcKeywords docProps of + Just xs -> intercalate "," xs + Nothing -> "" + return $ + mknode "cp:coreProperties" + [("xmlns:cp","http://schemas.openxmlformats.org/package/2006/metadata/core-properties") + ,("xmlns:dc","http://purl.org/dc/elements/1.1/") + ,("xmlns:dcterms","http://purl.org/dc/terms/") + ,("xmlns:dcmitype","http://purl.org/dc/dcmitype/") + ,("xmlns:xsi","http://www.w3.org/2001/XMLSchema-instance")] + $ (mknode "dc:title" [] $ fromMaybe "" $ dcTitle docProps) + : (mknode "dc:creator" [] $ fromMaybe "" $ dcCreator docProps) + : (mknode "cp:keywords" [] keywords) + : (\x -> [ mknode "dcterms:created" [("xsi:type","dcterms:W3CDTF")] x + , mknode "dcterms:modified" [("xsi:type","dcterms:W3CDTF")] x + ]) (formatTime defaultTimeLocale "%FT%XZ" utctime) + +docPropsToEntry :: PandocMonad m => DocProps -> P m Entry +docPropsToEntry docProps = docPropsElement docProps >>= + elemToEntry "docProps/core.xml" + + +defaultContentTypeToElem :: DefaultContentType -> Element +defaultContentTypeToElem dct = + mknode "Default" + [("Extension", defContentTypesExt dct), + ("ContentType", defContentTypesType dct)] + () + +overrideContentTypeToElem :: OverrideContentType -> Element +overrideContentTypeToElem oct = + mknode "Override" + [("PartName", overrideContentTypesPart oct), + ("ContentType", overrideContentTypesType oct)] + () + +contentTypesToElement :: ContentTypes -> Element +contentTypesToElement ct = + let ns = "http://schemas.openxmlformats.org/package/2006/content-types" + in + mknode "Types" [("xmlns", ns)] $ + (map defaultContentTypeToElem $ contentTypesDefaults ct) ++ + (map overrideContentTypeToElem $ contentTypesOverrides ct) + +data DefaultContentType = DefaultContentType + { defContentTypesExt :: String + , defContentTypesType:: MimeType + } + deriving (Show, Eq) + +data OverrideContentType = OverrideContentType + { overrideContentTypesPart :: FilePath + , overrideContentTypesType :: MimeType + } + deriving (Show, Eq) + +data ContentTypes = ContentTypes { contentTypesDefaults :: [DefaultContentType] + , contentTypesOverrides :: [OverrideContentType] + } + deriving (Show, Eq) + +contentTypesToEntry :: PandocMonad m => ContentTypes -> P m Entry +contentTypesToEntry ct = elemToEntry "[Content_Types].xml" $ contentTypesToElement ct + +pathToOverride :: FilePath -> Maybe OverrideContentType +pathToOverride fp = OverrideContentType ("/" ++ fp) <$> (getContentType fp) + +mediaFileContentType :: FilePath -> Maybe DefaultContentType +mediaFileContentType fp = case takeExtension fp of + '.' : ext -> Just $ + DefaultContentType { defContentTypesExt = ext + , defContentTypesType = + case getMimeType fp of + Just mt -> mt + Nothing -> "application/octet-stream" + } + _ -> Nothing + +mediaContentType :: MediaInfo -> Maybe DefaultContentType +mediaContentType mInfo + | Just ('.' : ext) <- mInfoExt mInfo = + Just $ DefaultContentType { defContentTypesExt = ext + , defContentTypesType = + case mInfoMimeType mInfo of + Just mt -> mt + Nothing -> "application/octet-stream" + } + | otherwise = Nothing + +presentationToContentTypes :: PandocMonad m => Presentation -> P m ContentTypes +presentationToContentTypes (Presentation _ slides) = do + mediaInfos <- (mconcat . M.elems) <$> gets stMediaIds + filePaths <- patternsToFilePaths inheritedPatterns + let mediaFps = filter (match (compile "ppt/media/image*")) filePaths + let defaults = [ DefaultContentType "xml" "application/xml" + , DefaultContentType "rels" "application/vnd.openxmlformats-package.relationships+xml" + ] + mediaDefaults = nub $ + (mapMaybe mediaContentType $ mediaInfos) ++ + (mapMaybe mediaFileContentType $ mediaFps) + + inheritedOverrides = mapMaybe pathToOverride filePaths + docPropsOverride = mapMaybe pathToOverride ["docProps/core.xml"] + presOverride = mapMaybe pathToOverride ["ppt/presentation.xml"] + relativePaths <- mapM slideToFilePath slides + let slideOverrides = mapMaybe + (\fp -> pathToOverride $ "ppt/slides/" ++ fp) + relativePaths + return $ ContentTypes + (defaults ++ mediaDefaults) + (inheritedOverrides ++ docPropsOverride ++ presOverride ++ slideOverrides) + +presML :: String +presML = "application/vnd.openxmlformats-officedocument.presentationml" + +noPresML :: String +noPresML = "application/vnd.openxmlformats-officedocument" + +getContentType :: FilePath -> Maybe MimeType +getContentType fp + | fp == "ppt/presentation.xml" = Just $ presML ++ ".presentation.main+xml" + | fp == "ppt/presProps.xml" = Just $ presML ++ ".presProps+xml" + | fp == "ppt/viewProps.xml" = Just $ presML ++ ".viewProps+xml" + | fp == "ppt/tableStyles.xml" = Just $ presML ++ ".tableStyles+xml" + | fp == "docProps/core.xml" = Just $ "application/vnd.openxmlformats-package.core-properties+xml" + | fp == "docProps/app.xml" = Just $ noPresML ++ ".extended-properties+xml" + | "ppt" : "slideMasters" : f : [] <- splitDirectories fp + , (_, ".xml") <- splitExtension f = + Just $ presML ++ ".slideMaster+xml" + | "ppt" : "slides" : f : [] <- splitDirectories fp + , (_, ".xml") <- splitExtension f = + Just $ presML ++ ".slide+xml" + | "ppt" : "notesMasters" : f : [] <- splitDirectories fp + , (_, ".xml") <- splitExtension f = + Just $ presML ++ ".notesMaster+xml" + | "ppt" : "notesSlides" : f : [] <- splitDirectories fp + , (_, ".xml") <- splitExtension f = + Just $ presML ++ ".notesSlide+xml" + | "ppt" : "theme" : f : [] <- splitDirectories fp + , (_, ".xml") <- splitExtension f = + Just $ noPresML ++ ".theme+xml" + | "ppt" : "slideLayouts" : _ : [] <- splitDirectories fp= + Just $ presML ++ ".slideLayout+xml" + | otherwise = Nothing + +autoNumberingToType :: ListAttributes -> String +autoNumberingToType (_, numStyle, numDelim) = + typeString ++ delimString + where + typeString = case numStyle of + Decimal -> "arabic" + UpperAlpha -> "alphaUc" + LowerAlpha -> "alphaLc" + UpperRoman -> "romanUc" + LowerRoman -> "romanLc" + _ -> "arabic" + delimString = case numDelim of + Period -> "Period" + OneParen -> "ParenR" + TwoParens -> "ParenBoth" + _ -> "Period" diff --git a/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs b/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs new file mode 100644 index 000000000..f5f7d850f --- /dev/null +++ b/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs @@ -0,0 +1,925 @@ +{-# LANGUAGE PatternGuards #-} + +{- +Copyright (C) 2017-2018 Jesse Rosenthal <jrosenthal@jhu.edu> + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- | + Module : Text.Pandoc.Writers.Powerpoint.Presentation + Copyright : Copyright (C) 2017-2018 Jesse Rosenthal + License : GNU GPL, version 2 or above + + Maintainer : Jesse Rosenthal <jrosenthal@jhu.edu> + Stability : alpha + Portability : portable + +Definition of Presentation datatype, modeling a MS Powerpoint (pptx) +document, and functions for converting a Pandoc document to +Presentation. +-} + +module Text.Pandoc.Writers.Powerpoint.Presentation ( documentToPresentation + , Presentation(..) + , DocProps(..) + , Slide(..) + , Layout(..) + , Notes(..) + , SlideId(..) + , Shape(..) + , Graphic(..) + , BulletType(..) + , Algnment(..) + , Paragraph(..) + , ParaElem(..) + , ParaProps(..) + , RunProps(..) + , TableProps(..) + , Strikethrough(..) + , Capitals(..) + , PicProps(..) + , URL + , TeXString(..) + , LinkTarget(..) + ) where + + +import Control.Monad.Reader +import Control.Monad.State +import Data.List (intercalate) +import Data.Default +import Text.Pandoc.Definition +import Text.Pandoc.ImageSize +import Text.Pandoc.Slides (getSlideLevel) +import Text.Pandoc.Options +import Text.Pandoc.Logging +import Text.Pandoc.Walk +import Text.Pandoc.Compat.Time (UTCTime) +import qualified Text.Pandoc.Shared as Shared -- so we don't overlap "Element" +import Text.Pandoc.Writers.Shared (metaValueToInlines) +import qualified Data.Map as M +import qualified Data.Set as S +import Data.Maybe (maybeToList) +import Text.Pandoc.Highlighting +import qualified Data.Text as T +import Control.Applicative ((<|>)) +import Skylighting + +data WriterEnv = WriterEnv { envMetadata :: Meta + , envRunProps :: RunProps + , envParaProps :: ParaProps + , envSlideLevel :: Int + , envOpts :: WriterOptions + , envSlideHasHeader :: Bool + , envInList :: Bool + , envInNoteSlide :: Bool + , envCurSlideId :: SlideId + } + deriving (Show) + +instance Default WriterEnv where + def = WriterEnv { envMetadata = mempty + , envRunProps = def + , envParaProps = def + , envSlideLevel = 2 + , envOpts = def + , envSlideHasHeader = False + , envInList = False + , envInNoteSlide = False + , envCurSlideId = SlideId "Default" + } + + +data WriterState = WriterState { stNoteIds :: M.Map Int [Block] + -- associate anchors with slide id + , stAnchorMap :: M.Map String SlideId + , stSlideIdSet :: S.Set SlideId + , stLog :: [LogMessage] + + } deriving (Show, Eq) + +instance Default WriterState where + def = WriterState { stNoteIds = mempty + , stAnchorMap = mempty + -- we reserve this s + , stSlideIdSet = reservedSlideIds + , stLog = [] + } + +metadataSlideId :: SlideId +metadataSlideId = SlideId "Metadata" + +tocSlideId :: SlideId +tocSlideId = SlideId "TOC" + +endNotesSlideId :: SlideId +endNotesSlideId = SlideId "EndNotes" + +reservedSlideIds :: S.Set SlideId +reservedSlideIds = S.fromList [ metadataSlideId + , tocSlideId + , endNotesSlideId + ] + +uniqueSlideId' :: Integer -> S.Set SlideId -> String -> SlideId +uniqueSlideId' n idSet s = + let s' = if n == 0 then s else (s ++ "-" ++ show n) + in if SlideId s' `S.member` idSet + then uniqueSlideId' (n+1) idSet s + else SlideId s' + +uniqueSlideId :: S.Set SlideId -> String -> SlideId +uniqueSlideId = uniqueSlideId' 0 + +runUniqueSlideId :: String -> Pres SlideId +runUniqueSlideId s = do + idSet <- gets stSlideIdSet + let sldId = uniqueSlideId idSet s + modify $ \st -> st{stSlideIdSet = S.insert sldId idSet} + return sldId + +addLogMessage :: LogMessage -> Pres () +addLogMessage msg = modify $ \st -> st{stLog = msg : (stLog st)} + +type Pres = ReaderT WriterEnv (State WriterState) + +runPres :: WriterEnv -> WriterState -> Pres a -> (a, [LogMessage]) +runPres env st p = (pres, reverse $ stLog finalSt) + where (pres, finalSt) = runState (runReaderT p env) st + +-- GHC 7.8 will still complain about concat <$> mapM unless we specify +-- Functor. We can get rid of this when we stop supporting GHC 7.8. +concatMapM :: (Monad m) => (a -> m [b]) -> [a] -> m [b] +concatMapM f xs = liftM concat (mapM f xs) + +type Pixels = Integer + +data Presentation = Presentation DocProps [Slide] + deriving (Show) + +data DocProps = DocProps { dcTitle :: Maybe String + , dcSubject :: Maybe String + , dcCreator :: Maybe String + , dcKeywords :: Maybe [String] + , dcCreated :: Maybe UTCTime + } deriving (Show, Eq) + + +data Slide = Slide { slideId :: SlideId + , slideLayout :: Layout + , slideNotes :: (Maybe Notes) + } deriving (Show, Eq) + +newtype SlideId = SlideId String + deriving (Show, Eq, Ord) + +-- In theory you could have anything on a notes slide but it seems +-- designed mainly for one textbox, so we'll just put in the contents +-- of that textbox, to avoid other shapes that won't work as well. +newtype Notes = Notes [Paragraph] + deriving (Show, Eq) + +data Layout = MetadataSlide { metadataSlideTitle :: [ParaElem] + , metadataSlideSubtitle :: [ParaElem] + , metadataSlideAuthors :: [[ParaElem]] + , metadataSlideDate :: [ParaElem] + } + | TitleSlide { titleSlideHeader :: [ParaElem]} + | ContentSlide { contentSlideHeader :: [ParaElem] + , contentSlideContent :: [Shape] + } + | TwoColumnSlide { twoColumnSlideHeader :: [ParaElem] + , twoColumnSlideLeft :: [Shape] + , twoColumnSlideRight :: [Shape] + } + deriving (Show, Eq) + +data Shape = Pic PicProps FilePath [ParaElem] + | GraphicFrame [Graphic] [ParaElem] + | TextBox [Paragraph] + deriving (Show, Eq) + +type Cell = [Paragraph] + +data TableProps = TableProps { tblPrFirstRow :: Bool + , tblPrBandRow :: Bool + } deriving (Show, Eq) + +data Graphic = Tbl TableProps [Cell] [[Cell]] + deriving (Show, Eq) + + +data Paragraph = Paragraph { paraProps :: ParaProps + , paraElems :: [ParaElem] + } deriving (Show, Eq) + + +data BulletType = Bullet + | AutoNumbering ListAttributes + deriving (Show, Eq) + +data Algnment = AlgnLeft | AlgnRight | AlgnCenter + deriving (Show, Eq) + +data ParaProps = ParaProps { pPropMarginLeft :: Maybe Pixels + , pPropMarginRight :: Maybe Pixels + , pPropLevel :: Int + , pPropBullet :: Maybe BulletType + , pPropAlign :: Maybe Algnment + , pPropSpaceBefore :: Maybe Pixels + } deriving (Show, Eq) + +instance Default ParaProps where + def = ParaProps { pPropMarginLeft = Just 0 + , pPropMarginRight = Just 0 + , pPropLevel = 0 + , pPropBullet = Nothing + , pPropAlign = Nothing + , pPropSpaceBefore = Nothing + } + +newtype TeXString = TeXString {unTeXString :: String} + deriving (Eq, Show) + +data ParaElem = Break + | Run RunProps String + -- It would be more elegant to have native TeXMath + -- Expressions here, but this allows us to use + -- `convertmath` from T.P.Writers.Math. Will perhaps + -- revisit in the future. + | MathElem MathType TeXString + deriving (Show, Eq) + +data Strikethrough = NoStrike | SingleStrike | DoubleStrike + deriving (Show, Eq) + +data Capitals = NoCapitals | SmallCapitals | AllCapitals + deriving (Show, Eq) + +type URL = String + +data LinkTarget = ExternalTarget (URL, String) + | InternalTarget SlideId + deriving (Show, Eq) + +data RunProps = RunProps { rPropBold :: Bool + , rPropItalics :: Bool + , rStrikethrough :: Maybe Strikethrough + , rBaseline :: Maybe Int + , rCap :: Maybe Capitals + , rLink :: Maybe LinkTarget + , rPropCode :: Bool + , rPropBlockQuote :: Bool + , rPropForceSize :: Maybe Pixels + , rSolidFill :: Maybe Color + -- TODO: Make a full underline data type with + -- the different options. + , rPropUnderline :: Bool + } deriving (Show, Eq) + +instance Default RunProps where + def = RunProps { rPropBold = False + , rPropItalics = False + , rStrikethrough = Nothing + , rBaseline = Nothing + , rCap = Nothing + , rLink = Nothing + , rPropCode = False + , rPropBlockQuote = False + , rPropForceSize = Nothing + , rSolidFill = Nothing + , rPropUnderline = False + } + +data PicProps = PicProps { picPropLink :: Maybe LinkTarget + , picWidth :: Maybe Dimension + , picHeight :: Maybe Dimension + } deriving (Show, Eq) + +instance Default PicProps where + def = PicProps { picPropLink = Nothing + , picWidth = Nothing + , picHeight = Nothing + } + +-------------------------------------------------- + +inlinesToParElems :: [Inline] -> Pres [ParaElem] +inlinesToParElems ils = concatMapM inlineToParElems ils + +inlineToParElems :: Inline -> Pres [ParaElem] +inlineToParElems (Str s) = do + pr <- asks envRunProps + return [Run pr s] +inlineToParElems (Emph ils) = + local (\r -> r{envRunProps = (envRunProps r){rPropItalics=True}}) $ + inlinesToParElems ils +inlineToParElems (Strong ils) = + local (\r -> r{envRunProps = (envRunProps r){rPropBold=True}}) $ + inlinesToParElems ils +inlineToParElems (Strikeout ils) = + local (\r -> r{envRunProps = (envRunProps r){rStrikethrough=Just SingleStrike}}) $ + inlinesToParElems ils +inlineToParElems (Superscript ils) = + local (\r -> r{envRunProps = (envRunProps r){rBaseline=Just 30000}}) $ + inlinesToParElems ils +inlineToParElems (Subscript ils) = + local (\r -> r{envRunProps = (envRunProps r){rBaseline=Just (-25000)}}) $ + inlinesToParElems ils +inlineToParElems (SmallCaps ils) = + local (\r -> r{envRunProps = (envRunProps r){rCap = Just SmallCapitals}}) $ + inlinesToParElems ils +inlineToParElems Space = inlineToParElems (Str " ") +inlineToParElems SoftBreak = inlineToParElems (Str " ") +inlineToParElems LineBreak = return [Break] +inlineToParElems (Link _ ils (url, title)) = do + local (\r ->r{envRunProps = (envRunProps r){rLink = Just $ ExternalTarget (url, title)}}) $ + inlinesToParElems ils +inlineToParElems (Code _ str) = do + local (\r ->r{envRunProps = (envRunProps r){rPropCode = True}}) $ + inlineToParElems $ Str str +inlineToParElems (Math mathtype str) = + return [MathElem mathtype (TeXString str)] +inlineToParElems (Note blks) = do + notes <- gets stNoteIds + let maxNoteId = case M.keys notes of + [] -> 0 + lst -> maximum lst + curNoteId = maxNoteId + 1 + modify $ \st -> st { stNoteIds = M.insert curNoteId blks notes } + local (\env -> env{envRunProps = (envRunProps env){rLink = Just $ InternalTarget endNotesSlideId}}) $ + inlineToParElems $ Superscript [Str $ show curNoteId] +inlineToParElems (Span _ ils) = concatMapM inlineToParElems ils +inlineToParElems (RawInline _ _) = return [] +inlineToParElems _ = return [] + +isListType :: Block -> Bool +isListType (OrderedList _ _) = True +isListType (BulletList _) = True +isListType (DefinitionList _) = True +isListType _ = False + +registerAnchorId :: String -> Pres () +registerAnchorId anchor = do + anchorMap <- gets stAnchorMap + sldId <- asks envCurSlideId + unless (null anchor) $ + modify $ \st -> st {stAnchorMap = M.insert anchor sldId anchorMap} + +-- Currently hardcoded, until I figure out how to make it dynamic. +blockQuoteSize :: Pixels +blockQuoteSize = 20 + +noteSize :: Pixels +noteSize = 18 + +blockToParagraphs :: Block -> Pres [Paragraph] +blockToParagraphs (Plain ils) = do + parElems <- inlinesToParElems ils + pProps <- asks envParaProps + return [Paragraph pProps parElems] +blockToParagraphs (Para ils) = do + parElems <- inlinesToParElems ils + pProps <- asks envParaProps + return [Paragraph pProps parElems] +blockToParagraphs (LineBlock ilsList) = do + parElems <- inlinesToParElems $ intercalate [LineBreak] ilsList + pProps <- asks envParaProps + return [Paragraph pProps parElems] +-- TODO: work out the attributes +blockToParagraphs (CodeBlock attr str) = + local (\r -> r{ envParaProps = def{pPropMarginLeft = Just 100} + , envRunProps = (envRunProps r){rPropCode = True}}) $ do + mbSty <- writerHighlightStyle <$> asks envOpts + synMap <- writerSyntaxMap <$> asks envOpts + case mbSty of + Just sty -> + case highlight synMap (formatSourceLines sty) attr str of + Right pElems -> do pProps <- asks envParaProps + return $ [Paragraph pProps pElems] + Left _ -> blockToParagraphs $ Para [Str str] + Nothing -> blockToParagraphs $ Para [Str str] +-- We can't yet do incremental lists, but we should render a +-- (BlockQuote List) as a list to maintain compatibility with other +-- formats. +blockToParagraphs (BlockQuote (blk : blks)) | isListType blk = do + ps <- blockToParagraphs blk + ps' <- blockToParagraphs $ BlockQuote blks + return $ ps ++ ps' +blockToParagraphs (BlockQuote blks) = + local (\r -> r{ envParaProps = (envParaProps r){pPropMarginLeft = Just 100} + , envRunProps = (envRunProps r){rPropForceSize = Just blockQuoteSize}})$ + concatMapM blockToParagraphs blks +-- TODO: work out the format +blockToParagraphs (RawBlock _ _) = return [] +blockToParagraphs (Header _ (ident, _, _) ils) = do + -- Note that this function only deals with content blocks, so it + -- will only touch headers that are above the current slide level -- + -- slides at or below the slidelevel will be taken care of by + -- `blocksToSlide'`. We have the register anchors in both of them. + registerAnchorId ident + -- we set the subeader to bold + parElems <- local (\e->e{envRunProps = (envRunProps e){rPropBold=True}}) $ + inlinesToParElems ils + -- and give it a bit of space before it. + return [Paragraph def{pPropSpaceBefore = Just 30} parElems] +blockToParagraphs (BulletList blksLst) = do + pProps <- asks envParaProps + let lvl = pPropLevel pProps + local (\env -> env{ envInList = True + , envParaProps = pProps{ pPropLevel = lvl + 1 + , pPropBullet = Just Bullet + , pPropMarginLeft = Nothing + }}) $ + concatMapM multiParBullet blksLst +blockToParagraphs (OrderedList listAttr blksLst) = do + pProps <- asks envParaProps + let lvl = pPropLevel pProps + local (\env -> env{ envInList = True + , envParaProps = pProps{ pPropLevel = lvl + 1 + , pPropBullet = Just (AutoNumbering listAttr) + , pPropMarginLeft = Nothing + }}) $ + concatMapM multiParBullet blksLst +blockToParagraphs (DefinitionList entries) = do + let go :: ([Inline], [[Block]]) -> Pres [Paragraph] + go (ils, blksLst) = do + term <-blockToParagraphs $ Para [Strong ils] + -- For now, we'll treat each definition term as a + -- blockquote. We can extend this further later. + definition <- concatMapM (blockToParagraphs . BlockQuote) blksLst + return $ term ++ definition + concatMapM go entries +blockToParagraphs (Div (_, ("notes" : []), _) _) = return [] +blockToParagraphs (Div _ blks) = concatMapM blockToParagraphs blks +blockToParagraphs blk = do + addLogMessage $ BlockNotRendered blk + return [] + +-- Make sure the bullet env gets turned off after the first para. +multiParBullet :: [Block] -> Pres [Paragraph] +multiParBullet [] = return [] +multiParBullet (b:bs) = do + pProps <- asks envParaProps + p <- blockToParagraphs b + ps <- local (\env -> env{envParaProps = pProps{pPropBullet = Nothing}}) $ + concatMapM blockToParagraphs bs + return $ p ++ ps + +cellToParagraphs :: Alignment -> TableCell -> Pres [Paragraph] +cellToParagraphs algn tblCell = do + paras <- mapM (blockToParagraphs) tblCell + let alignment = case algn of + AlignLeft -> Just AlgnLeft + AlignRight -> Just AlgnRight + AlignCenter -> Just AlgnCenter + AlignDefault -> Nothing + paras' = map (map (\p -> p{paraProps = (paraProps p){pPropAlign = alignment}})) paras + return $ concat paras' + +rowToParagraphs :: [Alignment] -> [TableCell] -> Pres [[Paragraph]] +rowToParagraphs algns tblCells = do + -- We have to make sure we have the right number of alignments + let pairs = zip (algns ++ repeat AlignDefault) tblCells + mapM (\(a, tc) -> cellToParagraphs a tc) pairs + +withAttr :: Attr -> Shape -> Shape +withAttr attr (Pic picPr url caption) = + let picPr' = picPr { picWidth = dimension Width attr + , picHeight = dimension Height attr + } + in + Pic picPr' url caption +withAttr _ sp = sp + +blockToShape :: Block -> Pres Shape +blockToShape (Plain (il:_)) | Image attr ils (url, _) <- il = + (withAttr attr . Pic def url) <$> (inlinesToParElems ils) +blockToShape (Para (il:_)) | Image attr ils (url, _) <- il = + (withAttr attr . Pic def url) <$> (inlinesToParElems ils) +blockToShape (Plain (il:_)) | Link _ (il':_) target <- il + , Image attr ils (url, _) <- il' = + (withAttr attr . Pic def {picPropLink = Just $ ExternalTarget target} url) <$> + (inlinesToParElems ils) +blockToShape (Para (il:_)) | Link _ (il':_) target <- il + , Image attr ils (url, _) <- il' = + (withAttr attr . Pic def{picPropLink = Just $ ExternalTarget target} url) <$> + (inlinesToParElems ils) +blockToShape (Table caption algn _ hdrCells rows) = do + caption' <- inlinesToParElems caption + hdrCells' <- rowToParagraphs algn hdrCells + rows' <- mapM (rowToParagraphs algn) rows + let tblPr = if null hdrCells + then TableProps { tblPrFirstRow = False + , tblPrBandRow = True + } + else TableProps { tblPrFirstRow = True + , tblPrBandRow = True + } + + return $ GraphicFrame [Tbl tblPr hdrCells' rows'] caption' +blockToShape blk = do paras <- blockToParagraphs blk + let paras' = map (\par -> par{paraElems = combineParaElems $ paraElems par}) paras + return $ TextBox paras' + +combineShapes :: [Shape] -> [Shape] +combineShapes [] = [] +combineShapes (s : []) = [s] +combineShapes (pic@(Pic _ _ _) : ss) = pic : combineShapes ss +combineShapes ((TextBox []) : ss) = combineShapes ss +combineShapes (s : TextBox [] : ss) = combineShapes (s : ss) +combineShapes ((TextBox (p:ps)) : (TextBox (p':ps')) : ss) = + combineShapes $ TextBox ((p:ps) ++ (p':ps')) : ss +combineShapes (s:ss) = s : combineShapes ss + +blocksToShapes :: [Block] -> Pres [Shape] +blocksToShapes blks = combineShapes <$> mapM blockToShape blks + +isImage :: Inline -> Bool +isImage (Image _ _ _) = True +isImage (Link _ ((Image _ _ _) : _) _) = True +isImage _ = False + +splitBlocks' :: [Block] -> [[Block]] -> [Block] -> Pres [[Block]] +splitBlocks' cur acc [] = return $ acc ++ (if null cur then [] else [cur]) +splitBlocks' cur acc (HorizontalRule : blks) = + splitBlocks' [] (acc ++ (if null cur then [] else [cur])) blks +splitBlocks' cur acc (h@(Header n _ _) : blks) = do + slideLevel <- asks envSlideLevel + case compare n slideLevel of + LT -> splitBlocks' [] (acc ++ (if null cur then [] else [cur]) ++ [[h]]) blks + EQ -> splitBlocks' [h] (acc ++ (if null cur then [] else [cur])) blks + GT -> splitBlocks' (cur ++ [h]) acc blks +-- `blockToParagraphs` treats Plain and Para the same, so we can save +-- some code duplication by treating them the same here. +splitBlocks' cur acc ((Plain ils) : blks) = splitBlocks' cur acc ((Para ils) : blks) +splitBlocks' cur acc ((Para (il:ils)) : blks) | isImage il = do + slideLevel <- asks envSlideLevel + case cur of + (Header n _ _) : [] | n == slideLevel -> + splitBlocks' [] + (acc ++ [cur ++ [Para [il]]]) + (if null ils then blks else (Para ils) : blks) + _ -> splitBlocks' [] + (acc ++ (if null cur then [] else [cur]) ++ [[Para [il]]]) + (if null ils then blks else (Para ils) : blks) +splitBlocks' cur acc (tbl@(Table _ _ _ _ _) : blks) = do + slideLevel <- asks envSlideLevel + case cur of + (Header n _ _) : [] | n == slideLevel -> + splitBlocks' [] (acc ++ [cur ++ [tbl]]) blks + _ -> splitBlocks' [] (acc ++ (if null cur then [] else [cur]) ++ [[tbl]]) blks +splitBlocks' cur acc (d@(Div (_, classes, _) _): blks) | "columns" `elem` classes = do + slideLevel <- asks envSlideLevel + case cur of + (Header n _ _) : [] | n == slideLevel -> + splitBlocks' [] (acc ++ [cur ++ [d]]) blks + _ -> splitBlocks' [] (acc ++ (if null cur then [] else [cur]) ++ [[d]]) blks +splitBlocks' cur acc (blk : blks) = splitBlocks' (cur ++ [blk]) acc blks + +splitBlocks :: [Block] -> Pres [[Block]] +splitBlocks = splitBlocks' [] [] + +blocksToSlide' :: Int -> [Block] -> Pres Slide +blocksToSlide' lvl ((Header n (ident, _, _) ils) : blks) + | n < lvl = do + registerAnchorId ident + sldId <- asks envCurSlideId + hdr <- inlinesToParElems ils + return $ Slide sldId (TitleSlide {titleSlideHeader = hdr}) Nothing + | n == lvl = do + registerAnchorId ident + hdr <- inlinesToParElems ils + -- Now get the slide without the header, and then add the header + -- in. + slide <- blocksToSlide' lvl blks + let layout = case slideLayout slide of + ContentSlide _ cont -> ContentSlide hdr cont + TwoColumnSlide _ contL contR -> TwoColumnSlide hdr contL contR + layout' -> layout' + return $ slide{slideLayout = layout} +blocksToSlide' _ (blk : blks) + | Div (_, classes, _) divBlks <- blk + , "columns" `elem` classes + , (Div (_, clsL, _) blksL) : (Div (_, clsR, _) blksR) : remaining <- divBlks + , "column" `elem` clsL, "column" `elem` clsR = do + unless (null blks) + (mapM (addLogMessage . BlockNotRendered) blks >> return ()) + unless (null remaining) + (mapM (addLogMessage . BlockNotRendered) remaining >> return ()) + mbSplitBlksL <- splitBlocks blksL + mbSplitBlksR <- splitBlocks blksR + let blksL' = case mbSplitBlksL of + bs : _ -> bs + [] -> [] + let blksR' = case mbSplitBlksR of + bs : _ -> bs + [] -> [] + shapesL <- blocksToShapes blksL' + shapesR <- blocksToShapes blksR' + sldId <- asks envCurSlideId + return $ Slide + sldId + TwoColumnSlide { twoColumnSlideHeader = [] + , twoColumnSlideLeft = shapesL + , twoColumnSlideRight = shapesR + } + Nothing +blocksToSlide' _ (blk : blks) = do + inNoteSlide <- asks envInNoteSlide + shapes <- if inNoteSlide + then forceFontSize noteSize $ blocksToShapes (blk : blks) + else blocksToShapes (blk : blks) + sldId <- asks envCurSlideId + return $ + Slide + sldId + ContentSlide { contentSlideHeader = [] + , contentSlideContent = shapes + } + Nothing +blocksToSlide' _ [] = do + sldId <- asks envCurSlideId + return $ + Slide + sldId + ContentSlide { contentSlideHeader = [] + , contentSlideContent = [] + } + Nothing + +blocksToSlide :: [Block] -> Pres Slide +blocksToSlide blks = do + slideLevel <- asks envSlideLevel + blocksToSlide' slideLevel blks + +makeNoteEntry :: Int -> [Block] -> [Block] +makeNoteEntry n blks = + let enum = Str (show n ++ ".") + in + case blks of + (Para ils : blks') -> (Para $ enum : Space : ils) : blks' + _ -> (Para [enum]) : blks + +forceFontSize :: Pixels -> Pres a -> Pres a +forceFontSize px x = do + rpr <- asks envRunProps + local (\r -> r {envRunProps = rpr{rPropForceSize = Just px}}) x + +-- We leave these as blocks because we will want to include them in +-- the TOC. +makeEndNotesSlideBlocks :: Pres [Block] +makeEndNotesSlideBlocks = do + noteIds <- gets stNoteIds + slideLevel <- asks envSlideLevel + meta <- asks envMetadata + -- Get identifiers so we can give the notes section a unique ident. + anchorSet <- M.keysSet <$> gets stAnchorMap + if M.null noteIds + then return [] + else do let title = case lookupMeta "notes-title" meta of + Just val -> metaValueToInlines val + Nothing -> [Str "Notes"] + ident = Shared.uniqueIdent title anchorSet + hdr = Header slideLevel (ident, [], []) title + blks <- return $ + concatMap (\(n, bs) -> makeNoteEntry n bs) $ + M.toList noteIds + return $ hdr : blks + +getMetaSlide :: Pres (Maybe Slide) +getMetaSlide = do + meta <- asks envMetadata + title <- inlinesToParElems $ docTitle meta + subtitle <- inlinesToParElems $ + case lookupMeta "subtitle" meta of + Just (MetaString s) -> [Str s] + Just (MetaInlines ils) -> ils + Just (MetaBlocks [Plain ils]) -> ils + Just (MetaBlocks [Para ils]) -> ils + _ -> [] + authors <- mapM inlinesToParElems $ docAuthors meta + date <- inlinesToParElems $ docDate meta + if null title && null subtitle && null authors && null date + then return Nothing + else return $ + Just $ + Slide + metadataSlideId + MetadataSlide { metadataSlideTitle = title + , metadataSlideSubtitle = subtitle + , metadataSlideAuthors = authors + , metadataSlideDate = date + } + Nothing + +-- adapted from the markdown writer +elementToListItem :: Shared.Element -> Pres [Block] +elementToListItem (Shared.Sec lev _nums (ident,_,_) headerText subsecs) = do + opts <- asks envOpts + let headerLink = if null ident + then walk Shared.deNote headerText + else [Link nullAttr (walk Shared.deNote headerText) + ('#':ident, "")] + listContents <- if null subsecs || lev >= writerTOCDepth opts + then return [] + else mapM elementToListItem subsecs + return [Plain headerLink, BulletList listContents] +elementToListItem (Shared.Blk _) = return [] + +makeTOCSlide :: [Block] -> Pres Slide +makeTOCSlide blks = local (\env -> env{envCurSlideId = tocSlideId}) $ do + contents <- BulletList <$> mapM elementToListItem (Shared.hierarchicalize blks) + meta <- asks envMetadata + slideLevel <- asks envSlideLevel + let tocTitle = case lookupMeta "toc-title" meta of + Just val -> metaValueToInlines val + Nothing -> [Str "Table of Contents"] + hdr = Header slideLevel nullAttr tocTitle + sld <- blocksToSlide [hdr, contents] + return sld + +combineParaElems' :: Maybe ParaElem -> [ParaElem] -> [ParaElem] +combineParaElems' mbPElem [] = maybeToList mbPElem +combineParaElems' Nothing (pElem : pElems) = + combineParaElems' (Just pElem) pElems +combineParaElems' (Just pElem') (pElem : pElems) + | Run rPr' s' <- pElem' + , Run rPr s <- pElem + , rPr == rPr' = + combineParaElems' (Just $ Run rPr' $ s' ++ s) pElems + | otherwise = + pElem' : combineParaElems' (Just pElem) pElems + +combineParaElems :: [ParaElem] -> [ParaElem] +combineParaElems = combineParaElems' Nothing + +applyToParagraph :: Monad m => (ParaElem -> m ParaElem) -> Paragraph -> m Paragraph +applyToParagraph f para = do + paraElems' <- mapM f $ paraElems para + return $ para {paraElems = paraElems'} + +applyToShape :: Monad m => (ParaElem -> m ParaElem) -> Shape -> m Shape +applyToShape f (Pic pPr fp pes) = do + pes' <- mapM f pes + return $ Pic pPr fp pes' +applyToShape f (GraphicFrame gfx pes) = do + pes' <- mapM f pes + return $ GraphicFrame gfx pes' +applyToShape f (TextBox paras) = do + paras' <- mapM (applyToParagraph f) paras + return $ TextBox paras' + +applyToLayout :: Monad m => (ParaElem -> m ParaElem) -> Layout -> m Layout +applyToLayout f (MetadataSlide title subtitle authors date) = do + title' <- mapM f title + subtitle' <- mapM f subtitle + authors' <- mapM (mapM f) authors + date' <- mapM f date + return $ MetadataSlide title' subtitle' authors' date' +applyToLayout f (TitleSlide title) = do + title' <- mapM f title + return $ TitleSlide title' +applyToLayout f (ContentSlide hdr content) = do + hdr' <- mapM f hdr + content' <- mapM (applyToShape f) content + return $ ContentSlide hdr' content' +applyToLayout f (TwoColumnSlide hdr contentL contentR) = do + hdr' <- mapM f hdr + contentL' <- mapM (applyToShape f) contentL + contentR' <- mapM (applyToShape f) contentR + return $ TwoColumnSlide hdr' contentL' contentR' + +applyToSlide :: Monad m => (ParaElem -> m ParaElem) -> Slide -> m Slide +applyToSlide f slide = do + layout' <- applyToLayout f $ slideLayout slide + mbNotes' <- case slideNotes slide of + Just (Notes notes) -> (Just . Notes) <$> + mapM (applyToParagraph f) notes + Nothing -> return Nothing + return slide{slideLayout = layout', slideNotes = mbNotes'} + +replaceAnchor :: ParaElem -> Pres ParaElem +replaceAnchor (Run rProps s) + | Just (ExternalTarget ('#':anchor, _)) <- rLink rProps = do + anchorMap <- gets stAnchorMap + -- If the anchor is not in the anchormap, we just remove the + -- link. + let rProps' = case M.lookup anchor anchorMap of + Just n -> rProps{rLink = Just $ InternalTarget n} + Nothing -> rProps{rLink = Nothing} + return $ Run rProps' s +replaceAnchor pe = return pe + +blocksToPresentationSlides :: [Block] -> Pres [Slide] +blocksToPresentationSlides blks = do + opts <- asks envOpts + metadataslides <- maybeToList <$> getMetaSlide + -- As far as I can tell, if we want to have a variable-length toc in + -- the future, we'll have to make it twice. Once to get the length, + -- and a second time to include the notes slide. We can't make the + -- notes slide before the body slides because we need to know if + -- there are notes, and we can't make either before the toc slide, + -- because we need to know its length to get slide numbers right. + -- + -- For now, though, since the TOC slide is only length 1, if it + -- exists, we'll just get the length, and then come back to make the + -- slide later + blksLst <- splitBlocks blks + bodySlideIds <- mapM + (\n -> runUniqueSlideId $ "BodySlide" ++ show n) + (take (length blksLst) [1..] :: [Integer]) + bodyslides <- mapM + (\(bs, ident) -> + local (\st -> st{envCurSlideId = ident}) (blocksToSlide bs)) + (zip blksLst bodySlideIds) + endNotesSlideBlocks <- makeEndNotesSlideBlocks + -- now we come back and make the real toc... + tocSlides <- if writerTableOfContents opts + then do toc <- makeTOCSlide $ blks ++ endNotesSlideBlocks + return [toc] + else return [] + -- ... and the notes slide. We test to see if the blocks are empty, + -- because we don't want to make an empty slide. + endNotesSlides <- if null endNotesSlideBlocks + then return [] + else do endNotesSlide <- local + (\env -> env { envCurSlideId = endNotesSlideId + , envInNoteSlide = True + }) + (blocksToSlide $ endNotesSlideBlocks) + return [endNotesSlide] + + let slides = metadataslides ++ tocSlides ++ bodyslides ++ endNotesSlides + mapM (applyToSlide replaceAnchor) slides + +metaToDocProps :: Meta -> DocProps +metaToDocProps meta = + let keywords = case lookupMeta "keywords" meta of + Just (MetaList xs) -> Just $ map Shared.stringify xs + _ -> Nothing + + authors = case map Shared.stringify $ docAuthors meta of + [] -> Nothing + ss -> Just $ intercalate ";" ss + in + DocProps{ dcTitle = Shared.stringify <$> lookupMeta "title" meta + , dcSubject = Shared.stringify <$> lookupMeta "subject" meta + , dcCreator = authors + , dcKeywords = keywords + , dcCreated = Nothing + } + +documentToPresentation :: WriterOptions + -> Pandoc + -> (Presentation, [LogMessage]) +documentToPresentation opts (Pandoc meta blks) = + let env = def { envOpts = opts + , envMetadata = meta + , envSlideLevel = case writerSlideLevel opts of + Just lvl -> lvl + Nothing -> getSlideLevel blks + } + (presSlides, msgs) = runPres env def $ blocksToPresentationSlides blks + docProps = metaToDocProps meta + in + (Presentation docProps presSlides, msgs) + +-- -------------------------------------------------------------- + +applyTokStyToRunProps :: TokenStyle -> RunProps -> RunProps +applyTokStyToRunProps tokSty rProps = + rProps{ rSolidFill = tokenColor tokSty <|> rSolidFill rProps + , rPropBold = tokenBold tokSty || rPropBold rProps + , rPropItalics = tokenItalic tokSty || rPropItalics rProps + , rPropUnderline = tokenUnderline tokSty || rPropUnderline rProps + } + +formatToken :: Style -> Token -> ParaElem +formatToken sty (tokType, txt) = + let rProps = def{rPropCode = True, rSolidFill = defaultColor sty} + rProps' = case M.lookup tokType (tokenStyles sty) of + Just tokSty -> applyTokStyToRunProps tokSty rProps + Nothing -> rProps + in + Run rProps' $ T.unpack txt + +formatSourceLine :: Style -> FormatOptions -> SourceLine -> [ParaElem] +formatSourceLine sty _ srcLn = map (formatToken sty) srcLn + +formatSourceLines :: Style -> FormatOptions -> [SourceLine] -> [ParaElem] +formatSourceLines sty opts srcLns = intercalate [Break] $ + map (formatSourceLine sty opts) srcLns diff --git a/src/Text/Pandoc/Writers/RST.hs b/src/Text/Pandoc/Writers/RST.hs index 515276985..a57527aa8 100644 --- a/src/Text/Pandoc/Writers/RST.hs +++ b/src/Text/Pandoc/Writers/RST.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {- -Copyright (C) 2006-2017 John MacFarlane <jgm@berkeley.edu> +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 @@ -19,7 +19,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.Writers.RST - Copyright : Copyright (C) 2006-2017 John MacFarlane + Copyright : Copyright (C) 2006-2018 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> @@ -57,7 +57,6 @@ data WriterState = , stHasRawTeX :: Bool , stOptions :: WriterOptions , stTopLevel :: Bool - , stLastNested :: Bool } type RST = StateT WriterState @@ -68,7 +67,7 @@ writeRST opts document = do let st = WriterState { stNotes = [], stLinks = [], stImages = [], stHasMath = False, stHasRawTeX = False, stOptions = opts, - stTopLevel = True, stLastNested = False} + stTopLevel = True } evalStateT (pandocToRST document) st -- | Return RST representation of document. @@ -353,33 +352,26 @@ blockListToRST' :: PandocMonad m -> [Block] -- ^ List of block elements -> RST m Doc blockListToRST' topLevel blocks = do + -- insert comment between list and quoted blocks, see #4248 and #3675 + let fixBlocks (b1:b2@(BlockQuote _):bs) + | toClose b1 = b1 : commentSep : b2 : fixBlocks bs + where + toClose (Plain{}) = False + toClose (Header{}) = False + toClose (LineBlock{}) = False + toClose (HorizontalRule) = False + toClose (Para [Image _ _ (_,'f':'i':'g':':':_)]) = True + toClose (Para{}) = False + toClose _ = True + commentSep = RawBlock "rst" "..\n\n" + fixBlocks (b:bs) = b : fixBlocks bs + fixBlocks [] = [] tl <- gets stTopLevel - modify (\s->s{stTopLevel=topLevel, stLastNested=False}) - res <- vcat `fmap` mapM blockToRST' blocks + modify (\s->s{stTopLevel=topLevel}) + res <- vcat `fmap` mapM blockToRST (fixBlocks blocks) modify (\s->s{stTopLevel=tl}) return res -blockToRST' :: PandocMonad m => Block -> RST m Doc -blockToRST' (x@BlockQuote{}) = do - lastNested <- gets stLastNested - res <- blockToRST x - modify (\s -> s{stLastNested = True}) - return $ if lastNested - then ".." $+$ res - else res -blockToRST' x = do - modify (\s -> s{stLastNested = - case x of - Para [Image _ _ (_,'f':'i':'g':':':_)] -> True - Para{} -> False - Plain{} -> False - Header{} -> False - LineBlock{} -> False - HorizontalRule -> False - _ -> True - }) - blockToRST x - blockListToRST :: PandocMonad m => [Block] -- ^ List of block elements -> RST m Doc diff --git a/src/Text/Pandoc/Writers/RTF.hs b/src/Text/Pandoc/Writers/RTF.hs index 955b3f7f1..790bebc01 100644 --- a/src/Text/Pandoc/Writers/RTF.hs +++ b/src/Text/Pandoc/Writers/RTF.hs @@ -1,6 +1,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {- -Copyright (C) 2006-2017 John MacFarlane <jgm@berkeley.edu> +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 @@ -19,7 +19,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.Writers.RTF - Copyright : Copyright (C) 2006-2017 John MacFarlane + Copyright : Copyright (C) 2006-2018 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> diff --git a/src/Text/Pandoc/Writers/Shared.hs b/src/Text/Pandoc/Writers/Shared.hs index 83280fa5c..ae4cc5cc5 100644 --- a/src/Text/Pandoc/Writers/Shared.hs +++ b/src/Text/Pandoc/Writers/Shared.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {- -Copyright (C) 2013-2017 John MacFarlane <jgm@berkeley.edu> +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 @@ -19,7 +19,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.Writers.Shared - Copyright : Copyright (C) 2013-2017 John MacFarlane + Copyright : Copyright (C) 2013-2018 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> @@ -40,6 +40,7 @@ module Text.Pandoc.Writers.Shared ( , fixDisplayMath , unsmartify , gridTable + , metaValueToInlines ) where import Control.Monad (zipWithM) @@ -55,6 +56,7 @@ import qualified Text.Pandoc.Builder as Builder import Text.Pandoc.Definition import Text.Pandoc.Options import Text.Pandoc.Pretty +import Text.Pandoc.Walk (query) import Text.Pandoc.UTF8 (toStringLazy) import Text.Pandoc.XML (escapeStringForXML) @@ -308,3 +310,10 @@ gridTable opts blocksToDoc headless aligns widths headers rows = do head'' $$ body $$ border '-' (repeat AlignDefault) widthsInChars + +metaValueToInlines :: MetaValue -> [Inline] +metaValueToInlines (MetaString s) = [Str s] +metaValueToInlines (MetaInlines ils) = ils +metaValueToInlines (MetaBlocks bs) = query return bs +metaValueToInlines (MetaBool b) = [Str $ show b] +metaValueToInlines _ = [] diff --git a/src/Text/Pandoc/Writers/TEI.hs b/src/Text/Pandoc/Writers/TEI.hs index 8e9d155fa..907e2af24 100644 --- a/src/Text/Pandoc/Writers/TEI.hs +++ b/src/Text/Pandoc/Writers/TEI.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {- -Copyright (C) 2006-2017 John MacFarlane <jgm@berkeley.edu> +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 @@ -20,7 +20,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.Writers.Docbook - Copyright : Copyright (C) 2006-2017 John MacFarlane + Copyright : Copyright (C) 2006-2018 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> diff --git a/src/Text/Pandoc/Writers/Texinfo.hs b/src/Text/Pandoc/Writers/Texinfo.hs index 15dd2e3d9..b5d72aa56 100644 --- a/src/Text/Pandoc/Writers/Texinfo.hs +++ b/src/Text/Pandoc/Writers/Texinfo.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {- -Copyright (C) 2008-2017 John MacFarlane +Copyright (C) 2008-2018 John MacFarlane 2012 Peter Wang This program is free software; you can redistribute it and/or modify @@ -20,7 +20,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.Writers.Texinfo - Copyright : Copyright (C) 2008-2017 John MacFarlane + Copyright : Copyright (C) 2008-2018 John MacFarlane 2012 Peter Wang License : GNU GPL, version 2 or above diff --git a/src/Text/Pandoc/Writers/Textile.hs b/src/Text/Pandoc/Writers/Textile.hs index 11fb2ae12..f46eb43bc 100644 --- a/src/Text/Pandoc/Writers/Textile.hs +++ b/src/Text/Pandoc/Writers/Textile.hs @@ -1,5 +1,5 @@ {- -Copyright (C) 2010-2017 John MacFarlane <jgm@berkeley.edu> +Copyright (C) 2010-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 @@ -18,7 +18,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.Writers.Textile - Copyright : Copyright (C) 2010-2017 John MacFarlane + Copyright : Copyright (C) 2010-2018 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> diff --git a/src/Text/Pandoc/Writers/ZimWiki.hs b/src/Text/Pandoc/Writers/ZimWiki.hs index 30317db73..dec1f9d4a 100644 --- a/src/Text/Pandoc/Writers/ZimWiki.hs +++ b/src/Text/Pandoc/Writers/ZimWiki.hs @@ -1,6 +1,6 @@ {- -Copyright (C) 2008-2017 John MacFarlane <jgm@berkeley.edu> - 2017 Alex Ivkin +Copyright (C) 2008-2018 John MacFarlane <jgm@berkeley.edu> + 2017-2018 Alex Ivkin This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -19,7 +19,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.Writers.ZimWiki - Copyright : Copyright (C) 2008-2017 John MacFarlane, 2017 Alex Ivkin + Copyright : Copyright (C) 2008-2018 John MacFarlane, 2017-2018 Alex Ivkin License : GNU GPL, version 2 or above Maintainer : Alex Ivkin <alex@ivkin.net> diff --git a/src/Text/Pandoc/XML.hs b/src/Text/Pandoc/XML.hs index 67608fb43..62874f0b9 100644 --- a/src/Text/Pandoc/XML.hs +++ b/src/Text/Pandoc/XML.hs @@ -1,5 +1,5 @@ {- -Copyright (C) 2006-2017 John MacFarlane <jgm@berkeley.edu> +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 @@ -18,7 +18,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.XML - Copyright : Copyright (C) 2006-2017 John MacFarlane + Copyright : Copyright (C) 2006-2018 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> |