diff options
Diffstat (limited to 'src/Text/Pandoc')
22 files changed, 221 insertions, 132 deletions
diff --git a/src/Text/Pandoc/Extensions.hs b/src/Text/Pandoc/Extensions.hs index f85b23abd..6cb87eef6 100644 --- a/src/Text/Pandoc/Extensions.hs +++ b/src/Text/Pandoc/Extensions.hs @@ -227,7 +227,7 @@ plainExtensions = extensionsFromList , Ext_strikeout ] --- | Extensions to be used with github-flavored markdown. +-- | Extensions to be used with PHP Markdown Extra. phpMarkdownExtraExtensions :: Extensions phpMarkdownExtraExtensions = extensionsFromList [ Ext_footnotes diff --git a/src/Text/Pandoc/Lua/Filter.hs b/src/Text/Pandoc/Lua/Filter.hs index 553dda8de..e8958347d 100644 --- a/src/Text/Pandoc/Lua/Filter.hs +++ b/src/Text/Pandoc/Lua/Filter.hs @@ -129,7 +129,7 @@ walkMWithLuaFilter :: LuaFilter -> Pandoc -> Lua Pandoc walkMWithLuaFilter f = walkInlines f >=> walkBlocks f >=> walkMeta f >=> walkPandoc f -mconcatMapM :: (Monad m, Functor m) => (a -> m [a]) -> [a] -> m [a] +mconcatMapM :: (Monad m) => (a -> m [a]) -> [a] -> m [a] mconcatMapM f = fmap mconcat . mapM f hasOneOf :: LuaFilter -> [String] -> Bool diff --git a/src/Text/Pandoc/Lua/Module/Pandoc.hs b/src/Text/Pandoc/Lua/Module/Pandoc.hs index 8f7653550..09892db49 100644 --- a/src/Text/Pandoc/Lua/Module/Pandoc.hs +++ b/src/Text/Pandoc/Lua/Module/Pandoc.hs @@ -46,7 +46,7 @@ pushModule datadir = do LuaUtil.addFunction "walk_inline" walkInline return 1 -walkElement :: (Pushable a, Walkable [Inline] a, Walkable [Block] a) +walkElement :: (Walkable [Inline] a, Walkable [Block] a) => a -> LuaFilter -> Lua a walkElement x f = walkInlines f x >>= walkBlocks f diff --git a/src/Text/Pandoc/Lua/Module/System.hs b/src/Text/Pandoc/Lua/Module/System.hs index 5149c2112..50db21244 100644 --- a/src/Text/Pandoc/Lua/Module/System.hs +++ b/src/Text/Pandoc/Lua/Module/System.hs @@ -27,8 +27,8 @@ pushModule = do addField "arch" arch addField "os" os addFunction "environment" env - addFunction "get_current_directory" getwd + addFunction "get_working_directory" getwd addFunction "with_environment" with_env - addFunction "with_temp_directory" with_tmpdir + addFunction "with_temporary_directory" with_tmpdir addFunction "with_working_directory" with_wd return 1 diff --git a/src/Text/Pandoc/Parsing.hs b/src/Text/Pandoc/Parsing.hs index 15349314f..49249bec8 100644 --- a/src/Text/Pandoc/Parsing.hs +++ b/src/Text/Pandoc/Parsing.hs @@ -313,8 +313,7 @@ many1Till p end = do return (first:rest) -- | Like @manyTill@, but also returns the result of end parser. -manyUntil :: (Stream s m t) - => ParserT s u m a +manyUntil :: ParserT s u m a -> ParserT s u m b -> ParserT s u m ([a], b) manyUntil p end = scan @@ -328,8 +327,7 @@ manyUntil p end = scan -- | Like @sepBy1@ from Parsec, -- but does not fail if it @sep@ succeeds and @p@ fails. -sepBy1' :: (Stream s m t) - => ParsecT s u m a +sepBy1' :: ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a] sepBy1' p sep = (:) <$> p <*> many (try $ sep >> p) @@ -440,7 +438,7 @@ stringAnyCase (x:xs) = do return (firstChar:rest) -- | Parse contents of 'str' using 'parser' and return result. -parseFromString :: (Monad m, Stream s m Char, IsString s) +parseFromString :: (Stream s m Char, IsString s) => ParserT s st m r -> String -> ParserT s st m r @@ -458,7 +456,7 @@ parseFromString parser str = do -- | Like 'parseFromString' but specialized for 'ParserState'. -- This resets 'stateLastStrPos', which is almost always what we want. -parseFromString' :: (Monad m, Stream s m Char, IsString s) +parseFromString' :: (Stream s m Char, IsString s) => ParserT s ParserState m a -> String -> ParserT s ParserState m a @@ -1019,7 +1017,7 @@ gridTableFooter = blanklines --- -- | Removes the ParsecT layer from the monad transformer stack -readWithM :: (Monad m, Stream s m Char, ToString s) +readWithM :: (Stream s m Char, ToString s) => ParserT s st m a -- ^ parser -> st -- ^ initial state -> s -- ^ input @@ -1410,7 +1408,7 @@ extractIdClass (ident, cls, kvs) = (ident', cls', kvs') Nothing -> cls kvs' = filter (\(k,_) -> k /= "id" || k /= "class") kvs -insertIncludedFile' :: (PandocMonad m, HasIncludeFiles st, Monad mf) +insertIncludedFile' :: (PandocMonad m, HasIncludeFiles st) => ParserT [a] st m (mf Blocks) -> (String -> [a]) -> [FilePath] -> FilePath diff --git a/src/Text/Pandoc/Readers/HTML.hs b/src/Text/Pandoc/Readers/HTML.hs index 78b377993..392530609 100644 --- a/src/Text/Pandoc/Readers/HTML.hs +++ b/src/Text/Pandoc/Readers/HTML.hs @@ -435,7 +435,7 @@ eSection = try $ do TagOpen tag _ <- lookAhead $ pSatisfy sectTag setInChapter (pInTags tag block) -headerLevel :: PandocMonad m => Text -> TagParser m Int +headerLevel :: Text -> TagParser m Int headerLevel tagtype = case safeRead (T.unpack (T.drop 1 tagtype)) of Just level -> @@ -1129,7 +1129,7 @@ _ `closes` _ = False --- parsers for use in markdown, textile readers -- | Matches a stretch of HTML in balanced tags. -htmlInBalanced :: (HasReaderOptions st, Monad m) +htmlInBalanced :: Monad m => (Tag String -> Bool) -> ParserT String st m String htmlInBalanced f = try $ do diff --git a/src/Text/Pandoc/Readers/Ipynb.hs b/src/Text/Pandoc/Readers/Ipynb.hs index 04e0b1595..dbca5a59f 100644 --- a/src/Text/Pandoc/Readers/Ipynb.hs +++ b/src/Text/Pandoc/Readers/Ipynb.hs @@ -53,7 +53,7 @@ readIpynb opts t = do Right (notebook3 :: Notebook NbV3) -> notebookToPandoc opts notebook3 Left err -> throwError $ PandocIpynbDecodingError err -notebookToPandoc :: (PandocMonad m, FromJSON (Notebook a)) +notebookToPandoc :: PandocMonad m => ReaderOptions -> Notebook a -> m Pandoc notebookToPandoc opts notebook = do let cells = notebookCells notebook diff --git a/src/Text/Pandoc/Readers/LaTeX.hs b/src/Text/Pandoc/Readers/LaTeX.hs index 6734bc32d..0202c1fc4 100644 --- a/src/Text/Pandoc/Readers/LaTeX.hs +++ b/src/Text/Pandoc/Readers/LaTeX.hs @@ -1379,7 +1379,7 @@ doref cls = do "" (inBrackets $ str refstr) -lookupListDefault :: (Show k, Ord k) => v -> [k] -> M.Map k v -> v +lookupListDefault :: (Ord k) => v -> [k] -> M.Map k v -> v lookupListDefault d = (fromMaybe d .) . lookupList where lookupList l m = msum $ map (`M.lookup` m) l @@ -1502,12 +1502,15 @@ macroDef = guardDisabled Ext_latex_macros <|> updateState (\s -> s{ sMacros = M.insert name macro' (sMacros s) }) environmentDef = do - (name, macro1, macro2) <- newenvironment - guardDisabled Ext_latex_macros <|> - do updateState $ \s -> s{ sMacros = - M.insert name macro1 (sMacros s) } - updateState $ \s -> s{ sMacros = - M.insert ("end" <> name) macro2 (sMacros s) } + mbenv <- newenvironment + case mbenv of + Nothing -> return () + Just (name, macro1, macro2) -> do + guardDisabled Ext_latex_macros <|> + do updateState $ \s -> s{ sMacros = + M.insert name macro1 (sMacros s) } + updateState $ \s -> s{ sMacros = + M.insert ("end" <> name) macro2 (sMacros s) } -- @\newenvironment{envname}[n-args][default]{begin}{end}@ -- is equivalent to -- @\newcommand{\envname}[n-args][default]{begin}@ @@ -1580,14 +1583,16 @@ newcommand = do : (contents' ++ [ Tok pos Symbol "}", Tok pos Symbol "}" ]) _ -> contents' - when (mtype == "newcommand") $ do - macros <- sMacros <$> getState - case M.lookup name macros of - Just _ -> report $ MacroAlreadyDefined (T.unpack txt) pos - Nothing -> return () - return (name, Macro ExpandWhenUsed argspecs optarg contents) - -newenvironment :: PandocMonad m => LP m (Text, Macro, Macro) + macros <- sMacros <$> getState + case M.lookup name macros of + Just macro + | mtype == "newcommand" -> do + report $ MacroAlreadyDefined (T.unpack txt) pos + return (name, macro) + | mtype == "providecommand" -> return (name, macro) + _ -> return (name, Macro ExpandWhenUsed argspecs optarg contents) + +newenvironment :: PandocMonad m => LP m (Maybe (Text, Macro, Macro)) newenvironment = do pos <- getPosition Tok _ (CtrlSeq mtype) _ <- controlSeq "newenvironment" <|> @@ -1604,13 +1609,17 @@ newenvironment = do let argspecs = map (\i -> ArgNum i) [1..numargs] startcontents <- spaces >> bracedOrToken endcontents <- spaces >> bracedOrToken - when (mtype == "newenvironment") $ do - macros <- sMacros <$> getState - case M.lookup name macros of - Just _ -> report $ MacroAlreadyDefined (T.unpack name) pos - Nothing -> return () - return (name, Macro ExpandWhenUsed argspecs optarg startcontents, - Macro ExpandWhenUsed [] Nothing endcontents) + macros <- sMacros <$> getState + case M.lookup name macros of + Just _ + | mtype == "newenvironment" -> do + report $ MacroAlreadyDefined (T.unpack name) pos + return Nothing + | mtype == "provideenvironment" -> do + return Nothing + _ -> return $ Just (name, + Macro ExpandWhenUsed argspecs optarg startcontents, + Macro ExpandWhenUsed [] Nothing endcontents) bracketedNum :: PandocMonad m => LP m Int bracketedNum = do @@ -1640,6 +1649,12 @@ looseItem = do skipopts return mempty +epigraph :: PandocMonad m => LP m Blocks +epigraph = do + p1 <- grouped blocks + p2 <- grouped blocks + return $ divWith ("", ["epigraph"], []) (p1 <> p2) + resetCaption :: PandocMonad m => LP m () resetCaption = updateState $ \st -> st{ sCaption = (Nothing, Nothing) } @@ -1795,6 +1810,8 @@ blockCommands = M.fromList , ("usepackage", include "usepackage") -- preamble , ("PackageError", mempty <$ (braced >> braced >> braced)) + -- epigraph package + , ("epigraph", epigraph) ] diff --git a/src/Text/Pandoc/Readers/Man.hs b/src/Text/Pandoc/Readers/Man.hs index a9676c960..c21fd00c3 100644 --- a/src/Text/Pandoc/Readers/Man.hs +++ b/src/Text/Pandoc/Readers/Man.hs @@ -323,8 +323,7 @@ parseItalic [] = do parseItalic args = return $ emph $ mconcat $ intersperse B.space $ map linePartsToInlines args -parseAlternatingFonts :: PandocMonad m - => [Inlines -> Inlines] +parseAlternatingFonts :: [Inlines -> Inlines] -> [Arg] -> ManParser m Inlines parseAlternatingFonts constructors args = return $ mconcat $ diff --git a/src/Text/Pandoc/Readers/Markdown.hs b/src/Text/Pandoc/Readers/Markdown.hs index ab5aa6b05..3d2ba490d 100644 --- a/src/Text/Pandoc/Readers/Markdown.hs +++ b/src/Text/Pandoc/Readers/Markdown.hs @@ -857,7 +857,8 @@ listLine continuationIndent = try $ do listLineCommon :: PandocMonad m => MarkdownParser m String listLineCommon = concat <$> manyTill - ( many1 (satisfy $ \c -> c /= '\n' && c /= '<') + ( many1 (satisfy $ \c -> c `notElem` ['\n', '<', '`']) + <|> fmap snd (withRaw code) <|> fmap snd (htmlTag isCommentTag) <|> count 1 anyChar ) newline @@ -932,14 +933,14 @@ listItem :: PandocMonad m -> MarkdownParser m a -> MarkdownParser m (F Blocks) listItem fourSpaceRule start = try $ do - (first, continuationIndent) <- rawListItem fourSpaceRule start - continuations <- many (listContinuation continuationIndent) -- parsing with ListItemState forces markers at beginning of lines to -- count as list item markers, even if not separated by blank space. -- see definition of "endline" state <- getState let oldContext = stateParserContext state setState $ state {stateParserContext = ListItemState} + (first, continuationIndent) <- rawListItem fourSpaceRule start + continuations <- many (listContinuation continuationIndent) -- parse the extracted block, which may contain various block elements: let raw = concat (first:continuations) contents <- parseFromString' parseBlocks raw @@ -1583,8 +1584,9 @@ code = try $ do starts <- many1 (char '`') skipSpaces result <- (trim . concat) <$> - manyTill (many1 (noneOf "`\n") <|> many1 (char '`') <|> - (char '\n' >> notFollowedBy' blankline >> return " ")) + manyTill (notFollowedBy (inList >> listStart) >> + (many1 (noneOf "`\n") <|> many1 (char '`') <|> + (char '\n' >> notFollowedBy' blankline >> return " "))) (try (skipSpaces >> count (length starts) (char '`') >> notFollowedBy (char '`'))) rawattr <- diff --git a/src/Text/Pandoc/Readers/Odt.hs b/src/Text/Pandoc/Readers/Odt.hs index 3a3d1e992..dfa019932 100644 --- a/src/Text/Pandoc/Readers/Odt.hs +++ b/src/Text/Pandoc/Readers/Odt.hs @@ -86,9 +86,8 @@ archiveToOdt archive where filePathIsOdtMedia :: FilePath -> Bool filePathIsOdtMedia fp = - let (dir, _) = splitFileName fp - in - (dir == "Pictures/") + let (dir, name) = splitFileName fp + in (dir == "Pictures/") || (dir /= "./" && name == "content.xml") -- diff --git a/src/Text/Pandoc/Readers/Odt/ContentReader.hs b/src/Text/Pandoc/Readers/Odt/ContentReader.hs index 1d9a0cb8c..d8e5ba272 100644 --- a/src/Text/Pandoc/Readers/Odt/ContentReader.hs +++ b/src/Text/Pandoc/Readers/Odt/ContentReader.hs @@ -1,5 +1,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE Arrows #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} @@ -26,21 +28,26 @@ import Control.Applicative hiding (liftA, liftA2, liftA3) import Control.Arrow import qualified Data.ByteString.Lazy as B -import Data.List (find, intercalate) +import Data.Foldable (fold) +import Data.List (find, intercalate, stripPrefix) import qualified Data.Map as M import Data.Maybe +import Data.Semigroup (First(..), Option(..)) +import Text.TeXMath (readMathML, writeTeX) import qualified Text.XML.Light as XML import Text.Pandoc.Builder import Text.Pandoc.MediaBag (MediaBag, insertMedia) import Text.Pandoc.Shared import Text.Pandoc.Extensions (extensionsFromList, Extension(..)) +import qualified Text.Pandoc.UTF8 as UTF8 import Text.Pandoc.Readers.Odt.Base import Text.Pandoc.Readers.Odt.Namespaces import Text.Pandoc.Readers.Odt.StyleReader +import Text.Pandoc.Readers.Odt.Arrows.State (foldS) import Text.Pandoc.Readers.Odt.Arrows.Utils import Text.Pandoc.Readers.Odt.Generic.Fallible import Text.Pandoc.Readers.Odt.Generic.Utils @@ -498,6 +505,13 @@ type InlineMatcher = ElementMatcher Inlines type BlockMatcher = ElementMatcher Blocks +newtype FirstMatch a = FirstMatch (Option (First a)) + deriving (Foldable, Monoid, Semigroup) + +firstMatch :: a -> FirstMatch a +firstMatch = FirstMatch . Option . Just . First + + -- matchingElement :: (Monoid e) => Namespace -> ElementName @@ -598,7 +612,7 @@ read_paragraph = matchingElement NsText "p" , read_reference_start , read_bookmark_ref , read_reference_ref - , read_maybe_nested_img_frame + , read_frame , read_text_seq ] read_plain_text @@ -624,7 +638,7 @@ read_header = matchingElement NsText "h" , read_reference_start , read_bookmark_ref , read_reference_ref - , read_maybe_nested_img_frame + , read_frame ] read_plain_text ) -< blocks anchor <- getHeaderAnchor -< children @@ -737,32 +751,43 @@ read_table_cell = matchingElement NsTable "table-cell" ] ---------------------- --- Images +-- Frames ---------------------- -- -read_maybe_nested_img_frame :: InlineMatcher -read_maybe_nested_img_frame = matchingElement NsDraw "frame" - $ proc blocks -> do - img <- (findChild' NsDraw "image") -< () - case img of - Just _ -> read_frame -< blocks - Nothing -> matchChildContent' [ read_frame_text_box ] -< blocks - -read_frame :: OdtReaderSafe Inlines Inlines -read_frame = - proc blocks -> do - let exts = extensionsFromList [Ext_auto_identifiers] - w <- ( findAttr' NsSVG "width" ) -< () - h <- ( findAttr' NsSVG "height" ) -< () - titleNodes <- ( matchChildContent' [ read_frame_title ] ) -< blocks - src <- matchChildContent' [ read_image_src ] -< blocks - resource <- lookupResource -< src - _ <- updateMediaWithResource -< resource - alt <- (matchChildContent [] read_plain_text) -< blocks - arr (uncurry4 imageWith ) -< - (image_attributes w h, src, - inlineListToIdentifier exts (toList titleNodes), alt) +read_frame :: InlineMatcher +read_frame = matchingElement NsDraw "frame" + $ filterChildrenName' NsDraw (`elem` ["image", "object", "text-box"]) + >>> foldS read_frame_child + >>> arr fold + +read_frame_child :: OdtReaderSafe XML.Element (FirstMatch Inlines) +read_frame_child = + proc child -> case elName child of + "image" -> read_frame_img -< child + "object" -> read_frame_mathml -< child + "text-box" -> read_frame_text_box -< child + _ -> returnV mempty -< () + +read_frame_img :: OdtReaderSafe XML.Element (FirstMatch Inlines) +read_frame_img = + proc img -> do + src <- executeIn (findAttr' NsXLink "href") -< img + case fold src of + "" -> returnV mempty -< () + src' -> do + let exts = extensionsFromList [Ext_auto_identifiers] + resource <- lookupResource -< src' + _ <- updateMediaWithResource -< resource + w <- findAttr' NsSVG "width" -< () + h <- findAttr' NsSVG "height" -< () + titleNodes <- matchChildContent' [ read_frame_title ] -< () + alt <- matchChildContent [] read_plain_text -< () + arr (firstMatch . uncurry4 imageWith) -< + (image_attributes w h, src', inlineListToIdentifier exts (toList titleNodes), alt) + +read_frame_title :: InlineMatcher +read_frame_title = matchingElement NsSVG "title" (matchChildContent [] read_plain_text) image_attributes :: Maybe String -> Maybe String -> Attr image_attributes x y = @@ -772,28 +797,29 @@ image_attributes x y = dim name (Just v) = [(name, v)] dim _ Nothing = [] -read_image_src :: (Namespace, ElementName, OdtReader Anchor Anchor) -read_image_src = matchingElement NsDraw "image" - $ proc _ -> do - imgSrc <- findAttr NsXLink "href" -< () - case imgSrc of - Right src -> returnV src -<< () - Left _ -> returnV "" -< () - -read_frame_title :: InlineMatcher -read_frame_title = matchingElement NsSVG "title" (matchChildContent [] read_plain_text) - -read_frame_text_box :: InlineMatcher -read_frame_text_box = matchingElement NsDraw "text-box" - $ proc blocks -> do - paragraphs <- (matchChildContent' [ read_paragraph ]) -< blocks - arr read_img_with_caption -< toList paragraphs - -read_img_with_caption :: [Block] -> Inlines +read_frame_mathml :: OdtReaderSafe XML.Element (FirstMatch Inlines) +read_frame_mathml = + proc obj -> do + src <- executeIn (findAttr' NsXLink "href") -< obj + case fold src of + "" -> returnV mempty -< () + src' -> do + let path = fromMaybe src' (stripPrefix "./" src') ++ "/content.xml" + (_, mathml) <- lookupResource -< path + case readMathML (UTF8.toString $ B.toStrict mathml) of + Left _ -> returnV mempty -< () + Right exps -> arr (firstMatch . displayMath . writeTeX) -< exps + +read_frame_text_box :: OdtReaderSafe XML.Element (FirstMatch Inlines) +read_frame_text_box = proc box -> do + paragraphs <- executeIn (matchChildContent' [ read_paragraph ]) -< box + arr read_img_with_caption -< toList paragraphs + +read_img_with_caption :: [Block] -> FirstMatch Inlines read_img_with_caption (Para [Image attr alt (src,title)] : _) = - singleton (Image attr alt (src, 'f':'i':'g':':':title)) -- no text, default caption + firstMatch $ singleton (Image attr alt (src, 'f':'i':'g':':':title)) -- no text, default caption read_img_with_caption (Para (Image attr _ (src,title) : txt) : _) = - singleton (Image attr txt (src, 'f':'i':'g':':':title) ) -- override caption with the text that follows + firstMatch $ singleton (Image attr txt (src, 'f':'i':'g':':':title) ) -- override caption with the text that follows read_img_with_caption ( Para (_ : xs) : ys) = read_img_with_caption (Para xs : ys) read_img_with_caption _ = @@ -901,8 +927,8 @@ post_process' (Table _ a w h r : Div ("", ["caption"], _) [Para inlines] : xs) = post_process' bs = bs read_body :: OdtReader _x (Pandoc, MediaBag) -read_body = executeIn NsOffice "body" - $ executeIn NsOffice "text" +read_body = executeInSub NsOffice "body" + $ executeInSub NsOffice "text" $ liftAsSuccess $ proc inlines -> do txt <- read_text -< inlines diff --git a/src/Text/Pandoc/Readers/Odt/Generic/XMLConverter.hs b/src/Text/Pandoc/Readers/Odt/Generic/XMLConverter.hs index c45916c03..ccbaf6fc4 100644 --- a/src/Text/Pandoc/Readers/Odt/Generic/XMLConverter.hs +++ b/src/Text/Pandoc/Readers/Odt/Generic/XMLConverter.hs @@ -29,8 +29,10 @@ module Text.Pandoc.Readers.Odt.Generic.XMLConverter , modifyExtraState , producingExtraState , findChild' +, filterChildrenName' , isSet' , isSetWithDefault +, elName , searchAttr , lookupAttr , lookupAttr' @@ -43,6 +45,7 @@ module Text.Pandoc.Readers.Odt.Generic.XMLConverter , readAttrWithDefault , getAttr , executeIn +, executeInSub , withEveryL , tryAll , matchContent' @@ -309,34 +312,44 @@ readNSattributes = fromState $ \state -> maybe (state, failEmpty ) -- | Given a namespace id and an element name, creates a 'XML.QName' for -- internal use -elemName :: (NameSpaceID nsID) +qualifyName :: (NameSpaceID nsID) => nsID -> ElementName -> XMLConverter nsID extraState x XML.QName -elemName nsID name = lookupNSiri nsID +qualifyName nsID name = lookupNSiri nsID &&& lookupNSprefix nsID >>% XML.QName name -- | Checks if a given element matches both a specified namespace id +-- and a predicate +elemNameMatches :: (NameSpaceID nsID) + => nsID -> (ElementName -> Bool) + -> XMLConverter nsID extraState XML.Element Bool +elemNameMatches nsID f = keepingTheValue (lookupNSiri nsID) >>% hasMatchingName + where hasMatchingName e iri = let name = XML.elName e + in f (XML.qName name) + && XML.qURI name == iri + +-- | Checks if a given element matches both a specified namespace id -- and a specified element name elemNameIs :: (NameSpaceID nsID) => nsID -> ElementName -> XMLConverter nsID extraState XML.Element Bool -elemNameIs nsID name = keepingTheValue (lookupNSiri nsID) >>% hasThatName - where hasThatName e iri = let elName = XML.elName e - in XML.qName elName == name - && XML.qURI elName == iri +elemNameIs nsID name = elemNameMatches nsID (== name) -------------------------------------------------------------------------------- -- General content -------------------------------------------------------------------------------- +elName :: XML.Element -> ElementName +elName = XML.qName . XML.elName + -- elContent :: XMLConverter nsID extraState x [XML.Content] elContent = getCurrentElement >>^ XML.elContent -------------------------------------------------------------------------------- --- Chilren +-- Children -------------------------------------------------------------------------------- -- @@ -344,7 +357,7 @@ elContent = getCurrentElement findChildren :: (NameSpaceID nsID) => nsID -> ElementName -> XMLConverter nsID extraState x [XML.Element] -findChildren nsID name = elemName nsID name +findChildren nsID name = qualifyName nsID name &&& getCurrentElement >>% XML.findChildren @@ -353,7 +366,7 @@ findChild' :: (NameSpaceID nsID) => nsID -> ElementName -> XMLConverter nsID extraState x (Maybe XML.Element) -findChild' nsID name = elemName nsID name +findChild' nsID name = qualifyName nsID name &&& getCurrentElement >>% XML.findChild @@ -364,6 +377,14 @@ findChild :: (NameSpaceID nsID) findChild nsID name = findChild' nsID name >>> maybeToChoice +filterChildrenName' :: (NameSpaceID nsID) + => nsID + -> (ElementName -> Bool) + -> XMLConverter nsID extraState x [XML.Element] +filterChildrenName' nsID f = getCurrentElement + >>> arr XML.elChildren + >>> iterateS (keepingTheValue (elemNameMatches nsID f)) + >>> arr (catMaybes . fmap (uncurry $ bool Nothing . Just)) -------------------------------------------------------------------------------- -- Attributes @@ -441,7 +462,7 @@ lookupDefaultingAttr nsID attrName findAttr' :: (NameSpaceID nsID) => nsID -> AttributeName -> XMLConverter nsID extraState x (Maybe AttributeValue) -findAttr' nsID attrName = elemName nsID attrName +findAttr' nsID attrName = qualifyName nsID attrName &&& getCurrentElement >>% XML.findAttr @@ -537,15 +558,21 @@ executeThere a = second jumpThere >>> jumpBack -- >>? jumpBack would not ensure the jump. >>^ collapseEither --- | Do something in a sub-element, tnen come back -executeIn :: (NameSpaceID nsID) - => nsID -> ElementName - -> FallibleXMLConverter nsID extraState f s - -> FallibleXMLConverter nsID extraState f s -executeIn nsID name a = keepingTheValue - (findChild nsID name) - >>> ignoringState liftFailure - >>? switchingTheStack a + +-- | Do something in a specific element, then come back +executeIn :: XMLConverter nsID extraState XML.Element s + -> XMLConverter nsID extraState XML.Element s +executeIn a = duplicate >>> switchingTheStack a + +-- | Do something in a sub-element, then come back +executeInSub :: (NameSpaceID nsID) + => nsID -> ElementName + -> FallibleXMLConverter nsID extraState f s + -> FallibleXMLConverter nsID extraState f s +executeInSub nsID name a = keepingTheValue + (findChild nsID name) + >>> ignoringState liftFailure + >>? switchingTheStack a where liftFailure (_, (Left f)) = Left f liftFailure (x, (Right e)) = Right (x, e) diff --git a/src/Text/Pandoc/Readers/Odt/StyleReader.hs b/src/Text/Pandoc/Readers/Odt/StyleReader.hs index 23ca57786..79e8d7aea 100644 --- a/src/Text/Pandoc/Readers/Odt/StyleReader.hs +++ b/src/Text/Pandoc/Readers/Odt/StyleReader.hs @@ -113,7 +113,7 @@ type StyleReaderSafe a b = XMLReaderSafe FontPitches a b -- | A reader for font pitches fontPitchReader :: XMLReader _s _x FontPitches -fontPitchReader = executeIn NsOffice "font-face-decls" ( +fontPitchReader = executeInSub NsOffice "font-face-decls" ( withEveryL NsStyle "font-face" (liftAsSuccess ( findAttr' NsStyle "name" &&& @@ -423,7 +423,7 @@ readAllStyles = ( readFontPitches -- readStyles :: StyleReader _x Styles -readStyles = executeIn NsOffice "styles" $ liftAsSuccess +readStyles = executeInSub NsOffice "styles" $ liftAsSuccess $ liftA3 Styles ( tryAll NsStyle "style" readStyle >>^ M.fromList ) ( tryAll NsText "list-style" readListStyle >>^ M.fromList ) @@ -431,7 +431,7 @@ readStyles = executeIn NsOffice "styles" $ liftAsSuccess -- readAutomaticStyles :: StyleReader _x Styles -readAutomaticStyles = executeIn NsOffice "automatic-styles" $ liftAsSuccess +readAutomaticStyles = executeInSub NsOffice "automatic-styles" $ liftAsSuccess $ liftA3 Styles ( tryAll NsStyle "style" readStyle >>^ M.fromList ) ( tryAll NsText "list-style" readListStyle >>^ M.fromList ) @@ -462,7 +462,7 @@ readStyleProperties = liftA2 SProps -- readTextProperties :: StyleReader _x TextProperties readTextProperties = - executeIn NsStyle "text-properties" $ liftAsSuccess + executeInSub NsStyle "text-properties" $ liftAsSuccess ( liftA6 PropT ( searchAttr NsXSL_FO "font-style" False isFontEmphasised ) ( searchAttr NsXSL_FO "font-weight" False isFontBold ) @@ -501,7 +501,7 @@ readLineMode modeAttr styleAttr = proc x -> do -- readParaProperties :: StyleReader _x ParaProperties readParaProperties = - executeIn NsStyle "paragraph-properties" $ liftAsSuccess + executeInSub NsStyle "paragraph-properties" $ liftAsSuccess ( liftA3 PropP ( liftA2 readNumbering ( isSet' NsText "number-lines" ) diff --git a/src/Text/Pandoc/Readers/Org/Blocks.hs b/src/Text/Pandoc/Readers/Org/Blocks.hs index 9c409510f..46ddc4257 100644 --- a/src/Text/Pandoc/Readers/Org/Blocks.hs +++ b/src/Text/Pandoc/Readers/Org/Blocks.hs @@ -772,7 +772,7 @@ bulletList = try $ do fmap (B.bulletList . compactify) . sequence <$> many1 (listItem (bulletListStart `indented` indent)) -indented :: Monad m => OrgParser m Int -> Int -> OrgParser m Int +indented :: OrgParser m Int -> Int -> OrgParser m Int indented indentedMarker minIndent = try $ do n <- indentedMarker guard (minIndent <= n) diff --git a/src/Text/Pandoc/Readers/RST.hs b/src/Text/Pandoc/Readers/RST.hs index b54f5ccbf..105d27088 100644 --- a/src/Text/Pandoc/Readers/RST.hs +++ b/src/Text/Pandoc/Readers/RST.hs @@ -645,7 +645,7 @@ directive' = do name = trim $ fromMaybe "" (lookup "name" fields) classes = words $ maybe "" trim (lookup "class" fields) keyvals = [(k, trim v) | (k, v) <- fields, k /= "name", k /= "class"] - imgAttr cl = ("", classes ++ alignClasses, widthAttr ++ heightAttr) + imgAttr cl = (name, classes ++ alignClasses, widthAttr ++ heightAttr) where alignClasses = words $ maybe "" trim (lookup cl fields) ++ maybe "" (\x -> "align-" ++ trim x) diff --git a/src/Text/Pandoc/Readers/TikiWiki.hs b/src/Text/Pandoc/Readers/TikiWiki.hs index 8e01a80f8..5daf6b0bb 100644 --- a/src/Text/Pandoc/Readers/TikiWiki.hs +++ b/src/Text/Pandoc/Readers/TikiWiki.hs @@ -54,10 +54,10 @@ type TikiWikiParser = ParserT [Char] ParserState -- utility functions -- -tryMsg :: PandocMonad m => String -> TikiWikiParser m a -> TikiWikiParser m a +tryMsg :: String -> TikiWikiParser m a -> TikiWikiParser m a tryMsg msg p = try p <?> msg -skip :: PandocMonad m => TikiWikiParser m a -> TikiWikiParser m () +skip :: TikiWikiParser m a -> TikiWikiParser m () skip parser = Control.Monad.void parser nested :: PandocMonad m => TikiWikiParser m a -> TikiWikiParser m a diff --git a/src/Text/Pandoc/Writers/EPUB.hs b/src/Text/Pandoc/Writers/EPUB.hs index 82a6b4403..0f4e338e6 100644 --- a/src/Text/Pandoc/Writers/EPUB.hs +++ b/src/Text/Pandoc/Writers/EPUB.hs @@ -41,6 +41,7 @@ import qualified Text.Pandoc.Class as P import Data.Time import Text.Pandoc.Definition import Text.Pandoc.Error +import Text.Pandoc.ImageSize import Text.Pandoc.Logging import Text.Pandoc.MIME (MimeType, extensionFromMimeType, getMimeType) import Text.Pandoc.Options (EPUBVersion (..), HTMLMathMethod (..), @@ -451,14 +452,23 @@ pandocToEPUB version opts doc = do Nothing -> return ([],[]) Just img -> do let coverImage = takeFileName img + imgContent <- lift $ P.readFileLazy img + (coverImageWidth, coverImageHeight) <- + case imageSize opts' (B.toStrict imgContent) of + Right sz -> return $ sizeInPixels sz + Left err' -> (0, 0) <$ report + (CouldNotDetermineImageSize img err') cpContent <- lift $ writeHtml opts'{ writerVariables = ("coverpage","true"): ("pagetitle", escapeStringForXML plainTitle): + ("cover-image", coverImage): + ("cover-image-width", show coverImageWidth): + ("cover-image-height", + show coverImageHeight): cssvars True ++ vars } - (Pandoc meta [RawBlock (Format "html") $ "<div id=\"cover-image\">\n<img src=\"../media/" ++ coverImage ++ "\" alt=\"cover image\" />\n</div>"]) - imgContent <- lift $ P.readFileLazy img + (Pandoc meta []) coverEntry <- mkEntry "text/cover.xhtml" cpContent coverImageEntry <- mkEntry ("media/" ++ coverImage) imgContent diff --git a/src/Text/Pandoc/Writers/HTML.hs b/src/Text/Pandoc/Writers/HTML.hs index ca44583ab..241479157 100644 --- a/src/Text/Pandoc/Writers/HTML.hs +++ b/src/Text/Pandoc/Writers/HTML.hs @@ -621,6 +621,7 @@ toAttrs kvs = do if x `Set.member` (html5Attributes <> rdfaAttributes) || ':' `elem` x -- e.g. epub: namespace || "data-" `isPrefixOf` x + || "aria-" `isPrefixOf` x then Just $ customAttribute (fromString x) (toValue y) else Just $ customAttribute (fromString ("data-" ++ x)) (toValue y) diff --git a/src/Text/Pandoc/Writers/JATS.hs b/src/Text/Pandoc/Writers/JATS.hs index 145d37bee..61a68d543 100644 --- a/src/Text/Pandoc/Writers/JATS.hs +++ b/src/Text/Pandoc/Writers/JATS.hs @@ -88,7 +88,9 @@ docToJATS opts (Pandoc meta blocks) = do mapM (elementToJATS opts' startLvl) elements notes <- reverse . map snd <$> gets jatsNotes backs <- mapM (elementToJATS opts' startLvl) backElements - let fns = inTagsIndented "fn-group" $ vcat notes + let fns = if null notes + then mempty + else inTagsIndented "fn-group" $ vcat notes let back = render' $ vcat backs $$ fns let date = case getField "date" metadata -- an object `mplus` diff --git a/src/Text/Pandoc/Writers/Man.hs b/src/Text/Pandoc/Writers/Man.hs index ed8682a84..506461fac 100644 --- a/src/Text/Pandoc/Writers/Man.hs +++ b/src/Text/Pandoc/Writers/Man.hs @@ -26,6 +26,7 @@ import Text.Pandoc.Logging import Text.Pandoc.Options import Text.Pandoc.Pretty import Text.Pandoc.Shared +import Text.Pandoc.Walk (walk) import Text.Pandoc.Templates import Text.Pandoc.Writers.Math import Text.Pandoc.Writers.Shared @@ -228,7 +229,9 @@ definitionListItemToMan :: PandocMonad m -> ([Inline],[[Block]]) -> StateT WriterState m Doc definitionListItemToMan opts (label, defs) = do - labelText <- inlineListToMan opts label + -- in most man pages, option and other code in option lists is boldface, + -- but not other things, so we try to reproduce this style: + labelText <- inlineListToMan opts $ makeCodeBold label contents <- if null defs then return empty else liftM vcat $ forM defs $ \blocks -> @@ -245,7 +248,12 @@ definitionListItemToMan opts (label, defs) = do then empty else text ".RS" $$ rest' $$ text ".RE" [] -> return empty - return $ text ".TP" $$ nowrap (text ".B " <> labelText) $$ contents + return $ text ".TP" $$ nowrap labelText $$ contents + +makeCodeBold :: [Inline] -> [Inline] +makeCodeBold = walk go + where go x@(Code{}) = Strong [x] + go x = x -- | Convert list of Pandoc block elements to man. blockListToMan :: PandocMonad m diff --git a/src/Text/Pandoc/Writers/Shared.hs b/src/Text/Pandoc/Writers/Shared.hs index 1f55be797..a9163b3b9 100644 --- a/src/Text/Pandoc/Writers/Shared.hs +++ b/src/Text/Pandoc/Writers/Shared.hs @@ -63,7 +63,7 @@ import Text.Pandoc.XML (escapeStringForXML) -- Variables overwrite metadata fields with the same names. -- If multiple variables are set with the same name, a list is -- assigned. Does nothing if 'writerTemplate' is Nothing. -metaToJSON :: (Functor m, Monad m, ToJSON a) +metaToJSON :: (Monad m, ToJSON a) => WriterOptions -> ([Block] -> m a) -> ([Inline] -> m a) @@ -76,7 +76,7 @@ metaToJSON opts blockWriter inlineWriter meta -- | Like 'metaToJSON', but does not include variables and is -- not sensitive to 'writerTemplate'. -metaToJSON' :: (Functor m, Monad m, ToJSON a) +metaToJSON' :: (Monad m, ToJSON a) => ([Block] -> m a) -> ([Inline] -> m a) -> Meta @@ -99,7 +99,7 @@ addVariablesToJSON opts metadata = where combineMetadata (Object o1) (Object o2) = Object $ H.union o1 o2 combineMetadata x _ = x -metaValueToJSON :: (Functor m, Monad m, ToJSON a) +metaValueToJSON :: (Monad m, ToJSON a) => ([Block] -> m a) -> ([Inline] -> m a) -> MetaValue |