aboutsummaryrefslogtreecommitdiff
path: root/src/Text/Pandoc
diff options
context:
space:
mode:
authorJesse Rosenthal <jrosenthal@jhu.edu>2016-11-28 17:13:46 -0500
committerJohn MacFarlane <jgm@berkeley.edu>2017-01-25 17:07:40 +0100
commitb53ebcdf8e8e1f7098a0c93ead4b5bf99971c77f (patch)
tree01e8d78b85f68e88a737baec9e6bbc932f0a84be /src/Text/Pandoc
parent840439ab2a4d44bc4d295df0d66003fbcc9bb18e (diff)
downloadpandoc-b53ebcdf8e8e1f7098a0c93ead4b5bf99971c77f.tar.gz
Working on readers.
Diffstat (limited to 'src/Text/Pandoc')
-rw-r--r--src/Text/Pandoc/Class.hs10
-rw-r--r--src/Text/Pandoc/Readers/CommonMark.hs7
-rw-r--r--src/Text/Pandoc/Readers/DocBook.hs32
-rw-r--r--src/Text/Pandoc/Readers/Docx.hs96
-rw-r--r--src/Text/Pandoc/Readers/EPUB.hs50
-rw-r--r--src/Text/Pandoc/Readers/HTML.hs213
-rw-r--r--src/Text/Pandoc/Readers/Haddock.hs19
-rw-r--r--src/Text/Pandoc/Readers/LaTeX.hs203
-rw-r--r--src/Text/Pandoc/Readers/Markdown.hs478
-rw-r--r--src/Text/Pandoc/Readers/MediaWiki.hs146
-rw-r--r--src/Text/Pandoc/Readers/Native.hs7
-rw-r--r--src/Text/Pandoc/Readers/OPML.hs36
-rw-r--r--src/Text/Pandoc/Readers/Odt.hs22
-rw-r--r--src/Text/Pandoc/Readers/Org.hs20
-rw-r--r--src/Text/Pandoc/Readers/Org/BlockStarts.hs33
-rw-r--r--src/Text/Pandoc/Readers/Org/Blocks.hs163
-rw-r--r--src/Text/Pandoc/Readers/Org/ExportSettings.hs33
-rw-r--r--src/Text/Pandoc/Readers/Org/Inlines.hs246
-rw-r--r--src/Text/Pandoc/Readers/Org/Meta.hs45
-rw-r--r--src/Text/Pandoc/Readers/Org/ParserState.hs4
-rw-r--r--src/Text/Pandoc/Readers/Org/Parsing.hs36
-rw-r--r--src/Text/Pandoc/Readers/RST.hs245
-rw-r--r--src/Text/Pandoc/Readers/TWiki.hs25
-rw-r--r--src/Text/Pandoc/Readers/Textile.hs176
-rw-r--r--src/Text/Pandoc/Readers/Txt2Tags.hs45
25 files changed, 1279 insertions, 1111 deletions
diff --git a/src/Text/Pandoc/Class.hs b/src/Text/Pandoc/Class.hs
index 12e6f900b..5cef621dc 100644
--- a/src/Text/Pandoc/Class.hs
+++ b/src/Text/Pandoc/Class.hs
@@ -35,6 +35,7 @@ module Text.Pandoc.Class ( PandocMonad(..)
, PureState(..)
, PureEnv(..)
, getPOSIXTime
+ , addWarningWithPos
, PandocIO(..)
, PandocPure(..)
, PandocExecutionError(..)
@@ -57,6 +58,7 @@ import qualified Text.Pandoc.Shared as IO ( fetchItem
, warn
, readDataFile)
import Text.Pandoc.Compat.Time (UTCTime)
+import Text.Pandoc.Parsing (ParserT, ParserState, SourcePos)
import qualified Text.Pandoc.Compat.Time as IO (getCurrentTime)
import Data.Time.Clock.POSIX ( utcTimeToPOSIXSeconds
, posixSecondsToUTCTime
@@ -109,6 +111,14 @@ class (Functor m, Applicative m, Monad m, MonadError PandocExecutionError m) =>
getPOSIXTime :: (PandocMonad m) => m POSIXTime
getPOSIXTime = utcTimeToPOSIXSeconds <$> getCurrentTime
+addWarningWithPos :: PandocMonad m
+ => Maybe SourcePos
+ -> String
+ -> ParserT [Char] ParserState m ()
+addWarningWithPos mbpos msg =
+ lift $
+ warn $
+ msg ++ maybe "" (\pos -> " " ++ show pos) mbpos
-- We can add to this as we go
data PandocExecutionError = PandocFileReadError FilePath
diff --git a/src/Text/Pandoc/Readers/CommonMark.hs b/src/Text/Pandoc/Readers/CommonMark.hs
index d20d386e7..38c54c8dc 100644
--- a/src/Text/Pandoc/Readers/CommonMark.hs
+++ b/src/Text/Pandoc/Readers/CommonMark.hs
@@ -37,11 +37,12 @@ import Data.Text (unpack, pack)
import Data.List (groupBy)
import Text.Pandoc.Definition
import Text.Pandoc.Options
-import Text.Pandoc.Error
+import Text.Pandoc.Class (PandocMonad)
-- | Parse a CommonMark formatted string into a 'Pandoc' structure.
-readCommonMark :: ReaderOptions -> String -> Either PandocError Pandoc
-readCommonMark opts = Right . nodeToPandoc . commonmarkToNode opts' . pack
+readCommonMark :: PandocMonad m => ReaderOptions -> String -> m Pandoc
+readCommonMark opts s = return $
+ nodeToPandoc $ commonmarkToNode opts' $ pack s
where opts' = if readerSmart opts
then [optNormalize, optSmart]
else [optNormalize]
diff --git a/src/Text/Pandoc/Readers/DocBook.hs b/src/Text/Pandoc/Readers/DocBook.hs
index 68552ccb3..bef256a93 100644
--- a/src/Text/Pandoc/Readers/DocBook.hs
+++ b/src/Text/Pandoc/Readers/DocBook.hs
@@ -13,10 +13,9 @@ import Control.Monad.State
import Data.List (intersperse)
import Data.Maybe (fromMaybe)
import Text.TeXMath (readMathML, writeTeX)
-import Text.Pandoc.Error (PandocError)
-import Control.Monad.Except
import Data.Default
import Data.Foldable (asum)
+import Text.Pandoc.Class (PandocMonad)
{-
@@ -502,7 +501,7 @@ List of all DocBook tags, with [x] indicating implemented,
[x] ?asciidoc-br? - line break from asciidoc docbook output
-}
-type DB = ExceptT PandocError (State DBState)
+type DB m = StateT DBState m
data DBState = DBState{ dbSectionLevel :: Int
, dbQuoteType :: QuoteType
@@ -523,10 +522,11 @@ instance Default DBState where
, dbContent = [] }
-readDocBook :: ReaderOptions -> String -> Either PandocError Pandoc
-readDocBook _ inp = (\blocks -> Pandoc (dbMeta st') (toList . mconcat $ blocks)) <$> bs
- where (bs , st') = flip runState (def{ dbContent = tree }) . runExceptT . mapM parseBlock $ tree
- tree = normalizeTree . parseXML . handleInstructions $ inp
+readDocBook :: PandocMonad m => ReaderOptions -> String -> m Pandoc
+readDocBook _ inp = do
+ let tree = normalizeTree . parseXML . handleInstructions $ inp
+ (bs, st') <- flip runStateT (def{ dbContent = tree }) $ mapM parseBlock $ tree
+ return $ Pandoc (dbMeta st') (toList . mconcat $ bs)
-- We treat <?asciidoc-br?> specially (issue #1236), converting it
-- to <br/>, since xml-light doesn't parse the instruction correctly.
@@ -538,7 +538,7 @@ handleInstructions xs = case break (=='<') xs of
([], '<':zs) -> '<' : handleInstructions zs
(ys, zs) -> ys ++ handleInstructions zs
-getFigure :: Element -> DB Blocks
+getFigure :: PandocMonad m => Element -> DB m Blocks
getFigure e = do
tit <- case filterChild (named "title") e of
Just t -> getInlines t
@@ -579,20 +579,20 @@ named s e = qName (elName e) == s
--
-acceptingMetadata :: DB a -> DB a
+acceptingMetadata :: PandocMonad m => DB m a -> DB m a
acceptingMetadata p = do
modify (\s -> s { dbAcceptsMeta = True } )
res <- p
modify (\s -> s { dbAcceptsMeta = False })
return res
-checkInMeta :: Monoid a => DB () -> DB a
+checkInMeta :: (PandocMonad m, Monoid a) => DB m () -> DB m a
checkInMeta p = do
accepts <- dbAcceptsMeta <$> get
when accepts p
return mempty
-addMeta :: ToMetaValue a => String -> a -> DB ()
+addMeta :: PandocMonad m => ToMetaValue a => String -> a -> DB m ()
addMeta field val = modify (setMeta field val)
instance HasMeta DBState where
@@ -631,7 +631,7 @@ addToStart toadd bs =
-- function that is used by both mediaobject (in parseBlock)
-- and inlinemediaobject (in parseInline)
-- A DocBook mediaobject is a wrapper around a set of alternative presentations
-getMediaobject :: Element -> DB Inlines
+getMediaobject :: PandocMonad m => Element -> DB m Inlines
getMediaobject e = do
(imageUrl, attr) <-
case filterChild (named "imageobject") e of
@@ -658,11 +658,11 @@ getMediaobject e = do
else (return figTitle, "fig:")
liftM (imageWith attr imageUrl title) caption
-getBlocks :: Element -> DB Blocks
+getBlocks :: PandocMonad m => Element -> DB m Blocks
getBlocks e = mconcat <$> (mapM parseBlock $ elContent e)
-parseBlock :: Content -> DB Blocks
+parseBlock :: PandocMonad m => Content -> DB m Blocks
parseBlock (Text (CData CDataRaw _ _)) = return mempty -- DOCTYPE
parseBlock (Text (CData _ s _)) = if all isSpace s
then return mempty
@@ -902,7 +902,7 @@ parseBlock (Elem e) =
lineItems = mapM getInlines $ filterChildren (named "line") e
metaBlock = acceptingMetadata (getBlocks e) >> return mempty
-getInlines :: Element -> DB Inlines
+getInlines :: PandocMonad m => Element -> DB m Inlines
getInlines e' = (trimInlines . mconcat) <$> (mapM parseInline $ elContent e')
strContentRecursive :: Element -> String
@@ -913,7 +913,7 @@ elementToStr :: Content -> Content
elementToStr (Elem e') = Text $ CData CDataText (strContentRecursive e') Nothing
elementToStr x = x
-parseInline :: Content -> DB Inlines
+parseInline :: PandocMonad m => Content -> DB m Inlines
parseInline (Text (CData _ s _)) = return $ text s
parseInline (CRef ref) =
return $ maybe (text $ map toUpper ref) (text) $ lookupEntity ref
diff --git a/src/Text/Pandoc/Readers/Docx.hs b/src/Text/Pandoc/Readers/Docx.hs
index a43043d84..87b64d544 100644
--- a/src/Text/Pandoc/Readers/Docx.hs
+++ b/src/Text/Pandoc/Readers/Docx.hs
@@ -82,7 +82,7 @@ import Text.Pandoc.Readers.Docx.Parse
import Text.Pandoc.Readers.Docx.Lists
import Text.Pandoc.Readers.Docx.Combine
import Text.Pandoc.Shared
-import Text.Pandoc.MediaBag (insertMedia, MediaBag)
+import Text.Pandoc.MediaBag (MediaBag)
import Data.List (delete, intersect)
import Text.TeXMath (writeTeX)
import Data.Default (Default)
@@ -96,27 +96,28 @@ import qualified Data.Sequence as Seq (null)
#if !(MIN_VERSION_base(4,8,0))
import Data.Traversable (traverse)
#endif
+import Control.Monad.Except (throwError)
+import Text.Pandoc.Class (PandocMonad, PandocExecutionError(..))
+import qualified Text.Pandoc.Class as P
-import Text.Pandoc.Error
-import Control.Monad.Except
-
-readDocxWithWarnings :: ReaderOptions
- -> B.ByteString
- -> Either PandocError (Pandoc, MediaBag, [String])
-readDocxWithWarnings opts bytes
+readDocx :: PandocMonad m
+ => ReaderOptions
+ -> B.ByteString
+ -> m Pandoc
+readDocx opts bytes
| Right archive <- toArchiveOrFail bytes
, Right (docx, parserWarnings) <- archiveToDocxWithWarnings archive = do
- (meta, blks, mediaBag, warnings) <- docxToOutput opts docx
- return (Pandoc meta blks, mediaBag, parserWarnings ++ warnings)
-readDocxWithWarnings _ _ =
- Left (ParseFailure "couldn't parse docx file")
-
-readDocx :: ReaderOptions
+ mapM_ P.warn parserWarnings
+ (meta, blks) <- docxToOutput opts docx
+ return $ Pandoc meta blks
+readDocx _ _ =
+ throwError $ PandocSomeError "couldn't parse docx file"
+
+readDocxWithWarnings :: PandocMonad m
+ => ReaderOptions
-> B.ByteString
- -> Either PandocError (Pandoc, MediaBag)
-readDocx opts bytes = do
- (pandoc, mediaBag, _) <- readDocxWithWarnings opts bytes
- return (pandoc, mediaBag)
+ -> m Pandoc
+readDocxWithWarnings = readDocx
data DState = DState { docxAnchorMap :: M.Map String String
, docxMediaBag :: MediaBag
@@ -137,15 +138,10 @@ data DEnv = DEnv { docxOptions :: ReaderOptions
instance Default DEnv where
def = DEnv def False
-type DocxContext = ExceptT PandocError (ReaderT DEnv (State DState))
+type DocxContext m = ReaderT DEnv (StateT DState m)
-evalDocxContext :: DocxContext a -> DEnv -> DState -> Either PandocError a
-evalDocxContext ctx env st = flip evalState st . flip runReaderT env . runExceptT $ ctx
-
-addDocxWarning :: String -> DocxContext ()
-addDocxWarning msg = do
- warnings <- gets docxWarnings
- modify $ \s -> s {docxWarnings = msg : warnings}
+evalDocxContext :: PandocMonad m => DocxContext m a -> DEnv -> DState -> m a
+evalDocxContext ctx env st = flip evalStateT st $ flip runReaderT env $ ctx
-- This is empty, but we put it in for future-proofing.
spansToKeep :: [String]
@@ -179,7 +175,7 @@ isEmptyPar (Paragraph _ parParts) =
isEmptyElem _ = True
isEmptyPar _ = False
-bodyPartsToMeta' :: [BodyPart] -> DocxContext (M.Map String MetaValue)
+bodyPartsToMeta' :: PandocMonad m => [BodyPart] -> DocxContext m (M.Map String MetaValue)
bodyPartsToMeta' [] = return M.empty
bodyPartsToMeta' (bp : bps)
| (Paragraph pPr parParts) <- bp
@@ -195,7 +191,7 @@ bodyPartsToMeta' (bp : bps)
return $ M.insertWith f metaField (MetaInlines (toList inlines)) remaining
bodyPartsToMeta' (_ : bps) = bodyPartsToMeta' bps
-bodyPartsToMeta :: [BodyPart] -> DocxContext Meta
+bodyPartsToMeta :: PandocMonad m => [BodyPart] -> DocxContext m Meta
bodyPartsToMeta bps = do
mp <- bodyPartsToMeta' bps
let mp' =
@@ -297,7 +293,7 @@ runStyleToTransform rPr
emph . (runStyleToTransform rPr {rUnderline = Nothing})
| otherwise = id
-runToInlines :: Run -> DocxContext Inlines
+runToInlines :: PandocMonad m => Run -> DocxContext m Inlines
runToInlines (Run rs runElems)
| Just (s, _) <- rStyle rs
, s `elem` codeStyles =
@@ -318,8 +314,7 @@ runToInlines (Endnote bps) = do
blksList <- smushBlocks <$> (mapM bodyPartToBlocks bps)
return $ note blksList
runToInlines (InlineDrawing fp title alt bs ext) = do
- mediaBag <- gets docxMediaBag
- modify $ \s -> s { docxMediaBag = insertMedia fp Nothing bs mediaBag }
+ (lift . lift) $ P.insertMedia fp Nothing bs
return $ imageWith (extentToAttr ext) fp title $ text alt
runToInlines InlineChart = return $ spanWith ("", ["chart"], []) $ text "[CHART]"
@@ -330,7 +325,7 @@ extentToAttr (Just (w, h)) =
showDim d = show (d / 914400) ++ "in"
extentToAttr _ = nullAttr
-blocksToInlinesWarn :: String -> Blocks -> DocxContext Inlines
+blocksToInlinesWarn :: PandocMonad m => String -> Blocks -> DocxContext m Inlines
blocksToInlinesWarn cmtId blks = do
let blkList = toList blks
notParaOrPlain :: Block -> Bool
@@ -338,10 +333,10 @@ blocksToInlinesWarn cmtId blks = do
notParaOrPlain (Plain _) = False
notParaOrPlain _ = True
when (not $ null $ filter notParaOrPlain blkList)
- (addDocxWarning $ "Docx comment " ++ cmtId ++ " will not retain formatting")
+ ((lift . lift) $ P.warn $ "Docx comment " ++ cmtId ++ " will not retain formatting")
return $ fromList $ blocksToInlines blkList
-parPartToInlines :: ParPart -> DocxContext Inlines
+parPartToInlines :: PandocMonad m => ParPart -> DocxContext m Inlines
parPartToInlines (PlainRun r) = runToInlines r
parPartToInlines (Insertion _ author date runs) = do
opts <- asks docxOptions
@@ -403,8 +398,7 @@ parPartToInlines (BookMark _ anchor) =
(modify $ \s -> s { docxAnchorMap = M.insert anchor newAnchor anchorMap})
return $ spanWith (newAnchor, ["anchor"], []) mempty
parPartToInlines (Drawing fp title alt bs ext) = do
- mediaBag <- gets docxMediaBag
- modify $ \s -> s { docxMediaBag = insertMedia fp Nothing bs mediaBag }
+ (lift . lift) $ P.insertMedia fp Nothing bs
return $ imageWith (extentToAttr ext) fp title $ text alt
parPartToInlines Chart = do
return $ spanWith ("", ["chart"], []) $ text "[CHART]"
@@ -426,10 +420,10 @@ isAnchorSpan _ = False
dummyAnchors :: [String]
dummyAnchors = ["_GoBack"]
-makeHeaderAnchor :: Blocks -> DocxContext Blocks
+makeHeaderAnchor :: PandocMonad m => Blocks -> DocxContext m Blocks
makeHeaderAnchor bs = traverse makeHeaderAnchor' bs
-makeHeaderAnchor' :: Block -> DocxContext Block
+makeHeaderAnchor' :: PandocMonad m => Block -> DocxContext m Block
-- If there is an anchor already there (an anchor span in the header,
-- to be exact), we rename and associate the new id with the old one.
makeHeaderAnchor' (Header n (ident, classes, kvs) ils)
@@ -463,12 +457,12 @@ singleParaToPlain blks
singleton $ Plain ils
singleParaToPlain blks = blks
-cellToBlocks :: Cell -> DocxContext Blocks
+cellToBlocks :: PandocMonad m => Cell -> DocxContext m Blocks
cellToBlocks (Cell bps) = do
blks <- smushBlocks <$> mapM bodyPartToBlocks bps
return $ fromList $ blocksToDefinitions $ blocksToBullets $ toList blks
-rowToBlocksList :: Row -> DocxContext [Blocks]
+rowToBlocksList :: PandocMonad m => Row -> DocxContext m [Blocks]
rowToBlocksList (Row cells) = do
blksList <- mapM cellToBlocks cells
return $ map singleParaToPlain blksList
@@ -518,7 +512,7 @@ parStyleToTransform pPr
False -> parStyleToTransform pPr'
parStyleToTransform _ = id
-bodyPartToBlocks :: BodyPart -> DocxContext Blocks
+bodyPartToBlocks :: PandocMonad m => BodyPart -> DocxContext m Blocks
bodyPartToBlocks (Paragraph pPr parparts)
| not $ null $ codeDivs `intersect` (pStyle pPr) =
return
@@ -597,7 +591,7 @@ bodyPartToBlocks (OMathPara e) = do
-- replace targets with generated anchors.
-rewriteLink' :: Inline -> DocxContext Inline
+rewriteLink' :: PandocMonad m => Inline -> DocxContext m Inline
rewriteLink' l@(Link attr ils ('#':target, title)) = do
anchorMap <- gets docxAnchorMap
return $ case M.lookup target anchorMap of
@@ -605,23 +599,21 @@ rewriteLink' l@(Link attr ils ('#':target, title)) = do
Nothing -> l
rewriteLink' il = return il
-rewriteLinks :: [Block] -> DocxContext [Block]
+rewriteLinks :: PandocMonad m => [Block] -> DocxContext m [Block]
rewriteLinks = mapM (walkM rewriteLink')
-bodyToOutput :: Body -> DocxContext (Meta, [Block], MediaBag, [String])
+bodyToOutput :: PandocMonad m => Body -> DocxContext m (Meta, [Block])
bodyToOutput (Body bps) = do
let (metabps, blkbps) = sepBodyParts bps
meta <- bodyPartsToMeta metabps
blks <- smushBlocks <$> mapM bodyPartToBlocks blkbps
blks' <- rewriteLinks $ blocksToDefinitions $ blocksToBullets $ toList blks
- mediaBag <- gets docxMediaBag
- warnings <- gets docxWarnings
- return $ (meta,
- blks',
- mediaBag,
- warnings)
-
-docxToOutput :: ReaderOptions -> Docx -> Either PandocError (Meta, [Block], MediaBag, [String])
+ return $ (meta, blks')
+
+docxToOutput :: PandocMonad m
+ => ReaderOptions
+ -> Docx
+ -> m (Meta, [Block])
docxToOutput opts (Docx (Document _ body)) =
let dEnv = def { docxOptions = opts} in
evalDocxContext (bodyToOutput body) dEnv def
diff --git a/src/Text/Pandoc/Readers/EPUB.hs b/src/Text/Pandoc/Readers/EPUB.hs
index 4c31bf1ae..0dbe87052 100644
--- a/src/Text/Pandoc/Readers/EPUB.hs
+++ b/src/Text/Pandoc/Readers/EPUB.hs
@@ -11,13 +11,12 @@ module Text.Pandoc.Readers.EPUB
import Text.XML.Light
import Text.Pandoc.Definition hiding (Attr)
import Text.Pandoc.Readers.HTML (readHtml)
-import Text.Pandoc.Error
import Text.Pandoc.Walk (walk, query)
import Text.Pandoc.Options ( ReaderOptions(..), readerTrace)
import Text.Pandoc.Shared (escapeURI, collapseFilePath, addMetaField)
import Network.URI (unEscapeString)
import Text.Pandoc.MediaBag (MediaBag, insertMedia)
-import Control.Monad.Except (MonadError, throwError, runExcept, Except)
+import Control.Monad.Except (throwError)
import Text.Pandoc.MIME (MimeType)
import qualified Text.Pandoc.Builder as B
import Codec.Archive.Zip ( Archive (..), toArchiveOrFail, fromEntry
@@ -33,23 +32,25 @@ import Data.Maybe (mapMaybe, fromMaybe)
import qualified Data.Map as M (Map, lookup, fromList, elems)
import Data.Monoid ((<>))
import Control.DeepSeq (deepseq, NFData)
+import Text.Pandoc.Class (PandocMonad, PandocExecutionError(..))
+import qualified Text.Pandoc.Class as P
import Debug.Trace (trace)
type Items = M.Map String (FilePath, MimeType)
-readEPUB :: ReaderOptions -> BL.ByteString -> Either PandocError (Pandoc, MediaBag)
+readEPUB :: PandocMonad m => ReaderOptions -> BL.ByteString -> m Pandoc
readEPUB opts bytes = case toArchiveOrFail bytes of
- Right archive -> runEPUB $ archiveToEPUB opts $ archive
- Left _ -> Left $ ParseFailure "Couldn't extract ePub file"
+ Right archive -> archiveToEPUB opts $ archive
+ Left _ -> throwError $ PandocParseError "Couldn't extract ePub file"
-runEPUB :: Except PandocError a -> Either PandocError a
-runEPUB = runExcept
+-- runEPUB :: Except PandocError a -> Either PandocError a
+-- runEPUB = runExcept
-- Note that internal reference are aggresively normalised so that all ids
-- are of the form "filename#id"
--
-archiveToEPUB :: (MonadError PandocError m) => ReaderOptions -> Archive -> m (Pandoc, MediaBag)
+archiveToEPUB :: (PandocMonad m) => ReaderOptions -> Archive -> m Pandoc
archiveToEPUB os archive = do
-- root is path to folder with manifest file in
(root, content) <- getManifest archive
@@ -63,24 +64,21 @@ archiveToEPUB os archive = do
foldM' (\a b -> ((a <>) . walk (prependHash escapedSpine))
`liftM` parseSpineElem root b) mempty spine
let ast = coverDoc <> (Pandoc meta bs)
- let mediaBag = fetchImages (M.elems items) root archive ast
- return $ (ast, mediaBag)
+ P.setMediaBag $ fetchImages (M.elems items) root archive ast
+ return ast
where
os' = os {readerParseRaw = True}
- parseSpineElem :: MonadError PandocError m => FilePath -> (FilePath, MimeType) -> m Pandoc
+ parseSpineElem :: PandocMonad m => FilePath -> (FilePath, MimeType) -> m Pandoc
parseSpineElem (normalise -> r) (normalise -> path, mime) = do
when (readerTrace os) (traceM path)
doc <- mimeToReader mime r path
let docSpan = B.doc $ B.para $ B.spanWith (takeFileName path, [], []) mempty
return $ docSpan <> doc
- mimeToReader :: MonadError PandocError m => MimeType -> FilePath -> FilePath -> m Pandoc
+ mimeToReader :: PandocMonad m => MimeType -> FilePath -> FilePath -> m Pandoc
mimeToReader "application/xhtml+xml" (unEscapeString -> root)
(unEscapeString -> path) = do
fname <- findEntryByPathE (root </> path) archive
- html <- either throwError return .
- readHtml os' .
- UTF8.toStringLazy $
- fromEntry fname
+ html <- readHtml os' . UTF8.toStringLazy $ fromEntry fname
return $ fixInternalReferences path html
mimeToReader s _ (unEscapeString -> path)
| s `elem` imageMimes = return $ imageToPandoc path
@@ -121,7 +119,7 @@ imageMimes = ["image/gif", "image/jpeg", "image/png"]
type CoverImage = FilePath
-parseManifest :: (MonadError PandocError m) => Element -> m (Maybe CoverImage, Items)
+parseManifest :: (PandocMonad m) => Element -> m (Maybe CoverImage, Items)
parseManifest content = do
manifest <- findElementE (dfName "manifest") content
let items = findChildren (dfName "item") manifest
@@ -137,7 +135,7 @@ parseManifest content = do
mime <- findAttrE (emptyName "media-type") e
return (uid, (href, mime))
-parseSpine :: MonadError PandocError m => Items -> Element -> m [(FilePath, MimeType)]
+parseSpine :: PandocMonad m => Items -> Element -> m [(FilePath, MimeType)]
parseSpine is e = do
spine <- findElementE (dfName "spine") e
let itemRefs = findChildren (dfName "itemref") spine
@@ -148,7 +146,7 @@ parseSpine is e = do
guard linear
findAttr (emptyName "idref") ref
-parseMeta :: MonadError PandocError m => Element -> m Meta
+parseMeta :: PandocMonad m => Element -> m Meta
parseMeta content = do
meta <- findElementE (dfName "metadata") content
let dcspace (QName _ (Just "http://purl.org/dc/elements/1.1/") (Just "dc")) = True
@@ -166,7 +164,7 @@ renameMeta :: String -> String
renameMeta "creator" = "author"
renameMeta s = s
-getManifest :: MonadError PandocError m => Archive -> m (String, Element)
+getManifest :: PandocMonad m => Archive -> m (String, Element)
getManifest archive = do
metaEntry <- findEntryByPathE ("META-INF" </> "container.xml") archive
docElem <- (parseXMLDocE . UTF8.toStringLazy . fromEntry) metaEntry
@@ -268,18 +266,18 @@ emptyName s = QName s Nothing Nothing
-- Convert Maybe interface to Either
-findAttrE :: MonadError PandocError m => QName -> Element -> m String
+findAttrE :: PandocMonad m => QName -> Element -> m String
findAttrE q e = mkE "findAttr" $ findAttr q e
-findEntryByPathE :: MonadError PandocError m => FilePath -> Archive -> m Entry
+findEntryByPathE :: PandocMonad m => FilePath -> Archive -> m Entry
findEntryByPathE (normalise -> path) a =
mkE ("No entry on path: " ++ path) $ findEntryByPath path a
-parseXMLDocE :: MonadError PandocError m => String -> m Element
+parseXMLDocE :: PandocMonad m => String -> m Element
parseXMLDocE doc = mkE "Unable to parse XML doc" $ parseXMLDoc doc
-findElementE :: MonadError PandocError m => QName -> Element -> m Element
+findElementE :: PandocMonad m => QName -> Element -> m Element
findElementE e x = mkE ("Unable to find element: " ++ show e) $ findElement e x
-mkE :: MonadError PandocError m => String -> Maybe a -> m a
-mkE s = maybe (throwError . ParseFailure $ s) return
+mkE :: PandocMonad m => String -> Maybe a -> m a
+mkE s = maybe (throwError . PandocParseError $ s) return
diff --git a/src/Text/Pandoc/Readers/HTML.hs b/src/Text/Pandoc/Readers/HTML.hs
index abe5f66ce..ef28ff739 100644
--- a/src/Text/Pandoc/Readers/HTML.hs
+++ b/src/Text/Pandoc/Readers/HTML.hs
@@ -44,7 +44,7 @@ import Text.Pandoc.Definition
import qualified Text.Pandoc.Builder as B
import Text.Pandoc.Builder (Blocks, Inlines, trimInlines, HasMeta(..))
import Text.Pandoc.Shared ( extractSpaces, renderTags', addMetaField
- , escapeURI, safeRead, mapLeft )
+ , escapeURI, safeRead )
import Text.Pandoc.Options (ReaderOptions(readerParseRaw, readerTrace)
, Extension (Ext_epub_html_exts,
Ext_native_divs, Ext_native_spans))
@@ -62,38 +62,46 @@ import Text.Printf (printf)
import Debug.Trace (trace)
import Text.TeXMath (readMathML, writeTeX)
import Data.Default (Default (..), def)
-import Control.Monad.Reader (Reader,ask, asks, local, runReader)
+import Control.Monad.Reader (ask, asks, local, ReaderT, runReaderT, lift)
import Network.URI (URI, parseURIReference, nonStrictRelativeTo)
-import Text.Pandoc.Error
import Text.Pandoc.CSS (foldOrElse, pickStyleAttrProps)
import Data.Monoid ((<>))
import Text.Parsec.Error
import qualified Data.Set as Set
+import Text.Pandoc.Class (PandocMonad, PandocExecutionError(..))
+import Control.Monad.Except (throwError)
+
-- | Convert HTML-formatted string to 'Pandoc' document.
-readHtml :: ReaderOptions -- ^ Reader options
+readHtml :: PandocMonad m
+ => ReaderOptions -- ^ Reader options
-> String -- ^ String to parse (assumes @'\n'@ line endings)
- -> Either PandocError Pandoc
-readHtml opts inp =
- mapLeft (ParseFailure . getError) . flip runReader def $
- runParserT parseDoc
- (HTMLState def{ stateOptions = opts } [] Nothing Set.empty M.empty)
- "source" tags
- where tags = stripPrefixes . canonicalizeTags $
- parseTagsOptions parseOptions{ optTagPosition = True } inp
- parseDoc = do
- blocks <- (fixPlains False) . mconcat <$> manyTill block eof
- meta <- stateMeta . parserState <$> getState
- bs' <- replaceNotes (B.toList blocks)
- return $ Pandoc meta bs'
- getError (errorMessages -> ms) = case ms of
- [] -> ""
- (m:_) -> messageString m
-
-replaceNotes :: [Block] -> TagParser [Block]
+ -> m Pandoc
+readHtml opts inp = do
+ let tags = stripPrefixes . canonicalizeTags $
+ parseTagsOptions parseOptions{ optTagPosition = True } inp
+ parseDoc = do
+ blocks <- (fixPlains False) . mconcat <$> manyTill block eof
+ meta <- stateMeta . parserState <$> getState
+ bs' <- replaceNotes (B.toList blocks)
+ return $ Pandoc meta bs'
+ getError (errorMessages -> ms) = case ms of
+ [] -> ""
+ (m:_) -> messageString m
+ result <- flip runReaderT def $
+ runParserT parseDoc
+ (HTMLState def{ stateOptions = opts } [] Nothing Set.empty M.empty)
+ "source" tags
+ case result of
+ Right doc -> return doc
+ Left err -> throwError $ PandocParseError $ getError err
+
+ where
+
+replaceNotes :: PandocMonad m => [Block] -> TagParser m [Block]
replaceNotes = walkM replaceNotes'
-replaceNotes' :: Inline -> TagParser Inline
+replaceNotes' :: PandocMonad m => Inline -> TagParser m Inline
replaceNotes' (RawInline (Format "noteref") ref) = maybe (Str "") (Note . B.toList) . lookup ref <$> getNotes
where
getNotes = noteTable <$> getState
@@ -113,20 +121,20 @@ data HTMLLocal = HTMLLocal { quoteContext :: QuoteContext
, inPlain :: Bool -- ^ Set if in pPlain
}
-setInChapter :: HTMLParser s a -> HTMLParser s a
+setInChapter :: PandocMonad m => HTMLParser m s a -> HTMLParser m s a
setInChapter = local (\s -> s {inChapter = True})
-setInPlain :: HTMLParser s a -> HTMLParser s a
+setInPlain :: PandocMonad m => HTMLParser m s a -> HTMLParser m s a
setInPlain = local (\s -> s {inPlain = True})
-type HTMLParser s = ParserT s HTMLState (Reader HTMLLocal)
+type HTMLParser m s = ParserT s HTMLState (ReaderT HTMLLocal m)
-type TagParser = HTMLParser [Tag String]
+type TagParser m = HTMLParser m [Tag String]
-pBody :: TagParser Blocks
+pBody :: PandocMonad m => TagParser m Blocks
pBody = pInTags "body" block
-pHead :: TagParser Blocks
+pHead :: PandocMonad m => TagParser m Blocks
pHead = pInTags "head" $ pTitle <|> pMetaTag <|> pBaseTag <|> (mempty <$ pAnyTag)
where pTitle = pInTags "title" inline >>= setTitle . trimInlines
setTitle t = mempty <$ (updateState $ B.setMeta "title" t)
@@ -149,7 +157,7 @@ pHead = pInTags "head" $ pTitle <|> pMetaTag <|> pBaseTag <|> (mempty <$ pAnyTag
parseURIReference $ fromAttrib "href" bt }
return mempty
-block :: TagParser Blocks
+block :: PandocMonad m => TagParser m Blocks
block = do
tr <- getOption readerTrace
pos <- getPosition
@@ -176,13 +184,16 @@ block = do
(take 60 $ show $ B.toList res)) (return ())
return res
-namespaces :: [(String, TagParser Inlines)]
+namespaces :: PandocMonad m => [(String, TagParser m Inlines)]
namespaces = [(mathMLNamespace, pMath True)]
mathMLNamespace :: String
mathMLNamespace = "http://www.w3.org/1998/Math/MathML"
-eSwitch :: Monoid a => (Inlines -> a) -> TagParser a -> TagParser a
+eSwitch :: (PandocMonad m, Monoid a)
+ => (Inlines -> a)
+ -> TagParser m a
+ -> TagParser m a
eSwitch constructor parser = try $ do
guardEnabled Ext_epub_html_exts
pSatisfy (~== TagOpen "switch" [])
@@ -195,7 +206,7 @@ eSwitch constructor parser = try $ do
pSatisfy (~== TagClose "switch")
return $ maybe fallback constructor cases
-eCase :: TagParser (Maybe Inlines)
+eCase :: PandocMonad m => TagParser m (Maybe Inlines)
eCase = do
skipMany pBlank
TagOpen _ attr <- lookAhead $ pSatisfy $ (~== TagOpen "case" [])
@@ -203,7 +214,7 @@ eCase = do
Just p -> Just <$> (pInTags "case" (skipMany pBlank *> p <* skipMany pBlank))
Nothing -> Nothing <$ manyTill pAnyTag (pSatisfy (~== TagClose "case"))
-eFootnote :: TagParser ()
+eFootnote :: PandocMonad m => TagParser m ()
eFootnote = try $ do
let notes = ["footnote", "rearnote"]
guardEnabled Ext_epub_html_exts
@@ -213,10 +224,10 @@ eFootnote = try $ do
content <- pInTags tag block
addNote ident content
-addNote :: String -> Blocks -> TagParser ()
+addNote :: PandocMonad m => String -> Blocks -> TagParser m ()
addNote uid cont = updateState (\s -> s {noteTable = (uid, cont) : (noteTable s)})
-eNoteref :: TagParser Inlines
+eNoteref :: PandocMonad m => TagParser m Inlines
eNoteref = try $ do
guardEnabled Ext_epub_html_exts
TagOpen tag attr <- lookAhead $ pAnyTag
@@ -227,17 +238,17 @@ eNoteref = try $ do
return $ B.rawInline "noteref" ident
-- Strip TOC if there is one, better to generate again
-eTOC :: TagParser ()
+eTOC :: PandocMonad m => TagParser m ()
eTOC = try $ do
guardEnabled Ext_epub_html_exts
(TagOpen tag attr) <- lookAhead $ pAnyTag
guard (maybe False (== "toc") (lookup "type" attr))
void (pInTags tag block)
-pList :: TagParser Blocks
+pList :: PandocMonad m => TagParser m Blocks
pList = pBulletList <|> pOrderedList <|> pDefinitionList
-pBulletList :: TagParser Blocks
+pBulletList :: PandocMonad m => TagParser m Blocks
pBulletList = try $ do
pSatisfy (~== TagOpen "ul" [])
let nonItem = pSatisfy (\t ->
@@ -249,7 +260,7 @@ pBulletList = try $ do
items <- manyTill (pListItem nonItem) (pCloses "ul")
return $ B.bulletList $ map (fixPlains True) items
-pListItem :: TagParser a -> TagParser Blocks
+pListItem :: PandocMonad m => TagParser m a -> TagParser m Blocks
pListItem nonItem = do
TagOpen _ attr <- lookAhead $ pSatisfy (~== TagOpen "li" [])
let liDiv = maybe mempty (\x -> B.divWith (x, [], []) mempty) (lookup "id" attr)
@@ -271,7 +282,7 @@ parseTypeAttr "A" = UpperAlpha
parseTypeAttr "1" = Decimal
parseTypeAttr _ = DefaultStyle
-pOrderedList :: TagParser Blocks
+pOrderedList :: PandocMonad m => TagParser m Blocks
pOrderedList = try $ do
TagOpen _ attribs <- pSatisfy (~== TagOpen "ol" [])
let (start, style) = (sta', sty')
@@ -302,13 +313,13 @@ pOrderedList = try $ do
items <- manyTill (pListItem nonItem) (pCloses "ol")
return $ B.orderedListWith (start, style, DefaultDelim) $ map (fixPlains True) items
-pDefinitionList :: TagParser Blocks
+pDefinitionList :: PandocMonad m => TagParser m Blocks
pDefinitionList = try $ do
pSatisfy (~== TagOpen "dl" [])
items <- manyTill pDefListItem (pCloses "dl")
return $ B.definitionList items
-pDefListItem :: TagParser (Inlines, [Blocks])
+pDefListItem :: PandocMonad m => TagParser m (Inlines, [Blocks])
pDefListItem = try $ do
let nonItem = pSatisfy (\t -> not (t ~== TagOpen "dt" []) &&
not (t ~== TagOpen "dd" []) && not (t ~== TagClose "dl"))
@@ -334,7 +345,7 @@ fixPlains inList bs = if any isParaish bs'
plainToPara x = x
bs' = B.toList bs
-pRawTag :: TagParser String
+pRawTag :: PandocMonad m => TagParser m String
pRawTag = do
tag <- pAnyTag
let ignorable x = x `elem` ["html","head","body","!DOCTYPE","?xml"]
@@ -342,7 +353,7 @@ pRawTag = do
then return []
else return $ renderTags' [tag]
-pDiv :: TagParser Blocks
+pDiv :: PandocMonad m => TagParser m Blocks
pDiv = try $ do
guardEnabled Ext_native_divs
let isDivLike "div" = True
@@ -356,7 +367,7 @@ pDiv = try $ do
else classes
return $ B.divWith (ident, classes', kvs) contents
-pRawHtmlBlock :: TagParser Blocks
+pRawHtmlBlock :: PandocMonad m => TagParser m Blocks
pRawHtmlBlock = do
raw <- pHtmlBlock "script" <|> pHtmlBlock "style" <|> pRawTag
parseRaw <- getOption readerParseRaw
@@ -364,21 +375,21 @@ pRawHtmlBlock = do
then return $ B.rawBlock "html" raw
else return mempty
-pHtmlBlock :: String -> TagParser String
+pHtmlBlock :: PandocMonad m => String -> TagParser m String
pHtmlBlock t = try $ do
open <- pSatisfy (~== TagOpen t [])
contents <- manyTill pAnyTag (pSatisfy (~== TagClose t))
return $ renderTags' $ [open] ++ contents ++ [TagClose t]
-- Sets chapter context
-eSection :: TagParser Blocks
+eSection :: PandocMonad m => TagParser m Blocks
eSection = try $ do
let matchChapter as = maybe False (isInfixOf "chapter") (lookup "type" as)
let sectTag = tagOpen (`elem` sectioningContent) matchChapter
TagOpen tag _ <- lookAhead $ pSatisfy sectTag
setInChapter (pInTags tag block)
-headerLevel :: String -> TagParser Int
+headerLevel :: PandocMonad m => String -> TagParser m Int
headerLevel tagtype = do
let level = read (drop 1 tagtype)
(try $ do
@@ -388,7 +399,7 @@ headerLevel tagtype = do
<|>
return level
-eTitlePage :: TagParser ()
+eTitlePage :: PandocMonad m => TagParser m ()
eTitlePage = try $ do
let isTitlePage as = maybe False (isInfixOf "titlepage") (lookup "type" as)
let groupTag = tagOpen (\x -> x `elem` groupingContent || x == "section")
@@ -396,7 +407,7 @@ eTitlePage = try $ do
TagOpen tag _ <- lookAhead $ pSatisfy groupTag
() <$ pInTags tag block
-pHeader :: TagParser Blocks
+pHeader :: PandocMonad m => TagParser m Blocks
pHeader = try $ do
TagOpen tagtype attr <- pSatisfy $
tagOpen (`elem` ["h1","h2","h3","h4","h5","h6"])
@@ -412,12 +423,12 @@ pHeader = try $ do
then mempty -- skip a representation of the title in the body
else B.headerWith attr' level contents
-pHrule :: TagParser Blocks
+pHrule :: PandocMonad m => TagParser m Blocks
pHrule = do
pSelfClosing (=="hr") (const True)
return B.horizontalRule
-pTable :: TagParser Blocks
+pTable :: PandocMonad m => TagParser m Blocks
pTable = try $ do
TagOpen _ _ <- pSatisfy (~== TagOpen "table" [])
skipMany pBlank
@@ -456,7 +467,7 @@ pTable = try $ do
else widths'
return $ B.table caption (zip aligns widths) head' rows
-pCol :: TagParser Double
+pCol :: PandocMonad m => TagParser m Double
pCol = try $ do
TagOpen _ attribs <- pSatisfy (~== TagOpen "col" [])
skipMany pBlank
@@ -472,7 +483,7 @@ pCol = try $ do
fromMaybe 0.0 $ safeRead ('0':'.':init x)
_ -> 0.0
-pColgroup :: TagParser [Double]
+pColgroup :: PandocMonad m => TagParser m [Double]
pColgroup = try $ do
pSatisfy (~== TagOpen "colgroup" [])
skipMany pBlank
@@ -485,31 +496,31 @@ noColOrRowSpans t = isNullOrOne "colspan" && isNullOrOne "rowspan"
"1" -> True
_ -> False
-pCell :: String -> TagParser [Blocks]
+pCell :: PandocMonad m => String -> TagParser m [Blocks]
pCell celltype = try $ do
skipMany pBlank
res <- pInTags' celltype noColOrRowSpans block
skipMany pBlank
return [res]
-pBlockQuote :: TagParser Blocks
+pBlockQuote :: PandocMonad m => TagParser m Blocks
pBlockQuote = do
contents <- pInTags "blockquote" block
return $ B.blockQuote $ fixPlains False contents
-pPlain :: TagParser Blocks
+pPlain :: PandocMonad m => TagParser m Blocks
pPlain = do
contents <- setInPlain $ trimInlines . mconcat <$> many1 inline
if B.isNull contents
then return mempty
else return $ B.plain contents
-pPara :: TagParser Blocks
+pPara :: PandocMonad m => TagParser m Blocks
pPara = do
contents <- trimInlines <$> pInTags "p" inline
return $ B.para contents
-pCodeBlock :: TagParser Blocks
+pCodeBlock :: PandocMonad m => TagParser m Blocks
pCodeBlock = try $ do
TagOpen _ attr <- pSatisfy (~== TagOpen "pre" [])
contents <- manyTill pAnyTag (pCloses "pre" <|> eof)
@@ -529,7 +540,7 @@ tagToString (TagText s) = s
tagToString (TagOpen "br" _) = "\n"
tagToString _ = ""
-inline :: TagParser Inlines
+inline :: PandocMonad m => TagParser m Inlines
inline = choice
[ eNoteref
, eSwitch id inline
@@ -549,30 +560,31 @@ inline = choice
, pRawHtmlInline
]
-pLocation :: TagParser ()
+pLocation :: PandocMonad m => TagParser m ()
pLocation = do
(TagPosition r c) <- pSat isTagPosition
setPosition $ newPos "input" r c
-pSat :: (Tag String -> Bool) -> TagParser (Tag String)
+pSat :: PandocMonad m => (Tag String -> Bool) -> TagParser m (Tag String)
pSat f = do
pos <- getPosition
token show (const pos) (\x -> if f x then Just x else Nothing)
-pSatisfy :: (Tag String -> Bool) -> TagParser (Tag String)
+pSatisfy :: PandocMonad m => (Tag String -> Bool) -> TagParser m (Tag String)
pSatisfy f = try $ optional pLocation >> pSat f
-pAnyTag :: TagParser (Tag String)
+pAnyTag :: PandocMonad m => TagParser m (Tag String)
pAnyTag = pSatisfy (const True)
-pSelfClosing :: (String -> Bool) -> ([Attribute String] -> Bool)
- -> TagParser (Tag String)
+pSelfClosing :: PandocMonad m
+ => (String -> Bool) -> ([Attribute String] -> Bool)
+ -> TagParser m (Tag String)
pSelfClosing f g = do
open <- pSatisfy (tagOpen f g)
optional $ pSatisfy (tagClose f)
return open
-pQ :: TagParser Inlines
+pQ :: PandocMonad m => TagParser m Inlines
pQ = do
context <- asks quoteContext
let quoteType = case context of
@@ -587,19 +599,19 @@ pQ = do
withQuoteContext innerQuoteContext $
pInlinesInTags "q" constructor
-pEmph :: TagParser Inlines
+pEmph :: PandocMonad m => TagParser m Inlines
pEmph = pInlinesInTags "em" B.emph <|> pInlinesInTags "i" B.emph
-pStrong :: TagParser Inlines
+pStrong :: PandocMonad m => TagParser m Inlines
pStrong = pInlinesInTags "strong" B.strong <|> pInlinesInTags "b" B.strong
-pSuperscript :: TagParser Inlines
+pSuperscript :: PandocMonad m => TagParser m Inlines
pSuperscript = pInlinesInTags "sup" B.superscript
-pSubscript :: TagParser Inlines
+pSubscript :: PandocMonad m => TagParser m Inlines
pSubscript = pInlinesInTags "sub" B.subscript
-pStrikeout :: TagParser Inlines
+pStrikeout :: PandocMonad m => TagParser m Inlines
pStrikeout = do
pInlinesInTags "s" B.strikeout <|>
pInlinesInTags "strike" B.strikeout <|>
@@ -608,7 +620,7 @@ pStrikeout = do
contents <- mconcat <$> manyTill inline (pCloses "span")
return $ B.strikeout contents)
-pLineBreak :: TagParser Inlines
+pLineBreak :: PandocMonad m => TagParser m Inlines
pLineBreak = do
pSelfClosing (=="br") (const True)
return B.linebreak
@@ -619,7 +631,7 @@ maybeFromAttrib :: String -> Tag String -> Maybe String
maybeFromAttrib name (TagOpen _ attrs) = lookup name attrs
maybeFromAttrib _ _ = Nothing
-pLink :: TagParser Inlines
+pLink :: PandocMonad m => TagParser m Inlines
pLink = try $ do
tag <- pSatisfy $ tagOpenLit "a" (const True)
let title = fromAttrib "title" tag
@@ -639,7 +651,7 @@ pLink = try $ do
_ -> url'
return $ B.linkWith (uid, cls, []) (escapeURI url) title lab
-pImage :: TagParser Inlines
+pImage :: PandocMonad m => TagParser m Inlines
pImage = do
tag <- pSelfClosing (=="img") (isJust . lookup "src")
mbBaseHref <- baseHref <$> getState
@@ -657,13 +669,13 @@ pImage = do
let kvs = concat $ map getAtt ["width", "height", "sizes", "srcset"]
return $ B.imageWith (uid, cls, kvs) (escapeURI url) title (B.text alt)
-pCode :: TagParser Inlines
+pCode :: PandocMonad m => TagParser m Inlines
pCode = try $ do
(TagOpen open attr) <- pSatisfy $ tagOpen (`elem` ["code","tt"]) (const True)
result <- manyTill pAnyTag (pCloses open)
return $ B.codeWith (mkAttr attr) $ intercalate " " $ lines $ innerText result
-pSpan :: TagParser Inlines
+pSpan :: PandocMonad m => TagParser m Inlines
pSpan = try $ do
guardEnabled Ext_native_spans
TagOpen _ attr <- lookAhead $ pSatisfy $ tagOpen (=="span") (const True)
@@ -674,7 +686,7 @@ pSpan = try $ do
let tag = if isSmallCaps then B.smallcaps else B.spanWith (mkAttr attr)
return $ tag contents
-pRawHtmlInline :: TagParser Inlines
+pRawHtmlInline :: PandocMonad m => TagParser m Inlines
pRawHtmlInline = do
inplain <- asks inPlain
result <- pSatisfy (tagComment (const True))
@@ -689,7 +701,7 @@ pRawHtmlInline = do
mathMLToTeXMath :: String -> Either String String
mathMLToTeXMath s = writeTeX <$> readMathML s
-pMath :: Bool -> TagParser Inlines
+pMath :: PandocMonad m => Bool -> TagParser m Inlines
pMath inCase = try $ do
open@(TagOpen _ attr) <- pSatisfy $ tagOpen (=="math") (const True)
-- we'll assume math tags are MathML unless specially marked
@@ -705,22 +717,25 @@ pMath inCase = try $ do
Just "block" -> B.displayMath x
_ -> B.math x
-pInlinesInTags :: String -> (Inlines -> Inlines)
- -> TagParser Inlines
+pInlinesInTags :: PandocMonad m => String -> (Inlines -> Inlines)
+ -> TagParser m Inlines
pInlinesInTags tagtype f = extractSpaces f <$> pInTags tagtype inline
-pInTags :: (Monoid a) => String -> TagParser a -> TagParser a
+pInTags :: (PandocMonad m, Monoid a) => String -> TagParser m a -> TagParser m a
pInTags tagtype parser = pInTags' tagtype (const True) parser
-pInTags' :: (Monoid a) => String -> (Tag String -> Bool) -> TagParser a
- -> TagParser a
+pInTags' :: (PandocMonad m, Monoid a)
+ => String
+ -> (Tag String -> Bool)
+ -> TagParser m a
+ -> TagParser m a
pInTags' tagtype tagtest parser = try $ do
pSatisfy (\t -> t ~== TagOpen tagtype [] && tagtest t)
mconcat <$> manyTill parser (pCloses tagtype <|> eof)
-- parses p, preceeded by an optional opening tag
-- and followed by an optional closing tags
-pOptInTag :: String -> TagParser a -> TagParser a
+pOptInTag :: PandocMonad m => String -> TagParser m a -> TagParser m a
pOptInTag tagtype p = try $ do
skipMany pBlank
optional $ pSatisfy (~== TagOpen tagtype [])
@@ -731,7 +746,7 @@ pOptInTag tagtype p = try $ do
skipMany pBlank
return x
-pCloses :: String -> TagParser ()
+pCloses :: PandocMonad m => String -> TagParser m ()
pCloses tagtype = try $ do
t <- lookAhead $ pSatisfy $ \tag -> isTagClose tag || isTagOpen tag
case t of
@@ -744,23 +759,25 @@ pCloses tagtype = try $ do
(TagClose "table") | tagtype == "tr" -> return ()
_ -> mzero
-pTagText :: TagParser Inlines
+pTagText :: PandocMonad m => TagParser m Inlines
pTagText = try $ do
(TagText str) <- pSatisfy isTagText
st <- getState
qu <- ask
- case flip runReader qu $ runParserT (many pTagContents) st "text" str of
- Left _ -> fail $ "Could not parse `" ++ str ++ "'"
+ parsed <- lift $ lift $
+ flip runReaderT qu $ runParserT (many pTagContents) st "text" str
+ case parsed of
+ Left _ -> throwError $ PandocParseError $ "Could not parse `" ++ str ++ "'"
Right result -> return $ mconcat result
-pBlank :: TagParser ()
+pBlank :: PandocMonad m => TagParser m ()
pBlank = try $ do
(TagText str) <- pSatisfy isTagText
guard $ all isSpace str
-type InlinesParser = HTMLParser String
+type InlinesParser m = HTMLParser m String
-pTagContents :: InlinesParser Inlines
+pTagContents :: PandocMonad m => InlinesParser m Inlines
pTagContents =
B.displayMath <$> mathDisplay
<|> B.math <$> mathInline
@@ -770,7 +787,7 @@ pTagContents =
<|> pSymbol
<|> pBad
-pStr :: InlinesParser Inlines
+pStr :: PandocMonad m => InlinesParser m Inlines
pStr = do
result <- many1 $ satisfy $ \c ->
not (isSpace c) && not (isSpecial c) && not (isBad c)
@@ -789,13 +806,13 @@ isSpecial '\8220' = True
isSpecial '\8221' = True
isSpecial _ = False
-pSymbol :: InlinesParser Inlines
+pSymbol :: PandocMonad m => InlinesParser m Inlines
pSymbol = satisfy isSpecial >>= return . B.str . (:[])
isBad :: Char -> Bool
isBad c = c >= '\128' && c <= '\159' -- not allowed in HTML
-pBad :: InlinesParser Inlines
+pBad :: PandocMonad m => InlinesParser m Inlines
pBad = do
c <- satisfy isBad
let c' = case c of
@@ -829,7 +846,7 @@ pBad = do
_ -> '?'
return $ B.str [c']
-pSpace :: InlinesParser Inlines
+pSpace :: PandocMonad m => InlinesParser m Inlines
pSpace = many1 (satisfy isSpace) >>= \xs ->
if '\n' `elem` xs
then return B.softbreak
@@ -1070,7 +1087,7 @@ instance HasHeaderMap HTMLState where
-- This signature should be more general
-- MonadReader HTMLLocal m => HasQuoteContext st m
-instance HasQuoteContext st (Reader HTMLLocal) where
+instance PandocMonad m => HasQuoteContext st (ReaderT HTMLLocal m) where
getQuoteContext = asks quoteContext
withQuoteContext q = local (\s -> s{quoteContext = q})
diff --git a/src/Text/Pandoc/Readers/Haddock.hs b/src/Text/Pandoc/Readers/Haddock.hs
index 12953bb72..4d33f657c 100644
--- a/src/Text/Pandoc/Readers/Haddock.hs
+++ b/src/Text/Pandoc/Readers/Haddock.hs
@@ -25,14 +25,23 @@ import Text.Pandoc.Options
import Documentation.Haddock.Parser
import Documentation.Haddock.Types
import Debug.Trace (trace)
+import Control.Monad.Except (throwError)
+import Text.Pandoc.Class (PandocMonad, PandocExecutionError(..))
-import Text.Pandoc.Error
-- | Parse Haddock markup and return a 'Pandoc' document.
-readHaddock :: ReaderOptions -- ^ Reader options
- -> String -- ^ String to parse
- -> Either PandocError Pandoc
-readHaddock opts =
+readHaddock :: PandocMonad m
+ => ReaderOptions
+ -> String
+ -> m Pandoc
+readHaddock opts s = case readHaddockEither opts s of
+ Right result -> return result
+ Left e -> throwError e
+
+readHaddockEither :: ReaderOptions -- ^ Reader options
+ -> String -- ^ String to parse
+ -> Either PandocExecutionError Pandoc
+readHaddockEither opts =
#if MIN_VERSION_haddock_library(1,2,0)
Right . B.doc . docHToBlocks . trace' . _doc . parseParas
#else
diff --git a/src/Text/Pandoc/Readers/LaTeX.hs b/src/Text/Pandoc/Readers/LaTeX.hs
index edcf35e51..2506c17be 100644
--- a/src/Text/Pandoc/Readers/LaTeX.hs
+++ b/src/Text/Pandoc/Readers/LaTeX.hs
@@ -56,14 +56,21 @@ import qualified Control.Exception as E
import Text.Pandoc.Highlighting (fromListingsLanguage)
import Text.Pandoc.ImageSize (numUnit, showFl)
import Text.Pandoc.Error
+import Control.Monad.Except (throwError)
+import Text.Pandoc.Class (PandocMonad, PandocExecutionError(..), PandocPure)
-- | Parse LaTeX from string and return 'Pandoc' document.
-readLaTeX :: ReaderOptions -- ^ Reader options
+readLaTeX :: PandocMonad m
+ => ReaderOptions -- ^ Reader options
-> String -- ^ String to parse (assumes @'\n'@ line endings)
- -> Either PandocError Pandoc
-readLaTeX opts = readWith parseLaTeX def{ stateOptions = opts }
-
-parseLaTeX :: LP Pandoc
+ -> m Pandoc
+readLaTeX opts ltx = do
+ parsed <- readWithM parseLaTeX def{ stateOptions = opts } ltx
+ case parsed of
+ Right result -> return result
+ Left _ -> throwError $ PandocParseError "parsing error"
+
+parseLaTeX :: PandocMonad m => LP m Pandoc
parseLaTeX = do
bs <- blocks
eof
@@ -72,9 +79,9 @@ parseLaTeX = do
let (Pandoc _ bs') = doc bs
return $ Pandoc meta bs'
-type LP = Parser String ParserState
+type LP m = ParserT String ParserState m
-anyControlSeq :: LP String
+anyControlSeq :: PandocMonad m => LP m String
anyControlSeq = do
char '\\'
next <- option '\n' anyChar
@@ -83,7 +90,7 @@ anyControlSeq = do
c | isLetter c -> (c:) <$> (many letter <* optional sp)
| otherwise -> return [c]
-controlSeq :: String -> LP String
+controlSeq :: PandocMonad m => String -> LP m String
controlSeq name = try $ do
char '\\'
case name of
@@ -92,26 +99,26 @@ controlSeq name = try $ do
cs -> string cs <* notFollowedBy letter <* optional sp
return name
-dimenarg :: LP String
+dimenarg :: PandocMonad m => LP m String
dimenarg = try $ do
ch <- option "" $ string "="
num <- many1 digit
dim <- oneOfStrings ["pt","pc","in","bp","cm","mm","dd","cc","sp"]
return $ ch ++ num ++ dim
-sp :: LP ()
+sp :: PandocMonad m => LP m ()
sp = whitespace <|> endline
-whitespace :: LP ()
+whitespace :: PandocMonad m => LP m ()
whitespace = skipMany1 $ satisfy (\c -> c == ' ' || c == '\t')
-endline :: LP ()
+endline :: PandocMonad m => LP m ()
endline = try (newline >> lookAhead anyChar >> notFollowedBy blankline)
isLowerHex :: Char -> Bool
isLowerHex x = x >= '0' && x <= '9' || x >= 'a' && x <= 'f'
-tildeEscape :: LP Char
+tildeEscape :: PandocMonad m => LP m Char
tildeEscape = try $ do
string "^^"
c <- satisfy (\x -> x >= '\0' && x <= '\128')
@@ -124,29 +131,29 @@ tildeEscape = try $ do
| otherwise -> return $ chr (x + 64)
else return $ chr $ read ('0':'x':c:d)
-comment :: LP ()
+comment :: PandocMonad m => LP m ()
comment = do
char '%'
skipMany (satisfy (/='\n'))
optional newline
return ()
-bgroup :: LP ()
+bgroup :: PandocMonad m => LP m ()
bgroup = try $ do
skipMany (spaceChar <|> try (newline <* notFollowedBy blankline))
() <$ char '{'
<|> () <$ controlSeq "bgroup"
<|> () <$ controlSeq "begingroup"
-egroup :: LP ()
+egroup :: PandocMonad m => LP m ()
egroup = () <$ char '}'
<|> () <$ controlSeq "egroup"
<|> () <$ controlSeq "endgroup"
-grouped :: Monoid a => LP a -> LP a
+grouped :: PandocMonad m => Monoid a => LP m a -> LP m a
grouped parser = try $ bgroup *> (mconcat <$> manyTill parser egroup)
-braced :: LP String
+braced :: PandocMonad m => LP m String
braced = bgroup *> (concat <$> manyTill
( many1 (satisfy (\c -> c /= '\\' && c /= '}' && c /= '{'))
<|> try (string "\\}")
@@ -156,16 +163,16 @@ braced = bgroup *> (concat <$> manyTill
<|> count 1 anyChar
) egroup)
-bracketed :: Monoid a => LP a -> LP a
+bracketed :: PandocMonad m => Monoid a => LP m a -> LP m a
bracketed parser = try $ char '[' *> (mconcat <$> manyTill parser (char ']'))
-mathDisplay :: LP String -> LP Inlines
+mathDisplay :: PandocMonad m => LP m String -> LP m Inlines
mathDisplay p = displayMath <$> (try p >>= applyMacros' . trim)
-mathInline :: LP String -> LP Inlines
+mathInline :: PandocMonad m => LP m String -> LP m Inlines
mathInline p = math <$> (try p >>= applyMacros')
-mathChars :: LP String
+mathChars :: PandocMonad m => LP m String
mathChars =
concat <$> many (escapedChar
<|> (snd <$> withRaw braced)
@@ -179,7 +186,7 @@ mathChars =
isOrdChar '\\' = False
isOrdChar _ = True
-quoted' :: (Inlines -> Inlines) -> LP String -> LP () -> LP Inlines
+quoted' :: PandocMonad m => (Inlines -> Inlines) -> LP m String -> LP m () -> LP m Inlines
quoted' f starter ender = do
startchs <- starter
smart <- getOption readerSmart
@@ -194,7 +201,7 @@ quoted' f starter ender = do
_ -> startchs)
else lit startchs
-doubleQuote :: LP Inlines
+doubleQuote :: PandocMonad m => LP m Inlines
doubleQuote = do
quoted' doubleQuoted (try $ string "``") (void $ try $ string "''")
<|> quoted' doubleQuoted (string "“") (void $ char '”')
@@ -202,7 +209,7 @@ doubleQuote = do
<|> quoted' doubleQuoted (try $ string "\"`") (void $ try $ string "\"'")
<|> quoted' doubleQuoted (string "\"") (void $ char '"')
-singleQuote :: LP Inlines
+singleQuote :: PandocMonad m => LP m Inlines
singleQuote = do
smart <- getOption readerSmart
if smart
@@ -210,7 +217,7 @@ singleQuote = do
<|> quoted' singleQuoted (string "‘") (try $ char '’' >> notFollowedBy letter)
else str <$> many1 (oneOf "`\'‘’")
-inline :: LP Inlines
+inline :: PandocMonad m => LP m Inlines
inline = (mempty <$ comment)
<|> (space <$ whitespace)
<|> (softbreak <$ endline)
@@ -235,10 +242,10 @@ inline = (mempty <$ comment)
<|> (str . (:[]) <$> oneOf "#&~^'`\"[]") -- TODO print warning?
-- <|> (str <$> count 1 (satisfy (\c -> c /= '\\' && c /='\n' && c /='}' && c /='{'))) -- eat random leftover characters
-inlines :: LP Inlines
+inlines :: PandocMonad m => LP m Inlines
inlines = mconcat <$> many (notFollowedBy (char '}') *> inline)
-inlineGroup :: LP Inlines
+inlineGroup :: PandocMonad m => LP m Inlines
inlineGroup = do
ils <- grouped inline
if isNull ils
@@ -247,7 +254,7 @@ inlineGroup = do
-- we need the span so we can detitlecase bibtex entries;
-- we need to know when something is {C}apitalized
-block :: LP Blocks
+block :: PandocMonad m => LP m Blocks
block = (mempty <$ comment)
<|> (mempty <$ ((spaceChar <|> newline) *> spaces))
<|> environment
@@ -258,10 +265,10 @@ block = (mempty <$ comment)
<|> (mempty <$ char '&') -- loose & in table environment
-blocks :: LP Blocks
+blocks :: PandocMonad m => LP m Blocks
blocks = mconcat <$> many block
-getRawCommand :: String -> LP String
+getRawCommand :: PandocMonad m => String -> LP m String
getRawCommand name' = do
rawargs <- withRaw (many (try (optional sp *> opt)) *>
option "" (try (optional sp *> dimenarg)) *>
@@ -273,7 +280,7 @@ lookupListDefault d = (fromMaybe d .) . lookupList
where
lookupList l m = msum $ map (`M.lookup` m) l
-blockCommand :: LP Blocks
+blockCommand :: PandocMonad m => LP m Blocks
blockCommand = try $ do
name <- anyControlSeq
guard $ name /= "begin" && name /= "end"
@@ -291,21 +298,21 @@ inBrackets :: Inlines -> Inlines
inBrackets x = str "[" <> x <> str "]"
-- eat an optional argument and one or more arguments in braces
-ignoreInlines :: String -> (String, LP Inlines)
+ignoreInlines :: PandocMonad m => String -> (String, LP m Inlines)
ignoreInlines name = (name, doraw <|> (mempty <$ optargs))
where optargs = skipopts *> skipMany (try $ optional sp *> braced)
contseq = '\\':name
doraw = (rawInline "latex" . (contseq ++) . snd) <$>
(getOption readerParseRaw >>= guard >> withRaw optargs)
-ignoreBlocks :: String -> (String, LP Blocks)
+ignoreBlocks :: PandocMonad m => String -> (String, LP m Blocks)
ignoreBlocks name = (name, doraw <|> (mempty <$ optargs))
where optargs = skipopts *> skipMany (try $ optional sp *> braced)
contseq = '\\':name
doraw = (rawBlock "latex" . (contseq ++) . snd) <$>
(getOption readerParseRaw >>= guard >> withRaw optargs)
-blockCommands :: M.Map String (LP Blocks)
+blockCommands :: PandocMonad m => M.Map String (LP m Blocks)
blockCommands = M.fromList $
[ ("par", mempty <$ skipopts)
, ("title", mempty <$ (skipopts *>
@@ -370,14 +377,14 @@ blockCommands = M.fromList $
, "newpage"
]
-addMeta :: ToMetaValue a => String -> a -> LP ()
+addMeta :: PandocMonad m => ToMetaValue a => String -> a -> LP m ()
addMeta field val = updateState $ \st ->
st{ stateMeta = addMetaField field val $ stateMeta st }
splitBibs :: String -> [Inlines]
splitBibs = map (str . flip replaceExtension "bib" . trim) . splitBy (==',')
-setCaption :: LP Blocks
+setCaption :: PandocMonad m => LP m Blocks
setCaption = do
ils <- tok
mblabel <- option Nothing $
@@ -389,10 +396,10 @@ setCaption = do
updateState $ \st -> st{ stateCaption = Just ils' }
return mempty
-resetCaption :: LP ()
+resetCaption :: PandocMonad m => LP m ()
resetCaption = updateState $ \st -> st{ stateCaption = Nothing }
-authors :: LP ()
+authors :: PandocMonad m => LP m ()
authors = try $ do
char '{'
let oneAuthor = mconcat <$>
@@ -403,7 +410,7 @@ authors = try $ do
char '}'
addMeta "author" (map trimInlines auths)
-section :: Attr -> Int -> LP Blocks
+section :: PandocMonad m => Attr -> Int -> LP m Blocks
section (ident, classes, kvs) lvl = do
hasChapters <- stateHasChapters `fmap` getState
let lvl' = if hasChapters then lvl + 1 else lvl
@@ -413,7 +420,7 @@ section (ident, classes, kvs) lvl = do
attr' <- registerHeader (lab, classes, kvs) contents
return $ headerWith attr' lvl' contents
-inlineCommand :: LP Inlines
+inlineCommand :: PandocMonad m => LP m Inlines
inlineCommand = try $ do
name <- anyControlSeq
guard $ name /= "begin" && name /= "end"
@@ -435,14 +442,14 @@ inlineCommand = try $ do
optional (try (string "{}")))
<|> raw
-unlessParseRaw :: LP ()
+unlessParseRaw :: PandocMonad m => LP m ()
unlessParseRaw = getOption readerParseRaw >>= guard . not
isBlockCommand :: String -> Bool
-isBlockCommand s = s `M.member` blockCommands
+isBlockCommand s = s `M.member` (blockCommands :: M.Map String (LP PandocPure Blocks))
-inlineEnvironments :: M.Map String (LP Inlines)
+inlineEnvironments :: PandocMonad m => M.Map String (LP m Inlines)
inlineEnvironments = M.fromList
[ ("displaymath", mathEnv id Nothing "displaymath")
, ("math", math <$> verbEnv "math")
@@ -460,7 +467,7 @@ inlineEnvironments = M.fromList
, ("alignat*", mathEnv id (Just "aligned") "alignat*")
]
-inlineCommands :: M.Map String (LP Inlines)
+inlineCommands :: PandocMonad m => M.Map String (LP m Inlines)
inlineCommands = M.fromList $
[ ("emph", extractSpaces emph <$> tok)
, ("textit", extractSpaces emph <$> tok)
@@ -621,7 +628,7 @@ inlineCommands = M.fromList $
-- in which case they will appear as raw latex blocks:
[ "index" ]
-mkImage :: [(String, String)] -> String -> LP Inlines
+mkImage :: PandocMonad m => [(String, String)] -> String -> LP m Inlines
mkImage options src = do
let replaceTextwidth (k,v) = case numUnit v of
Just (num, "\\textwidth") -> (k, showFl (num * 100) ++ "%")
@@ -645,7 +652,7 @@ unescapeURL ('\\':x:xs) | isEscapable x = x:unescapeURL xs
unescapeURL (x:xs) = x:unescapeURL xs
unescapeURL [] = ""
-enquote :: LP Inlines
+enquote :: PandocMonad m => LP m Inlines
enquote = do
skipopts
context <- stateQuoteContext <$> getState
@@ -653,18 +660,18 @@ enquote = do
then singleQuoted <$> withQuoteContext InSingleQuote tok
else doubleQuoted <$> withQuoteContext InDoubleQuote tok
-doverb :: LP Inlines
+doverb :: PandocMonad m => LP m Inlines
doverb = do
marker <- anyChar
code <$> manyTill (satisfy (/='\n')) (char marker)
-doLHSverb :: LP Inlines
+doLHSverb :: PandocMonad m => LP m Inlines
doLHSverb = codeWith ("",["haskell"],[]) <$> manyTill (satisfy (/='\n')) (char '|')
-lit :: String -> LP Inlines
+lit :: String -> LP m Inlines
lit = pure . str
-accent :: (Char -> String) -> Inlines -> LP Inlines
+accent :: (Char -> String) -> Inlines -> LP m Inlines
accent f ils =
case toList ils of
(Str (x:xs) : ys) -> return $ fromList (Str (f x ++ xs) : ys)
@@ -870,53 +877,53 @@ breve 'U' = "Ŭ"
breve 'u' = "ŭ"
breve c = [c]
-tok :: LP Inlines
+tok :: PandocMonad m => LP m Inlines
tok = try $ grouped inline <|> inlineCommand <|> str <$> count 1 inlineChar
-opt :: LP Inlines
+opt :: PandocMonad m => LP m Inlines
opt = bracketed inline
-rawopt :: LP String
+rawopt :: PandocMonad m => LP m String
rawopt = do
contents <- bracketed (many1 (noneOf "[]") <|> try (string "\\]") <|>
try (string "\\[") <|> rawopt)
optional sp
return $ "[" ++ contents ++ "]"
-skipopts :: LP ()
+skipopts :: PandocMonad m => LP m ()
skipopts = skipMany rawopt
-- opts in angle brackets are used in beamer
-rawangle :: LP ()
+rawangle :: PandocMonad m => LP m ()
rawangle = try $ do
char '<'
skipMany (noneOf ">")
char '>'
return ()
-skipangles :: LP ()
+skipangles :: PandocMonad m => LP m ()
skipangles = skipMany rawangle
-inlineText :: LP Inlines
+inlineText :: PandocMonad m => LP m Inlines
inlineText = str <$> many1 inlineChar
-inlineChar :: LP Char
+inlineChar :: PandocMonad m => LP m Char
inlineChar = noneOf "\\$%&~#{}^'`\"‘’“”-[] \t\n"
-environment :: LP Blocks
+environment :: PandocMonad m => LP m Blocks
environment = do
controlSeq "begin"
name <- braced
M.findWithDefault mzero name environments
<|> rawEnv name
-inlineEnvironment :: LP Inlines
+inlineEnvironment :: PandocMonad m => LP m Inlines
inlineEnvironment = try $ do
controlSeq "begin"
name <- braced
M.findWithDefault mzero name inlineEnvironments
-rawEnv :: String -> LP Blocks
+rawEnv :: PandocMonad m => String -> LP m Blocks
rawEnv name = do
parseRaw <- getOption readerParseRaw
rawOptions <- mconcat <$> many rawopt
@@ -1045,7 +1052,7 @@ readFileFromDirs (d:ds) f =
----
-keyval :: LP (String, String)
+keyval :: PandocMonad m => LP m (String, String)
keyval = try $ do
key <- many1 alphaNum
val <- option "" $ char '=' >> many1 (alphaNum <|> char '.' <|> char '\\')
@@ -1055,25 +1062,25 @@ keyval = try $ do
return (key, val)
-keyvals :: LP [(String, String)]
+keyvals :: PandocMonad m => LP m [(String, String)]
keyvals = try $ char '[' *> manyTill keyval (char ']')
-alltt :: String -> LP Blocks
+alltt :: PandocMonad m => String -> LP m Blocks
alltt t = walk strToCode <$> parseFromString blocks
(substitute " " "\\ " $ substitute "%" "\\%" $
intercalate "\\\\\n" $ lines t)
where strToCode (Str s) = Code nullAttr s
strToCode x = x
-rawLaTeXBlock :: LP String
+rawLaTeXBlock :: PandocMonad m => LP m String
rawLaTeXBlock = snd <$> try (withRaw (environment <|> blockCommand))
-rawLaTeXInline :: LP Inline
+rawLaTeXInline :: PandocMonad m => LP m Inline
rawLaTeXInline = do
raw <- (snd <$> withRaw inlineCommand) <|> (snd <$> withRaw blockCommand)
RawInline "latex" <$> applyMacros' raw
-addImageCaption :: Blocks -> LP Blocks
+addImageCaption :: PandocMonad m => Blocks -> LP m Blocks
addImageCaption = walkM go
where go (Image attr alt (src,tit)) = do
mbcapt <- stateCaption <$> getState
@@ -1082,7 +1089,7 @@ addImageCaption = walkM go
Nothing -> Image attr alt (src,tit)
go x = return x
-addTableCaption :: Blocks -> LP Blocks
+addTableCaption :: PandocMonad m => Blocks -> LP m Blocks
addTableCaption = walkM go
where go (Table c als ws hs rs) = do
mbcapt <- stateCaption <$> getState
@@ -1091,7 +1098,7 @@ addTableCaption = walkM go
Nothing -> Table c als ws hs rs
go x = return x
-environments :: M.Map String (LP Blocks)
+environments :: PandocMonad m => M.Map String (LP m Blocks)
environments = M.fromList
[ ("document", env "document" blocks <* skipMany anyChar)
, ("abstract", mempty <$ (env "abstract" blocks >>= addMeta "abstract"))
@@ -1159,7 +1166,7 @@ environments = M.fromList
, ("alignat*", mathEnv para (Just "aligned") "alignat*")
]
-letterContents :: LP Blocks
+letterContents :: PandocMonad m => LP m Blocks
letterContents = do
bs <- blocks
st <- getState
@@ -1170,7 +1177,7 @@ letterContents = do
_ -> mempty
return $ addr <> bs -- sig added by \closing
-closing :: LP Blocks
+closing :: PandocMonad m => LP m Blocks
closing = do
contents <- tok
st <- getState
@@ -1184,17 +1191,17 @@ closing = do
_ -> mempty
return $ para (trimInlines contents) <> sigs
-item :: LP Blocks
+item :: PandocMonad m => LP m Blocks
item = blocks *> controlSeq "item" *> skipopts *> blocks
-looseItem :: LP Blocks
+looseItem :: PandocMonad m => LP m Blocks
looseItem = do
ctx <- stateParserContext `fmap` getState
if ctx == ListItemState
then mzero
else return mempty
-descItem :: LP (Inlines, [Blocks])
+descItem :: PandocMonad m => LP m (Inlines, [Blocks])
descItem = do
blocks -- skip blocks before item
controlSeq "item"
@@ -1203,12 +1210,12 @@ descItem = do
bs <- blocks
return (ils, [bs])
-env :: String -> LP a -> LP a
+env :: PandocMonad m => String -> LP m a -> LP m a
env name p = p <*
(try (controlSeq "end" *> braced >>= guard . (== name))
<?> ("\\end{" ++ name ++ "}"))
-listenv :: String -> LP a -> LP a
+listenv :: PandocMonad m => String -> LP m a -> LP m a
listenv name p = try $ do
oldCtx <- stateParserContext `fmap` getState
updateState $ \st -> st{ stateParserContext = ListItemState }
@@ -1216,14 +1223,14 @@ listenv name p = try $ do
updateState $ \st -> st{ stateParserContext = oldCtx }
return res
-mathEnv :: (Inlines -> a) -> Maybe String -> String -> LP a
+mathEnv :: PandocMonad m => (Inlines -> a) -> Maybe String -> String -> LP m a
mathEnv f innerEnv name = f <$> mathDisplay (inner <$> verbEnv name)
where inner x = case innerEnv of
Nothing -> x
Just y -> "\\begin{" ++ y ++ "}\n" ++ x ++
"\\end{" ++ y ++ "}"
-verbEnv :: String -> LP String
+verbEnv :: PandocMonad m => String -> LP m String
verbEnv name = do
skipopts
optional blankline
@@ -1231,7 +1238,7 @@ verbEnv name = do
res <- manyTill anyChar endEnv
return $ stripTrailingNewlines res
-fancyverbEnv :: String -> LP Blocks
+fancyverbEnv :: PandocMonad m => String -> LP m Blocks
fancyverbEnv name = do
options <- option [] keyvals
let kvs = [ (if k == "firstnumber"
@@ -1242,7 +1249,7 @@ fancyverbEnv name = do
let attr = ("",classes,kvs)
codeBlockWith attr <$> verbEnv name
-orderedList' :: LP Blocks
+orderedList' :: PandocMonad m => LP m Blocks
orderedList' = do
optional sp
(_, style, delim) <- option (1, DefaultStyle, DefaultDelim) $
@@ -1259,14 +1266,14 @@ orderedList' = do
bs <- listenv "enumerate" (many item)
return $ orderedListWith (start, style, delim) bs
-paragraph :: LP Blocks
+paragraph :: PandocMonad m => LP m Blocks
paragraph = do
x <- trimInlines . mconcat <$> many1 inline
if x == mempty
then return mempty
else return $ para x
-preamble :: LP Blocks
+preamble :: PandocMonad m => LP m Blocks
preamble = mempty <$> manyTill preambleBlock beginDoc
where beginDoc = lookAhead $ try $ controlSeq "begin" *> string "{document}"
preambleBlock = void comment
@@ -1292,7 +1299,7 @@ addSuffix s ks@(_:_) =
in init ks ++ [k {citationSuffix = citationSuffix k ++ s}]
addSuffix _ _ = []
-simpleCiteArgs :: LP [Citation]
+simpleCiteArgs :: PandocMonad m => LP m [Citation]
simpleCiteArgs = try $ do
first <- optionMaybe $ toList <$> opt
second <- optionMaybe $ toList <$> opt
@@ -1312,7 +1319,7 @@ simpleCiteArgs = try $ do
}
return $ addPrefix pre $ addSuffix suf $ map conv keys
-citationLabel :: LP String
+citationLabel :: PandocMonad m => LP m String
citationLabel = optional sp *>
(many1 (satisfy isBibtexKeyChar)
<* optional sp
@@ -1320,7 +1327,7 @@ citationLabel = optional sp *>
<* optional sp)
where isBibtexKeyChar c = isAlphaNum c || c `elem` (".:;?!`'()/*@_+=-[]" :: String)
-cites :: CitationMode -> Bool -> LP [Citation]
+cites :: PandocMonad m => CitationMode -> Bool -> LP m [Citation]
cites mode multi = try $ do
cits <- if multi
then many1 simpleCiteArgs
@@ -1332,12 +1339,12 @@ cites mode multi = try $ do
[] -> []
_ -> map (\a -> a {citationMode = mode}) cs
-citation :: String -> CitationMode -> Bool -> LP Inlines
+citation :: PandocMonad m => String -> CitationMode -> Bool -> LP m Inlines
citation name mode multi = do
(c,raw) <- withRaw $ cites mode multi
return $ cite c (rawInline "latex" $ "\\" ++ name ++ raw)
-complexNatbibCitation :: CitationMode -> LP Inlines
+complexNatbibCitation :: PandocMonad m => CitationMode -> LP m Inlines
complexNatbibCitation mode = try $ do
let ils = (toList . trimInlines . mconcat) <$>
many (notFollowedBy (oneOf "\\};") >> inline)
@@ -1359,7 +1366,7 @@ complexNatbibCitation mode = try $ do
-- tables
-parseAligns :: LP [Alignment]
+parseAligns :: PandocMonad m => LP m [Alignment]
parseAligns = try $ do
char '{'
let maybeBar = skipMany $ sp <|> () <$ char '|' <|> () <$ (char '@' >> braced)
@@ -1375,7 +1382,7 @@ parseAligns = try $ do
spaces
return aligns'
-hline :: LP ()
+hline :: PandocMonad m => LP m ()
hline = try $ do
spaces'
controlSeq "hline" <|>
@@ -1389,16 +1396,16 @@ hline = try $ do
optional $ bracketed (many1 (satisfy (/=']')))
return ()
-lbreak :: LP ()
+lbreak :: PandocMonad m => LP m ()
lbreak = () <$ try (spaces' *>
(controlSeq "\\" <|> controlSeq "tabularnewline") <*
spaces')
-amp :: LP ()
+amp :: PandocMonad m => LP m ()
amp = () <$ try (spaces' *> char '&' <* spaces')
-parseTableRow :: Int -- ^ number of columns
- -> LP [Blocks]
+parseTableRow :: PandocMonad m => Int -- ^ number of columns
+ -> LP m [Blocks]
parseTableRow cols = try $ do
let tableCellInline = notFollowedBy (amp <|> lbreak) >> inline
let minipage = try $ controlSeq "begin" *> string "{minipage}" *>
@@ -1415,10 +1422,10 @@ parseTableRow cols = try $ do
spaces'
return cells''
-spaces' :: LP ()
+spaces' :: PandocMonad m => LP m ()
spaces' = spaces *> skipMany (comment *> spaces)
-simpTable :: Bool -> LP Blocks
+simpTable :: PandocMonad m => Bool -> LP m Blocks
simpTable hasWidthParameter = try $ do
when hasWidthParameter $ () <$ (spaces' >> tok)
skipopts
@@ -1442,13 +1449,13 @@ simpTable hasWidthParameter = try $ do
lookAhead $ controlSeq "end" -- make sure we're at end
return $ table mempty (zip aligns (repeat 0)) header'' rows
-startInclude :: LP Blocks
+startInclude :: PandocMonad m => LP m Blocks
startInclude = do
fn <- braced
setPosition $ newPos fn 1 1
return mempty
-endInclude :: LP Blocks
+endInclude :: PandocMonad m => LP m Blocks
endInclude = do
fn <- braced
ln <- braced
diff --git a/src/Text/Pandoc/Readers/Markdown.hs b/src/Text/Pandoc/Readers/Markdown.hs
index cd35a8738..e5df065ff 100644
--- a/src/Text/Pandoc/Readers/Markdown.hs
+++ b/src/Text/Pandoc/Readers/Markdown.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE RelaxedPolyRec #-} -- needed for inlinesBetween on GHC < 7
{-# LANGUAGE ScopedTypeVariables #-}
+
{-
Copyright (C) 2006-2015 John MacFarlane <jgm@berkeley.edu>
@@ -65,24 +66,31 @@ import qualified Data.Set as Set
import Text.Printf (printf)
import Debug.Trace (trace)
import Data.Monoid ((<>))
-import Text.Pandoc.Error
+import Control.Monad.Trans (lift)
+import Control.Monad.Except (throwError, catchError)
+import Text.Pandoc.Class (PandocMonad, PandocExecutionError(..))
+import qualified Text.Pandoc.Class as P
-type MarkdownParser = Parser [Char] ParserState
+type MarkdownParser m = ParserT [Char] ParserState m
-- | Read markdown from an input string and return a Pandoc document.
-readMarkdown :: ReaderOptions -- ^ Reader options
+readMarkdown :: PandocMonad m
+ => ReaderOptions -- ^ Reader options
-> String -- ^ String to parse (assuming @'\n'@ line endings)
- -> Either PandocError Pandoc
-readMarkdown opts s =
- (readWith parseMarkdown) def{ stateOptions = opts } (s ++ "\n\n")
+ -> m Pandoc
+readMarkdown opts s = do
+ parsed <- (readWithM parseMarkdown) def{ stateOptions = opts } (s ++ "\n\n")
+ case parsed of
+ Right result -> return result
+ Left _ -> throwError $ PandocParseError "markdown parse error"
-- | Read markdown from an input string and return a pair of a Pandoc document
-- and a list of warnings.
-readMarkdownWithWarnings :: ReaderOptions -- ^ Reader options
+readMarkdownWithWarnings :: PandocMonad m
+ => ReaderOptions -- ^ Reader options
-> String -- ^ String to parse (assuming @'\n'@ line endings)
- -> Either PandocError (Pandoc, [String])
-readMarkdownWithWarnings opts s =
- (readWithWarnings parseMarkdown) def{ stateOptions = opts } (s ++ "\n\n")
+ -> m Pandoc
+readMarkdownWithWarnings = readMarkdown
trimInlinesF :: F Inlines -> F Inlines
trimInlinesF = liftM trimInlines
@@ -117,25 +125,25 @@ isBlank _ = False
--
-- | Succeeds when we're in list context.
-inList :: MarkdownParser ()
+inList :: PandocMonad m => MarkdownParser m ()
inList = do
ctx <- stateParserContext <$> getState
guard (ctx == ListItemState)
-spnl :: Parser [Char] st ()
+spnl :: PandocMonad m => ParserT [Char] st m ()
spnl = try $ do
skipSpaces
optional newline
skipSpaces
notFollowedBy (char '\n')
-indentSpaces :: MarkdownParser String
+indentSpaces :: PandocMonad m => MarkdownParser m String
indentSpaces = try $ do
tabStop <- getOption readerTabStop
count tabStop (char ' ') <|>
string "\t" <?> "indentation"
-nonindentSpaces :: MarkdownParser String
+nonindentSpaces :: PandocMonad m => MarkdownParser m String
nonindentSpaces = do
tabStop <- getOption readerTabStop
sps <- many (char ' ')
@@ -144,17 +152,17 @@ nonindentSpaces = do
else unexpected "indented line"
-- returns number of spaces parsed
-skipNonindentSpaces :: MarkdownParser Int
+skipNonindentSpaces :: PandocMonad m => MarkdownParser m Int
skipNonindentSpaces = do
tabStop <- getOption readerTabStop
atMostSpaces (tabStop - 1) <* notFollowedBy (char ' ')
-atMostSpaces :: Int -> MarkdownParser Int
+atMostSpaces :: PandocMonad m => Int -> MarkdownParser m Int
atMostSpaces n
| n > 0 = (char ' ' >> (+1) <$> atMostSpaces (n-1)) <|> return 0
| otherwise = return 0
-litChar :: MarkdownParser Char
+litChar :: PandocMonad m => MarkdownParser m Char
litChar = escapedChar'
<|> characterReference
<|> noneOf "\n"
@@ -162,14 +170,14 @@ litChar = escapedChar'
-- | Parse a sequence of inline elements between square brackets,
-- including inlines between balanced pairs of square brackets.
-inlinesInBalancedBrackets :: MarkdownParser (F Inlines)
+inlinesInBalancedBrackets :: PandocMonad m => MarkdownParser m (F Inlines)
inlinesInBalancedBrackets = do
char '['
(_, raw) <- withRaw $ charsInBalancedBrackets 1
guard $ not $ null raw
parseFromString (trimInlinesF . mconcat <$> many inline) (init raw)
-charsInBalancedBrackets :: Int -> MarkdownParser ()
+charsInBalancedBrackets :: PandocMonad m => Int -> MarkdownParser m ()
charsInBalancedBrackets 0 = return ()
charsInBalancedBrackets openBrackets =
(char '[' >> charsInBalancedBrackets (openBrackets + 1))
@@ -185,7 +193,7 @@ charsInBalancedBrackets openBrackets =
-- document structure
--
-rawTitleBlockLine :: MarkdownParser String
+rawTitleBlockLine :: PandocMonad m => MarkdownParser m String
rawTitleBlockLine = do
char '%'
skipSpaces
@@ -196,13 +204,13 @@ rawTitleBlockLine = do
anyLine
return $ trim $ unlines (first:rest)
-titleLine :: MarkdownParser (F Inlines)
+titleLine :: PandocMonad m => MarkdownParser m (F Inlines)
titleLine = try $ do
raw <- rawTitleBlockLine
res <- parseFromString (many inline) raw
return $ trimInlinesF $ mconcat res
-authorsLine :: MarkdownParser (F [Inlines])
+authorsLine :: PandocMonad m => MarkdownParser m (F [Inlines])
authorsLine = try $ do
raw <- rawTitleBlockLine
let sep = (char ';' <* spaces) <|> newline
@@ -212,16 +220,16 @@ authorsLine = try $ do
sep
sequence <$> parseFromString pAuthors raw
-dateLine :: MarkdownParser (F Inlines)
+dateLine :: PandocMonad m => MarkdownParser m (F Inlines)
dateLine = try $ do
raw <- rawTitleBlockLine
res <- parseFromString (many inline) raw
return $ trimInlinesF $ mconcat res
-titleBlock :: MarkdownParser ()
+titleBlock :: PandocMonad m => MarkdownParser m ()
titleBlock = pandocTitleBlock <|> mmdTitleBlock
-pandocTitleBlock :: MarkdownParser ()
+pandocTitleBlock :: PandocMonad m => MarkdownParser m ()
pandocTitleBlock = try $ do
guardEnabled Ext_pandoc_title_block
lookAhead (char '%')
@@ -239,7 +247,15 @@ pandocTitleBlock = try $ do
$ nullMeta
updateState $ \st -> st{ stateMeta' = stateMeta' st <> meta' }
-yamlMetaBlock :: MarkdownParser (F Blocks)
+
+-- Adapted from solution at
+-- http://stackoverflow.com/a/29448764/1901888
+foldrWithKeyM :: Monad m => (k -> b -> a -> m a) -> a -> H.HashMap k b -> m a
+foldrWithKeyM f acc = H.foldrWithKey f' (return acc)
+ where
+ f' k b ma = ma >>= \a -> f k b a
+
+yamlMetaBlock :: PandocMonad m => MarkdownParser m (F Blocks)
yamlMetaBlock = try $ do
guardEnabled Ext_yaml_metadata_block
pos <- getPosition
@@ -252,18 +268,20 @@ yamlMetaBlock = try $ do
optional blanklines
opts <- stateOptions <$> getState
meta' <- case Yaml.decodeEither' $ UTF8.fromString rawYaml of
- Right (Yaml.Object hashmap) -> return $ return $
- H.foldrWithKey (\k v m ->
- if ignorable k
- then m
- else case yamlToMeta opts v of
- Left _ -> m
- Right v' -> B.setMeta (T.unpack k) v' m)
- nullMeta hashmap
- Right Yaml.Null -> return $ return nullMeta
+ Right (Yaml.Object hashmap) ->
+ foldrWithKeyM
+ (\k v m -> do
+ if ignorable k
+ then return m
+ else (do v' <- lift $ yamlToMeta opts v
+ return $ B.setMeta (T.unpack k) v' m)
+ `catchError`
+ (\_ -> return m)
+ ) nullMeta hashmap
+ Right Yaml.Null -> return nullMeta
Right _ -> do
- addWarning (Just pos) "YAML header is not an object"
- return $ return nullMeta
+ P.addWarningWithPos (Just pos) "YAML header is not an object"
+ return nullMeta
Left err' -> do
case err' of
InvalidYaml (Just YamlParseException{
@@ -273,24 +291,24 @@ yamlMetaBlock = try $ do
yamlLine = yline
, yamlColumn = ycol
}}) ->
- addWarning (Just $ setSourceLine
+ P.addWarningWithPos (Just $ setSourceLine
(setSourceColumn pos
(sourceColumn pos + ycol))
(sourceLine pos + 1 + yline))
$ "Could not parse YAML header: " ++
problem
- _ -> addWarning (Just pos)
+ _ -> P.addWarningWithPos (Just pos)
$ "Could not parse YAML header: " ++
show err'
- return $ return nullMeta
- updateState $ \st -> st{ stateMeta' = stateMeta' st <> meta' }
+ return nullMeta
+ updateState $ \st -> st{ stateMeta' = stateMeta' st <> (return meta') }
return mempty
-- ignore fields ending with _
ignorable :: Text -> Bool
ignorable t = (T.pack "_") `T.isSuffixOf` t
-toMetaValue :: ReaderOptions -> Text -> Either PandocError MetaValue
+toMetaValue :: PandocMonad m => ReaderOptions -> Text -> m MetaValue
toMetaValue opts x = toMeta <$> readMarkdown opts' (T.unpack x)
where
toMeta p =
@@ -307,7 +325,7 @@ toMetaValue opts x = toMeta <$> readMarkdown opts' (T.unpack x)
, Ext_yaml_metadata_block
]
-yamlToMeta :: ReaderOptions -> Yaml.Value -> Either PandocError MetaValue
+yamlToMeta :: PandocMonad m => ReaderOptions -> Yaml.Value -> m MetaValue
yamlToMeta opts (Yaml.String t) = toMetaValue opts t
yamlToMeta _ (Yaml.Number n)
-- avoid decimal points for numbers that don't need them:
@@ -327,10 +345,10 @@ yamlToMeta opts (Yaml.Object o) = MetaMap <$> H.foldrWithKey (\k v m ->
(return M.empty) o
yamlToMeta _ _ = return $ MetaString ""
-stopLine :: MarkdownParser ()
+stopLine :: PandocMonad m => MarkdownParser m ()
stopLine = try $ (string "---" <|> string "...") >> blankline >> return ()
-mmdTitleBlock :: MarkdownParser ()
+mmdTitleBlock :: PandocMonad m => MarkdownParser m ()
mmdTitleBlock = try $ do
guardEnabled Ext_mmd_title_block
firstPair <- kvPair False
@@ -340,7 +358,7 @@ mmdTitleBlock = try $ do
updateState $ \st -> st{ stateMeta' = stateMeta' st <>
return (Meta $ M.fromList kvPairs) }
-kvPair :: Bool -> MarkdownParser (String, MetaValue)
+kvPair :: PandocMonad m => Bool -> MarkdownParser m (String, MetaValue)
kvPair allowEmpty = try $ do
key <- many1Till (alphaNum <|> oneOf "_- ") (char ':')
val <- trim <$> manyTill anyChar
@@ -350,7 +368,7 @@ kvPair allowEmpty = try $ do
let val' = MetaBlocks $ B.toList $ B.plain $ B.text $ val
return (key',val')
-parseMarkdown :: MarkdownParser Pandoc
+parseMarkdown :: PandocMonad m => MarkdownParser m Pandoc
parseMarkdown = do
-- markdown allows raw HTML
updateState $ \state -> state { stateOptions =
@@ -375,7 +393,7 @@ softBreakFilter (x:SoftBreak:y:zs) =
_ -> x:SoftBreak:y:zs
softBreakFilter xs = xs
-referenceKey :: MarkdownParser (F Blocks)
+referenceKey :: PandocMonad m => MarkdownParser m (F Blocks)
referenceKey = try $ do
pos <- getPosition
skipNonindentSpaces
@@ -402,18 +420,18 @@ referenceKey = try $ do
let oldkeys = stateKeys st
let key = toKey raw
case M.lookup key oldkeys of
- Just _ -> addWarning (Just pos) $ "Duplicate link reference `" ++ raw ++ "'"
+ Just _ -> P.addWarningWithPos (Just pos) $ "Duplicate link reference `" ++ raw ++ "'"
Nothing -> return ()
updateState $ \s -> s { stateKeys = M.insert key (target, attr') oldkeys }
return $ return mempty
-referenceTitle :: MarkdownParser String
+referenceTitle :: PandocMonad m => MarkdownParser m String
referenceTitle = try $ do
skipSpaces >> optional newline >> skipSpaces
quotedTitle '"' <|> quotedTitle '\'' <|> charsInBalanced '(' ')' litChar
-- A link title in quotes
-quotedTitle :: Char -> MarkdownParser String
+quotedTitle :: PandocMonad m => Char -> MarkdownParser m String
quotedTitle c = try $ do
char c
notFollowedBy spaces
@@ -425,7 +443,7 @@ quotedTitle c = try $ do
-- | PHP Markdown Extra style abbreviation key. Currently
-- we just skip them, since Pandoc doesn't have an element for
-- an abbreviation.
-abbrevKey :: MarkdownParser (F Blocks)
+abbrevKey :: PandocMonad m => MarkdownParser m (F Blocks)
abbrevKey = do
guardEnabled Ext_abbreviations
try $ do
@@ -436,23 +454,23 @@ abbrevKey = do
blanklines
return $ return mempty
-noteMarker :: MarkdownParser String
+noteMarker :: PandocMonad m => MarkdownParser m String
noteMarker = string "[^" >> many1Till (satisfy $ not . isBlank) (char ']')
-rawLine :: MarkdownParser String
+rawLine :: PandocMonad m => MarkdownParser m String
rawLine = try $ do
notFollowedBy blankline
notFollowedBy' $ try $ skipNonindentSpaces >> noteMarker
optional indentSpaces
anyLine
-rawLines :: MarkdownParser String
+rawLines :: PandocMonad m => MarkdownParser m String
rawLines = do
first <- anyLine
rest <- many rawLine
return $ unlines (first:rest)
-noteBlock :: MarkdownParser (F Blocks)
+noteBlock :: PandocMonad m => MarkdownParser m (F Blocks)
noteBlock = try $ do
pos <- getPosition
skipNonindentSpaces
@@ -468,7 +486,7 @@ noteBlock = try $ do
let newnote = (ref, parsed)
oldnotes <- stateNotes' <$> getState
case lookup ref oldnotes of
- Just _ -> addWarning (Just pos) $ "Duplicate note reference `" ++ ref ++ "'"
+ Just _ -> P.addWarningWithPos (Just pos) $ "Duplicate note reference `" ++ ref ++ "'"
Nothing -> return ()
updateState $ \s -> s { stateNotes' = newnote : oldnotes }
return mempty
@@ -477,10 +495,10 @@ noteBlock = try $ do
-- parsing blocks
--
-parseBlocks :: MarkdownParser (F Blocks)
+parseBlocks :: PandocMonad m => MarkdownParser m (F Blocks)
parseBlocks = mconcat <$> manyTill block eof
-block :: MarkdownParser (F Blocks)
+block :: PandocMonad m => MarkdownParser m (F Blocks)
block = do
tr <- getOption readerTrace
pos <- getPosition
@@ -519,16 +537,16 @@ block = do
-- header blocks
--
-header :: MarkdownParser (F Blocks)
+header :: PandocMonad m => MarkdownParser m (F Blocks)
header = setextHeader <|> atxHeader <?> "header"
-atxChar :: MarkdownParser Char
+atxChar :: PandocMonad m => MarkdownParser m Char
atxChar = do
exts <- getOption readerExtensions
return $ if Set.member Ext_literate_haskell exts
then '=' else '#'
-atxHeader :: MarkdownParser (F Blocks)
+atxHeader :: PandocMonad m => MarkdownParser m (F Blocks)
atxHeader = try $ do
level <- atxChar >>= many1 . char >>= return . length
notFollowedBy $ guardEnabled Ext_fancy_lists >>
@@ -542,7 +560,7 @@ atxHeader = try $ do
<|> registerImplicitHeader raw attr'
return $ B.headerWith attr' level <$> text
-atxClosing :: MarkdownParser Attr
+atxClosing :: PandocMonad m => MarkdownParser m Attr
atxClosing = try $ do
attr' <- option nullAttr
(guardEnabled Ext_mmd_header_identifiers >> mmdHeaderIdentifier)
@@ -553,7 +571,7 @@ atxClosing = try $ do
blanklines
return attr
-setextHeaderEnd :: MarkdownParser Attr
+setextHeaderEnd :: PandocMonad m => MarkdownParser m Attr
setextHeaderEnd = try $ do
attr <- option nullAttr
$ (guardEnabled Ext_mmd_header_identifiers >> mmdHeaderIdentifier)
@@ -561,13 +579,13 @@ setextHeaderEnd = try $ do
blanklines
return attr
-mmdHeaderIdentifier :: MarkdownParser Attr
+mmdHeaderIdentifier :: PandocMonad m => MarkdownParser m Attr
mmdHeaderIdentifier = do
ident <- stripFirstAndLast . snd <$> reference
skipSpaces
return (ident,[],[])
-setextHeader :: MarkdownParser (F Blocks)
+setextHeader :: PandocMonad m => MarkdownParser m (F Blocks)
setextHeader = try $ do
-- This lookahead prevents us from wasting time parsing Inlines
-- unless necessary -- it gives a significant performance boost.
@@ -585,7 +603,7 @@ setextHeader = try $ do
<|> registerImplicitHeader raw attr'
return $ B.headerWith attr' level <$> text
-registerImplicitHeader :: String -> Attr -> MarkdownParser ()
+registerImplicitHeader :: PandocMonad m => String -> Attr -> MarkdownParser m ()
registerImplicitHeader raw attr@(ident, _, _) = do
let key = toKey $ "[" ++ raw ++ "]"
updateState (\s -> s { stateHeaderKeys =
@@ -595,7 +613,7 @@ registerImplicitHeader raw attr@(ident, _, _) = do
-- hrule block
--
-hrule :: Parser [Char] st (F Blocks)
+hrule :: PandocMonad m => ParserT [Char] st m (F Blocks)
hrule = try $ do
skipSpaces
start <- satisfy isHruleChar
@@ -609,12 +627,13 @@ hrule = try $ do
-- code blocks
--
-indentedLine :: MarkdownParser String
+indentedLine :: PandocMonad m => MarkdownParser m String
indentedLine = indentSpaces >> anyLine >>= return . (++ "\n")
-blockDelimiter :: (Char -> Bool)
+blockDelimiter :: PandocMonad m
+ => (Char -> Bool)
-> Maybe Int
- -> Parser [Char] st Int
+ -> ParserT [Char] st m Int
blockDelimiter f len = try $ do
c <- lookAhead (satisfy f)
case len of
@@ -622,7 +641,7 @@ blockDelimiter f len = try $ do
Nothing -> count 3 (char c) >> many (char c) >>=
return . (+ 3) . length
-attributes :: MarkdownParser Attr
+attributes :: PandocMonad m => MarkdownParser m Attr
attributes = try $ do
char '{'
spnl
@@ -630,28 +649,28 @@ attributes = try $ do
char '}'
return $ foldl (\x f -> f x) nullAttr attrs
-attribute :: MarkdownParser (Attr -> Attr)
+attribute :: PandocMonad m => MarkdownParser m (Attr -> Attr)
attribute = identifierAttr <|> classAttr <|> keyValAttr <|> specialAttr
-identifier :: MarkdownParser String
+identifier :: PandocMonad m => MarkdownParser m String
identifier = do
first <- letter
rest <- many $ alphaNum <|> oneOf "-_:."
return (first:rest)
-identifierAttr :: MarkdownParser (Attr -> Attr)
+identifierAttr :: PandocMonad m => MarkdownParser m (Attr -> Attr)
identifierAttr = try $ do
char '#'
result <- identifier
return $ \(_,cs,kvs) -> (result,cs,kvs)
-classAttr :: MarkdownParser (Attr -> Attr)
+classAttr :: PandocMonad m => MarkdownParser m (Attr -> Attr)
classAttr = try $ do
char '.'
result <- identifier
return $ \(id',cs,kvs) -> (id',cs ++ [result],kvs)
-keyValAttr :: MarkdownParser (Attr -> Attr)
+keyValAttr :: PandocMonad m => MarkdownParser m (Attr -> Attr)
keyValAttr = try $ do
key <- identifier
char '='
@@ -664,12 +683,12 @@ keyValAttr = try $ do
"class" -> (id',cs ++ words val,kvs)
_ -> (id',cs,kvs ++ [(key,val)])
-specialAttr :: MarkdownParser (Attr -> Attr)
+specialAttr :: PandocMonad m => MarkdownParser m (Attr -> Attr)
specialAttr = do
char '-'
return $ \(id',cs,kvs) -> (id',cs ++ ["unnumbered"],kvs)
-codeBlockFenced :: MarkdownParser (F Blocks)
+codeBlockFenced :: PandocMonad m => MarkdownParser m (F Blocks)
codeBlockFenced = try $ do
c <- try (guardEnabled Ext_fenced_code_blocks >> lookAhead (char '~'))
<|> (guardEnabled Ext_backtick_code_blocks >> lookAhead (char '`'))
@@ -690,7 +709,7 @@ toLanguageId = map toLower . go
go "objective-c" = "objectivec"
go x = x
-codeBlockIndented :: MarkdownParser (F Blocks)
+codeBlockIndented :: PandocMonad m => MarkdownParser m (F Blocks)
codeBlockIndented = do
contents <- many1 (indentedLine <|>
try (do b <- blanklines
@@ -701,7 +720,7 @@ codeBlockIndented = do
return $ return $ B.codeBlockWith ("", classes, []) $
stripTrailingNewlines $ concat contents
-lhsCodeBlock :: MarkdownParser (F Blocks)
+lhsCodeBlock :: PandocMonad m => MarkdownParser m (F Blocks)
lhsCodeBlock = do
guardEnabled Ext_literate_haskell
(return . B.codeBlockWith ("",["sourceCode","literate","haskell"],[]) <$>
@@ -709,7 +728,7 @@ lhsCodeBlock = do
<|> (return . B.codeBlockWith ("",["sourceCode","haskell"],[]) <$>
lhsCodeBlockInverseBird)
-lhsCodeBlockLaTeX :: MarkdownParser String
+lhsCodeBlockLaTeX :: PandocMonad m => MarkdownParser m String
lhsCodeBlockLaTeX = try $ do
string "\\begin{code}"
manyTill spaceChar newline
@@ -717,13 +736,13 @@ lhsCodeBlockLaTeX = try $ do
blanklines
return $ stripTrailingNewlines contents
-lhsCodeBlockBird :: MarkdownParser String
+lhsCodeBlockBird :: PandocMonad m => MarkdownParser m String
lhsCodeBlockBird = lhsCodeBlockBirdWith '>'
-lhsCodeBlockInverseBird :: MarkdownParser String
+lhsCodeBlockInverseBird :: PandocMonad m => MarkdownParser m String
lhsCodeBlockInverseBird = lhsCodeBlockBirdWith '<'
-lhsCodeBlockBirdWith :: Char -> MarkdownParser String
+lhsCodeBlockBirdWith :: PandocMonad m => Char -> MarkdownParser m String
lhsCodeBlockBirdWith c = try $ do
pos <- getPosition
when (sourceColumn pos /= 1) $ fail "Not in first column"
@@ -735,7 +754,7 @@ lhsCodeBlockBirdWith c = try $ do
blanklines
return $ intercalate "\n" lns'
-birdTrackLine :: Char -> Parser [Char] st String
+birdTrackLine :: PandocMonad m => Char -> ParserT [Char] st m String
birdTrackLine c = try $ do
char c
-- allow html tags on left margin:
@@ -746,10 +765,10 @@ birdTrackLine c = try $ do
-- block quotes
--
-emailBlockQuoteStart :: MarkdownParser Char
+emailBlockQuoteStart :: PandocMonad m => MarkdownParser m Char
emailBlockQuoteStart = try $ skipNonindentSpaces >> char '>' <* optional (char ' ')
-emailBlockQuote :: MarkdownParser [String]
+emailBlockQuote :: PandocMonad m => MarkdownParser m [String]
emailBlockQuote = try $ do
emailBlockQuoteStart
let emailLine = many $ nonEndline <|> try
@@ -763,7 +782,7 @@ emailBlockQuote = try $ do
optional blanklines
return raw
-blockQuote :: MarkdownParser (F Blocks)
+blockQuote :: PandocMonad m => MarkdownParser m (F Blocks)
blockQuote = do
raw <- emailBlockQuote
-- parse the extracted block, which may contain various block elements:
@@ -774,7 +793,7 @@ blockQuote = do
-- list blocks
--
-bulletListStart :: MarkdownParser ()
+bulletListStart :: PandocMonad m => MarkdownParser m ()
bulletListStart = try $ do
optional newline -- if preceded by a Plain block in a list context
startpos <- sourceColumn <$> getPosition
@@ -786,7 +805,7 @@ bulletListStart = try $ do
lookAhead (newline <|> spaceChar)
() <$ atMostSpaces (tabStop - (endpos - startpos))
-anyOrderedListStart :: MarkdownParser (Int, ListNumberStyle, ListNumberDelim)
+anyOrderedListStart :: PandocMonad m => MarkdownParser m (Int, ListNumberStyle, ListNumberDelim)
anyOrderedListStart = try $ do
optional newline -- if preceded by a Plain block in a list context
startpos <- sourceColumn <$> getPosition
@@ -810,10 +829,10 @@ anyOrderedListStart = try $ do
atMostSpaces (tabStop - (endpos - startpos))
return res
-listStart :: MarkdownParser ()
+listStart :: PandocMonad m => MarkdownParser m ()
listStart = bulletListStart <|> (anyOrderedListStart >> return ())
-listLine :: MarkdownParser String
+listLine :: PandocMonad m => MarkdownParser m String
listLine = try $ do
notFollowedBy' (do indentSpaces
many spaceChar
@@ -822,7 +841,7 @@ listLine = try $ do
optional (() <$ indentSpaces)
listLineCommon
-listLineCommon :: MarkdownParser String
+listLineCommon :: PandocMonad m => MarkdownParser m String
listLineCommon = concat <$> manyTill
( many1 (satisfy $ \c -> c /= '\n' && c /= '<')
<|> liftM snd (htmlTag isCommentTag)
@@ -830,8 +849,9 @@ listLineCommon = concat <$> manyTill
) newline
-- parse raw text for one list item, excluding start marker and continuations
-rawListItem :: MarkdownParser a
- -> MarkdownParser String
+rawListItem :: PandocMonad m
+ => MarkdownParser m a
+ -> MarkdownParser m String
rawListItem start = try $ do
start
first <- listLineCommon
@@ -842,21 +862,21 @@ rawListItem start = try $ do
-- continuation of a list item - indented and separated by blankline
-- or (in compact lists) endline.
-- note: nested lists are parsed as continuations
-listContinuation :: MarkdownParser String
+listContinuation :: PandocMonad m => MarkdownParser m String
listContinuation = try $ do
lookAhead indentSpaces
result <- many1 listContinuationLine
blanks <- many blankline
return $ concat result ++ blanks
-notFollowedByHtmlCloser :: MarkdownParser ()
+notFollowedByHtmlCloser :: PandocMonad m => MarkdownParser m ()
notFollowedByHtmlCloser = do
inHtmlBlock <- stateInHtmlBlock <$> getState
case inHtmlBlock of
Just t -> notFollowedBy' $ htmlTag (~== TagClose t)
Nothing -> return ()
-listContinuationLine :: MarkdownParser String
+listContinuationLine :: PandocMonad m => MarkdownParser m String
listContinuationLine = try $ do
notFollowedBy blankline
notFollowedBy' listStart
@@ -865,8 +885,9 @@ listContinuationLine = try $ do
result <- anyLine
return $ result ++ "\n"
-listItem :: MarkdownParser a
- -> MarkdownParser (F Blocks)
+listItem :: PandocMonad m
+ => MarkdownParser m a
+ -> MarkdownParser m (F Blocks)
listItem start = try $ do
first <- rawListItem start
continuations <- many listContinuation
@@ -882,7 +903,7 @@ listItem start = try $ do
updateState (\st -> st {stateParserContext = oldContext})
return contents
-orderedList :: MarkdownParser (F Blocks)
+orderedList :: PandocMonad m => MarkdownParser m (F Blocks)
orderedList = try $ do
(start, style, delim) <- lookAhead anyOrderedListStart
unless (style `elem` [DefaultStyle, Decimal, Example] &&
@@ -903,14 +924,14 @@ orderedList = try $ do
start' <- option 1 $ guardEnabled Ext_startnum >> return start
return $ B.orderedListWith (start', style, delim) <$> fmap compactify' items
-bulletList :: MarkdownParser (F Blocks)
+bulletList :: PandocMonad m => MarkdownParser m (F Blocks)
bulletList = do
items <- fmap sequence $ many1 $ listItem bulletListStart
return $ B.bulletList <$> fmap compactify' items
-- definition lists
-defListMarker :: MarkdownParser ()
+defListMarker :: PandocMonad m => MarkdownParser m ()
defListMarker = do
sps <- nonindentSpaces
char ':' <|> char '~'
@@ -921,7 +942,7 @@ defListMarker = do
else mzero
return ()
-definitionListItem :: Bool -> MarkdownParser (F (Inlines, [Blocks]))
+definitionListItem :: PandocMonad m => Bool -> MarkdownParser m (F (Inlines, [Blocks]))
definitionListItem compact = try $ do
rawLine' <- anyLine
raw <- many1 $ defRawBlock compact
@@ -930,7 +951,7 @@ definitionListItem compact = try $ do
optional blanklines
return $ liftM2 (,) term (sequence contents)
-defRawBlock :: Bool -> MarkdownParser String
+defRawBlock :: PandocMonad m => Bool -> MarkdownParser m String
defRawBlock compact = try $ do
hasBlank <- option False $ blankline >> return True
defListMarker
@@ -952,7 +973,7 @@ defRawBlock compact = try $ do
return $ trimr (firstline ++ "\n" ++ unlines rawlines ++ cont) ++
if hasBlank || not (null cont) then "\n\n" else ""
-definitionList :: MarkdownParser (F Blocks)
+definitionList :: PandocMonad m => MarkdownParser m (F Blocks)
definitionList = try $ do
lookAhead (anyLine >>
optional (blankline >> notFollowedBy (table >> return ())) >>
@@ -960,13 +981,13 @@ definitionList = try $ do
defListMarker)
compactDefinitionList <|> normalDefinitionList
-compactDefinitionList :: MarkdownParser (F Blocks)
+compactDefinitionList :: PandocMonad m => MarkdownParser m (F Blocks)
compactDefinitionList = do
guardEnabled Ext_compact_definition_lists
items <- fmap sequence $ many1 $ definitionListItem True
return $ B.definitionList <$> fmap compactify'DL items
-normalDefinitionList :: MarkdownParser (F Blocks)
+normalDefinitionList :: PandocMonad m => MarkdownParser m (F Blocks)
normalDefinitionList = do
guardEnabled Ext_definition_lists
items <- fmap sequence $ many1 $ definitionListItem False
@@ -976,7 +997,7 @@ normalDefinitionList = do
-- paragraph block
--
-para :: MarkdownParser (F Blocks)
+para :: PandocMonad m => MarkdownParser m (F Blocks)
para = try $ do
exts <- getOption readerExtensions
result <- trimInlinesF . mconcat <$> many1 inline
@@ -1007,19 +1028,19 @@ para = try $ do
$ Image attr alt (src,'f':'i':'g':':':tit)
_ -> return $ B.para result'
-plain :: MarkdownParser (F Blocks)
+plain :: PandocMonad m => MarkdownParser m (F Blocks)
plain = fmap B.plain . trimInlinesF . mconcat <$> many1 inline
--
-- raw html
--
-htmlElement :: MarkdownParser String
+htmlElement :: PandocMonad m => MarkdownParser m String
htmlElement = rawVerbatimBlock
<|> strictHtmlBlock
<|> liftM snd (htmlTag isBlockTag)
-htmlBlock :: MarkdownParser (F Blocks)
+htmlBlock :: PandocMonad m => MarkdownParser m (F Blocks)
htmlBlock = do
guardEnabled Ext_raw_html
try (do
@@ -1044,24 +1065,24 @@ htmlBlock = do
<|> (guardEnabled Ext_markdown_in_html_blocks >> rawHtmlBlocks))
<|> htmlBlock'
-htmlBlock' :: MarkdownParser (F Blocks)
+htmlBlock' :: PandocMonad m => MarkdownParser m (F Blocks)
htmlBlock' = try $ do
first <- htmlElement
skipMany spaceChar
optional blanklines
return $ return $ B.rawBlock "html" first
-strictHtmlBlock :: MarkdownParser String
+strictHtmlBlock :: PandocMonad m => MarkdownParser m String
strictHtmlBlock = htmlInBalanced (not . isInlineTag)
-rawVerbatimBlock :: MarkdownParser String
+rawVerbatimBlock :: PandocMonad m => MarkdownParser m String
rawVerbatimBlock = htmlInBalanced isVerbTag
where isVerbTag (TagOpen "pre" _) = True
isVerbTag (TagOpen "style" _) = True
isVerbTag (TagOpen "script" _) = True
isVerbTag _ = False
-rawTeXBlock :: MarkdownParser (F Blocks)
+rawTeXBlock :: PandocMonad m => MarkdownParser m (F Blocks)
rawTeXBlock = do
guardEnabled Ext_raw_tex
result <- (B.rawBlock "latex" . concat <$>
@@ -1071,7 +1092,7 @@ rawTeXBlock = do
spaces
return $ return result
-rawHtmlBlocks :: MarkdownParser (F Blocks)
+rawHtmlBlocks :: PandocMonad m => MarkdownParser m (F Blocks)
rawHtmlBlocks = do
(TagOpen tagtype _, raw) <- htmlTag isBlockTag
-- try to find closing tag
@@ -1101,7 +1122,7 @@ stripMarkdownAttribute s = renderTags' $ map filterAttrib $ parseTags s
-- line block
--
-lineBlock :: MarkdownParser (F Blocks)
+lineBlock :: PandocMonad m => MarkdownParser m (F Blocks)
lineBlock = try $ do
guardEnabled Ext_line_blocks
lines' <- lineBlockLines >>=
@@ -1114,8 +1135,9 @@ lineBlock = try $ do
-- Parse a dashed line with optional trailing spaces; return its length
-- and the length including trailing space.
-dashedLine :: Char
- -> Parser [Char] st (Int, Int)
+dashedLine :: PandocMonad m
+ => Char
+ -> ParserT [Char] st m (Int, Int)
dashedLine ch = do
dashes <- many1 (char ch)
sp <- many spaceChar
@@ -1125,8 +1147,9 @@ dashedLine ch = do
-- Parse a table header with dashed lines of '-' preceded by
-- one (or zero) line of text.
-simpleTableHeader :: Bool -- ^ Headerless table
- -> MarkdownParser (F [Blocks], [Alignment], [Int])
+simpleTableHeader :: PandocMonad m
+ => Bool -- ^ Headerless table
+ -> MarkdownParser m (F [Blocks], [Alignment], [Int])
simpleTableHeader headless = try $ do
rawContent <- if headless
then return ""
@@ -1170,16 +1193,17 @@ alignType strLst len =
(False, False) -> AlignDefault
-- Parse a table footer - dashed lines followed by blank line.
-tableFooter :: MarkdownParser String
+tableFooter :: PandocMonad m => MarkdownParser m String
tableFooter = try $ skipNonindentSpaces >> many1 (dashedLine '-') >> blanklines
-- Parse a table separator - dashed line.
-tableSep :: MarkdownParser Char
+tableSep :: PandocMonad m => MarkdownParser m Char
tableSep = try $ skipNonindentSpaces >> many1 (dashedLine '-') >> char '\n'
-- Parse a raw line and split it into chunks by indices.
-rawTableLine :: [Int]
- -> MarkdownParser [String]
+rawTableLine :: PandocMonad m
+ => [Int]
+ -> MarkdownParser m [String]
rawTableLine indices = do
notFollowedBy' (blanklines <|> tableFooter)
line <- many1Till anyChar newline
@@ -1187,14 +1211,16 @@ rawTableLine indices = do
splitStringByIndices (init indices) line
-- Parse a table line and return a list of lists of blocks (columns).
-tableLine :: [Int]
- -> MarkdownParser (F [Blocks])
+tableLine :: PandocMonad m
+ => [Int]
+ -> MarkdownParser m (F [Blocks])
tableLine indices = rawTableLine indices >>=
fmap sequence . mapM (parseFromString (mconcat <$> many plain))
-- Parse a multiline table row and return a list of blocks (columns).
-multilineRow :: [Int]
- -> MarkdownParser (F [Blocks])
+multilineRow :: PandocMonad m
+ => [Int]
+ -> MarkdownParser m (F [Blocks])
multilineRow indices = do
colLines <- many1 (rawTableLine indices)
let cols = map unlines $ transpose colLines
@@ -1202,7 +1228,7 @@ multilineRow indices = do
-- Parses a table caption: inlines beginning with 'Table:'
-- and followed by blank lines.
-tableCaption :: MarkdownParser (F Inlines)
+tableCaption :: PandocMonad m => MarkdownParser m (F Inlines)
tableCaption = try $ do
guardEnabled Ext_table_captions
skipNonindentSpaces
@@ -1210,8 +1236,9 @@ tableCaption = try $ do
trimInlinesF . mconcat <$> many1 inline <* blanklines
-- Parse a simple table with '---' header and one line per row.
-simpleTable :: Bool -- ^ Headerless table
- -> MarkdownParser ([Alignment], [Double], F [Blocks], F [[Blocks]])
+simpleTable :: PandocMonad m
+ => Bool -- ^ Headerless table
+ -> MarkdownParser m ([Alignment], [Double], F [Blocks], F [[Blocks]])
simpleTable headless = do
(aligns, _widths, heads', lines') <-
tableWith (simpleTableHeader headless) tableLine
@@ -1224,13 +1251,15 @@ simpleTable headless = do
-- (which may be multiline), then the rows,
-- which may be multiline, separated by blank lines, and
-- ending with a footer (dashed line followed by blank line).
-multilineTable :: Bool -- ^ Headerless table
- -> MarkdownParser ([Alignment], [Double], F [Blocks], F [[Blocks]])
+multilineTable :: PandocMonad m
+ => Bool -- ^ Headerless table
+ -> MarkdownParser m ([Alignment], [Double], F [Blocks], F [[Blocks]])
multilineTable headless =
tableWith (multilineTableHeader headless) multilineRow blanklines tableFooter
-multilineTableHeader :: Bool -- ^ Headerless table
- -> MarkdownParser (F [Blocks], [Alignment], [Int])
+multilineTableHeader :: PandocMonad m
+ => Bool -- ^ Headerless table
+ -> MarkdownParser m (F [Blocks], [Alignment], [Int])
multilineTableHeader headless = try $ do
unless headless $
tableSep >> notFollowedBy blankline
@@ -1261,8 +1290,8 @@ multilineTableHeader headless = try $ do
-- (which may be grid), then the rows,
-- which may be grid, separated by blank lines, and
-- ending with a footer (dashed line followed by blank line).
-gridTable :: Bool -- ^ Headerless table
- -> MarkdownParser ([Alignment], [Double], F [Blocks], F [[Blocks]])
+gridTable :: PandocMonad m => Bool -- ^ Headerless table
+ -> MarkdownParser m ([Alignment], [Double], F [Blocks], F [[Blocks]])
gridTable headless =
tableWith (gridTableHeader headless) gridTableRow
(gridTableSep '-') gridTableFooter
@@ -1271,7 +1300,7 @@ gridTableSplitLine :: [Int] -> String -> [String]
gridTableSplitLine indices line = map removeFinalBar $ tail $
splitStringByIndices (init indices) $ trimr line
-gridPart :: Char -> Parser [Char] st ((Int, Int), Alignment)
+gridPart :: PandocMonad m => Char -> ParserT [Char] st m ((Int, Int), Alignment)
gridPart ch = do
leftColon <- option False (True <$ char ':')
dashes <- many1 (char ch)
@@ -1286,7 +1315,7 @@ gridPart ch = do
(False, False) -> AlignDefault
return ((lengthDashes, lengthDashes + 1), alignment)
-gridDashedLines :: Char -> Parser [Char] st [((Int, Int), Alignment)]
+gridDashedLines :: PandocMonad m => Char -> ParserT [Char] st m [((Int, Int), Alignment)]
gridDashedLines ch = try $ char '+' >> many1 (gridPart ch) <* blankline
removeFinalBar :: String -> String
@@ -1294,12 +1323,12 @@ removeFinalBar =
reverse . dropWhile (`elem` " \t") . dropWhile (=='|') . reverse
-- | Separator between rows of grid table.
-gridTableSep :: Char -> MarkdownParser Char
+gridTableSep :: PandocMonad m => Char -> MarkdownParser m Char
gridTableSep ch = try $ gridDashedLines ch >> return '\n'
-- | Parse header for a grid table.
-gridTableHeader :: Bool -- ^ Headerless table
- -> MarkdownParser (F [Blocks], [Alignment], [Int])
+gridTableHeader :: PandocMonad m => Bool -- ^ Headerless table
+ -> MarkdownParser m (F [Blocks], [Alignment], [Int])
gridTableHeader headless = try $ do
optional blanklines
dashes <- gridDashedLines '-'
@@ -1320,15 +1349,15 @@ gridTableHeader headless = try $ do
heads <- fmap sequence $ mapM (parseFromString parseBlocks . trim) rawHeads
return (heads, aligns, indices)
-gridTableRawLine :: [Int] -> MarkdownParser [String]
+gridTableRawLine :: PandocMonad m => [Int] -> MarkdownParser m [String]
gridTableRawLine indices = do
char '|'
line <- anyLine
return (gridTableSplitLine indices line)
-- | Parse row of grid table.
-gridTableRow :: [Int]
- -> MarkdownParser (F [Blocks])
+gridTableRow :: PandocMonad m => [Int]
+ -> MarkdownParser m (F [Blocks])
gridTableRow indices = do
colLines <- many1 (gridTableRawLine indices)
let cols = map ((++ "\n") . unlines . removeOneLeadingSpace) $
@@ -1344,10 +1373,10 @@ removeOneLeadingSpace xs =
startsWithSpace (y:_) = y == ' '
-- | Parse footer for a grid table.
-gridTableFooter :: MarkdownParser [Char]
+gridTableFooter :: PandocMonad m => MarkdownParser m [Char]
gridTableFooter = blanklines
-pipeBreak :: MarkdownParser ([Alignment], [Int])
+pipeBreak :: PandocMonad m => MarkdownParser m ([Alignment], [Int])
pipeBreak = try $ do
nonindentSpaces
openPipe <- (True <$ char '|') <|> return False
@@ -1359,7 +1388,7 @@ pipeBreak = try $ do
blankline
return $ unzip (first:rest)
-pipeTable :: MarkdownParser ([Alignment], [Double], F [Blocks], F [[Blocks]])
+pipeTable :: PandocMonad m => MarkdownParser m ([Alignment], [Double], F [Blocks], F [[Blocks]])
pipeTable = try $ do
nonindentSpaces
lookAhead nonspaceChar
@@ -1377,13 +1406,13 @@ pipeTable = try $ do
else replicate (length aligns) 0.0
return $ (aligns, widths, heads', sequence lines'')
-sepPipe :: MarkdownParser ()
+sepPipe :: PandocMonad m => MarkdownParser m ()
sepPipe = try $ do
char '|' <|> char '+'
notFollowedBy blankline
-- parse a row, also returning probable alignments for org-table cells
-pipeTableRow :: MarkdownParser (F [Blocks])
+pipeTableRow :: PandocMonad m => MarkdownParser m (F [Blocks])
pipeTableRow = try $ do
scanForPipe
skipMany spaceChar
@@ -1399,14 +1428,14 @@ pipeTableRow = try $ do
blankline
return $ sequence cells
-pipeTableCell :: MarkdownParser (F Blocks)
+pipeTableCell :: PandocMonad m => MarkdownParser m (F Blocks)
pipeTableCell = do
result <- many inline
if null result
then return mempty
else return $ B.plain . mconcat <$> sequence result
-pipeTableHeaderPart :: Parser [Char] st (Alignment, Int)
+pipeTableHeaderPart :: PandocMonad m => ParserT [Char] st m (Alignment, Int)
pipeTableHeaderPart = try $ do
skipMany spaceChar
left <- optionMaybe (char ':')
@@ -1422,7 +1451,7 @@ pipeTableHeaderPart = try $ do
(Just _,Just _) -> AlignCenter), len)
-- Succeed only if current line contains a pipe.
-scanForPipe :: Parser [Char] st ()
+scanForPipe :: PandocMonad m => ParserT [Char] st m ()
scanForPipe = do
inp <- getInput
case break (\c -> c == '\n' || c == '|') inp of
@@ -1432,11 +1461,12 @@ scanForPipe = do
-- | Parse a table using 'headerParser', 'rowParser',
-- 'lineParser', and 'footerParser'. Variant of the version in
-- Text.Pandoc.Parsing.
-tableWith :: MarkdownParser (F [Blocks], [Alignment], [Int])
- -> ([Int] -> MarkdownParser (F [Blocks]))
- -> MarkdownParser sep
- -> MarkdownParser end
- -> MarkdownParser ([Alignment], [Double], F [Blocks], F [[Blocks]])
+tableWith :: PandocMonad m
+ => MarkdownParser m (F [Blocks], [Alignment], [Int])
+ -> ([Int] -> MarkdownParser m (F [Blocks]))
+ -> MarkdownParser m sep
+ -> MarkdownParser m end
+ -> MarkdownParser m ([Alignment], [Double], F [Blocks], F [[Blocks]])
tableWith headerParser rowParser lineParser footerParser = try $ do
(heads, aligns, indices) <- headerParser
lines' <- fmap sequence $ rowParser indices `sepEndBy1` lineParser
@@ -1447,7 +1477,7 @@ tableWith headerParser rowParser lineParser footerParser = try $ do
else widthsFromIndices numColumns indices
return $ (aligns, widths, heads, lines')
-table :: MarkdownParser (F Blocks)
+table :: PandocMonad m => MarkdownParser m (F Blocks)
table = try $ do
frontCaption <- option Nothing (Just <$> tableCaption)
(aligns, widths, heads, lns) <-
@@ -1479,7 +1509,7 @@ table = try $ do
-- inline
--
-inline :: MarkdownParser (F Inlines)
+inline :: PandocMonad m => MarkdownParser m (F Inlines)
inline = choice [ whitespace
, bareURL
, str
@@ -1509,7 +1539,7 @@ inline = choice [ whitespace
, ltSign
] <?> "inline"
-escapedChar' :: MarkdownParser Char
+escapedChar' :: PandocMonad m => MarkdownParser m Char
escapedChar' = try $ do
char '\\'
(guardEnabled Ext_all_symbols_escapable >> satisfy (not . isAlphaNum))
@@ -1518,7 +1548,7 @@ escapedChar' = try $ do
<|> (guardEnabled Ext_escaped_line_breaks >> char '\n')
<|> oneOf "\\`*_{}[]()>#+-.!~\""
-escapedChar :: MarkdownParser (F Inlines)
+escapedChar :: PandocMonad m => MarkdownParser m (F Inlines)
escapedChar = do
result <- escapedChar'
case result of
@@ -1527,14 +1557,14 @@ escapedChar = do
return (return B.linebreak) -- "\[newline]" is a linebreak
_ -> return $ return $ B.str [result]
-ltSign :: MarkdownParser (F Inlines)
+ltSign :: PandocMonad m => MarkdownParser m (F Inlines)
ltSign = do
guardDisabled Ext_raw_html
<|> (notFollowedByHtmlCloser >> notFollowedBy' (htmlTag isBlockTag))
char '<'
return $ return $ B.str "<"
-exampleRef :: MarkdownParser (F Inlines)
+exampleRef :: PandocMonad m => MarkdownParser m (F Inlines)
exampleRef = try $ do
guardEnabled Ext_example_lists
char '@'
@@ -1545,7 +1575,7 @@ exampleRef = try $ do
Just n -> B.str (show n)
Nothing -> B.str ('@':lab)
-symbol :: MarkdownParser (F Inlines)
+symbol :: PandocMonad m => MarkdownParser m (F Inlines)
symbol = do
result <- noneOf "<\\\n\t "
<|> try (do lookAhead $ char '\\'
@@ -1554,7 +1584,7 @@ symbol = do
return $ return $ B.str [result]
-- parses inline code, between n `s and n `s
-code :: MarkdownParser (F Inlines)
+code :: PandocMonad m => MarkdownParser m (F Inlines)
code = try $ do
starts <- many1 (char '`')
skipSpaces
@@ -1566,7 +1596,7 @@ code = try $ do
>> attributes)
return $ return $ B.codeWith attr $ trim $ concat result
-math :: MarkdownParser (F Inlines)
+math :: PandocMonad m => MarkdownParser m (F Inlines)
math = (return . B.displayMath <$> (mathDisplay >>= applyMacros'))
<|> (return . B.math <$> (mathInline >>= applyMacros')) <+?>
((getOption readerSmart >>= guard) *> (return <$> apostrophe)
@@ -1574,8 +1604,9 @@ math = (return . B.displayMath <$> (mathDisplay >>= applyMacros'))
-- Parses material enclosed in *s, **s, _s, or __s.
-- Designed to avoid backtracking.
-enclosure :: Char
- -> MarkdownParser (F Inlines)
+enclosure :: PandocMonad m
+ => Char
+ -> MarkdownParser m (F Inlines)
enclosure c = do
-- we can't start an enclosure with _ if after a string and
-- the intraword_underscores extension is enabled:
@@ -1591,7 +1622,7 @@ enclosure c = do
1 -> one c mempty
_ -> return (return $ B.str cs)
-ender :: Char -> Int -> MarkdownParser ()
+ender :: PandocMonad m => Char -> Int -> MarkdownParser m ()
ender c n = try $ do
count n (char c)
guard (c == '*')
@@ -1602,7 +1633,7 @@ ender c n = try $ do
-- If one c, emit emph and then parse two.
-- If two cs, emit strong and then parse one.
-- Otherwise, emit ccc then the results.
-three :: Char -> MarkdownParser (F Inlines)
+three :: PandocMonad m => Char -> MarkdownParser m (F Inlines)
three c = do
contents <- mconcat <$> many (notFollowedBy (ender c 1) >> inline)
(ender c 3 >> return ((B.strong . B.emph) <$> contents))
@@ -1612,7 +1643,7 @@ three c = do
-- Parse inlines til you hit two c's, and emit strong.
-- If you never do hit two cs, emit ** plus inlines parsed.
-two :: Char -> F Inlines -> MarkdownParser (F Inlines)
+two :: PandocMonad m => Char -> F Inlines -> MarkdownParser m (F Inlines)
two c prefix' = do
contents <- mconcat <$> many (try $ notFollowedBy (ender c 2) >> inline)
(ender c 2 >> return (B.strong <$> (prefix' <> contents)))
@@ -1620,7 +1651,7 @@ two c prefix' = do
-- Parse inlines til you hit a c, and emit emph.
-- If you never hit a c, emit * plus inlines parsed.
-one :: Char -> F Inlines -> MarkdownParser (F Inlines)
+one :: PandocMonad m => Char -> F Inlines -> MarkdownParser m (F Inlines)
one c prefix' = do
contents <- mconcat <$> many ( (notFollowedBy (ender c 1) >> inline)
<|> try (string [c,c] >>
@@ -1629,47 +1660,48 @@ one c prefix' = do
(ender c 1 >> return (B.emph <$> (prefix' <> contents)))
<|> return (return (B.str [c]) <> (prefix' <> contents))
-strongOrEmph :: MarkdownParser (F Inlines)
+strongOrEmph :: PandocMonad m => MarkdownParser m (F Inlines)
strongOrEmph = enclosure '*' <|> enclosure '_'
-- | Parses a list of inlines between start and end delimiters.
-inlinesBetween :: (Show b)
- => MarkdownParser a
- -> MarkdownParser b
- -> MarkdownParser (F Inlines)
+inlinesBetween :: PandocMonad m
+ => (Show b)
+ => MarkdownParser m a
+ -> MarkdownParser m b
+ -> MarkdownParser m (F Inlines)
inlinesBetween start end =
(trimInlinesF . mconcat) <$> try (start >> many1Till inner end)
where inner = innerSpace <|> (notFollowedBy' (() <$ whitespace) >> inline)
innerSpace = try $ whitespace <* notFollowedBy' end
-strikeout :: MarkdownParser (F Inlines)
+strikeout :: PandocMonad m => MarkdownParser m (F Inlines)
strikeout = fmap B.strikeout <$>
(guardEnabled Ext_strikeout >> inlinesBetween strikeStart strikeEnd)
where strikeStart = string "~~" >> lookAhead nonspaceChar
>> notFollowedBy (char '~')
strikeEnd = try $ string "~~"
-superscript :: MarkdownParser (F Inlines)
+superscript :: PandocMonad m => MarkdownParser m (F Inlines)
superscript = fmap B.superscript <$> try (do
guardEnabled Ext_superscript
char '^'
mconcat <$> many1Till (notFollowedBy spaceChar >> inline) (char '^'))
-subscript :: MarkdownParser (F Inlines)
+subscript :: PandocMonad m => MarkdownParser m (F Inlines)
subscript = fmap B.subscript <$> try (do
guardEnabled Ext_subscript
char '~'
mconcat <$> many1Till (notFollowedBy spaceChar >> inline) (char '~'))
-whitespace :: MarkdownParser (F Inlines)
+whitespace :: PandocMonad m => MarkdownParser m (F Inlines)
whitespace = spaceChar >> return <$> (lb <|> regsp) <?> "whitespace"
where lb = spaceChar >> skipMany spaceChar >> option B.space (endline >> return B.linebreak)
regsp = skipMany spaceChar >> return B.space
-nonEndline :: Parser [Char] st Char
+nonEndline :: PandocMonad m => ParserT [Char] st m Char
nonEndline = satisfy (/='\n')
-str :: MarkdownParser (F Inlines)
+str :: PandocMonad m => MarkdownParser m (F Inlines)
str = do
result <- many1 alphaNum
updateLastStrPos
@@ -1699,7 +1731,7 @@ likelyAbbrev x =
in map snd $ filter (\(y,_) -> y == x) abbrPairs
-- an endline character that can be treated as a space, not a structural break
-endline :: MarkdownParser (F Inlines)
+endline :: PandocMonad m => MarkdownParser m (F Inlines)
endline = try $ do
newline
notFollowedBy blankline
@@ -1721,17 +1753,17 @@ endline = try $ do
--
-- a reference label for a link
-reference :: MarkdownParser (F Inlines, String)
+reference :: PandocMonad m => MarkdownParser m (F Inlines, String)
reference = do notFollowedBy' (string "[^") -- footnote reference
withRaw $ trimInlinesF <$> inlinesInBalancedBrackets
-parenthesizedChars :: MarkdownParser [Char]
+parenthesizedChars :: PandocMonad m => MarkdownParser m [Char]
parenthesizedChars = do
result <- charsInBalanced '(' ')' litChar
return $ '(' : result ++ ")"
-- source for a link, with optional title
-source :: MarkdownParser (String, String)
+source :: PandocMonad m => MarkdownParser m (String, String)
source = do
char '('
skipSpaces
@@ -1748,10 +1780,10 @@ source = do
char ')'
return (escapeURI $ trimr src, tit)
-linkTitle :: MarkdownParser String
+linkTitle :: PandocMonad m => MarkdownParser m String
linkTitle = quotedTitle '"' <|> quotedTitle '\''
-link :: MarkdownParser (F Inlines)
+link :: PandocMonad m => MarkdownParser m (F Inlines)
link = try $ do
st <- getState
guard $ stateAllowLinks st
@@ -1760,7 +1792,7 @@ link = try $ do
setState $ st{ stateAllowLinks = True }
regLink B.linkWith lab <|> referenceLink B.linkWith (lab,raw)
-bracketedSpan :: MarkdownParser (F Inlines)
+bracketedSpan :: PandocMonad m => MarkdownParser m (F Inlines)
bracketedSpan = try $ do
guardEnabled Ext_bracketed_spans
(lab,_) <- reference
@@ -1773,8 +1805,10 @@ bracketedSpan = try $ do
-> return $ B.smallcaps <$> lab
_ -> return $ B.spanWith attr <$> lab
-regLink :: (Attr -> String -> String -> Inlines -> Inlines)
- -> F Inlines -> MarkdownParser (F Inlines)
+regLink :: PandocMonad m
+ => (Attr -> String -> String -> Inlines -> Inlines)
+ -> F Inlines
+ -> MarkdownParser m (F Inlines)
regLink constructor lab = try $ do
(src, tit) <- source
attr <- option nullAttr $
@@ -1782,8 +1816,10 @@ regLink constructor lab = try $ do
return $ constructor attr src tit <$> lab
-- a link like [this][ref] or [this][] or [this]
-referenceLink :: (Attr -> String -> String -> Inlines -> Inlines)
- -> (F Inlines, String) -> MarkdownParser (F Inlines)
+referenceLink :: PandocMonad m
+ => (Attr -> String -> String -> Inlines -> Inlines)
+ -> (F Inlines, String)
+ -> MarkdownParser m (F Inlines)
referenceLink constructor (lab, raw) = do
sp <- (True <$ lookAhead (char ' ')) <|> return False
(_,raw') <- option (mempty, "") $
@@ -1824,7 +1860,7 @@ dropBrackets = reverse . dropRB . reverse . dropLB
dropLB ('[':xs) = xs
dropLB xs = xs
-bareURL :: MarkdownParser (F Inlines)
+bareURL :: PandocMonad m => MarkdownParser m (F Inlines)
bareURL = try $ do
guardEnabled Ext_autolink_bare_uris
getState >>= guard . stateAllowLinks
@@ -1832,7 +1868,7 @@ bareURL = try $ do
notFollowedBy $ try $ spaces >> htmlTag (~== TagClose "a")
return $ return $ B.link src "" (B.str orig)
-autoLink :: MarkdownParser (F Inlines)
+autoLink :: PandocMonad m => MarkdownParser m (F Inlines)
autoLink = try $ do
getState >>= guard . stateAllowLinks
char '<'
@@ -1846,7 +1882,7 @@ autoLink = try $ do
guardEnabled Ext_link_attributes >> attributes
return $ return $ B.linkWith attr (src ++ escapeURI extra) "" (B.str $ orig ++ extra)
-image :: MarkdownParser (F Inlines)
+image :: PandocMonad m => MarkdownParser m (F Inlines)
image = try $ do
char '!'
(lab,raw) <- reference
@@ -1856,7 +1892,7 @@ image = try $ do
_ -> B.imageWith attr' src
regLink constructor lab <|> referenceLink constructor (lab,raw)
-note :: MarkdownParser (F Inlines)
+note :: PandocMonad m => MarkdownParser m (F Inlines)
note = try $ do
guardEnabled Ext_footnotes
ref <- noteMarker
@@ -1872,14 +1908,14 @@ note = try $ do
let contents' = runF contents st{ stateNotes' = [] }
return $ B.note contents'
-inlineNote :: MarkdownParser (F Inlines)
+inlineNote :: PandocMonad m => MarkdownParser m (F Inlines)
inlineNote = try $ do
guardEnabled Ext_inline_notes
char '^'
contents <- inlinesInBalancedBrackets
return $ B.note . B.para <$> contents
-rawLaTeXInline' :: MarkdownParser (F Inlines)
+rawLaTeXInline' :: PandocMonad m => MarkdownParser m (F Inlines)
rawLaTeXInline' = try $ do
guardEnabled Ext_raw_tex
lookAhead $ char '\\' >> notFollowedBy' (string "start") -- context env
@@ -1887,7 +1923,7 @@ rawLaTeXInline' = try $ do
return $ return $ B.rawInline "tex" s
-- "tex" because it might be context or latex
-rawConTeXtEnvironment :: Parser [Char] st String
+rawConTeXtEnvironment :: PandocMonad m => ParserT [Char] st m String
rawConTeXtEnvironment = try $ do
string "\\start"
completion <- inBrackets (letter <|> digit <|> spaceChar)
@@ -1896,14 +1932,14 @@ rawConTeXtEnvironment = try $ do
(try $ string "\\stop" >> string completion)
return $ "\\start" ++ completion ++ concat contents ++ "\\stop" ++ completion
-inBrackets :: (Parser [Char] st Char) -> Parser [Char] st String
+inBrackets :: PandocMonad m => (ParserT [Char] st m Char) -> ParserT [Char] st m String
inBrackets parser = do
char '['
contents <- many parser
char ']'
return $ "[" ++ contents ++ "]"
-spanHtml :: MarkdownParser (F Inlines)
+spanHtml :: PandocMonad m => MarkdownParser m (F Inlines)
spanHtml = try $ do
guardEnabled Ext_native_spans
(TagOpen _ attrs, _) <- htmlTag (~== TagOpen "span" [])
@@ -1918,7 +1954,7 @@ spanHtml = try $ do
-> return $ B.smallcaps <$> contents
_ -> return $ B.spanWith (ident, classes, keyvals) <$> contents
-divHtml :: MarkdownParser (F Blocks)
+divHtml :: PandocMonad m => MarkdownParser m (F Blocks)
divHtml = try $ do
guardEnabled Ext_native_divs
(TagOpen _ attrs, rawtag) <- htmlTag (~== TagOpen "div" [])
@@ -1940,7 +1976,7 @@ divHtml = try $ do
else -- avoid backtracing
return $ return (B.rawBlock "html" (rawtag <> bls)) <> contents
-rawHtmlInline :: MarkdownParser (F Inlines)
+rawHtmlInline :: PandocMonad m => MarkdownParser m (F Inlines)
rawHtmlInline = do
guardEnabled Ext_raw_html
inHtmlBlock <- stateInHtmlBlock <$> getState
@@ -1962,7 +1998,7 @@ rawHtmlInline = do
emojiChars :: [Char]
emojiChars = ['a'..'z'] ++ ['0'..'9'] ++ ['_','+','-']
-emoji :: MarkdownParser (F Inlines)
+emoji :: PandocMonad m => MarkdownParser m (F Inlines)
emoji = try $ do
guardEnabled Ext_emoji
char ':'
@@ -1974,7 +2010,7 @@ emoji = try $ do
-- Citations
-cite :: MarkdownParser (F Inlines)
+cite :: PandocMonad m => MarkdownParser m (F Inlines)
cite = do
guardEnabled Ext_citations
citations <- textualCite
@@ -1982,7 +2018,7 @@ cite = do
return $ (flip B.cite (B.text raw)) <$> cs
return citations
-textualCite :: MarkdownParser (F Inlines)
+textualCite :: PandocMonad m => MarkdownParser m (F Inlines)
textualCite = try $ do
(_, key) <- citeKey
let first = Citation{ citationId = key
@@ -2017,7 +2053,7 @@ textualCite = try $ do
Just n -> B.str (show n)
_ -> B.cite [first] $ B.str $ '@':key)
-bareloc :: Citation -> MarkdownParser (F [Citation])
+bareloc :: PandocMonad m => Citation -> MarkdownParser m (F [Citation])
bareloc c = try $ do
spnl
char '['
@@ -2032,7 +2068,7 @@ bareloc c = try $ do
rest' <- rest
return $ c{ citationSuffix = B.toList suff' } : rest'
-normalCite :: MarkdownParser (F [Citation])
+normalCite :: PandocMonad m => MarkdownParser m (F [Citation])
normalCite = try $ do
char '['
spnl
@@ -2041,7 +2077,7 @@ normalCite = try $ do
char ']'
return citations
-suffix :: MarkdownParser (F Inlines)
+suffix :: PandocMonad m => MarkdownParser m (F Inlines)
suffix = try $ do
hasSpace <- option False (notFollowedBy nonspaceChar >> return True)
spnl
@@ -2050,14 +2086,14 @@ suffix = try $ do
then (B.space <>) <$> rest
else rest
-prefix :: MarkdownParser (F Inlines)
+prefix :: PandocMonad m => MarkdownParser m (F Inlines)
prefix = trimInlinesF . mconcat <$>
manyTill inline (char ']' <|> liftM (const ']') (lookAhead citeKey))
-citeList :: MarkdownParser (F [Citation])
+citeList :: PandocMonad m => MarkdownParser m (F [Citation])
citeList = fmap sequence $ sepBy1 citation (try $ char ';' >> spnl)
-citation :: MarkdownParser (F Citation)
+citation :: PandocMonad m => MarkdownParser m (F Citation)
citation = try $ do
pref <- prefix
(suppress_author, key) <- citeKey
@@ -2075,13 +2111,13 @@ citation = try $ do
, citationHash = 0
}
-smart :: MarkdownParser (F Inlines)
+smart :: PandocMonad m => MarkdownParser m (F Inlines)
smart = do
getOption readerSmart >>= guard
doubleQuoted <|> singleQuoted <|>
choice (map (return <$>) [apostrophe, dash, ellipses])
-singleQuoted :: MarkdownParser (F Inlines)
+singleQuoted :: PandocMonad m => MarkdownParser m (F Inlines)
singleQuoted = try $ do
singleQuoteStart
withQuoteContext InSingleQuote $
@@ -2091,7 +2127,7 @@ singleQuoted = try $ do
-- doubleQuoted will handle regular double-quoted sections, as well
-- as dialogues with an open double-quote without a close double-quote
-- in the same paragraph.
-doubleQuoted :: MarkdownParser (F Inlines)
+doubleQuoted :: PandocMonad m => MarkdownParser m (F Inlines)
doubleQuoted = try $ do
doubleQuoteStart
contents <- mconcat <$> many (try $ notFollowedBy doubleQuoteEnd >> inline)
diff --git a/src/Text/Pandoc/Readers/MediaWiki.hs b/src/Text/Pandoc/Readers/MediaWiki.hs
index 0dea22c53..7f45cdb2a 100644
--- a/src/Text/Pandoc/Readers/MediaWiki.hs
+++ b/src/Text/Pandoc/Readers/MediaWiki.hs
@@ -57,22 +57,26 @@ import Data.Char (isDigit, isSpace)
import Data.Maybe (fromMaybe)
import Text.Printf (printf)
import Debug.Trace (trace)
-
-import Text.Pandoc.Error
+import Control.Monad.Except (throwError)
+import Text.Pandoc.Class (PandocMonad, PandocExecutionError(..))
-- | Read mediawiki from an input string and return a Pandoc document.
-readMediaWiki :: ReaderOptions -- ^ Reader options
+readMediaWiki :: PandocMonad m
+ => ReaderOptions -- ^ Reader options
-> String -- ^ String to parse (assuming @'\n'@ line endings)
- -> Either PandocError Pandoc
-readMediaWiki opts s =
- readWith parseMediaWiki MWState{ mwOptions = opts
- , mwMaxNestingLevel = 4
- , mwNextLinkNumber = 1
- , mwCategoryLinks = []
- , mwHeaderMap = M.empty
- , mwIdentifierList = Set.empty
- }
- (s ++ "\n")
+ -> m Pandoc
+readMediaWiki opts s = do
+ parsed <- readWithM parseMediaWiki MWState{ mwOptions = opts
+ , mwMaxNestingLevel = 4
+ , mwNextLinkNumber = 1
+ , mwCategoryLinks = []
+ , mwHeaderMap = M.empty
+ , mwIdentifierList = Set.empty
+ }
+ (s ++ "\n")
+ case parsed of
+ Right result -> return result
+ Left _ -> throwError $ PandocParseError "problem parsing mediawiki"
data MWState = MWState { mwOptions :: ReaderOptions
, mwMaxNestingLevel :: Int
@@ -82,7 +86,7 @@ data MWState = MWState { mwOptions :: ReaderOptions
, mwIdentifierList :: Set.Set String
}
-type MWParser = Parser [Char] MWState
+type MWParser m = ParserT [Char] MWState m
instance HasReaderOptions MWState where
extractReaderOptions = mwOptions
@@ -101,7 +105,7 @@ instance HasIdentifierList MWState where
-- This is used to prevent exponential blowups for things like:
-- ''a'''a''a'''a''a'''a''a'''a
-nested :: MWParser a -> MWParser a
+nested :: PandocMonad m => MWParser m a -> MWParser m a
nested p = do
nestlevel <- mwMaxNestingLevel `fmap` getState
guard $ nestlevel > 0
@@ -116,7 +120,7 @@ specialChars = "'[]<=&*{}|\":\\"
spaceChars :: [Char]
spaceChars = " \n\t"
-sym :: String -> MWParser ()
+sym :: PandocMonad m => String -> MWParser m ()
sym s = () <$ try (string s)
newBlockTags :: [String]
@@ -137,10 +141,10 @@ eitherBlockOrInline :: [String]
eitherBlockOrInline = ["applet", "button", "del", "iframe", "ins",
"map", "area", "object"]
-htmlComment :: MWParser ()
+htmlComment :: PandocMonad m => MWParser m ()
htmlComment = () <$ htmlTag isCommentTag
-inlinesInTags :: String -> MWParser Inlines
+inlinesInTags :: PandocMonad m => String -> MWParser m Inlines
inlinesInTags tag = try $ do
(_,raw) <- htmlTag (~== TagOpen tag [])
if '/' `elem` raw -- self-closing tag
@@ -148,7 +152,7 @@ inlinesInTags tag = try $ do
else trimInlines . mconcat <$>
manyTill inline (htmlTag (~== TagClose tag))
-blocksInTags :: String -> MWParser Blocks
+blocksInTags :: PandocMonad m => String -> MWParser m Blocks
blocksInTags tag = try $ do
(_,raw) <- htmlTag (~== TagOpen tag [])
let closer = if tag == "li"
@@ -162,7 +166,7 @@ blocksInTags tag = try $ do
then return mempty
else mconcat <$> manyTill block closer
-charsInTags :: String -> MWParser [Char]
+charsInTags :: PandocMonad m => String -> MWParser m [Char]
charsInTags tag = try $ do
(_,raw) <- htmlTag (~== TagOpen tag [])
if '/' `elem` raw -- self-closing tag
@@ -173,7 +177,7 @@ charsInTags tag = try $ do
-- main parser
--
-parseMediaWiki :: MWParser Pandoc
+parseMediaWiki :: PandocMonad m => MWParser m Pandoc
parseMediaWiki = do
bs <- mconcat <$> many block
spaces
@@ -188,7 +192,7 @@ parseMediaWiki = do
-- block parsers
--
-block :: MWParser Blocks
+block :: PandocMonad m => MWParser m Blocks
block = do
tr <- getOption readerTrace
pos <- getPosition
@@ -209,14 +213,14 @@ block = do
(take 60 $ show $ B.toList res)) (return ())
return res
-para :: MWParser Blocks
+para :: PandocMonad m => MWParser m Blocks
para = do
contents <- trimInlines . mconcat <$> many1 inline
if F.all (==Space) contents
then return mempty
else return $ B.para contents
-table :: MWParser Blocks
+table :: PandocMonad m => MWParser m Blocks
table = do
tableStart
styles <- option [] parseAttrs <* blankline
@@ -244,10 +248,10 @@ table = do
else (replicate cols mempty, hdr:rows')
return $ B.table caption cellspecs headers rows
-parseAttrs :: MWParser [(String,String)]
+parseAttrs :: PandocMonad m => MWParser m [(String,String)]
parseAttrs = many1 parseAttr
-parseAttr :: MWParser (String, String)
+parseAttr :: PandocMonad m => MWParser m (String, String)
parseAttr = try $ do
skipMany spaceChar
k <- many1 letter
@@ -256,17 +260,17 @@ parseAttr = try $ do
<|> many1 (satisfy $ \c -> not (isSpace c) && c /= '|')
return (k,v)
-tableStart :: MWParser ()
+tableStart :: PandocMonad m => MWParser m ()
tableStart = try $ guardColumnOne *> skipSpaces *> sym "{|"
-tableEnd :: MWParser ()
+tableEnd :: PandocMonad m => MWParser m ()
tableEnd = try $ guardColumnOne *> skipSpaces *> sym "|}"
-rowsep :: MWParser ()
+rowsep :: PandocMonad m => MWParser m ()
rowsep = try $ guardColumnOne *> skipSpaces *> sym "|-" <*
optional parseAttr <* blanklines
-cellsep :: MWParser ()
+cellsep :: PandocMonad m => MWParser m ()
cellsep = try $
(guardColumnOne *> skipSpaces <*
( (char '|' <* notFollowedBy (oneOf "-}+"))
@@ -276,7 +280,7 @@ cellsep = try $
<|> (() <$ try (string "||"))
<|> (() <$ try (string "!!"))
-tableCaption :: MWParser Inlines
+tableCaption :: PandocMonad m => MWParser m Inlines
tableCaption = try $ do
guardColumnOne
skipSpaces
@@ -284,10 +288,10 @@ tableCaption = try $ do
optional (try $ parseAttr *> skipSpaces *> char '|' *> skipSpaces)
(trimInlines . mconcat) <$> many (notFollowedBy (cellsep <|> rowsep) *> inline)
-tableRow :: MWParser [((Alignment, Double), Blocks)]
+tableRow :: PandocMonad m => MWParser m [((Alignment, Double), Blocks)]
tableRow = try $ skipMany htmlComment *> many tableCell
-tableCell :: MWParser ((Alignment, Double), Blocks)
+tableCell :: PandocMonad m => MWParser m ((Alignment, Double), Blocks)
tableCell = try $ do
cellsep
skipMany spaceChar
@@ -313,7 +317,7 @@ parseWidth s =
('%':ds) | all isDigit ds -> safeRead ('0':'.':reverse ds)
_ -> Nothing
-template :: MWParser String
+template :: PandocMonad m => MWParser m String
template = try $ do
string "{{"
notFollowedBy (char '{')
@@ -322,7 +326,7 @@ template = try $ do
contents <- manyTill chunk (try $ string "}}")
return $ "{{" ++ concat contents ++ "}}"
-blockTag :: MWParser Blocks
+blockTag :: PandocMonad m => MWParser m Blocks
blockTag = do
(tag, _) <- lookAhead $ htmlTag isBlockTag'
case tag of
@@ -341,7 +345,7 @@ trimCode :: String -> String
trimCode ('\n':xs) = stripTrailingNewlines xs
trimCode xs = stripTrailingNewlines xs
-syntaxhighlight :: String -> [Attribute String] -> MWParser Blocks
+syntaxhighlight :: PandocMonad m => String -> [Attribute String] -> MWParser m Blocks
syntaxhighlight tag attrs = try $ do
let mblang = lookup "lang" attrs
let mbstart = lookup "start" attrs
@@ -351,13 +355,13 @@ syntaxhighlight tag attrs = try $ do
contents <- charsInTags tag
return $ B.codeBlockWith ("",classes,kvs) $ trimCode contents
-hrule :: MWParser Blocks
+hrule :: PandocMonad m => MWParser m Blocks
hrule = B.horizontalRule <$ try (string "----" *> many (char '-') *> newline)
-guardColumnOne :: MWParser ()
+guardColumnOne :: PandocMonad m => MWParser m ()
guardColumnOne = getPosition >>= \pos -> guard (sourceColumn pos == 1)
-preformatted :: MWParser Blocks
+preformatted :: PandocMonad m => MWParser m Blocks
preformatted = try $ do
guardColumnOne
char ' '
@@ -388,7 +392,7 @@ encode = B.fromList . normalizeCode . B.toList . walk strToCode
normalizeCode $ (Code a1 (x ++ y)) : zs
normalizeCode (x:xs) = x : normalizeCode xs
-header :: MWParser Blocks
+header :: PandocMonad m => MWParser m Blocks
header = try $ do
guardColumnOne
eqs <- many1 (char '=')
@@ -398,13 +402,13 @@ header = try $ do
attr <- registerHeader nullAttr contents
return $ B.headerWith attr lev contents
-bulletList :: MWParser Blocks
+bulletList :: PandocMonad m => MWParser m Blocks
bulletList = B.bulletList <$>
( many1 (listItem '*')
<|> (htmlTag (~== TagOpen "ul" []) *> spaces *> many (listItem '*' <|> li) <*
optional (htmlTag (~== TagClose "ul"))) )
-orderedList :: MWParser Blocks
+orderedList :: PandocMonad m => MWParser m Blocks
orderedList =
(B.orderedList <$> many1 (listItem '#'))
<|> try
@@ -415,10 +419,10 @@ orderedList =
let start = fromMaybe 1 $ safeRead $ fromAttrib "start" tag
return $ B.orderedListWith (start, DefaultStyle, DefaultDelim) items)
-definitionList :: MWParser Blocks
+definitionList :: PandocMonad m => MWParser m Blocks
definitionList = B.definitionList <$> many1 defListItem
-defListItem :: MWParser (Inlines, [Blocks])
+defListItem :: PandocMonad m => MWParser m (Inlines, [Blocks])
defListItem = try $ do
terms <- mconcat . intersperse B.linebreak <$> many defListTerm
-- we allow dd with no dt, or dt with no dd
@@ -429,27 +433,27 @@ defListItem = try $ do
else many (listItem ':')
return (terms, defs)
-defListTerm :: MWParser Inlines
+defListTerm :: PandocMonad m => MWParser m Inlines
defListTerm = char ';' >> skipMany spaceChar >> anyLine >>=
parseFromString (trimInlines . mconcat <$> many inline)
-listStart :: Char -> MWParser ()
+listStart :: PandocMonad m => Char -> MWParser m ()
listStart c = char c *> notFollowedBy listStartChar
-listStartChar :: MWParser Char
+listStartChar :: PandocMonad m => MWParser m Char
listStartChar = oneOf "*#;:"
-anyListStart :: MWParser Char
+anyListStart :: PandocMonad m => MWParser m Char
anyListStart = char '*'
<|> char '#'
<|> char ':'
<|> char ';'
-li :: MWParser Blocks
+li :: PandocMonad m => MWParser m Blocks
li = lookAhead (htmlTag (~== TagOpen "li" [])) *>
(firstParaToPlain <$> blocksInTags "li") <* spaces
-listItem :: Char -> MWParser Blocks
+listItem :: PandocMonad m => Char -> MWParser m Blocks
listItem c = try $ do
extras <- many (try $ char c <* lookAhead listStartChar)
if null extras
@@ -475,10 +479,10 @@ listItem c = try $ do
-- }}
-- * next list item
-- which seems to be valid mediawiki.
-listChunk :: MWParser String
+listChunk :: PandocMonad m => MWParser m String
listChunk = template <|> count 1 anyChar
-listItem' :: Char -> MWParser Blocks
+listItem' :: PandocMonad m => Char -> MWParser m Blocks
listItem' c = try $ do
listStart c
skipMany spaceChar
@@ -498,7 +502,7 @@ firstParaToPlain contents =
-- inline parsers
--
-inline :: MWParser Inlines
+inline :: PandocMonad m => MWParser m Inlines
inline = whitespace
<|> url
<|> str
@@ -516,10 +520,10 @@ inline = whitespace
<|> (B.rawInline "mediawiki" <$> template)
<|> special
-str :: MWParser Inlines
+str :: PandocMonad m => MWParser m Inlines
str = B.str <$> many1 (noneOf $ specialChars ++ spaceChars)
-math :: MWParser Inlines
+math :: PandocMonad m => MWParser m Inlines
math = (B.displayMath . trim <$> try (many1 (char ':') >> charsInTags "math"))
<|> (B.math . trim <$> charsInTags "math")
<|> (B.displayMath . trim <$> try (dmStart *> manyTill anyChar dmEnd))
@@ -529,13 +533,13 @@ math = (B.displayMath . trim <$> try (many1 (char ':') >> charsInTags "math"))
mStart = string "\\("
mEnd = try (string "\\)")
-variable :: MWParser String
+variable :: PandocMonad m => MWParser m String
variable = try $ do
string "{{{"
contents <- manyTill anyChar (try $ string "}}}")
return $ "{{{" ++ contents ++ "}}}"
-inlineTag :: MWParser Inlines
+inlineTag :: PandocMonad m => MWParser m Inlines
inlineTag = do
(tag, _) <- lookAhead $ htmlTag isInlineTag'
case tag of
@@ -557,18 +561,18 @@ inlineTag = do
TagOpen "hask" _ -> B.codeWith ("",["haskell"],[]) <$> charsInTags "hask"
_ -> B.rawInline "html" . snd <$> htmlTag (~== tag)
-special :: MWParser Inlines
+special :: PandocMonad m => MWParser m Inlines
special = B.str <$> count 1 (notFollowedBy' (htmlTag isBlockTag') *>
oneOf specialChars)
-inlineHtml :: MWParser Inlines
+inlineHtml :: PandocMonad m => MWParser m Inlines
inlineHtml = B.rawInline "html" . snd <$> htmlTag isInlineTag'
-whitespace :: MWParser Inlines
+whitespace :: PandocMonad m => MWParser m Inlines
whitespace = B.space <$ (skipMany1 spaceChar <|> htmlComment)
<|> B.softbreak <$ endline
-endline :: MWParser ()
+endline :: PandocMonad m => MWParser m ()
endline = () <$ try (newline <*
notFollowedBy spaceChar <*
notFollowedBy newline <*
@@ -577,12 +581,12 @@ endline = () <$ try (newline <*
notFollowedBy' header <*
notFollowedBy anyListStart)
-imageIdentifiers :: [MWParser ()]
+imageIdentifiers :: PandocMonad m => [MWParser m ()]
imageIdentifiers = [sym (identifier ++ ":") | identifier <- identifiers]
where identifiers = ["File", "Image", "Archivo", "Datei", "Fichier",
"Bild"]
-image :: MWParser Inlines
+image :: PandocMonad m => MWParser m Inlines
image = try $ do
sym "[["
choice imageIdentifiers
@@ -600,7 +604,7 @@ image = try $ do
<|> try (char '|' *> (mconcat <$> manyTill inline (sym "]]")))
return $ B.imageWith attr fname ("fig:" ++ stringify caption) caption
-imageOption :: MWParser String
+imageOption :: PandocMonad m => MWParser m String
imageOption = try $ char '|' *> opt
where
opt = try (oneOfStrings [ "border", "thumbnail", "frameless"
@@ -619,7 +623,7 @@ collapseUnderscores (x:xs) = x : collapseUnderscores xs
addUnderscores :: String -> String
addUnderscores = collapseUnderscores . intercalate "_" . words
-internalLink :: MWParser Inlines
+internalLink :: PandocMonad m => MWParser m Inlines
internalLink = try $ do
sym "[["
pagename <- unwords . words <$> many (noneOf "|]")
@@ -637,7 +641,7 @@ internalLink = try $ do
return mempty
else return link
-externalLink :: MWParser Inlines
+externalLink :: PandocMonad m => MWParser m Inlines
externalLink = try $ do
char '['
(_, src) <- uri
@@ -649,29 +653,29 @@ externalLink = try $ do
return $ B.str $ show num
return $ B.link src "" lab
-url :: MWParser Inlines
+url :: PandocMonad m => MWParser m Inlines
url = do
(orig, src) <- uri
return $ B.link src "" (B.str orig)
-- | Parses a list of inlines between start and end delimiters.
-inlinesBetween :: (Show b) => MWParser a -> MWParser b -> MWParser Inlines
+inlinesBetween :: (PandocMonad m, Show b) => MWParser m a -> MWParser m b -> MWParser m Inlines
inlinesBetween start end =
(trimInlines . mconcat) <$> try (start >> many1Till inner end)
where inner = innerSpace <|> (notFollowedBy' (() <$ whitespace) >> inline)
innerSpace = try $ whitespace <* notFollowedBy' end
-emph :: MWParser Inlines
+emph :: PandocMonad m => MWParser m Inlines
emph = B.emph <$> nested (inlinesBetween start end)
where start = sym "''" >> lookAhead nonspaceChar
end = try $ notFollowedBy' (() <$ strong) >> sym "''"
-strong :: MWParser Inlines
+strong :: PandocMonad m => MWParser m Inlines
strong = B.strong <$> nested (inlinesBetween start end)
where start = sym "'''" >> lookAhead nonspaceChar
end = try $ sym "'''"
-doubleQuotes :: MWParser Inlines
+doubleQuotes :: PandocMonad m => MWParser m Inlines
doubleQuotes = B.doubleQuoted <$> nested (inlinesBetween openDoubleQuote closeDoubleQuote)
where openDoubleQuote = sym "\"" >> lookAhead nonspaceChar
closeDoubleQuote = try $ sym "\""
diff --git a/src/Text/Pandoc/Readers/Native.hs b/src/Text/Pandoc/Readers/Native.hs
index 917a4a144..489ddcd4a 100644
--- a/src/Text/Pandoc/Readers/Native.hs
+++ b/src/Text/Pandoc/Readers/Native.hs
@@ -33,6 +33,7 @@ module Text.Pandoc.Readers.Native ( readNative ) where
import Text.Pandoc.Definition
import Text.Pandoc.Shared (safeRead)
+import Control.Monad.Except (throwError)
import Text.Pandoc.Error
import Text.Pandoc.Class
@@ -48,9 +49,11 @@ import Text.Pandoc.Class
--
readNative :: PandocMonad m
=> String -- ^ String to parse (assuming @'\n'@ line endings)
- -> m (Either PandocError Pandoc)
+ -> m Pandoc
readNative s =
- return $ maybe (Pandoc nullMeta <$> readBlocks s) Right (safeRead s)
+ case maybe (Pandoc nullMeta <$> readBlocks s) Right (safeRead s) of
+ Right doc -> return doc
+ Left _ -> throwError $ PandocParseError "couldn't read native"
readBlocks :: String -> Either PandocError [Block]
readBlocks s = maybe ((:[]) <$> readBlock s) Right (safeRead s)
diff --git a/src/Text/Pandoc/Readers/OPML.hs b/src/Text/Pandoc/Readers/OPML.hs
index 4dcf5e5a0..608e9ae0f 100644
--- a/src/Text/Pandoc/Readers/OPML.hs
+++ b/src/Text/Pandoc/Readers/OPML.hs
@@ -13,8 +13,9 @@ import Control.Monad.State
import Data.Default
import Control.Monad.Except
import Text.Pandoc.Error
+import Text.Pandoc.Class (PandocMonad, PandocExecutionError(..))
-type OPML = ExceptT PandocError (State OPMLState)
+type OPML m = StateT OPMLState m
data OPMLState = OPMLState{
opmlSectionLevel :: Int
@@ -30,12 +31,14 @@ instance Default OPMLState where
, opmlDocDate = mempty
}
-readOPML :: ReaderOptions -> String -> Either PandocError Pandoc
-readOPML _ inp = setTitle (opmlDocTitle st')
- . setAuthors (opmlDocAuthors st')
- . setDate (opmlDocDate st')
- . doc . mconcat <$> bs
- where (bs, st') = flip runState def . runExceptT $ (mapM parseBlock $ normalizeTree $ parseXML inp)
+readOPML :: PandocMonad m => ReaderOptions -> String -> m Pandoc
+readOPML _ inp = do
+ (bs, st') <- flip runStateT def (mapM parseBlock $ normalizeTree $ parseXML inp)
+ return $
+ setTitle (opmlDocTitle st') $
+ setAuthors (opmlDocAuthors st') $
+ setDate (opmlDocDate st') $
+ doc $ mconcat bs
-- normalize input, consolidating adjacent Text and CRef elements
normalizeTree :: [Content] -> [Content]
@@ -62,21 +65,22 @@ attrValue attr elt =
Just z -> z
Nothing -> ""
-exceptT :: Either PandocError a -> OPML a
-exceptT = either throwError return
+-- exceptT :: PandocMonad m => Either PandocExecutionError a -> OPML m a
+-- exceptT = either throwError return
-asHtml :: String -> OPML Inlines
-asHtml s = (\(Pandoc _ bs) -> case bs of
+asHtml :: PandocMonad m => String -> OPML m Inlines
+asHtml s =
+ (\(Pandoc _ bs) -> case bs of
[Plain ils] -> fromList ils
- _ -> mempty) <$> exceptT (readHtml def s)
+ _ -> mempty) <$> (lift $ readHtml def s)
-asMarkdown :: String -> OPML Blocks
-asMarkdown s = (\(Pandoc _ bs) -> fromList bs) <$> exceptT (readMarkdown def s)
+asMarkdown :: PandocMonad m => String -> OPML m Blocks
+asMarkdown s = (\(Pandoc _ bs) -> fromList bs) <$> (lift $ readMarkdown def s)
-getBlocks :: Element -> OPML Blocks
+getBlocks :: PandocMonad m => Element -> OPML m Blocks
getBlocks e = mconcat <$> (mapM parseBlock $ elContent e)
-parseBlock :: Content -> OPML Blocks
+parseBlock :: PandocMonad m => Content -> OPML m Blocks
parseBlock (Elem e) =
case qName (elName e) of
"ownerName" -> mempty <$ modify (\st ->
diff --git a/src/Text/Pandoc/Readers/Odt.hs b/src/Text/Pandoc/Readers/Odt.hs
index 046fb4d6d..898dda077 100644
--- a/src/Text/Pandoc/Readers/Odt.hs
+++ b/src/Text/Pandoc/Readers/Odt.hs
@@ -39,6 +39,10 @@ import qualified Data.ByteString.Lazy as B
import System.FilePath
+import Control.Monad.Except (throwError)
+
+import Text.Pandoc.Class (PandocMonad, PandocExecutionError(..))
+import qualified Text.Pandoc.Class as P
import Text.Pandoc.Definition
import Text.Pandoc.Error
import Text.Pandoc.Options
@@ -52,11 +56,21 @@ import Text.Pandoc.Readers.Odt.Generic.XMLConverter
import Text.Pandoc.Readers.Odt.Generic.Fallible
import Text.Pandoc.Shared (filteredFilesFromArchive)
---
-readOdt :: ReaderOptions
+readOdt :: PandocMonad m
+ => ReaderOptions
-> B.ByteString
- -> Either PandocError (Pandoc, MediaBag)
-readOdt _ bytes = bytesToOdt bytes-- of
+ -> m Pandoc
+readOdt opts bytes = case readOdt' opts bytes of
+ Right (doc, mb) -> do
+ P.setMediaBag mb
+ return doc
+ Left _ -> throwError $ PandocParseError "couldn't parse odt"
+
+--
+readOdt' :: ReaderOptions
+ -> B.ByteString
+ -> Either PandocError (Pandoc, MediaBag)
+readOdt' _ bytes = bytesToOdt bytes-- of
-- Right (pandoc, mediaBag) -> Right (pandoc , mediaBag)
-- Left err -> Left err
diff --git a/src/Text/Pandoc/Readers/Org.hs b/src/Text/Pandoc/Readers/Org.hs
index 4e1c926da..3a41ed317 100644
--- a/src/Text/Pandoc/Readers/Org.hs
+++ b/src/Text/Pandoc/Readers/Org.hs
@@ -31,24 +31,30 @@ import Text.Pandoc.Readers.Org.Blocks ( blockList, meta )
import Text.Pandoc.Readers.Org.Parsing ( OrgParser, readWithM )
import Text.Pandoc.Readers.Org.ParserState ( optionsToParserState )
+import Text.Pandoc.Class (PandocMonad, PandocExecutionError(..))
import Text.Pandoc.Definition
-import Text.Pandoc.Error
import Text.Pandoc.Options
-import Control.Monad.Reader ( runReader )
+import Control.Monad.Except ( throwError )
+import Control.Monad.Reader ( runReaderT )
-- | Parse org-mode string and return a Pandoc document.
-readOrg :: ReaderOptions -- ^ Reader options
+readOrg :: PandocMonad m
+ => ReaderOptions -- ^ Reader options
-> String -- ^ String to parse (assuming @'\n'@ line endings)
- -> Either PandocError Pandoc
-readOrg opts s = flip runReader def $
- readWithM parseOrg (optionsToParserState opts) (s ++ "\n\n")
+ -> m Pandoc
+readOrg opts s = do
+ parsed <- flip runReaderT def $
+ readWithM parseOrg (optionsToParserState opts) (s ++ "\n\n")
+ case parsed of
+ Right result -> return result
+ Left _ -> throwError $ PandocParseError "problem parsing org"
--
-- Parser
--
-parseOrg :: OrgParser Pandoc
+parseOrg :: PandocMonad m => OrgParser m Pandoc
parseOrg = do
blocks' <- blockList
meta' <- meta
diff --git a/src/Text/Pandoc/Readers/Org/BlockStarts.hs b/src/Text/Pandoc/Readers/Org/BlockStarts.hs
index b1004dda6..5588c4552 100644
--- a/src/Text/Pandoc/Readers/Org/BlockStarts.hs
+++ b/src/Text/Pandoc/Readers/Org/BlockStarts.hs
@@ -44,7 +44,7 @@ import Control.Monad ( void )
import Text.Pandoc.Readers.Org.Parsing
-- | Horizontal Line (five -- dashes or more)
-hline :: OrgParser ()
+hline :: Monad m => OrgParser m ()
hline = try $ do
skipSpaces
string "-----"
@@ -54,58 +54,59 @@ hline = try $ do
return ()
-- | Read the start of a header line, return the header level
-headerStart :: OrgParser Int
+headerStart :: Monad m => OrgParser m Int
headerStart = try $
(length <$> many1 (char '*')) <* many1 (char ' ') <* updateLastPreCharPos
-tableStart :: OrgParser Char
+tableStart :: Monad m => OrgParser m Char
tableStart = try $ skipSpaces *> char '|'
-latexEnvStart :: OrgParser String
+latexEnvStart :: Monad m => OrgParser m String
latexEnvStart = try $ do
skipSpaces *> string "\\begin{"
*> latexEnvName
<* string "}"
<* blankline
where
- latexEnvName :: OrgParser String
+ latexEnvName :: Monad m => OrgParser m String
latexEnvName = try $ mappend <$> many1 alphaNum <*> option "" (string "*")
-- | Parses bullet list marker.
-bulletListStart :: OrgParser ()
+bulletListStart :: Monad m => OrgParser m ()
bulletListStart = try $
choice
[ () <$ skipSpaces <* oneOf "+-" <* skipSpaces1
, () <$ skipSpaces1 <* char '*' <* skipSpaces1
]
-genericListStart :: OrgParser String
- -> OrgParser Int
+genericListStart :: Monad m
+ => OrgParser m String
+ -> OrgParser m Int
genericListStart listMarker = try $
(+) <$> (length <$> many spaceChar)
<*> (length <$> listMarker <* many1 spaceChar)
-orderedListStart :: OrgParser Int
+orderedListStart :: Monad m => OrgParser m Int
orderedListStart = genericListStart orderedListMarker
-- Ordered list markers allowed in org-mode
where orderedListMarker = mappend <$> many1 digit <*> (pure <$> oneOf ".)")
-drawerStart :: OrgParser String
+drawerStart :: Monad m => OrgParser m String
drawerStart = try $
skipSpaces *> drawerName <* skipSpaces <* newline
where drawerName = char ':' *> manyTill nonspaceChar (char ':')
-metaLineStart :: OrgParser ()
+metaLineStart :: Monad m => OrgParser m ()
metaLineStart = try $ skipSpaces <* string "#+"
-commentLineStart :: OrgParser ()
+commentLineStart :: Monad m => OrgParser m ()
commentLineStart = try $ skipSpaces <* string "# "
-exampleLineStart :: OrgParser ()
+exampleLineStart :: Monad m => OrgParser m ()
exampleLineStart = () <$ try (skipSpaces *> string ": ")
-noteMarker :: OrgParser String
+noteMarker :: Monad m => OrgParser m String
noteMarker = try $ do
char '['
choice [ many1Till digit (char ']')
@@ -114,12 +115,12 @@ noteMarker = try $ do
]
-- | Succeeds if the parser is at the end of a block.
-endOfBlock :: OrgParser ()
+endOfBlock :: Monad m => OrgParser m ()
endOfBlock = lookAhead . try $ do
void blankline <|> anyBlockStart
where
-- Succeeds if there is a new block starting at this position.
- anyBlockStart :: OrgParser ()
+ anyBlockStart :: Monad m => OrgParser m ()
anyBlockStart = try . choice $
[ exampleLineStart
, hline
diff --git a/src/Text/Pandoc/Readers/Org/Blocks.hs b/src/Text/Pandoc/Readers/Org/Blocks.hs
index 484d97482..5176e0f6c 100644
--- a/src/Text/Pandoc/Readers/Org/Blocks.hs
+++ b/src/Text/Pandoc/Readers/Org/Blocks.hs
@@ -44,6 +44,7 @@ import Text.Pandoc.Readers.Org.Shared
import qualified Text.Pandoc.Builder as B
import Text.Pandoc.Builder ( Inlines, Blocks )
+import Text.Pandoc.Class (PandocMonad)
import Text.Pandoc.Definition
import Text.Pandoc.Options
import Text.Pandoc.Shared ( compactify', compactify'DL, safeRead )
@@ -105,7 +106,7 @@ data Headline = Headline
-- | Read an Org mode headline and its contents (i.e. a document subtree).
-- @lvl@ gives the minimum acceptable level of the tree.
-headline :: Int -> OrgParser (F Headline)
+headline :: PandocMonad m => Int -> OrgParser m (F Headline)
headline lvl = try $ do
level <- headerStart
guard (lvl <= level)
@@ -130,16 +131,16 @@ headline lvl = try $ do
, headlineChildren = children'
}
where
- endOfTitle :: OrgParser ()
+ endOfTitle :: Monad m => OrgParser m ()
endOfTitle = void . lookAhead $ optional headerTags *> newline
- headerTags :: OrgParser [Tag]
+ headerTags :: Monad m => OrgParser m [Tag]
headerTags = try $
let tag = many1 (alphaNum <|> oneOf "@%#_") <* char ':'
in map toTag <$> (skipSpaces *> char ':' *> many1 tag <* skipSpaces)
-- | Convert an Org mode headline (i.e. a document tree) into pandoc's Blocks
-headlineToBlocks :: Headline -> OrgParser Blocks
+headlineToBlocks :: Monad m => Headline -> OrgParser m Blocks
headlineToBlocks hdln@(Headline {..}) = do
maxHeadlineLevels <- getExportSetting exportHeadlineLevels
case () of
@@ -162,7 +163,7 @@ isCommentTitle :: Inlines -> Bool
isCommentTitle (B.toList -> (Str "COMMENT":_)) = True
isCommentTitle _ = False
-archivedHeadlineToBlocks :: Headline -> OrgParser Blocks
+archivedHeadlineToBlocks :: Monad m => Headline -> OrgParser m Blocks
archivedHeadlineToBlocks hdln = do
archivedTreesOption <- getExportSetting exportArchivedTrees
case archivedTreesOption of
@@ -170,7 +171,7 @@ archivedHeadlineToBlocks hdln = do
ArchivedTreesExport -> headlineToHeaderWithContents hdln
ArchivedTreesHeadlineOnly -> headlineToHeader hdln
-headlineToHeaderWithList :: Headline -> OrgParser Blocks
+headlineToHeaderWithList :: Monad m => Headline -> OrgParser m Blocks
headlineToHeaderWithList hdln@(Headline {..}) = do
maxHeadlineLevels <- getExportSetting exportHeadlineLevels
header <- headlineToHeader hdln
@@ -189,13 +190,13 @@ headlineToHeaderWithList hdln@(Headline {..}) = do
(Header _ _ inlns:_) -> B.para (B.fromList inlns)
_ -> mempty
-headlineToHeaderWithContents :: Headline -> OrgParser Blocks
+headlineToHeaderWithContents :: Monad m => Headline -> OrgParser m Blocks
headlineToHeaderWithContents hdln@(Headline {..}) = do
header <- headlineToHeader hdln
childrenBlocks <- mconcat <$> sequence (map headlineToBlocks headlineChildren)
return $ header <> headlineContents <> childrenBlocks
-headlineToHeader :: Headline -> OrgParser Blocks
+headlineToHeader :: Monad m => Headline -> OrgParser m Blocks
headlineToHeader (Headline {..}) = do
exportTodoKeyword <- getExportSetting exportWithTodoKeywords
let todoText = if exportTodoKeyword
@@ -208,7 +209,7 @@ headlineToHeader (Headline {..}) = do
attr <- registerHeader propAttr headlineText
return $ B.headerWith attr headlineLevel text
-todoKeyword :: OrgParser TodoMarker
+todoKeyword :: Monad m => OrgParser m TodoMarker
todoKeyword = try $ do
taskStates <- activeTodoMarkers <$> getState
let kwParser tdm = try $ (tdm <$ string (todoMarkerName tdm) <* spaceChar)
@@ -250,7 +251,7 @@ tagToInline t = B.spanWith ("", ["tag"], [("data-tag-name", fromTag t)]) mempty
--
-- | Get a list of blocks.
-blockList :: OrgParser [Block]
+blockList :: PandocMonad m => OrgParser m [Block]
blockList = do
initialBlocks <- blocks
headlines <- sequence <$> manyTill (headline 1) eof
@@ -259,15 +260,15 @@ blockList = do
return . B.toList $ (runF initialBlocks st) <> headlineBlocks
-- | Get the meta information safed in the state.
-meta :: OrgParser Meta
+meta :: Monad m => OrgParser m Meta
meta = do
meta' <- metaExport
runF meta' <$> getState
-blocks :: OrgParser (F Blocks)
+blocks :: PandocMonad m => OrgParser m (F Blocks)
blocks = mconcat <$> manyTill block (void (lookAhead headerStart) <|> eof)
-block :: OrgParser (F Blocks)
+block :: PandocMonad m => OrgParser m (F Blocks)
block = choice [ mempty <$ blanklines
, table
, orgBlock
@@ -306,7 +307,7 @@ attrFromBlockAttributes (BlockAttributes{..}) =
kv = filter ((`notElem` ["id", "class"]) . fst) blockAttrKeyValues
in (ident, classes, kv)
-stringyMetaAttribute :: (String -> Bool) -> OrgParser (String, String)
+stringyMetaAttribute :: Monad m => (String -> Bool) -> OrgParser m (String, String)
stringyMetaAttribute attrCheck = try $ do
metaLineStart
attrName <- map toUpper <$> many1Till nonspaceChar (char ':')
@@ -315,7 +316,7 @@ stringyMetaAttribute attrCheck = try $ do
attrValue <- anyLine
return (attrName, attrValue)
-blockAttributes :: OrgParser BlockAttributes
+blockAttributes :: PandocMonad m => OrgParser m BlockAttributes
blockAttributes = try $ do
kv <- many (stringyMetaAttribute attrCheck)
let caption = foldl' (appendValues "CAPTION") Nothing kv
@@ -350,17 +351,17 @@ blockAttributes = try $ do
Just acc -> Just $ acc ++ ' ':value
Nothing -> Just value
-keyValues :: OrgParser [(String, String)]
+keyValues :: Monad m => OrgParser m [(String, String)]
keyValues = try $
manyTill ((,) <$> key <*> value) newline
where
- key :: OrgParser String
+ key :: Monad m => OrgParser m String
key = try $ skipSpaces *> char ':' *> many1 nonspaceChar
- value :: OrgParser String
+ value :: Monad m => OrgParser m String
value = skipSpaces *> manyTill anyChar endOfValue
- endOfValue :: OrgParser ()
+ endOfValue :: Monad m => OrgParser m ()
endOfValue =
lookAhead $ (() <$ try (many1 spaceChar <* key))
<|> () <$ newline
@@ -371,7 +372,7 @@ keyValues = try $
--
-- | Read an org-mode block delimited by #+BEGIN_TYPE and #+END_TYPE.
-orgBlock :: OrgParser (F Blocks)
+orgBlock :: PandocMonad m => OrgParser m (F Blocks)
orgBlock = try $ do
blockAttrs <- blockAttributes
blkType <- blockHeaderStart
@@ -390,25 +391,25 @@ orgBlock = try $ do
let (ident, classes, kv) = attrFromBlockAttributes blockAttrs
in fmap $ B.divWith (ident, classes ++ [blkType], kv)
where
- blockHeaderStart :: OrgParser String
+ blockHeaderStart :: Monad m => OrgParser m String
blockHeaderStart = try $ skipSpaces *> stringAnyCase "#+begin_" *> orgArgWord
lowercase :: String -> String
lowercase = map toLower
-rawBlockLines :: (String -> F Blocks) -> String -> OrgParser (F Blocks)
+rawBlockLines :: Monad m => (String -> F Blocks) -> String -> OrgParser m (F Blocks)
rawBlockLines f blockType = (ignHeaders *> (f <$> rawBlockContent blockType))
-parseBlockLines :: (F Blocks -> F Blocks) -> String -> OrgParser (F Blocks)
+parseBlockLines :: PandocMonad m => (F Blocks -> F Blocks) -> String -> OrgParser m (F Blocks)
parseBlockLines f blockType = (ignHeaders *> (f <$> parsedBlockContent))
where
- parsedBlockContent :: OrgParser (F Blocks)
+ parsedBlockContent :: PandocMonad m => OrgParser m (F Blocks)
parsedBlockContent = try $ do
raw <- rawBlockContent blockType
parseFromString blocks (raw ++ "\n")
-- | Read the raw string content of a block
-rawBlockContent :: String -> OrgParser String
+rawBlockContent :: Monad m => String -> OrgParser m String
rawBlockContent blockType = try $ do
blkLines <- manyTill rawLine blockEnder
tabLen <- getOption readerTabStop
@@ -418,10 +419,10 @@ rawBlockContent blockType = try $ do
. map (tabsToSpaces tabLen . commaEscaped)
$ blkLines
where
- rawLine :: OrgParser String
+ rawLine :: Monad m => OrgParser m String
rawLine = try $ ("" <$ blankline) <|> anyLine
- blockEnder :: OrgParser ()
+ blockEnder :: Monad m => OrgParser m ()
blockEnder = try $ skipSpaces <* stringAnyCase ("#+end_" <> blockType)
stripIndent :: [String] -> [String]
@@ -448,18 +449,18 @@ rawBlockContent blockType = try $ do
commaEscaped cs = cs
-- | Read but ignore all remaining block headers.
-ignHeaders :: OrgParser ()
+ignHeaders :: Monad m => OrgParser m ()
ignHeaders = (() <$ newline) <|> (() <$ anyLine)
-- | Read a block containing code intended for export in specific backends
-- only.
-exportBlock :: String -> OrgParser (F Blocks)
+exportBlock :: Monad m => String -> OrgParser m (F Blocks)
exportBlock blockType = try $ do
exportType <- skipSpaces *> orgArgWord <* ignHeaders
contents <- rawBlockContent blockType
returnF (B.rawBlock (map toLower exportType) contents)
-verseBlock :: String -> OrgParser (F Blocks)
+verseBlock :: PandocMonad m => String -> OrgParser m (F Blocks)
verseBlock blockType = try $ do
ignHeaders
content <- rawBlockContent blockType
@@ -468,7 +469,7 @@ verseBlock blockType = try $ do
where
-- replace initial spaces with nonbreaking spaces to preserve
-- indentation, parse the rest as normal inline
- parseVerseLine :: String -> OrgParser (F Inlines)
+ parseVerseLine :: PandocMonad m => String -> OrgParser m (F Inlines)
parseVerseLine cs = do
let (initialSpaces, indentedLine) = span isSpace cs
let nbspIndent = if null initialSpaces
@@ -480,7 +481,7 @@ verseBlock blockType = try $ do
-- | Read a code block and the associated results block if present. Which of
-- boths blocks is included in the output is determined using the "exports"
-- argument in the block header.
-codeBlock :: BlockAttributes -> String -> OrgParser (F Blocks)
+codeBlock :: PandocMonad m => BlockAttributes -> String -> OrgParser m (F Blocks)
codeBlock blockAttrs blockType = do
skipSpaces
(classes, kv) <- codeHeaderArgs <|> (mempty <$ ignHeaders)
@@ -513,7 +514,7 @@ exportsResults :: [(String, String)] -> Bool
exportsResults attrs = ("rundoc-exports", "results") `elem` attrs
|| ("rundoc-exports", "both") `elem` attrs
-trailingResultsBlock :: OrgParser (Maybe (F Blocks))
+trailingResultsBlock :: PandocMonad m => OrgParser m (Maybe (F Blocks))
trailingResultsBlock = optionMaybe . try $ do
blanklines
stringAnyCase "#+RESULTS:"
@@ -522,7 +523,7 @@ trailingResultsBlock = optionMaybe . try $ do
-- | Parse code block arguments
-- TODO: We currently don't handle switches.
-codeHeaderArgs :: OrgParser ([String], [(String, String)])
+codeHeaderArgs :: Monad m => OrgParser m ([String], [(String, String)])
codeHeaderArgs = try $ do
language <- skipSpaces *> orgArgWord
_ <- skipSpaces *> (try $ switch `sepBy` (many1 spaceChar))
@@ -537,27 +538,27 @@ codeHeaderArgs = try $ do
where
hasRundocParameters = not . null
-switch :: OrgParser (Char, Maybe String)
+switch :: Monad m => OrgParser m (Char, Maybe String)
switch = try $ simpleSwitch <|> lineNumbersSwitch
where
simpleSwitch = (\c -> (c, Nothing)) <$> (oneOf "-+" *> letter)
lineNumbersSwitch = (\ls -> ('l', Just ls)) <$>
(string "-l \"" *> many1Till nonspaceChar (char '"'))
-blockOption :: OrgParser (String, String)
+blockOption :: Monad m => OrgParser m (String, String)
blockOption = try $ do
argKey <- orgArgKey
paramValue <- option "yes" orgParamValue
return (argKey, paramValue)
-orgParamValue :: OrgParser String
+orgParamValue :: Monad m => OrgParser m String
orgParamValue = try $
skipSpaces
*> notFollowedBy (char ':' )
*> many1 nonspaceChar
<* skipSpaces
-horizontalRule :: OrgParser (F Blocks)
+horizontalRule :: Monad m => OrgParser m (F Blocks)
horizontalRule = return B.horizontalRule <$ try hline
@@ -568,7 +569,7 @@ horizontalRule = return B.horizontalRule <$ try hline
-- | A generic drawer which has no special meaning for org-mode.
-- Whether or not this drawer is included in the output depends on the drawers
-- export setting.
-genericDrawer :: OrgParser (F Blocks)
+genericDrawer :: PandocMonad m => OrgParser m (F Blocks)
genericDrawer = try $ do
name <- map toUpper <$> drawerStart
content <- manyTill drawerLine (try drawerEnd)
@@ -582,35 +583,35 @@ genericDrawer = try $ do
Right names | name `notElem` names -> return mempty
_ -> drawerDiv name <$> parseLines content
where
- parseLines :: [String] -> OrgParser (F Blocks)
+ parseLines :: PandocMonad m => [String] -> OrgParser m (F Blocks)
parseLines = parseFromString blocks . (++ "\n") . unlines
drawerDiv :: String -> F Blocks -> F Blocks
drawerDiv drawerName = fmap $ B.divWith (mempty, [drawerName, "drawer"], mempty)
-drawerLine :: OrgParser String
+drawerLine :: Monad m => OrgParser m String
drawerLine = anyLine
-drawerEnd :: OrgParser String
+drawerEnd :: Monad m => OrgParser m String
drawerEnd = try $
skipSpaces *> stringAnyCase ":END:" <* skipSpaces <* newline
-- | Read a :PROPERTIES: drawer and return the key/value pairs contained
-- within.
-propertiesDrawer :: OrgParser Properties
+propertiesDrawer :: Monad m => OrgParser m Properties
propertiesDrawer = try $ do
drawerType <- drawerStart
guard $ map toUpper drawerType == "PROPERTIES"
manyTill property (try drawerEnd)
where
- property :: OrgParser (PropertyKey, PropertyValue)
+ property :: Monad m => OrgParser m (PropertyKey, PropertyValue)
property = try $ (,) <$> key <*> value
- key :: OrgParser PropertyKey
+ key :: Monad m => OrgParser m PropertyKey
key = fmap toPropertyKey . try $
skipSpaces *> char ':' *> many1Till nonspaceChar (char ':')
- value :: OrgParser PropertyValue
+ value :: Monad m => OrgParser m PropertyValue
value = fmap toPropertyValue . try $
skipSpaces *> manyTill anyChar (try $ skipSpaces *> newline)
@@ -621,7 +622,7 @@ propertiesDrawer = try $ do
-- | Figures or an image paragraph (i.e. an image on a line by itself). Only
-- images with a caption attribute are interpreted as figures.
-figure :: OrgParser (F Blocks)
+figure :: PandocMonad m => OrgParser m (F Blocks)
figure = try $ do
figAttrs <- blockAttributes
src <- skipSpaces *> selfTarget <* skipSpaces <* endOfParagraph
@@ -632,7 +633,7 @@ figure = try $ do
let isFigure = not . isNothing $ blockAttrCaption figAttrs
return $ imageBlock isFigure figAttrs imgSrc
where
- selfTarget :: OrgParser String
+ selfTarget :: PandocMonad m => OrgParser m String
selfTarget = try $ char '[' *> linkTarget <* char ']'
imageBlock :: Bool -> BlockAttributes -> String -> F Blocks
@@ -654,7 +655,7 @@ figure = try $ do
else "fig:" ++ cs
-- | Succeeds if looking at the end of the current paragraph
-endOfParagraph :: OrgParser ()
+endOfParagraph :: Monad m => OrgParser m ()
endOfParagraph = try $ skipSpaces *> newline *> endOfBlock
@@ -663,11 +664,11 @@ endOfParagraph = try $ skipSpaces *> newline *> endOfBlock
--
-- | Example code marked up by a leading colon.
-example :: OrgParser (F Blocks)
+example :: Monad m => OrgParser m (F Blocks)
example = try $ do
return . return . exampleCode =<< unlines <$> many1 exampleLine
where
- exampleLine :: OrgParser String
+ exampleLine :: Monad m => OrgParser m String
exampleLine = try $ exampleLineStart *> anyLine
exampleCode :: String -> Blocks
@@ -678,10 +679,10 @@ exampleCode = B.codeBlockWith ("", ["example"], [])
-- Comments, Options and Metadata
--
-specialLine :: OrgParser (F Blocks)
+specialLine :: PandocMonad m => OrgParser m (F Blocks)
specialLine = fmap return . try $ rawExportLine <|> metaLine <|> commentLine
-rawExportLine :: OrgParser Blocks
+rawExportLine :: PnadocMonad m => OrgParser m Blocks
rawExportLine = try $ do
metaLineStart
key <- metaKey
@@ -689,7 +690,7 @@ rawExportLine = try $ do
then B.rawBlock key <$> anyLine
else mzero
-commentLine :: OrgParser Blocks
+commentLine :: Monad m => OrgParser m Blocks
commentLine = commentLineStart *> anyLine *> pure mempty
@@ -718,7 +719,7 @@ data OrgTable = OrgTable
, orgTableRows :: [[Blocks]]
}
-table :: OrgParser (F Blocks)
+table :: PandocMonad m => OrgParser m (F Blocks)
table = try $ do
blockAttrs <- blockAttributes
lookAhead tableStart
@@ -745,18 +746,18 @@ orgToPandocTable (OrgTable colProps heads lns) caption =
<*> totalWidth
in (align', width')
-tableRows :: OrgParser [OrgTableRow]
+tableRows :: PandocMonad m => OrgParser m [OrgTableRow]
tableRows = try $ many (tableAlignRow <|> tableHline <|> tableContentRow)
-tableContentRow :: OrgParser OrgTableRow
+tableContentRow :: PandocMonad m => OrgParser m OrgTableRow
tableContentRow = try $
OrgContentRow . sequence <$> (tableStart *> many1Till tableContentCell newline)
-tableContentCell :: OrgParser (F Blocks)
+tableContentCell :: PandocMonad m => OrgParser m (F Blocks)
tableContentCell = try $
fmap B.plain . trimInlinesF . mconcat <$> manyTill inline endOfCell
-tableAlignRow :: OrgParser OrgTableRow
+tableAlignRow :: Monad m => OrgParser m OrgTableRow
tableAlignRow = try $ do
tableStart
colProps <- many1Till columnPropertyCell newline
@@ -764,7 +765,7 @@ tableAlignRow = try $ do
guard $ any (/= def) colProps
return $ OrgAlignRow colProps
-columnPropertyCell :: OrgParser ColumnProperty
+columnPropertyCell :: Monad m => OrgParser m ColumnProperty
columnPropertyCell = emptyCell <|> propCell <?> "alignment info"
where
emptyCell = ColumnProperty Nothing Nothing <$ (try $ skipSpaces *> endOfCell)
@@ -776,18 +777,18 @@ columnPropertyCell = emptyCell <|> propCell <?> "alignment info"
<* char '>'
<* emptyCell)
-tableAlignFromChar :: OrgParser Alignment
+tableAlignFromChar :: Monad m => OrgParser m Alignment
tableAlignFromChar = try $
choice [ char 'l' *> return AlignLeft
, char 'c' *> return AlignCenter
, char 'r' *> return AlignRight
]
-tableHline :: OrgParser OrgTableRow
+tableHline :: Monad m => OrgParser m OrgTableRow
tableHline = try $
OrgHlineRow <$ (tableStart *> char '-' *> anyLine)
-endOfCell :: OrgParser Char
+endOfCell :: Monad m => OrgParser m Char
endOfCell = try $ char '|' <|> lookAhead newline
rowsToTable :: [OrgTableRow]
@@ -840,7 +841,7 @@ rowToContent orgTable row =
--
-- LaTeX fragments
--
-latexFragment :: OrgParser (F Blocks)
+latexFragment :: Monad m => OrgParser m (F Blocks)
latexFragment = try $ do
envName <- latexEnvStart
content <- mconcat <$> manyTill anyLineNewline (latexEnd envName)
@@ -851,7 +852,7 @@ latexFragment = try $ do
, "\\end{", e, "}\n"
]
-latexEnd :: String -> OrgParser ()
+latexEnd :: Monad m => String -> OrgParser m ()
latexEnd envName = try $
() <$ skipSpaces
<* string ("\\end{" ++ envName ++ "}")
@@ -861,7 +862,7 @@ latexEnd envName = try $
--
-- Footnote defintions
--
-noteBlock :: OrgParser (F Blocks)
+noteBlock :: PandocMonad m => OrgParser m (F Blocks)
noteBlock = try $ do
ref <- noteMarker <* skipSpaces
content <- mconcat <$> blocksTillHeaderOrNote
@@ -873,7 +874,7 @@ noteBlock = try $ do
<|> () <$ lookAhead headerStart)
-- Paragraphs or Plain text
-paraOrPlain :: OrgParser (F Blocks)
+paraOrPlain :: PandocMonad m => OrgParser m (F Blocks)
paraOrPlain = try $ do
-- Make sure we are not looking at a headline
notFollowedBy' (char '*' *> (oneOf " *"))
@@ -892,24 +893,24 @@ paraOrPlain = try $ do
-- list blocks
--
-list :: OrgParser (F Blocks)
+list :: PandocMonad m => OrgParser m (F Blocks)
list = choice [ definitionList, bulletList, orderedList ] <?> "list"
-definitionList :: OrgParser (F Blocks)
+definitionList :: PandocMonad m => OrgParser m (F Blocks)
definitionList = try $ do n <- lookAhead (bulletListStart' Nothing)
fmap B.definitionList . fmap compactify'DL . sequence
<$> many1 (definitionListItem $ bulletListStart' (Just n))
-bulletList :: OrgParser (F Blocks)
+bulletList :: PandocMonad m => OrgParser m (F Blocks)
bulletList = try $ do n <- lookAhead (bulletListStart' Nothing)
fmap B.bulletList . fmap compactify' . sequence
<$> many1 (listItem (bulletListStart' $ Just n))
-orderedList :: OrgParser (F Blocks)
+orderedList :: PandocMonad m => OrgParser m (F Blocks)
orderedList = fmap B.orderedList . fmap compactify' . sequence
<$> many1 (listItem orderedListStart)
-bulletListStart' :: Maybe Int -> OrgParser Int
+bulletListStart' :: Monad m => Maybe Int -> OrgParser m Int
-- returns length of bulletList prefix, inclusive of marker
bulletListStart' Nothing = do ind <- length <$> many spaceChar
oneOf (bullets $ ind == 0)
@@ -925,8 +926,9 @@ bulletListStart' (Just n) = do count (n-1) spaceChar
bullets :: Bool -> String
bullets unindented = if unindented then "+-" else "*+-"
-definitionListItem :: OrgParser Int
- -> OrgParser (F (Inlines, [Blocks]))
+definitionListItem :: PandocMonad m
+ => OrgParser m Int
+ -> OrgParser m (F (Inlines, [Blocks]))
definitionListItem parseMarkerGetLength = try $ do
markerLength <- parseMarkerGetLength
term <- manyTill (noneOf "\n\r") (try definitionMarker)
@@ -942,8 +944,9 @@ definitionListItem parseMarkerGetLength = try $ do
-- parse raw text for one list item, excluding start marker and continuations
-listItem :: OrgParser Int
- -> OrgParser (F Blocks)
+listItem :: PandocMonad m
+ => OrgParser m Int
+ -> OrgParser m (F Blocks)
listItem start = try . withContext ListItemState $ do
markerLength <- try start
firstLine <- anyLineNewline
@@ -953,8 +956,8 @@ listItem start = try . withContext ListItemState $ do
-- continuation of a list item - indented and separated by blankline or endline.
-- Note: nested lists are parsed as continuations.
-listContinuation :: Int
- -> OrgParser String
+listContinuation :: Monad m => Int
+ -> OrgParser m String
listContinuation markerLength = try $
notFollowedBy' blankline
*> (mappend <$> (concat <$> many1 listLine)
@@ -963,7 +966,7 @@ listContinuation markerLength = try $
listLine = try $ indentWith markerLength *> anyLineNewline
-- indent by specified number of spaces (or equiv. tabs)
- indentWith :: Int -> OrgParser String
+ indentWith :: Monad m => Int -> OrgParser m String
indentWith num = do
tabStop <- getOption readerTabStop
if num < tabStop
@@ -972,5 +975,5 @@ listContinuation markerLength = try $
, try (char '\t' >> count (num - tabStop) (char ' ')) ]
-- | Parse any line, include the final newline in the output.
-anyLineNewline :: OrgParser String
+anyLineNewline :: Monad m => OrgParser m String
anyLineNewline = (++ "\n") <$> anyLine
diff --git a/src/Text/Pandoc/Readers/Org/ExportSettings.hs b/src/Text/Pandoc/Readers/Org/ExportSettings.hs
index 764e5b0d5..391877c03 100644
--- a/src/Text/Pandoc/Readers/Org/ExportSettings.hs
+++ b/src/Text/Pandoc/Readers/Org/ExportSettings.hs
@@ -37,14 +37,14 @@ import Data.Char ( toLower )
import Data.Maybe ( listToMaybe )
-- | Read and handle space separated org-mode export settings.
-exportSettings :: OrgParser ()
+exportSettings :: Monad m => OrgParser m ()
exportSettings = void $ sepBy spaces exportSetting
-- | Setter function for export settings.
type ExportSettingSetter a = a -> ExportSettings -> ExportSettings
-- | Read and process a single org-mode export option.
-exportSetting :: OrgParser ()
+exportSetting :: Monad m => OrgParser m ()
exportSetting = choice
[ booleanSetting "^" (\val es -> es { exportSubSuperscripts = val })
, booleanSetting "'" (\val es -> es { exportSmartQuotes = val })
@@ -81,10 +81,11 @@ exportSetting = choice
, ignoredSetting "|"
] <?> "export setting"
-genericExportSetting :: OrgParser a
+genericExportSetting :: Monad m
+ => OrgParser m a
-> String
-> ExportSettingSetter a
- -> OrgParser ()
+ -> OrgParser m ()
genericExportSetting optionParser settingIdentifier setter = try $ do
_ <- string settingIdentifier *> char ':'
value <- optionParser
@@ -94,11 +95,11 @@ genericExportSetting optionParser settingIdentifier setter = try $ do
st { orgStateExportSettings = setter val . orgStateExportSettings $ st }
-- | A boolean option, either nil (False) or non-nil (True).
-booleanSetting :: String -> ExportSettingSetter Bool -> OrgParser ()
+booleanSetting :: Monad m => String -> ExportSettingSetter Bool -> OrgParser m ()
booleanSetting = genericExportSetting elispBoolean
-- | An integer-valued option.
-integerSetting :: String -> ExportSettingSetter Int -> OrgParser ()
+integerSetting :: Monad m => String -> ExportSettingSetter Int -> OrgParser m ()
integerSetting = genericExportSetting parseInt
where
parseInt = try $
@@ -106,9 +107,10 @@ integerSetting = genericExportSetting parseInt
-- | Either the string "headline" or an elisp boolean and treated as an
-- @ArchivedTreesOption@.
-archivedTreeSetting :: String
+archivedTreeSetting :: Monad m
+ => String
-> ExportSettingSetter ArchivedTreesOption
- -> OrgParser ()
+ -> OrgParser m ()
archivedTreeSetting =
genericExportSetting $ archivedTreesHeadlineSetting <|> archivedTreesBoolean
where
@@ -125,9 +127,10 @@ archivedTreeSetting =
else ArchivedTreesNoExport
-- | A list or a complement list (i.e. a list starting with `not`).
-complementableListSetting :: String
+complementableListSetting :: Monad m
+ => String
-> ExportSettingSetter (Either [String] [String])
- -> OrgParser ()
+ -> OrgParser m ()
complementableListSetting = genericExportSetting $ choice
[ Left <$> complementStringList
, Right <$> stringList
@@ -135,31 +138,31 @@ complementableListSetting = genericExportSetting $ choice
]
where
-- Read a plain list of strings.
- stringList :: OrgParser [String]
+ stringList :: Monad m => OrgParser m [String]
stringList = try $
char '('
*> sepBy elispString spaces
<* char ')'
-- Read an emacs lisp list specifying a complement set.
- complementStringList :: OrgParser [String]
+ complementStringList :: Monad m => OrgParser m [String]
complementStringList = try $
string "(not "
*> sepBy elispString spaces
<* char ')'
- elispString :: OrgParser String
+ elispString :: Monad m => OrgParser m String
elispString = try $
char '"'
*> manyTill alphaNum (char '"')
-- | Read but ignore the export setting.
-ignoredSetting :: String -> OrgParser ()
+ignoredSetting :: Monad m => String -> OrgParser m ()
ignoredSetting s = try (() <$ string s <* char ':' <* many1 nonspaceChar)
-- | Read an elisp boolean. Only NIL is treated as false, non-NIL values are
-- interpreted as true.
-elispBoolean :: OrgParser Bool
+elispBoolean :: Monad m => OrgParser m Bool
elispBoolean = try $ do
value <- many1 nonspaceChar
return $ case map toLower value of
diff --git a/src/Text/Pandoc/Readers/Org/Inlines.hs b/src/Text/Pandoc/Readers/Org/Inlines.hs
index 7e1bb61c2..5a02eb8eb 100644
--- a/src/Text/Pandoc/Readers/Org/Inlines.hs
+++ b/src/Text/Pandoc/Readers/Org/Inlines.hs
@@ -47,9 +47,11 @@ import Text.Pandoc.Options
import Text.Pandoc.Readers.LaTeX ( inlineCommand, rawLaTeXInline )
import Text.TeXMath ( readTeX, writePandoc, DisplayType(..) )
import qualified Text.TeXMath.Readers.MathML.EntityMap as MathMLEntityMap
+import Text.Pandoc.Class (PandocMonad)
import Prelude hiding (sequence)
import Control.Monad ( guard, mplus, mzero, when, void )
+import Control.Monad.Trans ( lift )
import Data.Char ( isAlphaNum, isSpace )
import Data.List ( intersperse )
import Data.Maybe ( fromMaybe )
@@ -60,46 +62,46 @@ import Data.Traversable (sequence)
--
-- Functions acting on the parser state
--
-recordAnchorId :: String -> OrgParser ()
+recordAnchorId :: PandocMonad m => String -> OrgParser m ()
recordAnchorId i = updateState $ \s ->
s{ orgStateAnchorIds = i : (orgStateAnchorIds s) }
-pushToInlineCharStack :: Char -> OrgParser ()
+pushToInlineCharStack :: PandocMonad m => Char -> OrgParser m ()
pushToInlineCharStack c = updateState $ \s ->
s{ orgStateEmphasisCharStack = c:orgStateEmphasisCharStack s }
-popInlineCharStack :: OrgParser ()
+popInlineCharStack :: PandocMonad m => OrgParser m ()
popInlineCharStack = updateState $ \s ->
s{ orgStateEmphasisCharStack = drop 1 . orgStateEmphasisCharStack $ s }
-surroundingEmphasisChar :: OrgParser [Char]
+surroundingEmphasisChar :: PandocMonad m => OrgParser m [Char]
surroundingEmphasisChar =
take 1 . drop 1 . orgStateEmphasisCharStack <$> getState
-startEmphasisNewlinesCounting :: Int -> OrgParser ()
+startEmphasisNewlinesCounting :: PandocMonad m => Int -> OrgParser m ()
startEmphasisNewlinesCounting maxNewlines = updateState $ \s ->
s{ orgStateEmphasisNewlines = Just maxNewlines }
-decEmphasisNewlinesCount :: OrgParser ()
+decEmphasisNewlinesCount :: PandocMonad m => OrgParser m ()
decEmphasisNewlinesCount = updateState $ \s ->
s{ orgStateEmphasisNewlines = (\n -> n - 1) <$> orgStateEmphasisNewlines s }
-newlinesCountWithinLimits :: OrgParser Bool
+newlinesCountWithinLimits :: PandocMonad m => OrgParser m Bool
newlinesCountWithinLimits = do
st <- getState
return $ ((< 0) <$> orgStateEmphasisNewlines st) /= Just True
-resetEmphasisNewlines :: OrgParser ()
+resetEmphasisNewlines :: PandocMonad m => OrgParser m ()
resetEmphasisNewlines = updateState $ \s ->
s{ orgStateEmphasisNewlines = Nothing }
-addToNotesTable :: OrgNoteRecord -> OrgParser ()
+addToNotesTable :: PandocMonad m => OrgNoteRecord -> OrgParser m ()
addToNotesTable note = do
oldnotes <- orgStateNotes' <$> getState
updateState $ \s -> s{ orgStateNotes' = note:oldnotes }
-- | Parse a single Org-mode inline element
-inline :: OrgParser (F Inlines)
+inline :: PandocMonad m => OrgParser m (F Inlines)
inline =
choice [ whitespace
, linebreak
@@ -125,7 +127,7 @@ inline =
<?> "inline"
-- | Read the rest of the input as inlines.
-inlines :: OrgParser (F Inlines)
+inlines :: PandocMonad m => OrgParser m (F Inlines)
inlines = trimInlinesF . mconcat <$> many1 inline
-- treat these as potentially non-text when parsing inline:
@@ -133,23 +135,23 @@ specialChars :: [Char]
specialChars = "\"$'()*+-,./:;<=>@[\\]^_{|}~"
-whitespace :: OrgParser (F Inlines)
+whitespace :: PandocMonad m => OrgParser m (F Inlines)
whitespace = pure B.space <$ skipMany1 spaceChar
<* updateLastPreCharPos
<* updateLastForbiddenCharPos
<?> "whitespace"
-linebreak :: OrgParser (F Inlines)
+linebreak :: PandocMonad m => OrgParser m (F Inlines)
linebreak = try $ pure B.linebreak <$ string "\\\\" <* skipSpaces <* newline
-str :: OrgParser (F Inlines)
+str :: PandocMonad m => OrgParser m (F Inlines)
str = return . B.str <$> many1 (noneOf $ specialChars ++ "\n\r ")
<* updateLastStrPos
-- | An endline character that can be treated as a space, not a structural
-- break. This should reflect the values of the Emacs variable
-- @org-element-pagaraph-separate@.
-endline :: OrgParser (F Inlines)
+endline :: PandocMonad m => OrgParser m (F Inlines)
endline = try $ do
newline
notFollowedBy' endOfBlock
@@ -174,7 +176,7 @@ endline = try $ do
-- contributors. All this should be consolidated once an official Org-mode
-- citation syntax has emerged.
-cite :: OrgParser (F Inlines)
+cite :: PandocMonad m => OrgParser m (F Inlines)
cite = try $ berkeleyCite <|> do
guardEnabled Ext_citations
(cs, raw) <- withRaw $ choice
@@ -185,40 +187,41 @@ cite = try $ berkeleyCite <|> do
return $ (flip B.cite (B.text raw)) <$> cs
-- | A citation in Pandoc Org-mode style (@[prefix \@citekey suffix]@).
-pandocOrgCite :: OrgParser (F [Citation])
+pandocOrgCite :: PandocMonad m => OrgParser m (F [Citation])
pandocOrgCite = try $
char '[' *> skipSpaces *> citeList <* skipSpaces <* char ']'
-orgRefCite :: OrgParser (F [Citation])
+orgRefCite :: PandocMonad m => OrgParser m (F [Citation])
orgRefCite = try $ choice
[ normalOrgRefCite
, fmap (:[]) <$> linkLikeOrgRefCite
]
-normalOrgRefCite :: OrgParser (F [Citation])
+normalOrgRefCite :: PandocMonad m => OrgParser m (F [Citation])
normalOrgRefCite = try $ do
mode <- orgRefCiteMode
- -- org-ref style citation key, parsed into a citation of the given mode
- let orgRefCiteItem :: OrgParser (F Citation)
- orgRefCiteItem = try $ do
- key <- orgRefCiteKey
- returnF $ Citation
- { citationId = key
- , citationPrefix = mempty
- , citationSuffix = mempty
- , citationMode = mode
- , citationNoteNum = 0
- , citationHash = 0
- }
- firstCitation <- orgRefCiteItem
- moreCitations <- many (try $ char ',' *> orgRefCiteItem)
+ firstCitation <- orgRefCiteList mode
+ moreCitations <- many (try $ char ',' *> orgRefCiteList mode)
return . sequence $ firstCitation : moreCitations
- where
+ where
+ -- | A list of org-ref style citation keys, parsed as citation of the given
+ -- citation mode.
+ orgRefCiteList :: PandocMonad m => CitationMode -> OrgParser m (F Citation)
+ orgRefCiteList citeMode = try $ do
+ key <- orgRefCiteKey
+ returnF $ Citation
+ { citationId = key
+ , citationPrefix = mempty
+ , citationSuffix = mempty
+ , citationMode = citeMode
+ , citationNoteNum = 0
+ , citationHash = 0
+ }
-- | Read an Berkeley-style Org-mode citation. Berkeley citation style was
-- develop and adjusted to Org-mode style by John MacFarlane and Richard
-- Lawrence, respectively, both philosophers at UC Berkeley.
-berkeleyCite :: OrgParser (F Inlines)
+berkeleyCite :: PandocMonad m => OrgParser m (F Inlines)
berkeleyCite = try $ do
bcl <- berkeleyCitationList
return $ do
@@ -260,7 +263,7 @@ data BerkeleyCitationList = BerkeleyCitationList
, berkeleyCiteCommonSuffix :: Maybe Inlines
, berkeleyCiteCitations :: [Citation]
}
-berkeleyCitationList :: OrgParser (F BerkeleyCitationList)
+berkeleyCitationList :: PandocMonad m => OrgParser m (F BerkeleyCitationList)
berkeleyCitationList = try $ do
char '['
parens <- choice [ False <$ berkeleyBareTag, True <$ berkeleyParensTag ]
@@ -275,22 +278,22 @@ berkeleyCitationList = try $ do
<*> sequence commonSuffix
<*> citations)
where
- citationListPart :: OrgParser (F Inlines)
+ citationListPart :: PandocMonad m => OrgParser m (F Inlines)
citationListPart = fmap (trimInlinesF . mconcat) . try . many1 $ do
notFollowedBy' citeKey
notFollowedBy (oneOf ";]")
inline
-berkeleyBareTag :: OrgParser ()
+berkeleyBareTag :: PandocMonad m => OrgParser m ()
berkeleyBareTag = try $ void berkeleyBareTag'
-berkeleyParensTag :: OrgParser ()
+berkeleyParensTag :: PandocMonad m => OrgParser m ()
berkeleyParensTag = try . void $ enclosedByPair '(' ')' berkeleyBareTag'
-berkeleyBareTag' :: OrgParser ()
+berkeleyBareTag' :: PandocMonad m => OrgParser m ()
berkeleyBareTag' = try $ void (string "cite")
-berkeleyTextualCite :: OrgParser (F [Citation])
+berkeleyTextualCite :: PandocMonad m => OrgParser m (F [Citation])
berkeleyTextualCite = try $ do
(suppressAuthor, key) <- citeKey
returnF . return $ Citation
@@ -305,14 +308,14 @@ berkeleyTextualCite = try $ do
-- The following is what a Berkeley-style bracketed textual citation parser
-- would look like. However, as these citations are a subset of Pandoc's Org
-- citation style, this isn't used.
--- berkeleyBracketedTextualCite :: OrgParser (F [Citation])
+-- berkeleyBracketedTextualCite :: PandocMonad m => OrgParser m (F [Citation])
-- berkeleyBracketedTextualCite = try . (fmap head) $
-- enclosedByPair '[' ']' berkeleyTextualCite
-- | Read a link-like org-ref style citation. The citation includes pre and
-- post text. However, multiple citations are not possible due to limitations
-- in the syntax.
-linkLikeOrgRefCite :: OrgParser (F Citation)
+linkLikeOrgRefCite :: PandocMonad m => OrgParser m (F Citation)
linkLikeOrgRefCite = try $ do
_ <- string "[["
mode <- orgRefCiteMode
@@ -335,13 +338,13 @@ linkLikeOrgRefCite = try $ do
-- | Read a citation key. The characters allowed in citation keys are taken
-- from the `org-ref-cite-re` variable in `org-ref.el`.
-orgRefCiteKey :: OrgParser String
+orgRefCiteKey :: PandocMonad m => OrgParser m String
orgRefCiteKey = try . many1 . satisfy $ \c ->
isAlphaNum c || c `elem` ("-_:\\./"::String)
-- | Supported citation types. Only a small subset of org-ref types is
-- supported for now. TODO: rewrite this, use LaTeX reader as template.
-orgRefCiteMode :: OrgParser CitationMode
+orgRefCiteMode :: PandocMonad m => OrgParser m CitationMode
orgRefCiteMode =
choice $ map (\(s, mode) -> mode <$ try (string s <* char ':'))
[ ("cite", AuthorInText)
@@ -352,10 +355,10 @@ orgRefCiteMode =
, ("citeyear", SuppressAuthor)
]
-citeList :: OrgParser (F [Citation])
+citeList :: PandocMonad m => OrgParser m (F [Citation])
citeList = sequence <$> sepEndBy1 citation (try $ char ';' *> skipSpaces)
-citation :: OrgParser (F Citation)
+citation :: PandocMonad m => OrgParser m (F Citation)
citation = try $ do
pref <- prefix
(suppress_author, key) <- citeKey
@@ -384,10 +387,10 @@ citation = try $ do
then (B.space <>) <$> rest
else rest
-footnote :: OrgParser (F Inlines)
+footnote :: PandocMonad m => OrgParser m (F Inlines)
footnote = try $ inlineNote <|> referencedNote
-inlineNote :: OrgParser (F Inlines)
+inlineNote :: PandocMonad m => OrgParser m (F Inlines)
inlineNote = try $ do
string "[fn:"
ref <- many alphaNum
@@ -397,7 +400,7 @@ inlineNote = try $ do
addToNotesTable ("fn:" ++ ref, note)
return $ B.note <$> note
-referencedNote :: OrgParser (F Inlines)
+referencedNote :: PandocMonad m => OrgParser m (F Inlines)
referencedNote = try $ do
ref <- noteMarker
return $ do
@@ -409,14 +412,14 @@ referencedNote = try $ do
let contents' = runF contents st{ orgStateNotes' = [] }
return $ B.note contents'
-linkOrImage :: OrgParser (F Inlines)
+linkOrImage :: PandocMonad m => OrgParser m (F Inlines)
linkOrImage = explicitOrImageLink
<|> selflinkOrImage
<|> angleLink
<|> plainLink
<?> "link or image"
-explicitOrImageLink :: OrgParser (F Inlines)
+explicitOrImageLink :: PandocMonad m => OrgParser m (F Inlines)
explicitOrImageLink = try $ do
char '['
srcF <- applyCustomLinkFormat =<< possiblyEmptyLinkTarget
@@ -431,30 +434,30 @@ explicitOrImageLink = try $ do
_ ->
linkToInlinesF src =<< title'
-selflinkOrImage :: OrgParser (F Inlines)
+selflinkOrImage :: PandocMonad m => OrgParser m (F Inlines)
selflinkOrImage = try $ do
src <- char '[' *> linkTarget <* char ']'
return $ linkToInlinesF src (B.str src)
-plainLink :: OrgParser (F Inlines)
+plainLink :: PandocMonad m => OrgParser m (F Inlines)
plainLink = try $ do
(orig, src) <- uri
returnF $ B.link src "" (B.str orig)
-angleLink :: OrgParser (F Inlines)
+angleLink :: PandocMonad m => OrgParser m (F Inlines)
angleLink = try $ do
char '<'
link <- plainLink
char '>'
return link
-linkTarget :: OrgParser String
+linkTarget :: PandocMonad m => OrgParser m String
linkTarget = enclosedByPair '[' ']' (noneOf "\n\r[]")
-possiblyEmptyLinkTarget :: OrgParser String
+possiblyEmptyLinkTarget :: PandocMonad m => OrgParser m String
possiblyEmptyLinkTarget = try linkTarget <|> ("" <$ string "[]")
-applyCustomLinkFormat :: String -> OrgParser (F String)
+applyCustomLinkFormat :: String -> OrgParser m (F String)
applyCustomLinkFormat link = do
let (linkType, rest) = break (== ':') link
return $ do
@@ -487,7 +490,7 @@ internalLink link title = do
-- @anchor-id@ contains spaces, we are more restrictive in what is accepted as
-- an anchor.
-anchor :: OrgParser (F Inlines)
+anchor :: PandocMonad m => OrgParser m (F Inlines)
anchor = try $ do
anchorId <- parseAnchor
recordAnchorId anchorId
@@ -509,7 +512,7 @@ solidify = map replaceSpecialChar
| otherwise = '-'
-- | Parses an inline code block and marks it as an babel block.
-inlineCodeBlock :: OrgParser (F Inlines)
+inlineCodeBlock :: PandocMonad m => OrgParser m (F Inlines)
inlineCodeBlock = try $ do
string "src_"
lang <- many1 orgArgWordChar
@@ -519,13 +522,13 @@ inlineCodeBlock = try $ do
let attrKeyVal = map toRundocAttrib (("language", lang) : opts)
returnF $ B.codeWith ("", attrClasses, attrKeyVal) inlineCode
where
- inlineBlockOption :: OrgParser (String, String)
+ inlineBlockOption :: PandocMonad m => OrgParser m (String, String)
inlineBlockOption = try $ do
argKey <- orgArgKey
paramValue <- option "yes" orgInlineParamValue
return (argKey, paramValue)
- orgInlineParamValue :: OrgParser String
+ orgInlineParamValue :: PandocMonad m => OrgParser m String
orgInlineParamValue = try $
skipSpaces
*> notFollowedBy (char ':')
@@ -533,7 +536,7 @@ inlineCodeBlock = try $ do
<* skipSpaces
-emphasizedText :: OrgParser (F Inlines)
+emphasizedText :: PandocMonad m => OrgParser m (F Inlines)
emphasizedText = do
state <- getState
guard . exportEmphasizedText . orgStateExportSettings $ state
@@ -544,60 +547,63 @@ emphasizedText = do
, underline
]
-enclosedByPair :: Char -- ^ opening char
+enclosedByPair :: PandocMonad m
+ => Char -- ^ opening char
-> Char -- ^ closing char
- -> OrgParser a -- ^ parser
- -> OrgParser [a]
+ -> OrgParser m a -- ^ parser
+ -> OrgParser m [a]
enclosedByPair s e p = char s *> many1Till p (char e)
-emph :: OrgParser (F Inlines)
+emph :: PandocMonad m => OrgParser m (F Inlines)
emph = fmap B.emph <$> emphasisBetween '/'
-strong :: OrgParser (F Inlines)
+strong :: PandocMonad m => OrgParser m (F Inlines)
strong = fmap B.strong <$> emphasisBetween '*'
-strikeout :: OrgParser (F Inlines)
+strikeout :: PandocMonad m => OrgParser m (F Inlines)
strikeout = fmap B.strikeout <$> emphasisBetween '+'
-- There is no underline, so we use strong instead.
-underline :: OrgParser (F Inlines)
+underline :: PandocMonad m => OrgParser m (F Inlines)
underline = fmap B.strong <$> emphasisBetween '_'
-verbatim :: OrgParser (F Inlines)
+verbatim :: PandocMonad m => OrgParser m (F Inlines)
verbatim = return . B.code <$> verbatimBetween '='
-code :: OrgParser (F Inlines)
+code :: PandocMonad m => OrgParser m (F Inlines)
code = return . B.code <$> verbatimBetween '~'
-subscript :: OrgParser (F Inlines)
+subscript :: PandocMonad m => OrgParser m (F Inlines)
subscript = fmap B.subscript <$> try (char '_' *> subOrSuperExpr)
-superscript :: OrgParser (F Inlines)
+superscript :: PandocMonad m => OrgParser m (F Inlines)
superscript = fmap B.superscript <$> try (char '^' *> subOrSuperExpr)
-math :: OrgParser (F Inlines)
+math :: PandocMonad m => OrgParser m (F Inlines)
math = return . B.math <$> choice [ math1CharBetween '$'
, mathStringBetween '$'
, rawMathBetween "\\(" "\\)"
]
-displayMath :: OrgParser (F Inlines)
+displayMath :: PandocMonad m => OrgParser m (F Inlines)
displayMath = return . B.displayMath <$> choice [ rawMathBetween "\\[" "\\]"
, rawMathBetween "$$" "$$"
]
-updatePositions :: Char
- -> OrgParser Char
+updatePositions :: PandocMonad m
+ => Char
+ -> OrgParser m Char
updatePositions c = do
when (c `elem` emphasisPreChars) updateLastPreCharPos
when (c `elem` emphasisForbiddenBorderChars) updateLastForbiddenCharPos
return c
-symbol :: OrgParser (F Inlines)
+symbol :: PandocMonad m => OrgParser m (F Inlines)
symbol = return . B.str . (: "") <$> (oneOf specialChars >>= updatePositions)
-emphasisBetween :: Char
- -> OrgParser (F Inlines)
+emphasisBetween :: PandocMonad m
+ => Char
+ -> OrgParser m (F Inlines)
emphasisBetween c = try $ do
startEmphasisNewlinesCounting emphasisAllowedNewlines
res <- enclosedInlines (emphasisStart c) (emphasisEnd c)
@@ -606,8 +612,9 @@ emphasisBetween c = try $ do
resetEmphasisNewlines
return res
-verbatimBetween :: Char
- -> OrgParser String
+verbatimBetween :: PandocMonad m
+ => Char
+ -> OrgParser m String
verbatimBetween c = try $
emphasisStart c *>
many1TillNOrLessNewlines 1 verbatimChar (emphasisEnd c)
@@ -615,8 +622,9 @@ verbatimBetween c = try $
verbatimChar = noneOf "\n\r" >>= updatePositions
-- | Parses a raw string delimited by @c@ using Org's math rules
-mathStringBetween :: Char
- -> OrgParser String
+mathStringBetween :: PandocMonad m
+ => Char
+ -> OrgParser m String
mathStringBetween c = try $ do
mathStart c
body <- many1TillNOrLessNewlines mathAllowedNewlines
@@ -626,8 +634,9 @@ mathStringBetween c = try $ do
return $ body ++ [final]
-- | Parse a single character between @c@ using math rules
-math1CharBetween :: Char
- -> OrgParser String
+math1CharBetween :: PandocMonad m
+ => Char
+ -> OrgParser m String
math1CharBetween c = try $ do
char c
res <- noneOf $ c:mathForbiddenBorderChars
@@ -635,13 +644,14 @@ math1CharBetween c = try $ do
eof <|> () <$ lookAhead (oneOf mathPostChars)
return [res]
-rawMathBetween :: String
+rawMathBetween :: PandocMonad m
+ => String
-> String
- -> OrgParser String
+ -> OrgParser m String
rawMathBetween s e = try $ string s *> manyTill anyChar (try $ string e)
-- | Parses the start (opening character) of emphasis
-emphasisStart :: Char -> OrgParser Char
+emphasisStart :: PandocMonad m => Char -> OrgParser m Char
emphasisStart c = try $ do
guard =<< afterEmphasisPreChar
guard =<< notAfterString
@@ -654,7 +664,7 @@ emphasisStart c = try $ do
return c
-- | Parses the closing character of emphasis
-emphasisEnd :: Char -> OrgParser Char
+emphasisEnd :: PandocMonad m => Char -> OrgParser m Char
emphasisEnd c = try $ do
guard =<< notAfterForbiddenBorderChar
char c
@@ -665,11 +675,11 @@ emphasisEnd c = try $ do
where acceptablePostChars =
surroundingEmphasisChar >>= \x -> oneOf (x ++ emphasisPostChars)
-mathStart :: Char -> OrgParser Char
+mathStart :: PandocMonad m => Char -> OrgParser m Char
mathStart c = try $
char c <* notFollowedBy' (oneOf (c:mathForbiddenBorderChars))
-mathEnd :: Char -> OrgParser Char
+mathEnd :: PandocMonad m => Char -> OrgParser m Char
mathEnd c = try $ do
res <- noneOf (c:mathForbiddenBorderChars)
char c
@@ -677,15 +687,15 @@ mathEnd c = try $ do
return res
-enclosedInlines :: OrgParser a
- -> OrgParser b
- -> OrgParser (F Inlines)
+enclosedInlines :: PandocMonad m => OrgParser m a
+ -> OrgParser m b
+ -> OrgParser m (F Inlines)
enclosedInlines start end = try $
trimInlinesF . mconcat <$> enclosed start end inline
-enclosedRaw :: OrgParser a
- -> OrgParser b
- -> OrgParser String
+enclosedRaw :: PandocMonad m => OrgParser m a
+ -> OrgParser m b
+ -> OrgParser m String
enclosedRaw start end = try $
start *> (onSingleLine <|> spanningTwoLines)
where onSingleLine = try $ many1Till (noneOf "\n\r") end
@@ -694,10 +704,10 @@ enclosedRaw start end = try $
-- | Like many1Till, but parses at most @n+1@ lines. @p@ must not consume
-- newlines.
-many1TillNOrLessNewlines :: Int
- -> OrgParser Char
- -> OrgParser a
- -> OrgParser String
+many1TillNOrLessNewlines :: PandocMonad m => Int
+ -> OrgParser m Char
+ -> OrgParser m a
+ -> OrgParser m String
many1TillNOrLessNewlines n p end = try $
nMoreLines (Just n) mempty >>= oneOrMore
where
@@ -746,21 +756,21 @@ mathAllowedNewlines :: Int
mathAllowedNewlines = 2
-- | Whether we are right behind a char allowed before emphasis
-afterEmphasisPreChar :: OrgParser Bool
+afterEmphasisPreChar :: PandocMonad m => OrgParser m Bool
afterEmphasisPreChar = do
pos <- getPosition
lastPrePos <- orgStateLastPreCharPos <$> getState
return . fromMaybe True $ (== pos) <$> lastPrePos
-- | Whether the parser is right after a forbidden border char
-notAfterForbiddenBorderChar :: OrgParser Bool
+notAfterForbiddenBorderChar :: PandocMonad m => OrgParser m Bool
notAfterForbiddenBorderChar = do
pos <- getPosition
lastFBCPos <- orgStateLastForbiddenCharPos <$> getState
return $ lastFBCPos /= Just pos
-- | Read a sub- or superscript expression
-subOrSuperExpr :: OrgParser (F Inlines)
+subOrSuperExpr :: PandocMonad m => OrgParser m (F Inlines)
subOrSuperExpr = try $
choice [ id <$> charsInBalanced '{' '}' (noneOf "\n\r")
, enclosing ('(', ')') <$> charsInBalanced '(' ')' (noneOf "\n\r")
@@ -768,7 +778,7 @@ subOrSuperExpr = try $
] >>= parseFromString (mconcat <$> many inline)
where enclosing (left, right) s = left : s ++ [right]
-simpleSubOrSuperString :: OrgParser String
+simpleSubOrSuperString :: PandocMonad m => OrgParser m String
simpleSubOrSuperString = try $ do
state <- getState
guard . exportSubSuperscripts . orgStateExportSettings $ state
@@ -777,17 +787,18 @@ simpleSubOrSuperString = try $ do
<*> many1 alphaNum
]
-inlineLaTeX :: OrgParser (F Inlines)
+inlineLaTeX :: PandocMonad m => OrgParser m (F Inlines)
inlineLaTeX = try $ do
cmd <- inlineLaTeXCommand
+ ils <- (lift . lift) $ parseAsInlineLaTeX cmd
maybe mzero returnF $
- parseAsMath cmd `mplus` parseAsMathMLSym cmd `mplus` parseAsInlineLaTeX cmd
+ parseAsMath cmd `mplus` parseAsMathMLSym cmd `mplus` ils
where
parseAsMath :: String -> Maybe Inlines
parseAsMath cs = B.fromList <$> texMathToPandoc cs
- parseAsInlineLaTeX :: String -> Maybe Inlines
- parseAsInlineLaTeX cs = maybeRight $ runParser inlineCommand state "" cs
+ parseAsInlineLaTeX :: PandocMonad m => String -> m (Maybe Inlines)
+ parseAsInlineLaTeX cs = maybeRight <$> runParserT inlineCommand state "" cs
parseAsMathMLSym :: String -> Maybe Inlines
parseAsMathMLSym cs = B.str <$> MathMLEntityMap.getUnicode (clean cs)
@@ -803,10 +814,11 @@ inlineLaTeX = try $ do
maybeRight :: Either a b -> Maybe b
maybeRight = either (const Nothing) Just
-inlineLaTeXCommand :: OrgParser String
+inlineLaTeXCommand :: PandocMonad m => OrgParser m String
inlineLaTeXCommand = try $ do
rest <- getInput
- case runParser rawLaTeXInline def "source" rest of
+ parsed <- (lift . lift) $ runParserT rawLaTeXInline def "source" rest
+ case parsed of
Right (RawInline _ cs) -> do
-- drop any trailing whitespace, those are not be part of the command as
-- far as org mode is concerned.
@@ -820,14 +832,14 @@ inlineLaTeXCommand = try $ do
dropWhileEnd :: (a -> Bool) -> [a] -> [a]
dropWhileEnd p = foldr (\x xs -> if p x && null xs then [] else x : xs) []
-exportSnippet :: OrgParser (F Inlines)
+exportSnippet :: PandocMonad m => OrgParser m (F Inlines)
exportSnippet = try $ do
string "@@"
format <- many1Till (alphaNum <|> char '-') (char ':')
snippet <- manyTill anyChar (try $ string "@@")
returnF $ B.rawInline format snippet
-smart :: OrgParser (F Inlines)
+smart :: PandocMonad m => OrgParser m (F Inlines)
smart = do
getOption readerSmart >>= guard
doubleQuoted <|> singleQuoted <|>
@@ -844,7 +856,7 @@ smart = do
<* updateLastForbiddenCharPos
*> return (B.str "\x2019")
-singleQuoted :: OrgParser (F Inlines)
+singleQuoted :: PandocMonad m => OrgParser m (F Inlines)
singleQuoted = try $ do
guard =<< getExportSetting exportSmartQuotes
singleQuoteStart
@@ -856,7 +868,7 @@ singleQuoted = try $ do
-- doubleQuoted will handle regular double-quoted sections, as well
-- as dialogues with an open double-quote without a close double-quote
-- in the same paragraph.
-doubleQuoted :: OrgParser (F Inlines)
+doubleQuoted :: PandocMonad m => OrgParser m (F Inlines)
doubleQuoted = try $ do
guard =<< getExportSetting exportSmartQuotes
doubleQuoteStart
diff --git a/src/Text/Pandoc/Readers/Org/Meta.hs b/src/Text/Pandoc/Readers/Org/Meta.hs
index 1fea3e890..2f4e21248 100644
--- a/src/Text/Pandoc/Readers/Org/Meta.hs
+++ b/src/Text/Pandoc/Readers/Org/Meta.hs
@@ -41,6 +41,7 @@ import Text.Pandoc.Readers.Org.Parsing
import qualified Text.Pandoc.Builder as B
import Text.Pandoc.Builder ( Blocks, Inlines )
+import Text.Pandoc.Class ( PandocMonad )
import Text.Pandoc.Definition
import Control.Monad ( mzero, void )
@@ -51,7 +52,7 @@ import Data.Monoid ( (<>) )
import Network.HTTP ( urlEncode )
-- | Returns the current meta, respecting export options.
-metaExport :: OrgParser (F Meta)
+metaExport :: Monad m => OrgParser m (F Meta)
metaExport = do
st <- getState
let settings = orgStateExportSettings st
@@ -68,10 +69,10 @@ removeMeta key meta' =
-- | Parse and handle a single line containing meta information
-- The order, in which blocks are tried, makes sure that we're not looking at
-- the beginning of a block, so we don't need to check for it
-metaLine :: OrgParser Blocks
+metaLine :: PandocMonad m => OrgParser m Blocks
metaLine = mempty <$ metaLineStart <* (optionLine <|> declarationLine)
-declarationLine :: OrgParser ()
+declarationLine :: PandocMonad m => OrgParser m ()
declarationLine = try $ do
key <- map toLower <$> metaKey
(key', value) <- metaValue key
@@ -79,12 +80,12 @@ declarationLine = try $ do
let meta' = B.setMeta key' <$> value <*> pure nullMeta
in st { orgStateMeta = meta' <> orgStateMeta st }
-metaKey :: OrgParser String
+metaKey :: Monad m => OrgParser m String
metaKey = map toLower <$> many1 (noneOf ": \n\r")
<* char ':'
<* skipSpaces
-metaValue :: String -> OrgParser (String, (F MetaValue))
+metaValue :: PandocMonad m => String -> OrgParser m (String, (F MetaValue))
metaValue key =
let inclKey = "header-includes"
in case key of
@@ -103,10 +104,10 @@ metaValue key =
accumulatingList inclKey (metaExportSnippet "html")
_ -> (key,) <$> metaString
-metaInlines :: OrgParser (F MetaValue)
+metaInlines :: PandocMonad m => OrgParser m (F MetaValue)
metaInlines = fmap (MetaInlines . B.toList) <$> inlinesTillNewline
-metaInlinesCommaSeparated :: OrgParser (F MetaValue)
+metaInlinesCommaSeparated :: PandocMonad m => OrgParser m (F MetaValue)
metaInlinesCommaSeparated = do
authStrs <- (many1 (noneOf ",\n")) `sepBy1` (char ',')
newline
@@ -114,21 +115,21 @@ metaInlinesCommaSeparated = do
let toMetaInlines = MetaInlines . B.toList
return $ MetaList . map toMetaInlines <$> sequence authors
-metaString :: OrgParser (F MetaValue)
+metaString :: Monad m => OrgParser m (F MetaValue)
metaString = metaModifiedString id
-metaModifiedString :: (String -> String) -> OrgParser (F MetaValue)
+metaModifiedString :: Monad m => (String -> String) -> OrgParser m (F MetaValue)
metaModifiedString f = return . MetaString . f <$> anyLine
-- | Read an format specific meta definition
-metaExportSnippet :: String -> OrgParser (F MetaValue)
+metaExportSnippet :: Monad m => String -> OrgParser m (F MetaValue)
metaExportSnippet format =
return . MetaInlines . B.toList . B.rawInline format <$> anyLine
-- | Accumulate the result of the @parser@ in a list under @key@.
-accumulatingList :: String
- -> OrgParser (F MetaValue)
- -> OrgParser (F MetaValue)
+accumulatingList :: Monad m => String
+ -> OrgParser m (F MetaValue)
+ -> OrgParser m (F MetaValue)
accumulatingList key p = do
value <- p
meta' <- orgStateMeta <$> getState
@@ -141,7 +142,7 @@ accumulatingList key p = do
--
-- export options
--
-optionLine :: OrgParser ()
+optionLine :: Monad m => OrgParser m ()
optionLine = try $ do
key <- metaKey
case key of
@@ -152,14 +153,14 @@ optionLine = try $ do
"typ_todo" -> todoSequence >>= updateState . registerTodoSequence
_ -> mzero
-addLinkFormat :: String
+addLinkFormat :: Monad m => String
-> (String -> String)
- -> OrgParser ()
+ -> OrgParser m ()
addLinkFormat key formatter = updateState $ \s ->
let fs = orgStateLinkFormatters s
in s{ orgStateLinkFormatters = M.insert key formatter fs }
-parseLinkFormat :: OrgParser ((String, String -> String))
+parseLinkFormat :: Monad m => OrgParser m ((String, String -> String))
parseLinkFormat = try $ do
linkType <- (:) <$> letter <*> many (alphaNum <|> oneOf "-_") <* skipSpaces
linkSubst <- parseFormat
@@ -167,7 +168,7 @@ parseLinkFormat = try $ do
-- | An ad-hoc, single-argument-only implementation of a printf-style format
-- parser.
-parseFormat :: OrgParser (String -> String)
+parseFormat :: Monad m => OrgParser m (String -> String)
parseFormat = try $ do
replacePlain <|> replaceUrl <|> justAppend
where
@@ -181,13 +182,13 @@ parseFormat = try $ do
rest = manyTill anyChar (eof <|> () <$ oneOf "\n\r")
tillSpecifier c = manyTill (noneOf "\n\r") (try $ string ('%':c:""))
-inlinesTillNewline :: OrgParser (F Inlines)
+inlinesTillNewline :: PandocMonad m => OrgParser m (F Inlines)
inlinesTillNewline = trimInlinesF . mconcat <$> manyTill inline newline
--
-- ToDo Sequences and Keywords
--
-todoSequence :: OrgParser TodoSequence
+todoSequence :: Monad m => OrgParser m TodoSequence
todoSequence = try $ do
todoKws <- todoKeywords
doneKws <- optionMaybe $ todoDoneSep *> todoKeywords
@@ -201,13 +202,13 @@ todoSequence = try $ do
(x:xs) -> return $ keywordsToSequence (reverse xs) [x]
where
- todoKeywords :: OrgParser [String]
+ todoKeywords :: Monad m => OrgParser m [String]
todoKeywords = try $
let keyword = many1 nonspaceChar <* skipSpaces
endOfKeywords = todoDoneSep <|> void newline
in manyTill keyword (lookAhead endOfKeywords)
- todoDoneSep :: OrgParser ()
+ todoDoneSep :: Monad m => OrgParser m ()
todoDoneSep = void . try $ skipSpaces *> char '|' <* skipSpaces1
keywordsToSequence :: [String] -> [String] -> TodoSequence
diff --git a/src/Text/Pandoc/Readers/Org/ParserState.hs b/src/Text/Pandoc/Readers/Org/ParserState.hs
index 38f95ca95..181dd1d5c 100644
--- a/src/Text/Pandoc/Readers/Org/ParserState.hs
+++ b/src/Text/Pandoc/Readers/Org/ParserState.hs
@@ -51,7 +51,7 @@ module Text.Pandoc.Readers.Org.ParserState
) where
import Control.Monad (liftM, liftM2)
-import Control.Monad.Reader (Reader, runReader, ask, asks, local)
+import Control.Monad.Reader (Reader, runReader, ReaderT, ask, asks, local)
import Data.Default (Default(..))
import qualified Data.Map as M
@@ -122,7 +122,7 @@ instance HasLastStrPosition OrgParserState where
getLastStrPos = orgStateLastStrPos
setLastStrPos pos st = st{ orgStateLastStrPos = Just pos }
-instance HasQuoteContext st (Reader OrgParserLocal) where
+instance Monad m => HasQuoteContext st (ReaderT OrgParserLocal m) where
getQuoteContext = asks orgLocalQuoteContext
withQuoteContext q = local (\s -> s{orgLocalQuoteContext = q})
diff --git a/src/Text/Pandoc/Readers/Org/Parsing.hs b/src/Text/Pandoc/Readers/Org/Parsing.hs
index 95415f823..1eb8a3b00 100644
--- a/src/Text/Pandoc/Readers/Org/Parsing.hs
+++ b/src/Text/Pandoc/Readers/Org/Parsing.hs
@@ -72,6 +72,7 @@ module Text.Pandoc.Readers.Org.Parsing
, citeKey
-- * Re-exports from Text.Pandoc.Parsec
, runParser
+ , runParserT
, getInput
, char
, letter
@@ -114,17 +115,17 @@ import Text.Pandoc.Parsing hiding ( anyLine, blanklines, newline
, parseFromString )
import Control.Monad ( guard )
-import Control.Monad.Reader ( Reader )
+import Control.Monad.Reader ( ReaderT )
-- | The parser used to read org files.
-type OrgParser = ParserT [Char] OrgParserState (Reader OrgParserLocal)
+type OrgParser m = ParserT [Char] OrgParserState (ReaderT OrgParserLocal m)
--
-- Adaptions and specializations of parsing utilities
--
-- | Parse any line of text
-anyLine :: OrgParser String
+anyLine :: Monad m => OrgParser m String
anyLine =
P.anyLine
<* updateLastPreCharPos
@@ -132,7 +133,7 @@ anyLine =
-- The version Text.Pandoc.Parsing cannot be used, as we need additional parts
-- of the state saved and restored.
-parseFromString :: OrgParser a -> String -> OrgParser a
+parseFromString :: Monad m => OrgParser m a -> String -> OrgParser m a
parseFromString parser str' = do
oldLastPreCharPos <- orgStateLastPreCharPos <$> getState
updateState $ \s -> s{ orgStateLastPreCharPos = Nothing }
@@ -141,33 +142,34 @@ parseFromString parser str' = do
return result
-- | Skip one or more tab or space characters.
-skipSpaces1 :: OrgParser ()
+skipSpaces1 :: Monad m => OrgParser m ()
skipSpaces1 = skipMany1 spaceChar
-- | Like @Text.Parsec.Char.newline@, but causes additional state changes.
-newline :: OrgParser Char
+newline :: Monad m => OrgParser m Char
newline =
P.newline
<* updateLastPreCharPos
<* updateLastForbiddenCharPos
-- | Like @Text.Parsec.Char.blanklines@, but causes additional state changes.
-blanklines :: OrgParser [Char]
+blanklines :: Monad m => OrgParser m [Char]
blanklines =
P.blanklines
<* updateLastPreCharPos
<* updateLastForbiddenCharPos
-- | Succeeds when we're in list context.
-inList :: OrgParser ()
+inList :: Monad m => OrgParser m ()
inList = do
ctx <- orgStateParserContext <$> getState
guard (ctx == ListItemState)
-- | Parse in different context
-withContext :: ParserContext -- ^ New parser context
- -> OrgParser a -- ^ Parser to run in that context
- -> OrgParser a
+withContext :: Monad m
+ => ParserContext -- ^ New parser context
+ -> OrgParser m a -- ^ Parser to run in that context
+ -> OrgParser m a
withContext context parser = do
oldContext <- orgStateParserContext <$> getState
updateState $ \s -> s{ orgStateParserContext = context }
@@ -180,19 +182,19 @@ withContext context parser = do
--
-- | Get an export setting.
-getExportSetting :: (ExportSettings -> a) -> OrgParser a
+getExportSetting :: Monad m => (ExportSettings -> a) -> OrgParser m a
getExportSetting s = s . orgStateExportSettings <$> getState
-- | Set the current position as the last position at which a forbidden char
-- was found (i.e. a character which is not allowed at the inner border of
-- markup).
-updateLastForbiddenCharPos :: OrgParser ()
+updateLastForbiddenCharPos :: Monad m => OrgParser m ()
updateLastForbiddenCharPos = getPosition >>= \p ->
updateState $ \s -> s{ orgStateLastForbiddenCharPos = Just p}
-- | Set the current parser position as the position at which a character was
-- seen which allows inline markup to follow.
-updateLastPreCharPos :: OrgParser ()
+updateLastPreCharPos :: Monad m => OrgParser m ()
updateLastPreCharPos = getPosition >>= \p ->
updateState $ \s -> s{ orgStateLastPreCharPos = Just p}
@@ -201,15 +203,15 @@ updateLastPreCharPos = getPosition >>= \p ->
--
-- | Read the key of a plist style key-value list.
-orgArgKey :: OrgParser String
+orgArgKey :: Monad m => OrgParser m String
orgArgKey = try $
skipSpaces *> char ':'
*> many1 orgArgWordChar
-- | Read the value of a plist style key-value list.
-orgArgWord :: OrgParser String
+orgArgWord :: Monad m => OrgParser m String
orgArgWord = many1 orgArgWordChar
-- | Chars treated as part of a word in plists.
-orgArgWordChar :: OrgParser Char
+orgArgWordChar :: Monad m => OrgParser m Char
orgArgWordChar = alphaNum <|> oneOf "-_"
diff --git a/src/Text/Pandoc/Readers/RST.hs b/src/Text/Pandoc/Readers/RST.hs
index e05b6cba2..4232f1c90 100644
--- a/src/Text/Pandoc/Readers/RST.hs
+++ b/src/Text/Pandoc/Readers/RST.hs
@@ -49,18 +49,29 @@ import qualified Text.Pandoc.Builder as B
import Data.Sequence (viewr, ViewR(..))
import Data.Char (toLower, isHexDigit, isSpace)
import Data.Monoid ((<>))
-import Text.Pandoc.Error
+import Control.Monad.Except (throwError)
+import Control.Monad.Trans (lift)
+import Text.Pandoc.Class (PandocMonad, PandocExecutionError(..))
+import qualified Text.Pandoc.Class as P
-- | Parse reStructuredText string and return Pandoc document.
-readRST :: ReaderOptions -- ^ Reader options
+readRST :: PandocMonad m
+ => ReaderOptions -- ^ Reader options
-> String -- ^ String to parse (assuming @'\n'@ line endings)
- -> Either PandocError Pandoc
-readRST opts s = (readWith parseRST) def{ stateOptions = opts } (s ++ "\n\n")
+ -> m Pandoc
+readRST opts s = do
+ parsed <- (readWithM parseRST) def{ stateOptions = opts } (s ++ "\n\n")
+ case parsed of
+ Right result -> return result
+ Left _ -> throwError $ PandocParseError "error parsing rst"
-readRSTWithWarnings :: ReaderOptions -> String -> Either PandocError (Pandoc, [String])
-readRSTWithWarnings opts s = (readWithWarnings parseRST) def{ stateOptions = opts } (s ++ "\n\n")
+readRSTWithWarnings :: PandocMonad m
+ => ReaderOptions -- ^ Reader options
+ -> String -- ^ String to parse (assuming @'\n'@ line endings)
+ -> m Pandoc
+readRSTWithWarnings = readRST
-type RSTParser = Parser [Char] ParserState
+type RSTParser m = ParserT [Char] ParserState m
--
-- Constants and data structure definitions
@@ -141,7 +152,7 @@ metaFromDefList ds meta = adjustAuthors $ foldr f meta ds
factorSemi (Str ys)
factorSemi x = [x]
-parseRST :: RSTParser Pandoc
+parseRST :: PandocMonad m => RSTParser m Pandoc
parseRST = do
optional blanklines -- skip blank lines at beginning of file
startPos <- getPosition
@@ -168,10 +179,10 @@ parseRST = do
-- parsing blocks
--
-parseBlocks :: RSTParser Blocks
+parseBlocks :: PandocMonad m => RSTParser m Blocks
parseBlocks = mconcat <$> manyTill block eof
-block :: RSTParser Blocks
+block :: PandocMonad m => RSTParser m Blocks
block = choice [ codeBlock
, blockQuote
, fieldList
@@ -191,7 +202,7 @@ block = choice [ codeBlock
-- field list
--
-rawFieldListItem :: Int -> RSTParser (String, String)
+rawFieldListItem :: Monad m => Int -> RSTParser m (String, String)
rawFieldListItem minIndent = try $ do
indent <- length <$> many (char ' ')
guard $ indent >= minIndent
@@ -204,7 +215,7 @@ rawFieldListItem minIndent = try $ do
let raw = (if null first then "" else (first ++ "\n")) ++ rest ++ "\n"
return (name, raw)
-fieldListItem :: Int -> RSTParser (Inlines, [Blocks])
+fieldListItem :: PandocMonad m => Int -> RSTParser m (Inlines, [Blocks])
fieldListItem minIndent = try $ do
(name, raw) <- rawFieldListItem minIndent
term <- parseInlineFromString name
@@ -212,7 +223,7 @@ fieldListItem minIndent = try $ do
optional blanklines
return (term, [contents])
-fieldList :: RSTParser Blocks
+fieldList :: PandocMonad m => RSTParser m Blocks
fieldList = try $ do
indent <- length <$> lookAhead (many spaceChar)
items <- many1 $ fieldListItem indent
@@ -224,7 +235,7 @@ fieldList = try $ do
-- line block
--
-lineBlock :: RSTParser Blocks
+lineBlock :: PandocMonad m => RSTParser m Blocks
lineBlock = try $ do
lines' <- lineBlockLines
lines'' <- mapM parseInlineFromString lines'
@@ -235,7 +246,7 @@ lineBlock = try $ do
--
-- note: paragraph can end in a :: starting a code block
-para :: RSTParser Blocks
+para :: PandocMonad m => RSTParser m Blocks
para = try $ do
result <- trimInlines . mconcat <$> many1 inline
option (B.plain result) $ try $ do
@@ -248,18 +259,18 @@ para = try $ do
<> raw
_ -> return (B.para result)
-plain :: RSTParser Blocks
+plain :: PandocMonad m => RSTParser m Blocks
plain = B.plain . trimInlines . mconcat <$> many1 inline
--
-- header blocks
--
-header :: RSTParser Blocks
+header :: PandocMonad m => RSTParser m Blocks
header = doubleHeader <|> singleHeader <?> "header"
-- a header with lines on top and bottom
-doubleHeader :: RSTParser Blocks
+doubleHeader :: PandocMonad m => RSTParser m Blocks
doubleHeader = try $ do
c <- oneOf underlineChars
rest <- many (char c) -- the top line
@@ -285,7 +296,7 @@ doubleHeader = try $ do
return $ B.headerWith attr level txt
-- a header with line on the bottom only
-singleHeader :: RSTParser Blocks
+singleHeader :: PandocMonad m => RSTParser m Blocks
singleHeader = try $ do
notFollowedBy' whitespace
txt <- trimInlines . mconcat <$> many1 (do {notFollowedBy blankline; inline})
@@ -309,7 +320,7 @@ singleHeader = try $ do
-- hrule block
--
-hrule :: Parser [Char] st Blocks
+hrule :: Monad m => ParserT [Char] st m Blocks
hrule = try $ do
chr <- oneOf underlineChars
count 3 (char chr)
@@ -323,14 +334,14 @@ hrule = try $ do
--
-- read a line indented by a given string
-indentedLine :: String -> Parser [Char] st [Char]
+indentedLine :: Monad m => String -> ParserT [Char] st m [Char]
indentedLine indents = try $ do
string indents
anyLine
-- one or more indented lines, possibly separated by blank lines.
-- any amount of indentation will work.
-indentedBlock :: Parser [Char] st [Char]
+indentedBlock :: Monad m => ParserT [Char] st m [Char]
indentedBlock = try $ do
indents <- lookAhead $ many1 spaceChar
lns <- many1 $ try $ do b <- option "" blanklines
@@ -339,24 +350,24 @@ indentedBlock = try $ do
optional blanklines
return $ unlines lns
-quotedBlock :: Parser [Char] st [Char]
+quotedBlock :: Monad m => ParserT [Char] st m [Char]
quotedBlock = try $ do
quote <- lookAhead $ oneOf "!\"#$%&'()*+,-./:;<=>?@[\\]^_`{|}~"
lns <- many1 $ lookAhead (char quote) >> anyLine
optional blanklines
return $ unlines lns
-codeBlockStart :: Parser [Char] st Char
+codeBlockStart :: Monad m => ParserT [Char] st m Char
codeBlockStart = string "::" >> blankline >> blankline
-codeBlock :: Parser [Char] st Blocks
+codeBlock :: Monad m => ParserT [Char] st m Blocks
codeBlock = try $ codeBlockStart >> codeBlockBody
-codeBlockBody :: Parser [Char] st Blocks
+codeBlockBody :: Monad m => ParserT [Char] st m Blocks
codeBlockBody = try $ B.codeBlock . stripTrailingNewlines <$>
(indentedBlock <|> quotedBlock)
-lhsCodeBlock :: RSTParser Blocks
+lhsCodeBlock :: Monad m => RSTParser m Blocks
lhsCodeBlock = try $ do
getPosition >>= guard . (==1) . sourceColumn
guardEnabled Ext_literate_haskell
@@ -366,14 +377,14 @@ lhsCodeBlock = try $ do
return $ B.codeBlockWith ("", ["sourceCode", "literate", "haskell"], [])
$ intercalate "\n" lns
-latexCodeBlock :: Parser [Char] st [[Char]]
+latexCodeBlock :: Monad m => ParserT [Char] st m [[Char]]
latexCodeBlock = try $ do
try (latexBlockLine "\\begin{code}")
many1Till anyLine (try $ latexBlockLine "\\end{code}")
where
latexBlockLine s = skipMany spaceChar >> string s >> blankline
-birdCodeBlock :: Parser [Char] st [[Char]]
+birdCodeBlock :: Monad m => ParserT [Char] st m [[Char]]
birdCodeBlock = filterSpace <$> many1 birdTrackLine
where filterSpace lns =
-- if (as is normal) there is always a space after >, drop it
@@ -381,14 +392,14 @@ birdCodeBlock = filterSpace <$> many1 birdTrackLine
then map (drop 1) lns
else lns
-birdTrackLine :: Parser [Char] st [Char]
+birdTrackLine :: Monad m => ParserT [Char] st m [Char]
birdTrackLine = char '>' >> anyLine
--
-- block quotes
--
-blockQuote :: RSTParser Blocks
+blockQuote :: PandocMonad m => RSTParser m Blocks
blockQuote = do
raw <- indentedBlock
-- parse the extracted block, which may contain various block elements:
@@ -399,10 +410,10 @@ blockQuote = do
-- list blocks
--
-list :: RSTParser Blocks
+list :: PandocMonad m => RSTParser m Blocks
list = choice [ bulletList, orderedList, definitionList ] <?> "list"
-definitionListItem :: RSTParser (Inlines, [Blocks])
+definitionListItem :: PandocMonad m => RSTParser m (Inlines, [Blocks])
definitionListItem = try $ do
-- avoid capturing a directive or comment
notFollowedBy (try $ char '.' >> char '.')
@@ -412,11 +423,11 @@ definitionListItem = try $ do
contents <- parseFromString parseBlocks $ raw ++ "\n"
return (term, [contents])
-definitionList :: RSTParser Blocks
+definitionList :: PandocMonad m => RSTParser m Blocks
definitionList = B.definitionList <$> many1 definitionListItem
-- parses bullet list start and returns its length (inc. following whitespace)
-bulletListStart :: Parser [Char] st Int
+bulletListStart :: Monad m => ParserT [Char] st m Int
bulletListStart = try $ do
notFollowedBy' hrule -- because hrules start out just like lists
marker <- oneOf bulletListMarkers
@@ -424,16 +435,16 @@ bulletListStart = try $ do
return $ length (marker:white)
-- parses ordered list start and returns its length (inc following whitespace)
-orderedListStart :: ListNumberStyle
+orderedListStart :: Monad m => ListNumberStyle
-> ListNumberDelim
- -> RSTParser Int
+ -> RSTParser m Int
orderedListStart style delim = try $ do
(_, markerLen) <- withHorizDisplacement (orderedListMarker style delim)
white <- many1 spaceChar
return $ markerLen + length white
-- parse a line of a list item
-listLine :: Int -> RSTParser [Char]
+listLine :: Monad m => Int -> RSTParser m [Char]
listLine markerLength = try $ do
notFollowedBy blankline
indentWith markerLength
@@ -441,7 +452,7 @@ listLine markerLength = try $ do
return $ line ++ "\n"
-- indent by specified number of spaces (or equiv. tabs)
-indentWith :: Int -> RSTParser [Char]
+indentWith :: Monad m => Int -> RSTParser m [Char]
indentWith num = do
tabStop <- getOption readerTabStop
if (num < tabStop)
@@ -450,8 +461,8 @@ indentWith num = do
(try (char '\t' >> count (num - tabStop) (char ' '))) ]
-- parse raw text for one list item, excluding start marker and continuations
-rawListItem :: RSTParser Int
- -> RSTParser (Int, [Char])
+rawListItem :: Monad m => RSTParser m Int
+ -> RSTParser m (Int, [Char])
rawListItem start = try $ do
markerLength <- start
firstLine <- anyLine
@@ -461,14 +472,15 @@ rawListItem start = try $ do
-- continuation of a list item - indented and separated by blankline or
-- (in compact lists) endline.
-- Note: nested lists are parsed as continuations.
-listContinuation :: Int -> RSTParser [Char]
+listContinuation :: Monad m => Int -> RSTParser m [Char]
listContinuation markerLength = try $ do
blanks <- many1 blankline
result <- many1 (listLine markerLength)
return $ blanks ++ concat result
-listItem :: RSTParser Int
- -> RSTParser Blocks
+listItem :: PandocMonad m
+ => RSTParser m Int
+ -> RSTParser m Blocks
listItem start = try $ do
(markerLength, first) <- rawListItem start
rest <- many (listContinuation markerLength)
@@ -490,21 +502,21 @@ listItem start = try $ do
[Para xs, DefinitionList ys] -> B.fromList [Plain xs, DefinitionList ys]
_ -> parsed
-orderedList :: RSTParser Blocks
+orderedList :: PandocMonad m => RSTParser m Blocks
orderedList = try $ do
(start, style, delim) <- lookAhead (anyOrderedListMarker <* spaceChar)
items <- many1 (listItem (orderedListStart style delim))
let items' = compactify' items
return $ B.orderedListWith (start, style, delim) items'
-bulletList :: RSTParser Blocks
+bulletList :: PandocMonad m => RSTParser m Blocks
bulletList = B.bulletList . compactify' <$> many1 (listItem bulletListStart)
--
-- directive (e.g. comment, container, compound-paragraph)
--
-comment :: RSTParser Blocks
+comment :: Monad m => RSTParser m Blocks
comment = try $ do
string ".."
skipMany1 spaceChar <|> (() <$ lookAhead newline)
@@ -513,11 +525,11 @@ comment = try $ do
optional indentedBlock
return mempty
-directiveLabel :: RSTParser String
+directiveLabel :: Monad m => RSTParser m String
directiveLabel = map toLower
<$> many1Till (letter <|> char '-') (try $ string "::")
-directive :: RSTParser Blocks
+directive :: PandocMonad m => RSTParser m Blocks
directive = try $ do
string ".."
directive'
@@ -526,7 +538,7 @@ directive = try $ do
-- date
-- include
-- title
-directive' :: RSTParser Blocks
+directive' :: PandocMonad m => RSTParser m Blocks
directive' = do
skipMany1 spaceChar
label <- directiveLabel
@@ -614,13 +626,13 @@ directive' = do
return $ B.divWith attrs children
other -> do
pos <- getPosition
- addWarning (Just pos) $ "ignoring unknown directive: " ++ other
+ P.addWarningWithPos (Just pos) $ "ignoring unknown directive: " ++ other
return mempty
-- TODO:
-- - Only supports :format: fields with a single format for :raw: roles,
-- change Text.Pandoc.Definition.Format to fix
-addNewRole :: String -> [(String, String)] -> RSTParser Blocks
+addNewRole :: PandocMonad m => String -> [(String, String)] -> RSTParser m Blocks
addNewRole roleString fields = do
(role, parentRole) <- parseFromString inheritedRole roleString
customRoles <- stateRstCustomRoles <$> getState
@@ -642,20 +654,20 @@ addNewRole roleString fields = do
-- warn about syntax we ignore
flip mapM_ fields $ \(key, _) -> case key of
- "language" -> when (baseRole /= "code") $ addWarning Nothing $
+ "language" -> when (baseRole /= "code") $ lift $ P.warn $
"ignoring :language: field because the parent of role :" ++
role ++ ": is :" ++ baseRole ++ ": not :code:"
- "format" -> when (baseRole /= "raw") $ addWarning Nothing $
+ "format" -> when (baseRole /= "raw") $ lift $ P.warn $
"ignoring :format: field because the parent of role :" ++
role ++ ": is :" ++ baseRole ++ ": not :raw:"
- _ -> addWarning Nothing $ "ignoring unknown field :" ++ key ++
+ _ -> lift $ P.warn $ "ignoring unknown field :" ++ key ++
": in definition of role :" ++ role ++ ": in"
when (parentRole == "raw" && countKeys "format" > 1) $
- addWarning Nothing $
+ lift $ P.warn $
"ignoring :format: fields after the first in the definition of role :"
++ role ++": in"
when (parentRole == "code" && countKeys "language" > 1) $
- addWarning Nothing $
+ lift $ P.warn $
"ignoring :language: fields after the first in the definition of role :"
++ role ++": in"
@@ -700,7 +712,7 @@ extractUnicodeChar s = maybe Nothing (\c -> Just (c,rest)) mbc
where (ds,rest) = span isHexDigit s
mbc = safeRead ('\'':'\\':'x':ds ++ "'")
-extractCaption :: RSTParser (Inlines, Blocks)
+extractCaption :: PandocMonad m => RSTParser m (Inlines, Blocks)
extractCaption = do
capt <- trimInlines . mconcat <$> many inline
legend <- optional blanklines >> (mconcat <$> many block)
@@ -712,7 +724,7 @@ toChunks = dropWhile null
. map (trim . unlines)
. splitBy (all (`elem` (" \t" :: String))) . lines
-codeblock :: [String] -> Maybe String -> String -> String -> RSTParser Blocks
+codeblock :: [String] -> Maybe String -> String -> String -> RSTParser m Blocks
codeblock classes numberLines lang body =
return $ B.codeBlockWith attribs $ stripTrailingNewlines body
where attribs = ("", classes', kvs)
@@ -728,7 +740,7 @@ codeblock classes numberLines lang body =
--- note block
---
-noteBlock :: RSTParser [Char]
+noteBlock :: Monad m => RSTParser m [Char]
noteBlock = try $ do
startPos <- getPosition
string ".."
@@ -747,7 +759,7 @@ noteBlock = try $ do
-- return blanks so line count isn't affected
return $ replicate (sourceLine endPos - sourceLine startPos) '\n'
-noteMarker :: RSTParser [Char]
+noteMarker :: Monad m => RSTParser m [Char]
noteMarker = do
char '['
res <- many1 digit
@@ -760,13 +772,13 @@ noteMarker = do
-- reference key
--
-quotedReferenceName :: RSTParser Inlines
+quotedReferenceName :: PandocMonad m => RSTParser m Inlines
quotedReferenceName = try $ do
char '`' >> notFollowedBy (char '`') -- `` means inline code!
label' <- trimInlines . mconcat <$> many1Till inline (char '`')
return label'
-unquotedReferenceName :: RSTParser Inlines
+unquotedReferenceName :: PandocMonad m => RSTParser m Inlines
unquotedReferenceName = try $ do
label' <- trimInlines . mconcat <$> many1Till inline (lookAhead $ char ':')
return label'
@@ -775,24 +787,24 @@ unquotedReferenceName = try $ do
-- plus isolated (no two adjacent) internal hyphens, underscores,
-- periods, colons and plus signs; no whitespace or other characters
-- are allowed.
-simpleReferenceName' :: Parser [Char] st String
+simpleReferenceName' :: Monad m => ParserT [Char] st m String
simpleReferenceName' = do
x <- alphaNum
xs <- many $ alphaNum
<|> (try $ oneOf "-_:+." <* lookAhead alphaNum)
return (x:xs)
-simpleReferenceName :: Parser [Char] st Inlines
+simpleReferenceName :: Monad m => ParserT [Char] st m Inlines
simpleReferenceName = do
raw <- simpleReferenceName'
return $ B.str raw
-referenceName :: RSTParser Inlines
+referenceName :: PandocMonad m => RSTParser m Inlines
referenceName = quotedReferenceName <|>
(try $ simpleReferenceName <* lookAhead (char ':')) <|>
unquotedReferenceName
-referenceKey :: RSTParser [Char]
+referenceKey :: PandocMonad m => RSTParser m [Char]
referenceKey = do
startPos <- getPosition
choice [substKey, anonymousKey, regularKey]
@@ -801,7 +813,7 @@ referenceKey = do
-- return enough blanks to replace key
return $ replicate (sourceLine endPos - sourceLine startPos) '\n'
-targetURI :: Parser [Char] st [Char]
+targetURI :: Monad m => ParserT [Char] st m [Char]
targetURI = do
skipSpaces
optional newline
@@ -810,7 +822,7 @@ targetURI = do
blanklines
return $ escapeURI $ trim $ contents
-substKey :: RSTParser ()
+substKey :: PandocMonad m => RSTParser m ()
substKey = try $ do
string ".."
skipMany1 spaceChar
@@ -828,7 +840,7 @@ substKey = try $ do
let key = toKey $ stripFirstAndLast ref
updateState $ \s -> s{ stateSubstitutions = M.insert key il $ stateSubstitutions s }
-anonymousKey :: RSTParser ()
+anonymousKey :: Monad m => RSTParser m ()
anonymousKey = try $ do
oneOfStrings [".. __:", "__"]
src <- targetURI
@@ -842,7 +854,7 @@ stripTicks = reverse . stripTick . reverse . stripTick
where stripTick ('`':xs) = xs
stripTick xs = xs
-regularKey :: RSTParser ()
+regularKey :: PandocMonad m => RSTParser m ()
regularKey = try $ do
string ".. _"
(_,ref) <- withRaw referenceName
@@ -869,31 +881,31 @@ regularKey = try $ do
-- Grid tables TODO:
-- - column spans
-dashedLine :: Char -> Parser [Char] st (Int, Int)
+dashedLine :: Monad m => Char -> ParserT [Char] st m (Int, Int)
dashedLine ch = do
dashes <- many1 (char ch)
sp <- many (char ' ')
return (length dashes, length $ dashes ++ sp)
-simpleDashedLines :: Char -> Parser [Char] st [(Int,Int)]
+simpleDashedLines :: Monad m => Char -> ParserT [Char] st m [(Int,Int)]
simpleDashedLines ch = try $ many1 (dashedLine ch)
-- Parse a table row separator
-simpleTableSep :: Char -> RSTParser Char
+simpleTableSep :: Monad m => Char -> RSTParser m Char
simpleTableSep ch = try $ simpleDashedLines ch >> newline
-- Parse a table footer
-simpleTableFooter :: RSTParser [Char]
+simpleTableFooter :: Monad m => RSTParser m [Char]
simpleTableFooter = try $ simpleTableSep '=' >> blanklines
-- Parse a raw line and split it into chunks by indices.
-simpleTableRawLine :: [Int] -> RSTParser [String]
+simpleTableRawLine :: Monad m => [Int] -> RSTParser m [String]
simpleTableRawLine indices = do
line <- many1Till anyChar newline
return (simpleTableSplitLine indices line)
-- Parse a table row and return a list of blocks (columns).
-simpleTableRow :: [Int] -> RSTParser [[Block]]
+simpleTableRow :: PandocMonad m => [Int] -> RSTParser m [[Block]]
simpleTableRow indices = do
notFollowedBy' simpleTableFooter
firstLine <- simpleTableRawLine indices
@@ -906,8 +918,9 @@ simpleTableSplitLine indices line =
map trim
$ tail $ splitByIndices (init indices) line
-simpleTableHeader :: Bool -- ^ Headerless table
- -> RSTParser ([[Block]], [Alignment], [Int])
+simpleTableHeader :: PandocMonad m
+ => Bool -- ^ Headerless table
+ -> RSTParser m ([[Block]], [Alignment], [Int])
simpleTableHeader headless = try $ do
optional blanklines
rawContent <- if headless
@@ -926,8 +939,9 @@ simpleTableHeader headless = try $ do
return (heads, aligns, indices)
-- Parse a simple table.
-simpleTable :: Bool -- ^ Headerless table
- -> RSTParser Blocks
+simpleTable :: PandocMonad m
+ => Bool -- ^ Headerless table
+ -> RSTParser m Blocks
simpleTable headless = do
Table c a _w h l <- tableWith (simpleTableHeader headless) simpleTableRow sep simpleTableFooter
-- Simple tables get 0s for relative column widths (i.e., use default)
@@ -935,12 +949,13 @@ simpleTable headless = do
where
sep = return () -- optional (simpleTableSep '-')
-gridTable :: Bool -- ^ Headerless table
- -> RSTParser Blocks
+gridTable :: PandocMonad m
+ => Bool -- ^ Headerless table
+ -> RSTParser m Blocks
gridTable headerless = B.singleton
<$> gridTableWith (B.toList <$> parseBlocks) headerless
-table :: RSTParser Blocks
+table :: PandocMonad m => RSTParser m Blocks
table = gridTable False <|> simpleTable False <|>
gridTable True <|> simpleTable True <?> "table"
@@ -948,7 +963,7 @@ table = gridTable False <|> simpleTable False <|>
-- inline
--
-inline :: RSTParser Inlines
+inline :: PandocMonad m => RSTParser m Inlines
inline = choice [ note -- can start with whitespace, so try before ws
, whitespace
, link
@@ -964,29 +979,29 @@ inline = choice [ note -- can start with whitespace, so try before ws
, escapedChar
, symbol ] <?> "inline"
-parseInlineFromString :: String -> RSTParser Inlines
+parseInlineFromString :: PandocMonad m => String -> RSTParser m Inlines
parseInlineFromString = parseFromString (trimInlines . mconcat <$> many inline)
-hyphens :: RSTParser Inlines
+hyphens :: Monad m => RSTParser m Inlines
hyphens = do
result <- many1 (char '-')
optional endline
-- don't want to treat endline after hyphen or dash as a space
return $ B.str result
-escapedChar :: Parser [Char] st Inlines
+escapedChar :: Monad m => ParserT [Char] st m Inlines
escapedChar = do c <- escaped anyChar
return $ if c == ' ' -- '\ ' is null in RST
then mempty
else B.str [c]
-symbol :: RSTParser Inlines
+symbol :: Monad m => RSTParser m Inlines
symbol = do
result <- oneOf specialChars
return $ B.str [result]
-- parses inline code, between codeStart and codeEnd
-code :: RSTParser Inlines
+code :: Monad m => RSTParser m Inlines
code = try $ do
string "``"
result <- manyTill anyChar (try (string "``"))
@@ -994,7 +1009,7 @@ code = try $ do
$ trim $ unwords $ lines result
-- succeeds only if we're not right after a str (ie. in middle of word)
-atStart :: RSTParser a -> RSTParser a
+atStart :: Monad m => RSTParser m a -> RSTParser m a
atStart p = do
pos <- getPosition
st <- getState
@@ -1002,11 +1017,11 @@ atStart p = do
guard $ stateLastStrPos st /= Just pos
p
-emph :: RSTParser Inlines
+emph :: PandocMonad m => RSTParser m Inlines
emph = B.emph . trimInlines . mconcat <$>
enclosed (atStart $ char '*') (char '*') inline
-strong :: RSTParser Inlines
+strong :: PandocMonad m => RSTParser m Inlines
strong = B.strong . trimInlines . mconcat <$>
enclosed (atStart $ string "**") (try $ string "**") inline
@@ -1018,12 +1033,12 @@ strong = B.strong . trimInlines . mconcat <$>
-- - Classes are silently discarded in addNewRole
-- - Lacks sensible implementation for title-reference (which is the default)
-- - Allows direct use of the :raw: role, rST only allows inherited use.
-interpretedRole :: RSTParser Inlines
+interpretedRole :: PandocMonad m => RSTParser m Inlines
interpretedRole = try $ do
(role, contents) <- roleBefore <|> roleAfter
renderRole contents Nothing role nullAttr
-renderRole :: String -> Maybe String -> String -> Attr -> RSTParser Inlines
+renderRole :: PandocMonad m => String -> Maybe String -> String -> Attr -> RSTParser m Inlines
renderRole contents fmt role attr = case role of
"sup" -> return $ B.superscript $ B.str contents
"superscript" -> return $ B.superscript $ B.str contents
@@ -1050,7 +1065,7 @@ renderRole contents fmt role attr = case role of
renderRole contents newFmt newRole newAttr
Nothing -> do
pos <- getPosition
- addWarning (Just pos) $ "ignoring unknown role :" ++ custom ++ ": in"
+ P.addWarningWithPos (Just pos) $ "ignoring unknown role :" ++ custom ++ ": in"
return $ B.str contents -- Undefined role
where
titleRef ref = return $ B.str ref -- FIXME: Not a sensible behaviour
@@ -1063,31 +1078,31 @@ renderRole contents fmt role attr = case role of
addClass :: String -> Attr -> Attr
addClass c (ident, classes, keyValues) = (ident, union classes [c], keyValues)
-roleName :: RSTParser String
+roleName :: PandocMonad m => RSTParser m String
roleName = many1 (letter <|> char '-')
-roleMarker :: RSTParser String
+roleMarker :: PandocMonad m => RSTParser m String
roleMarker = char ':' *> roleName <* char ':'
-roleBefore :: RSTParser (String,String)
+roleBefore :: PandocMonad m => RSTParser m (String,String)
roleBefore = try $ do
role <- roleMarker
contents <- unmarkedInterpretedText
return (role,contents)
-roleAfter :: RSTParser (String,String)
+roleAfter :: PandocMonad m => RSTParser m (String,String)
roleAfter = try $ do
contents <- unmarkedInterpretedText
role <- roleMarker <|> (stateRstDefaultRole <$> getState)
return (role,contents)
-unmarkedInterpretedText :: RSTParser [Char]
+unmarkedInterpretedText :: PandocMonad m => RSTParser m [Char]
unmarkedInterpretedText = enclosed (atStart $ char '`') (char '`') anyChar
-whitespace :: RSTParser Inlines
+whitespace :: PandocMonad m => RSTParser m Inlines
whitespace = B.space <$ skipMany1 spaceChar <?> "whitespace"
-str :: RSTParser Inlines
+str :: Monad m => RSTParser m Inlines
str = do
let strChar = noneOf ("\t\n " ++ specialChars)
result <- many1 strChar
@@ -1095,7 +1110,7 @@ str = do
return $ B.str result
-- an endline character that can be treated as a space, not a structural break
-endline :: RSTParser Inlines
+endline :: Monad m => RSTParser m Inlines
endline = try $ do
newline
notFollowedBy blankline
@@ -1111,10 +1126,10 @@ endline = try $ do
-- links
--
-link :: RSTParser Inlines
+link :: PandocMonad m => RSTParser m Inlines
link = choice [explicitLink, referenceLink, autoLink] <?> "link"
-explicitLink :: RSTParser Inlines
+explicitLink :: PandocMonad m => RSTParser m Inlines
explicitLink = try $ do
char '`'
notFollowedBy (char '`') -- `` marks start of inline code
@@ -1143,7 +1158,7 @@ explicitLink = try $ do
_ -> return (src, "", nullAttr)
return $ B.linkWith attr (escapeURI src') tit label''
-referenceLink :: RSTParser Inlines
+referenceLink :: PandocMonad m => RSTParser m Inlines
referenceLink = try $ do
(label',ref) <- withRaw (quotedReferenceName <|> simpleReferenceName) <*
char '_'
@@ -1169,20 +1184,20 @@ referenceLink = try $ do
when (isAnonKey key) $ updateState $ \s -> s{ stateKeys = M.delete key keyTable }
return $ B.linkWith attr src tit label'
-autoURI :: RSTParser Inlines
+autoURI :: Monad m => RSTParser m Inlines
autoURI = do
(orig, src) <- uri
return $ B.link src "" $ B.str orig
-autoEmail :: RSTParser Inlines
+autoEmail :: Monad m => RSTParser m Inlines
autoEmail = do
(orig, src) <- emailAddress
return $ B.link src "" $ B.str orig
-autoLink :: RSTParser Inlines
+autoLink :: PandocMonad m => RSTParser m Inlines
autoLink = autoURI <|> autoEmail
-subst :: RSTParser Inlines
+subst :: PandocMonad m => RSTParser m Inlines
subst = try $ do
(_,ref) <- withRaw $ enclosed (char '|') (char '|') inline
state <- getState
@@ -1196,7 +1211,7 @@ subst = try $ do
return mempty
Just target -> return target
-note :: RSTParser Inlines
+note :: PandocMonad m => RSTParser m Inlines
note = try $ do
optional whitespace
ref <- noteMarker
@@ -1224,20 +1239,20 @@ note = try $ do
updateState $ \st -> st{ stateNotes = newnotes }
return $ B.note contents
-smart :: RSTParser Inlines
+smart :: PandocMonad m => RSTParser m Inlines
smart = do
getOption readerSmart >>= guard
doubleQuoted <|> singleQuoted <|>
choice [apostrophe, dash, ellipses]
-singleQuoted :: RSTParser Inlines
+singleQuoted :: PandocMonad m => RSTParser m Inlines
singleQuoted = try $ do
singleQuoteStart
withQuoteContext InSingleQuote $
B.singleQuoted . trimInlines . mconcat <$>
many1Till inline singleQuoteEnd
-doubleQuoted :: RSTParser Inlines
+doubleQuoted :: PandocMonad m => RSTParser m Inlines
doubleQuoted = try $ do
doubleQuoteStart
withQuoteContext InDoubleQuote $
diff --git a/src/Text/Pandoc/Readers/TWiki.hs b/src/Text/Pandoc/Readers/TWiki.hs
index 76a25ad82..091dcd7b1 100644
--- a/src/Text/Pandoc/Readers/TWiki.hs
+++ b/src/Text/Pandoc/Readers/TWiki.hs
@@ -30,7 +30,6 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
Conversion of twiki text to 'Pandoc' document.
-}
module Text.Pandoc.Readers.TWiki ( readTWiki
- , readTWikiWithWarnings
) where
import Text.Pandoc.Definition
@@ -48,17 +47,25 @@ import Data.Char (isAlphaNum)
import qualified Data.Foldable as F
import Text.Pandoc.Error
--- | Read twiki from an input string and return a Pandoc document.
-readTWiki :: ReaderOptions -- ^ Reader options
- -> String -- ^ String to parse (assuming @'\n'@ line endings)
- -> Either PandocError Pandoc
-readTWiki opts s =
- (readWith parseTWiki) def{ stateOptions = opts } (s ++ "\n\n")
+import Control.Monad.Except (throwError)
+import Text.Pandoc.Class (PandocMonad, PandocExecutionError(..))
+import qualified Text.Pandoc.Class as P
-readTWikiWithWarnings :: ReaderOptions -- ^ Reader options
+-- | Read twiki from an input string and return a Pandoc document.
+readTWiki :: PandocMonad m
+ => ReaderOptions
+ -> String
+ -> m Pandoc
+readTWiki opts s = case readTWikiWithWarnings' opts s of
+ Right (doc, warns) -> do
+ mapM_ P.warn warns
+ return doc
+ Left _ -> throwError $ PandocParseError "couldn't parse TWiki"
+
+readTWikiWithWarnings' :: ReaderOptions -- ^ Reader options
-> String -- ^ String to parse (assuming @'\n'@ line endings)
-> Either PandocError (Pandoc, [String])
-readTWikiWithWarnings opts s =
+readTWikiWithWarnings' opts s =
(readWith parseTWikiWithWarnings) def{ stateOptions = opts } (s ++ "\n\n")
where parseTWikiWithWarnings = do
doc <- parseTWiki
diff --git a/src/Text/Pandoc/Readers/Textile.hs b/src/Text/Pandoc/Readers/Textile.hs
index 8dbbf7be2..5494695f5 100644
--- a/src/Text/Pandoc/Readers/Textile.hs
+++ b/src/Text/Pandoc/Readers/Textile.hs
@@ -68,18 +68,23 @@ import Control.Monad ( guard, liftM, when )
import Data.Monoid ((<>))
import Text.Printf
import Debug.Trace (trace)
-import Text.Pandoc.Error
+import Text.Pandoc.Class (PandocMonad, PandocExecutionError(..))
+import Control.Monad.Except (throwError)
-- | Parse a Textile text and return a Pandoc document.
-readTextile :: ReaderOptions -- ^ Reader options
+readTextile :: PandocMonad m
+ => ReaderOptions -- ^ Reader options
-> String -- ^ String to parse (assuming @'\n'@ line endings)
- -> Either PandocError Pandoc
-readTextile opts s =
- (readWith parseTextile) def{ stateOptions = opts } (s ++ "\n\n")
+ -> m Pandoc
+readTextile opts s = do
+ parsed <- readWithM parseTextile def{ stateOptions = opts } (s ++ "\n\n")
+ case parsed of
+ Right result -> return result
+ Left _ -> throwError $ PandocParseError "textile parse error"
-- | Generate a Pandoc ADT from a textile document
-parseTextile :: Parser [Char] ParserState Pandoc
+parseTextile :: PandocMonad m => ParserT [Char] ParserState m Pandoc
parseTextile = do
-- textile allows raw HTML and does smart punctuation by default,
-- but we do not enable smart punctuation unless it is explicitly
@@ -103,10 +108,10 @@ parseTextile = do
blocks <- parseBlocks
return $ Pandoc nullMeta (B.toList blocks) -- FIXME
-noteMarker :: Parser [Char] ParserState [Char]
+noteMarker :: PandocMonad m => ParserT [Char] ParserState m [Char]
noteMarker = skipMany spaceChar >> string "fn" >> manyTill digit (char '.')
-noteBlock :: Parser [Char] ParserState [Char]
+noteBlock :: PandocMonad m => ParserT [Char] ParserState m [Char]
noteBlock = try $ do
startPos <- getPosition
ref <- noteMarker
@@ -121,11 +126,11 @@ noteBlock = try $ do
return $ replicate (sourceLine endPos - sourceLine startPos) '\n'
-- | Parse document blocks
-parseBlocks :: Parser [Char] ParserState Blocks
+parseBlocks :: PandocMonad m => ParserT [Char] ParserState m Blocks
parseBlocks = mconcat <$> manyTill block eof
-- | Block parsers list tried in definition order
-blockParsers :: [Parser [Char] ParserState Blocks]
+blockParsers :: PandocMonad m => [ParserT [Char] ParserState m Blocks]
blockParsers = [ codeBlock
, header
, blockQuote
@@ -140,7 +145,7 @@ blockParsers = [ codeBlock
]
-- | Any block in the order of definition of blockParsers
-block :: Parser [Char] ParserState Blocks
+block :: PandocMonad m => ParserT [Char] ParserState m Blocks
block = do
res <- choice blockParsers <?> "block"
pos <- getPosition
@@ -150,16 +155,16 @@ block = do
(take 60 $ show $ B.toList res)) (return ())
return res
-commentBlock :: Parser [Char] ParserState Blocks
+commentBlock :: PandocMonad m => ParserT [Char] ParserState m Blocks
commentBlock = try $ do
string "###."
manyTill anyLine blanklines
return mempty
-codeBlock :: Parser [Char] ParserState Blocks
+codeBlock :: PandocMonad m => ParserT [Char] ParserState m Blocks
codeBlock = codeBlockBc <|> codeBlockPre
-codeBlockBc :: Parser [Char] ParserState Blocks
+codeBlockBc :: PandocMonad m => ParserT [Char] ParserState m Blocks
codeBlockBc = try $ do
string "bc."
extended <- option False (True <$ char '.')
@@ -179,7 +184,7 @@ trimTrailingNewlines :: String -> String
trimTrailingNewlines = reverse . dropWhile (=='\n') . reverse
-- | Code Blocks in Textile are between <pre> and </pre>
-codeBlockPre :: Parser [Char] ParserState Blocks
+codeBlockPre :: PandocMonad m => ParserT [Char] ParserState m Blocks
codeBlockPre = try $ do
(t@(TagOpen _ attrs),_) <- htmlTag (tagOpen (=="pre") (const True))
result' <- manyTill anyChar (htmlTag (tagClose (=="pre")))
@@ -198,7 +203,7 @@ codeBlockPre = try $ do
return $ B.codeBlockWith (ident,classes,kvs) result'''
-- | Header of the form "hN. content" with N in 1..6
-header :: Parser [Char] ParserState Blocks
+header :: PandocMonad m => ParserT [Char] ParserState m Blocks
header = try $ do
char 'h'
level <- digitToInt <$> oneOf "123456"
@@ -210,14 +215,14 @@ header = try $ do
return $ B.headerWith attr' level name
-- | Blockquote of the form "bq. content"
-blockQuote :: Parser [Char] ParserState Blocks
+blockQuote :: PandocMonad m => ParserT [Char] ParserState m Blocks
blockQuote = try $ do
string "bq" >> attributes >> char '.' >> whitespace
B.blockQuote <$> para
-- Horizontal rule
-hrule :: Parser [Char] st Blocks
+hrule :: PandocMonad m => ParserT [Char] st m Blocks
hrule = try $ do
skipSpaces
start <- oneOf "-*"
@@ -232,39 +237,39 @@ hrule = try $ do
-- | Can be a bullet list or an ordered list. This implementation is
-- strict in the nesting, sublist must start at exactly "parent depth
-- plus one"
-anyList :: Parser [Char] ParserState Blocks
+anyList :: PandocMonad m => ParserT [Char] ParserState m Blocks
anyList = try $ anyListAtDepth 1 <* blanklines
-- | This allow one type of list to be nested into an other type,
-- provided correct nesting
-anyListAtDepth :: Int -> Parser [Char] ParserState Blocks
+anyListAtDepth :: PandocMonad m => Int -> ParserT [Char] ParserState m Blocks
anyListAtDepth depth = choice [ bulletListAtDepth depth,
orderedListAtDepth depth,
definitionList ]
-- | Bullet List of given depth, depth being the number of leading '*'
-bulletListAtDepth :: Int -> Parser [Char] ParserState Blocks
+bulletListAtDepth :: PandocMonad m => Int -> ParserT [Char] ParserState m Blocks
bulletListAtDepth depth = try $ B.bulletList <$> many1 (bulletListItemAtDepth depth)
-- | Bullet List Item of given depth, depth being the number of
-- leading '*'
-bulletListItemAtDepth :: Int -> Parser [Char] ParserState Blocks
+bulletListItemAtDepth :: PandocMonad m => Int -> ParserT [Char] ParserState m Blocks
bulletListItemAtDepth = genericListItemAtDepth '*'
-- | Ordered List of given depth, depth being the number of
-- leading '#'
-orderedListAtDepth :: Int -> Parser [Char] ParserState Blocks
+orderedListAtDepth :: PandocMonad m => Int -> ParserT [Char] ParserState m Blocks
orderedListAtDepth depth = try $ do
items <- many1 (orderedListItemAtDepth depth)
return $ B.orderedList items
-- | Ordered List Item of given depth, depth being the number of
-- leading '#'
-orderedListItemAtDepth :: Int -> Parser [Char] ParserState Blocks
+orderedListItemAtDepth :: PandocMonad m => Int -> ParserT [Char] ParserState m Blocks
orderedListItemAtDepth = genericListItemAtDepth '#'
-- | Common implementation of list items
-genericListItemAtDepth :: Char -> Int -> Parser [Char] ParserState Blocks
+genericListItemAtDepth :: PandocMonad m => Char -> Int -> ParserT [Char] ParserState m Blocks
genericListItemAtDepth c depth = try $ do
count depth (char c) >> attributes >> whitespace
p <- mconcat <$> many listInline
@@ -273,25 +278,25 @@ genericListItemAtDepth c depth = try $ do
return $ (B.plain p) <> sublist
-- | A definition list is a set of consecutive definition items
-definitionList :: Parser [Char] ParserState Blocks
+definitionList :: PandocMonad m => ParserT [Char] ParserState m Blocks
definitionList = try $ B.definitionList <$> many1 definitionListItem
-- | List start character.
-listStart :: Parser [Char] ParserState ()
+listStart :: PandocMonad m => ParserT [Char] ParserState m ()
listStart = genericListStart '*'
<|> () <$ genericListStart '#'
<|> () <$ definitionListStart
-genericListStart :: Char -> Parser [Char] st ()
+genericListStart :: PandocMonad m => Char -> ParserT [Char] st m ()
genericListStart c = () <$ try (many1 (char c) >> whitespace)
-basicDLStart :: Parser [Char] ParserState ()
+basicDLStart :: PandocMonad m => ParserT [Char] ParserState m ()
basicDLStart = do
char '-'
whitespace
notFollowedBy newline
-definitionListStart :: Parser [Char] ParserState Inlines
+definitionListStart :: PandocMonad m => ParserT [Char] ParserState m Inlines
definitionListStart = try $ do
basicDLStart
trimInlines . mconcat <$>
@@ -300,7 +305,7 @@ definitionListStart = try $ do
<|> try (lookAhead (() <$ string ":="))
)
-listInline :: Parser [Char] ParserState Inlines
+listInline :: PandocMonad m => ParserT [Char] ParserState m Inlines
listInline = try (notFollowedBy newline >> inline)
<|> try (endline <* notFollowedBy listStart)
@@ -308,15 +313,15 @@ listInline = try (notFollowedBy newline >> inline)
-- the term defined, then spaces and ":=". The definition follows, on
-- the same single line, or spaned on multiple line, after a line
-- break.
-definitionListItem :: Parser [Char] ParserState (Inlines, [Blocks])
+definitionListItem :: PandocMonad m => ParserT [Char] ParserState m (Inlines, [Blocks])
definitionListItem = try $ do
term <- (mconcat . intersperse B.linebreak) <$> many1 definitionListStart
def' <- string ":=" *> optional whitespace *> (multilineDef <|> inlineDef)
return (term, def')
- where inlineDef :: Parser [Char] ParserState [Blocks]
+ where inlineDef :: PandocMonad m => ParserT [Char] ParserState m [Blocks]
inlineDef = liftM (\d -> [B.plain d])
$ optional whitespace >> (trimInlines . mconcat <$> many listInline) <* newline
- multilineDef :: Parser [Char] ParserState [Blocks]
+ multilineDef :: PandocMonad m => ParserT [Char] ParserState m [Blocks]
multilineDef = try $ do
optional whitespace >> newline
s <- many1Till anyChar (try (string "=:" >> newline))
@@ -327,7 +332,7 @@ definitionListItem = try $ do
-- raw content
-- | A raw Html Block, optionally followed by blanklines
-rawHtmlBlock :: Parser [Char] ParserState Blocks
+rawHtmlBlock :: PandocMonad m => ParserT [Char] ParserState m Blocks
rawHtmlBlock = try $ do
skipMany spaceChar
(_,b) <- htmlTag isBlockTag
@@ -335,14 +340,14 @@ rawHtmlBlock = try $ do
return $ B.rawBlock "html" b
-- | Raw block of LaTeX content
-rawLaTeXBlock' :: Parser [Char] ParserState Blocks
+rawLaTeXBlock' :: PandocMonad m => ParserT [Char] ParserState m Blocks
rawLaTeXBlock' = do
guardEnabled Ext_raw_tex
B.rawBlock "latex" <$> (rawLaTeXBlock <* spaces)
-- | In textile, paragraphs are separated by blank lines.
-para :: Parser [Char] ParserState Blocks
+para :: PandocMonad m => ParserT [Char] ParserState m Blocks
para = B.para . trimInlines . mconcat <$> many1 inline
-- Tables
@@ -353,7 +358,7 @@ toAlignment '>' = AlignRight
toAlignment '=' = AlignCenter
toAlignment _ = AlignDefault
-cellAttributes :: Parser [Char] ParserState (Bool, Alignment)
+cellAttributes :: PandocMonad m => ParserT [Char] ParserState m (Bool, Alignment)
cellAttributes = try $ do
isHeader <- option False (True <$ char '_')
-- we just ignore colspan and rowspan markers:
@@ -366,7 +371,7 @@ cellAttributes = try $ do
return (isHeader, alignment)
-- | A table cell spans until a pipe |
-tableCell :: Parser [Char] ParserState ((Bool, Alignment), Blocks)
+tableCell :: PandocMonad m => ParserT [Char] ParserState m ((Bool, Alignment), Blocks)
tableCell = try $ do
char '|'
(isHeader, alignment) <- option (False, AlignDefault) $ cellAttributes
@@ -377,7 +382,7 @@ tableCell = try $ do
return ((isHeader, alignment), B.plain content)
-- | A table row is made of many table cells
-tableRow :: Parser [Char] ParserState [((Bool, Alignment), Blocks)]
+tableRow :: PandocMonad m => ParserT [Char] ParserState m [((Bool, Alignment), Blocks)]
tableRow = try $ do
-- skip optional row attributes
optional $ try $ do
@@ -387,7 +392,7 @@ tableRow = try $ do
many1 tableCell <* char '|' <* blankline
-- | A table with an optional header.
-table :: Parser [Char] ParserState Blocks
+table :: PandocMonad m => ParserT [Char] ParserState m Blocks
table = try $ do
-- ignore table attributes
caption <- option mempty $ try $ do
@@ -411,7 +416,7 @@ table = try $ do
(map (map snd) rows)
-- | Ignore markers for cols, thead, tfoot.
-ignorableRow :: Parser [Char] ParserState ()
+ignorableRow :: PandocMonad m => ParserT [Char] ParserState m ()
ignorableRow = try $ do
char '|'
oneOf ":^-~"
@@ -420,7 +425,7 @@ ignorableRow = try $ do
_ <- anyLine
return ()
-explicitBlockStart :: String -> Parser [Char] ParserState ()
+explicitBlockStart :: PandocMonad m => String -> ParserT [Char] ParserState m ()
explicitBlockStart name = try $ do
string name
attributes
@@ -430,9 +435,10 @@ explicitBlockStart name = try $ do
-- | Blocks like 'p' and 'table' do not need explicit block tag.
-- However, they can be used to set HTML/CSS attributes when needed.
-maybeExplicitBlock :: String -- ^ block tag name
- -> Parser [Char] ParserState Blocks -- ^ implicit block
- -> Parser [Char] ParserState Blocks
+maybeExplicitBlock :: PandocMonad m
+ => String -- ^ block tag name
+ -> ParserT [Char] ParserState m Blocks -- ^ implicit block
+ -> ParserT [Char] ParserState m Blocks
maybeExplicitBlock name blk = try $ do
optional $ explicitBlockStart name
blk
@@ -445,12 +451,12 @@ maybeExplicitBlock name blk = try $ do
-- | Any inline element
-inline :: Parser [Char] ParserState Inlines
+inline :: PandocMonad m => ParserT [Char] ParserState m Inlines
inline = do
choice inlineParsers <?> "inline"
-- | Inline parsers tried in order
-inlineParsers :: [Parser [Char] ParserState Inlines]
+inlineParsers :: PandocMonad m => [ParserT [Char] ParserState m Inlines]
inlineParsers = [ str
, whitespace
, endline
@@ -470,7 +476,7 @@ inlineParsers = [ str
]
-- | Inline markups
-inlineMarkup :: Parser [Char] ParserState Inlines
+inlineMarkup :: PandocMonad m => ParserT [Char] ParserState m Inlines
inlineMarkup = choice [ simpleInline (string "??") (B.cite [])
, simpleInline (string "**") B.strong
, simpleInline (string "__") B.emph
@@ -484,29 +490,29 @@ inlineMarkup = choice [ simpleInline (string "??") (B.cite [])
]
-- | Trademark, registered, copyright
-mark :: Parser [Char] st Inlines
+mark :: PandocMonad m => ParserT [Char] st m Inlines
mark = try $ char '(' >> (try tm <|> try reg <|> copy)
-reg :: Parser [Char] st Inlines
+reg :: PandocMonad m => ParserT [Char] st m Inlines
reg = do
oneOf "Rr"
char ')'
return $ B.str "\174"
-tm :: Parser [Char] st Inlines
+tm :: PandocMonad m => ParserT [Char] st m Inlines
tm = do
oneOf "Tt"
oneOf "Mm"
char ')'
return $ B.str "\8482"
-copy :: Parser [Char] st Inlines
+copy :: PandocMonad m => ParserT [Char] st m Inlines
copy = do
oneOf "Cc"
char ')'
return $ B.str "\169"
-note :: Parser [Char] ParserState Inlines
+note :: PandocMonad m => ParserT [Char] ParserState m Inlines
note = try $ do
ref <- (char '[' *> many1 digit <* char ']')
notes <- stateNotes <$> getState
@@ -530,13 +536,13 @@ wordBoundaries :: [Char]
wordBoundaries = markupChars ++ stringBreakers
-- | Parse a hyphened sequence of words
-hyphenedWords :: Parser [Char] ParserState String
+hyphenedWords :: PandocMonad m => ParserT [Char] ParserState m String
hyphenedWords = do
x <- wordChunk
xs <- many (try $ char '-' >> wordChunk)
return $ intercalate "-" (x:xs)
-wordChunk :: Parser [Char] ParserState String
+wordChunk :: PandocMonad m => ParserT [Char] ParserState m String
wordChunk = try $ do
hd <- noneOf wordBoundaries
tl <- many ( (noneOf wordBoundaries) <|>
@@ -545,7 +551,7 @@ wordChunk = try $ do
return $ hd:tl
-- | Any string
-str :: Parser [Char] ParserState Inlines
+str :: PandocMonad m => ParserT [Char] ParserState m Inlines
str = do
baseStr <- hyphenedWords
-- RedCloth compliance : if parsed word is uppercase and immediatly
@@ -558,11 +564,11 @@ str = do
return $ B.str fullStr
-- | Some number of space chars
-whitespace :: Parser [Char] st Inlines
+whitespace :: PandocMonad m => ParserT [Char] st m Inlines
whitespace = many1 spaceChar >> return B.space <?> "whitespace"
-- | In Textile, an isolated endline character is a line break
-endline :: Parser [Char] ParserState Inlines
+endline :: PandocMonad m => ParserT [Char] ParserState m Inlines
endline = try $ do
newline
notFollowedBy blankline
@@ -570,18 +576,18 @@ endline = try $ do
notFollowedBy rawHtmlBlock
return B.linebreak
-rawHtmlInline :: Parser [Char] ParserState Inlines
+rawHtmlInline :: PandocMonad m => ParserT [Char] ParserState m Inlines
rawHtmlInline = B.rawInline "html" . snd <$> htmlTag isInlineTag
-- | Raw LaTeX Inline
-rawLaTeXInline' :: Parser [Char] ParserState Inlines
+rawLaTeXInline' :: PandocMonad m => ParserT [Char] ParserState m Inlines
rawLaTeXInline' = try $ do
guardEnabled Ext_raw_tex
B.singleton <$> rawLaTeXInline
-- | Textile standard link syntax is "label":target. But we
-- can also have ["label":target].
-link :: Parser [Char] ParserState Inlines
+link :: PandocMonad m => ParserT [Char] ParserState m Inlines
link = try $ do
bracketed <- (True <$ char '[') <|> return False
char '"' *> notFollowedBy (oneOf " \t\n\r")
@@ -600,7 +606,7 @@ link = try $ do
else B.spanWith attr $ B.link url "" name'
-- | image embedding
-image :: Parser [Char] ParserState Inlines
+image :: PandocMonad m => ParserT [Char] ParserState m Inlines
image = try $ do
char '!' >> notFollowedBy space
(ident, cls, kvs) <- attributes
@@ -612,50 +618,50 @@ image = try $ do
char '!'
return $ B.imageWith attr src alt (B.str alt)
-escapedInline :: Parser [Char] ParserState Inlines
+escapedInline :: PandocMonad m => ParserT [Char] ParserState m Inlines
escapedInline = escapedEqs <|> escapedTag
-escapedEqs :: Parser [Char] ParserState Inlines
+escapedEqs :: PandocMonad m => ParserT [Char] ParserState m Inlines
escapedEqs = B.str <$>
(try $ string "==" *> manyTill anyChar' (try $ string "=="))
-- | literal text escaped btw <notextile> tags
-escapedTag :: Parser [Char] ParserState Inlines
+escapedTag :: PandocMonad m => ParserT [Char] ParserState m Inlines
escapedTag = B.str <$>
(try $ string "<notextile>" *>
manyTill anyChar' (try $ string "</notextile>"))
-- | Any special symbol defined in wordBoundaries
-symbol :: Parser [Char] ParserState Inlines
+symbol :: PandocMonad m => ParserT [Char] ParserState m Inlines
symbol = B.str . singleton <$> (notFollowedBy newline *>
notFollowedBy rawHtmlBlock *>
oneOf wordBoundaries)
-- | Inline code
-code :: Parser [Char] ParserState Inlines
+code :: PandocMonad m => ParserT [Char] ParserState m Inlines
code = code1 <|> code2
-- any character except a newline before a blank line
-anyChar' :: Parser [Char] ParserState Char
+anyChar' :: PandocMonad m => ParserT [Char] ParserState m Char
anyChar' =
satisfy (/='\n') <|> (try $ char '\n' <* notFollowedBy blankline)
-code1 :: Parser [Char] ParserState Inlines
+code1 :: PandocMonad m => ParserT [Char] ParserState m Inlines
code1 = B.code <$> surrounded (char '@') anyChar'
-code2 :: Parser [Char] ParserState Inlines
+code2 :: PandocMonad m => ParserT [Char] ParserState m Inlines
code2 = do
htmlTag (tagOpen (=="tt") null)
B.code <$> manyTill anyChar' (try $ htmlTag $ tagClose (=="tt"))
-- | Html / CSS attributes
-attributes :: Parser [Char] ParserState Attr
+attributes :: PandocMonad m => ParserT [Char] ParserState m Attr
attributes = (foldl (flip ($)) ("",[],[])) <$>
try (do special <- option id specialAttribute
attrs <- many attribute
return (special : attrs))
-specialAttribute :: Parser [Char] ParserState (Attr -> Attr)
+specialAttribute :: PandocMonad m => ParserT [Char] ParserState m (Attr -> Attr)
specialAttribute = do
alignStr <- ("center" <$ char '=') <|>
("justify" <$ try (string "<>")) <|>
@@ -664,11 +670,11 @@ specialAttribute = do
notFollowedBy spaceChar
return $ addStyle ("text-align:" ++ alignStr)
-attribute :: Parser [Char] ParserState (Attr -> Attr)
+attribute :: PandocMonad m => ParserT [Char] ParserState m (Attr -> Attr)
attribute = try $
(classIdAttr <|> styleAttr <|> langAttr) <* notFollowedBy spaceChar
-classIdAttr :: Parser [Char] ParserState (Attr -> Attr)
+classIdAttr :: PandocMonad m => ParserT [Char] ParserState m (Attr -> Attr)
classIdAttr = try $ do -- (class class #id)
char '('
ws <- words `fmap` manyTill anyChar' (char ')')
@@ -679,7 +685,7 @@ classIdAttr = try $ do -- (class class #id)
classes' -> return $ \(_,_,keyvals) ->
("",classes',keyvals)
-styleAttr :: Parser [Char] ParserState (Attr -> Attr)
+styleAttr :: PandocMonad m => ParserT [Char] ParserState m (Attr -> Attr)
styleAttr = do
style <- try $ enclosed (char '{') (char '}') anyChar'
return $ addStyle style
@@ -690,21 +696,23 @@ addStyle style (id',classes,keyvals) =
where keyvals' = ("style", style') : [(k,v) | (k,v) <- keyvals, k /= "style"]
style' = style ++ ";" ++ concat [v | ("style",v) <- keyvals]
-langAttr :: Parser [Char] ParserState (Attr -> Attr)
+langAttr :: PandocMonad m => ParserT [Char] ParserState m (Attr -> Attr)
langAttr = do
lang <- try $ enclosed (char '[') (char ']') alphaNum
return $ \(id',classes,keyvals) -> (id',classes,("lang",lang):keyvals)
-- | Parses material surrounded by a parser.
-surrounded :: Parser [Char] st t -- ^ surrounding parser
- -> Parser [Char] st a -- ^ content parser (to be used repeatedly)
- -> Parser [Char] st [a]
+surrounded :: PandocMonad m
+ => ParserT [Char] st m t -- ^ surrounding parser
+ -> ParserT [Char] st m a -- ^ content parser (to be used repeatedly)
+ -> ParserT [Char] st m [a]
surrounded border =
enclosed (border *> notFollowedBy (oneOf " \t\n\r")) (try border)
-simpleInline :: Parser [Char] ParserState t -- ^ surrounding parser
- -> (Inlines -> Inlines) -- ^ Inline constructor
- -> Parser [Char] ParserState Inlines -- ^ content parser (to be used repeatedly)
+simpleInline :: PandocMonad m
+ => ParserT [Char] ParserState m t -- ^ surrounding parser
+ -> (Inlines -> Inlines) -- ^ Inline constructor
+ -> ParserT [Char] ParserState m Inlines -- ^ content parser (to be used repeatedly)
simpleInline border construct = try $ do
notAfterString
border *> notFollowedBy (oneOf " \t\n\r")
@@ -718,7 +726,7 @@ simpleInline border construct = try $ do
then body
else B.spanWith attr body
-groupedInlineMarkup :: Parser [Char] ParserState Inlines
+groupedInlineMarkup :: PandocMonad m => ParserT [Char] ParserState m Inlines
groupedInlineMarkup = try $ do
char '['
sp1 <- option mempty $ B.space <$ whitespace
diff --git a/src/Text/Pandoc/Readers/Txt2Tags.hs b/src/Text/Pandoc/Readers/Txt2Tags.hs
index 0aafc83c7..00b37503e 100644
--- a/src/Text/Pandoc/Readers/Txt2Tags.hs
+++ b/src/Text/Pandoc/Readers/Txt2Tags.hs
@@ -46,13 +46,12 @@ import Data.Maybe (fromMaybe)
import Control.Monad (void, guard, when)
import Data.Default
import Control.Monad.Reader (Reader, runReader, asks)
-import Text.Pandoc.Error
-import Data.Time.LocalTime (getZonedTime)
-import System.Directory(getModificationTime)
import Data.Time.Format (formatTime)
import Text.Pandoc.Compat.Time (defaultTimeLocale)
-import System.IO.Error (catchIOError)
+import Control.Monad.Except (throwError, catchError)
+import Text.Pandoc.Class (PandocMonad, PandocExecutionError(..))
+import qualified Text.Pandoc.Class as P
type T2T = ParserT String ParserState (Reader T2TMeta)
@@ -69,26 +68,42 @@ instance Default T2TMeta where
def = T2TMeta "" "" "" ""
-- | Get the meta information required by Txt2Tags macros
-getT2TMeta :: [FilePath] -> FilePath -> IO T2TMeta
-getT2TMeta inps out = do
- curDate <- formatTime defaultTimeLocale "%F" <$> getZonedTime
+getT2TMeta :: PandocMonad m => m T2TMeta
+getT2TMeta = do
+ mbInps <- P.getInputFiles
+ let inps = case mbInps of
+ Just x -> x
+ Nothing -> []
+ mbOutp <- P.getOutputFile
+ let outp = case mbOutp of
+ Just x -> x
+ Nothing -> ""
+ curDate <- formatTime defaultTimeLocale "%F" <$> P.getZonedTime
let getModTime = fmap (formatTime defaultTimeLocale "%T") .
- getModificationTime
+ P.getModificationTime
curMtime <- case inps of
- [] -> formatTime defaultTimeLocale "%T" <$> getZonedTime
- _ -> catchIOError
+ [] -> formatTime defaultTimeLocale "%T" <$> P.getZonedTime
+ _ -> catchError
(maximum <$> mapM getModTime inps)
(const (return ""))
- return $ T2TMeta curDate curMtime (intercalate ", " inps) out
+ return $ T2TMeta curDate curMtime (intercalate ", " inps) outp
-- | Read Txt2Tags from an input string returning a Pandoc document
-readTxt2Tags :: T2TMeta -> ReaderOptions -> String -> Either PandocError Pandoc
-readTxt2Tags t opts s = flip runReader t $ readWithM parseT2T (def {stateOptions = opts}) (s ++ "\n\n")
+readTxt2Tags :: PandocMonad m
+ => ReaderOptions
+ -> String
+ -> m Pandoc
+readTxt2Tags opts s = do
+ meta <- getT2TMeta
+ let parsed = flip runReader meta $ readWithM parseT2T (def {stateOptions = opts}) (s ++ "\n\n")
+ case parsed of
+ Right result -> return $ result
+ Left _ -> throwError $ PandocParseError "error parsing t2t"
-- | Read Txt2Tags (ignoring all macros) from an input string returning
-- a Pandoc document
-readTxt2TagsNoMacros :: ReaderOptions -> String -> Either PandocError Pandoc
-readTxt2TagsNoMacros = readTxt2Tags def
+readTxt2TagsNoMacros :: PandocMonad m => ReaderOptions -> String -> m Pandoc
+readTxt2TagsNoMacros = readTxt2Tags
parseT2T :: T2T Pandoc
parseT2T = do
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-29 12:34:29 +0000