aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJohn MacFarlane <jgm@berkeley.edu>2015-04-18 18:34:55 -0700
committerJohn MacFarlane <jgm@berkeley.edu>2015-04-18 19:00:32 -0700
commit1a69896d8f2c676aaf8563e1a7b2ba5870597f54 (patch)
tree6ef651eea3198730e9f8c1152bd54479f7a8c1c3
parent343b6051da9b6750e67de2e5279d4cf6b99067dd (diff)
downloadpandoc-1a69896d8f2c676aaf8563e1a7b2ba5870597f54.tar.gz
Revert "Merge pull request #1947 from mpickering/Fmonad"
Closes #2062. This reverts commit c302bdcdbe97b38721015fe82403b2a8f488a702, reversing changes made to b983adf0d0cbc98d2da1e2751f46ae1f93352be6. Conflicts: src/Text/Pandoc/Parsing.hs src/Text/Pandoc/Readers/Markdown.hs src/Text/Pandoc/Readers/Org.hs src/Text/Pandoc/Readers/RST.hs
Diffstat
-rw-r--r--src/Text/Pandoc/Parsing.hs55
-rw-r--r--src/Text/Pandoc/Readers/Markdown.hs671
-rw-r--r--src/Text/Pandoc/Readers/Org.hs474
-rw-r--r--src/Text/Pandoc/Readers/RST.hs2
4 files changed, 627 insertions, 575 deletions
diff --git a/src/Text/Pandoc/Parsing.hs b/src/Text/Pandoc/Parsing.hs
index 33120e55d..5c27d3e6d 100644
--- a/src/Text/Pandoc/Parsing.hs
+++ b/src/Text/Pandoc/Parsing.hs
@@ -65,8 +65,7 @@ module Text.Pandoc.Parsing ( anyLine,
widthsFromIndices,
gridTableWith,
readWith,
- returnWarnings,
- returnState,
+ readWithWarnings,
readWithM,
testStringWith,
guardEnabled,
@@ -105,8 +104,11 @@ module Text.Pandoc.Parsing ( anyLine,
applyMacros',
Parser,
ParserT,
+ F(..),
+ runF,
+ askF,
+ asksF,
token,
- generalize,
-- * Re-exports from Text.Pandoc.Parsec
Stream,
runParser,
@@ -187,7 +189,7 @@ import Data.Default
import qualified Data.Set as Set
import Control.Monad.Reader
import Control.Monad.Identity
-import Control.Applicative ((<$>), (<*>), (*>), (<*), (<$))
+import Control.Applicative ((<$>), (<*>), (*>), (<*), (<$), Applicative)
import Data.Monoid
import Data.Maybe (catMaybes)
@@ -197,6 +199,22 @@ type Parser t s = Parsec t s
type ParserT = ParsecT
+newtype F a = F { unF :: Reader ParserState a } deriving (Monad, Applicative, Functor)
+
+runF :: F a -> ParserState -> a
+runF = runReader . unF
+
+askF :: F ParserState
+askF = F ask
+
+asksF :: (ParserState -> a) -> F a
+asksF f = F $ asks f
+
+instance Monoid a => Monoid (F a) where
+ mempty = return mempty
+ mappend = liftM2 mappend
+ mconcat = liftM mconcat . sequence
+
-- | Parse any line of text
anyLine :: Stream [Char] m Char => ParserT [Char] st m [Char]
anyLine = do
@@ -860,18 +878,15 @@ readWith :: Parser [Char] st a
-> Either PandocError a
readWith p t inp = runIdentity $ readWithM p t inp
-returnWarnings :: (Stream s m c)
- => ParserT s ParserState m a
- -> ParserT s ParserState m (a, [String])
-returnWarnings p = do
+readWithWarnings :: Parser [Char] ParserState a
+ -> ParserState
+ -> String
+ -> Either PandocError (a, [String])
+readWithWarnings p = readWith $ do
doc <- p
warnings <- stateWarnings <$> getState
return (doc, warnings)
--- | Return the final internal state with the result of a parser
-returnState :: (Stream s m c) => ParsecT s st m a -> ParsecT s st m (a, st)
-returnState p = (,) <$> p <*> getState
-
-- | Parse a string with @parser@ (for testing).
testStringWith :: (Show a, Stream [Char] Identity Char)
=> ParserT [Char] ParserState Identity a
@@ -893,6 +908,7 @@ data ParserState = ParserState
stateNotes :: NoteTable, -- ^ List of notes (raw bodies)
stateNotes' :: NoteTable', -- ^ List of notes (parsed bodies)
stateMeta :: Meta, -- ^ Document metadata
+ stateMeta' :: F Meta, -- ^ Document metadata
stateHeaderTable :: [HeaderType], -- ^ Ordered list of header types used
stateHeaders :: M.Map Inlines String, -- ^ List of headers and ids (used for implicit ref links)
stateIdentifiers :: [String], -- ^ List of header identifiers used
@@ -907,8 +923,7 @@ data ParserState = ParserState
stateCaption :: Maybe Inlines, -- ^ Caption in current environment
stateInHtmlBlock :: Maybe String, -- ^ Tag type of HTML block being parsed
stateMarkdownAttribute :: Bool, -- ^ True if in markdown=1 context
- stateWarnings :: [String], -- ^ Warnings generated by the parser
- stateInFootnote :: Bool -- ^ True if in a footnote block.
+ stateWarnings :: [String] -- ^ Warnings generated by the parser
}
instance Default ParserState where
@@ -990,6 +1005,7 @@ defaultParserState =
stateNotes = [],
stateNotes' = [],
stateMeta = nullMeta,
+ stateMeta' = return nullMeta,
stateHeaderTable = [],
stateHeaders = M.empty,
stateIdentifiers = [],
@@ -1002,8 +1018,7 @@ defaultParserState =
stateCaption = Nothing,
stateInHtmlBlock = Nothing,
stateMarkdownAttribute = False,
- stateWarnings = [],
- stateInFootnote = False }
+ stateWarnings = []}
-- | Succeed only if the extension is enabled.
guardEnabled :: (Stream s m a, HasReaderOptions st) => Extension -> ParserT s st m ()
@@ -1042,7 +1057,7 @@ data QuoteContext
type NoteTable = [(String, String)]
-type NoteTable' = [(String, Blocks)] -- used in markdown reader
+type NoteTable' = [(String, F Blocks)] -- used in markdown reader
newtype Key = Key String deriving (Show, Read, Eq, Ord)
@@ -1238,15 +1253,11 @@ applyMacros' target = do
else return target
-- | Append a warning to the log.
-addWarning :: (Stream s m c) => Maybe SourcePos -> String -> ParserT s ParserState m ()
+addWarning :: Maybe SourcePos -> String -> Parser [Char] ParserState ()
addWarning mbpos msg =
updateState $ \st -> st{
stateWarnings = (msg ++ maybe "" (\pos -> " " ++ show pos) mbpos) :
stateWarnings st }
-
-generalize :: (Monad m) => Parser s st a -> ParserT s st m a
-generalize m = mkPT (\ s -> (return $ (return . runIdentity) <$> runIdentity (runParsecT m s)))
-
infixr 5 <+?>
(<+?>) :: (Monoid a, Monad m) => ParserT s st m a -> ParserT s st m a -> ParserT s st m a
a <+?> b = a >>= flip fmap (try b <|> return mempty) . (<>)
diff --git a/src/Text/Pandoc/Readers/Markdown.hs b/src/Text/Pandoc/Readers/Markdown.hs
index 17270b741..656e4ec66 100644
--- a/src/Text/Pandoc/Readers/Markdown.hs
+++ b/src/Text/Pandoc/Readers/Markdown.hs
@@ -32,7 +32,7 @@ Conversion of markdown-formatted plain text to 'Pandoc' document.
module Text.Pandoc.Readers.Markdown ( readMarkdown,
readMarkdownWithWarnings ) where
-import Data.List ( transpose, sortBy, intersperse, intercalate, elemIndex)
+import Data.List ( transpose, sortBy, findIndex, intersperse, intercalate )
import qualified Data.Map as M
import Data.Scientific (coefficient, base10Exponent)
import Data.Ord ( comparing )
@@ -58,7 +58,6 @@ import Text.Pandoc.Readers.HTML ( htmlTag, htmlInBalanced, isInlineTag, isBlockT
import Data.Monoid (mconcat, mempty)
import Control.Applicative ((<$>), (<*), (*>), (<$), (<*>))
import Control.Monad
-import Control.Monad.Reader
import System.FilePath (takeExtension, addExtension)
import Text.HTML.TagSoup
import Text.HTML.TagSoup.Match (tagOpen)
@@ -67,30 +66,25 @@ import Text.Printf (printf)
import Debug.Trace (trace)
import Text.Pandoc.Error
-type MarkdownParser a = ParserT [Char] ParserState (Reader ParserState) a
+type MarkdownParser = Parser [Char] ParserState
-- | Read markdown from an input string and return a Pandoc document.
readMarkdown :: ReaderOptions -- ^ Reader options
-> String -- ^ String to parse (assuming @'\n'@ line endings)
-> Either PandocError Pandoc
readMarkdown opts s =
- runMarkdown opts s parseMarkdown
+ (readWith parseMarkdown) def{ stateOptions = opts } (s ++ "\n\n")
-- | Read markdown from an input string and return a pair of a Pandoc document
-- and a list of warnings.
readMarkdownWithWarnings :: ReaderOptions -- ^ Reader options
-> String -- ^ String to parse (assuming @'\n'@ line endings)
- -> Either PandocError (Pandoc, [String])
-readMarkdownWithWarnings opts s = runMarkdown opts s (returnWarnings parseMarkdown)
+ -> Either PandocError (Pandoc, [String])
+readMarkdownWithWarnings opts s =
+ (readWithWarnings parseMarkdown) def{ stateOptions = opts } (s ++ "\n\n")
-runMarkdown :: forall a . ReaderOptions -> String -> MarkdownParser a -> Either PandocError a
-runMarkdown opts inp p = fst <$> res
- where
- imd = readWithM (returnState p) def{ stateOptions = opts } (inp ++ "\n\n")
- res :: Either PandocError (a, ParserState)
- res = runReader imd s
- s :: ParserState
- s = either def snd res
+trimInlinesF :: F Inlines -> F Inlines
+trimInlinesF = liftM trimInlines
--
-- Constants and data structure definitions
@@ -127,10 +121,10 @@ inList = do
ctx <- stateParserContext <$> getState
guard (ctx == ListItemState)
-isNull :: Inlines -> Bool
-isNull = B.isNull
+isNull :: F Inlines -> Bool
+isNull ils = B.isNull $ runF ils def
-spnl :: Monad m => ParserT [Char] st m ()
+spnl :: Parser [Char] st ()
spnl = try $ do
skipSpaces
optional newline
@@ -170,9 +164,9 @@ litChar = escapedChar'
-- | Parse a sequence of inline elements between square brackets,
-- including inlines between balanced pairs of square brackets.
-inlinesInBalancedBrackets :: MarkdownParser Inlines
+inlinesInBalancedBrackets :: MarkdownParser (F Inlines)
inlinesInBalancedBrackets = charsInBalancedBrackets >>=
- parseFromString (trimInlines . mconcat <$> many inline)
+ parseFromString (trimInlinesF . mconcat <$> many inline)
charsInBalancedBrackets :: MarkdownParser [Char]
charsInBalancedBrackets = do
@@ -189,16 +183,16 @@ charsInBalancedBrackets = do
-- document structure
--
-titleLine :: MarkdownParser Inlines
+titleLine :: MarkdownParser (F Inlines)
titleLine = try $ do
char '%'
skipSpaces
res <- many $ (notFollowedBy newline >> inline)
<|> try (endline >> whitespace)
newline
- return $ trimInlines $ mconcat res
+ return $ trimInlinesF $ mconcat res
-authorsLine :: MarkdownParser [Inlines]
+authorsLine :: MarkdownParser (F [Inlines])
authorsLine = try $ do
char '%'
skipSpaces
@@ -207,13 +201,13 @@ authorsLine = try $ do
(char ';' <|>
try (newline >> notFollowedBy blankline >> spaceChar))
newline
- return $ filter (not . isNull) $ map (trimInlines . mconcat) authors
+ return $ sequence $ filter (not . isNull) $ map (trimInlinesF . mconcat) authors
-dateLine :: MarkdownParser Inlines
+dateLine :: MarkdownParser (F Inlines)
dateLine = try $ do
char '%'
skipSpaces
- trimInlines . mconcat <$> manyTill inline newline
+ trimInlinesF . mconcat <$> manyTill inline newline
titleBlock :: MarkdownParser ()
titleBlock = pandocTitleBlock <|> mmdTitleBlock
@@ -223,16 +217,20 @@ pandocTitleBlock = try $ do
guardEnabled Ext_pandoc_title_block
lookAhead (char '%')
title <- option mempty titleLine
- author <- option [] authorsLine
+ author <- option (return []) authorsLine
date <- option mempty dateLine
optional blanklines
- let meta' = (if B.isNull title then id else B.setMeta "title" title)
- . (if null author then id else B.setMeta "author" author)
- . (if B.isNull date then id else B.setMeta "date" date)
- $ nullMeta
- updateState $ \st -> st{ stateMeta = stateMeta st <> meta' }
-
-yamlMetaBlock :: MarkdownParser Blocks
+ let meta' = do title' <- title
+ author' <- author
+ date' <- date
+ return $
+ (if B.isNull title' then id else B.setMeta "title" title')
+ . (if null author' then id else B.setMeta "author" author')
+ . (if B.isNull date' then id else B.setMeta "date" date')
+ $ nullMeta
+ updateState $ \st -> st{ stateMeta' = stateMeta' st <> meta' }
+
+yamlMetaBlock :: MarkdownParser (F Blocks)
yamlMetaBlock = try $ do
guardEnabled Ext_yaml_metadata_block
pos <- getPosition
@@ -245,7 +243,7 @@ yamlMetaBlock = try $ do
optional blanklines
opts <- stateOptions <$> getState
meta' <- case Yaml.decodeEither' $ UTF8.fromString rawYaml of
- Right (Yaml.Object hashmap) -> return $
+ Right (Yaml.Object hashmap) -> return $ return $
H.foldrWithKey (\k v m ->
if ignorable k
then m
@@ -253,10 +251,10 @@ yamlMetaBlock = try $ do
Left _ -> m
Right v' -> B.setMeta (T.unpack k) v' m)
nullMeta hashmap
- Right Yaml.Null -> return nullMeta
+ Right Yaml.Null -> return $ return nullMeta
Right _ -> do
addWarning (Just pos) "YAML header is not an object"
- return nullMeta
+ return $ return nullMeta
Left err' -> do
case err' of
InvalidYaml (Just YamlParseException{
@@ -275,13 +273,13 @@ yamlMetaBlock = try $ do
_ -> addWarning (Just pos)
$ "Could not parse YAML header: " ++
show err'
- return nullMeta
- updateState $ \st -> st{ stateMeta = stateMeta st <> meta' }
+ return $ return nullMeta
+ updateState $ \st -> st{ stateMeta' = stateMeta' st <> meta' }
return mempty
-- ignore fields ending with _
ignorable :: Text -> Bool
-ignorable t = T.pack "_" `T.isSuffixOf` t
+ignorable t = (T.pack "_") `T.isSuffixOf` t
toMetaValue :: ReaderOptions -> Text -> Either PandocError MetaValue
toMetaValue opts x = toMeta <$> readMarkdown opts' (T.unpack x)
@@ -328,8 +326,8 @@ mmdTitleBlock = try $ do
guardEnabled Ext_mmd_title_block
kvPairs <- many1 kvPair
blanklines
- updateState $ \st -> st{ stateMeta = stateMeta st <>
- (Meta $ M.fromList kvPairs) }
+ updateState $ \st -> st{ stateMeta' = stateMeta' st <>
+ return (Meta $ M.fromList kvPairs) }
kvPair :: MarkdownParser (String, MetaValue)
kvPair = try $ do
@@ -353,11 +351,11 @@ parseMarkdown = do
optional titleBlock
blocks <- parseBlocks
st <- getState
- let meta = stateMeta st
- let Pandoc _ bs = B.doc blocks
+ let meta = runF (stateMeta' st) st
+ let Pandoc _ bs = B.doc $ runF blocks st
return $ Pandoc meta bs
-referenceKey :: MarkdownParser Blocks
+referenceKey :: MarkdownParser (F Blocks)
referenceKey = try $ do
pos <- getPosition
skipNonindentSpaces
@@ -384,7 +382,7 @@ referenceKey = try $ do
Just _ -> addWarning (Just pos) $ "Duplicate link reference `" ++ raw ++ "'"
Nothing -> return ()
updateState $ \s -> s { stateKeys = M.insert key target oldkeys }
- return mempty
+ return $ return mempty
referenceTitle :: MarkdownParser String
referenceTitle = try $ do
@@ -404,7 +402,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 Blocks
+abbrevKey :: MarkdownParser (F Blocks)
abbrevKey = do
guardEnabled Ext_abbreviations
try $ do
@@ -413,7 +411,7 @@ abbrevKey = do
char ':'
skipMany (satisfy (/= '\n'))
blanklines
- return mempty
+ return $ return mempty
noteMarker :: MarkdownParser String
noteMarker = string "[^" >> many1Till (satisfy $ not . isBlank) (char ']')
@@ -431,7 +429,7 @@ rawLines = do
rest <- many rawLine
return $ unlines (first:rest)
-noteBlock :: MarkdownParser Blocks
+noteBlock :: MarkdownParser (F Blocks)
noteBlock = try $ do
pos <- getPosition
skipNonindentSpaces
@@ -443,7 +441,7 @@ noteBlock = try $ do
rest <- many $ try $ blanklines >> indentSpaces >> rawLines
let raw = unlines (first:rest) ++ "\n"
optional blanklines
- parsed <- parseFromString (inFootnote parseBlocks) raw
+ parsed <- parseFromString parseBlocks raw
let newnote = (ref, parsed)
oldnotes <- stateNotes' <$> getState
case lookup ref oldnotes of
@@ -452,29 +450,21 @@ noteBlock = try $ do
updateState $ \s -> s { stateNotes' = newnote : oldnotes }
return mempty
-inFootnote :: MarkdownParser a -> MarkdownParser a
-inFootnote p = do
- st <- stateInFootnote <$> getState
- updateState (\s -> s { stateInFootnote = True } )
- r <- p
- updateState (\s -> s { stateInFootnote = st } )
- return r
-
--
-- parsing blocks
--
-parseBlocks :: MarkdownParser Blocks
+parseBlocks :: MarkdownParser (F Blocks)
parseBlocks = mconcat <$> manyTill block eof
-block :: MarkdownParser Blocks
+block :: MarkdownParser (F Blocks)
block = do
tr <- getOption readerTrace
pos <- getPosition
res <- choice [ mempty <$ blanklines
, codeBlockFenced
, yamlMetaBlock
- , guardEnabled Ext_latex_macros *> macro
+ , guardEnabled Ext_latex_macros *> (macro >>= return . return)
-- note: bulletList needs to be before header because of
-- the possibility of empty list items: -
, bulletList
@@ -496,28 +486,29 @@ block = do
, para
, plain
] <?> "block"
- when tr $
+ when tr $ do
+ st <- getState
trace (printf "line %d: %s" (sourceLine pos)
- (take 60 . show . B.toList $ res)) (return ())
+ (take 60 $ show $ B.toList $ runF res st)) (return ())
return res
--
-- header blocks
--
-header :: MarkdownParser Blocks
+header :: MarkdownParser (F Blocks)
header = setextHeader <|> atxHeader <?> "header"
-atxHeader :: MarkdownParser Blocks
+atxHeader :: MarkdownParser (F Blocks)
atxHeader = try $ do
- level <- length <$> many1 (char '#')
+ level <- many1 (char '#') >>= return . length
notFollowedBy $ guardEnabled Ext_fancy_lists >>
(char '.' <|> char ')') -- this would be a list
skipSpaces
- text <- trimInlines . mconcat <$> many (notFollowedBy atxClosing >> inline)
+ text <- trimInlinesF . mconcat <$> many (notFollowedBy atxClosing >> inline)
attr <- atxClosing
- attr' <- registerHeader attr text
- return $ B.headerWith attr' level text
+ attr' <- registerHeader attr (runF text defaultParserState)
+ return $ B.headerWith attr' level <$> text
atxClosing :: MarkdownParser Attr
atxClosing = try $ do
@@ -544,25 +535,25 @@ mmdHeaderIdentifier = do
skipSpaces
return (ident,[],[])
-setextHeader :: MarkdownParser Blocks
+setextHeader :: MarkdownParser (F Blocks)
setextHeader = try $ do
-- This lookahead prevents us from wasting time parsing Inlines
-- unless necessary -- it gives a significant performance boost.
lookAhead $ anyLine >> many1 (oneOf setextHChars) >> blankline
- text <- trimInlines . mconcat <$> many1 (notFollowedBy setextHeaderEnd >> inline)
+ text <- trimInlinesF . mconcat <$> many1 (notFollowedBy setextHeaderEnd >> inline)
attr <- setextHeaderEnd
underlineChar <- oneOf setextHChars
many (char underlineChar)
blanklines
- let level = (fromMaybe 0 $ elemIndex underlineChar setextHChars) + 1
- attr' <- registerHeader attr text
- return $ B.headerWith attr' level text
+ let level = (fromMaybe 0 $ findIndex (== underlineChar) setextHChars) + 1
+ attr' <- registerHeader attr (runF text defaultParserState)
+ return $ B.headerWith attr' level <$> text
--
-- hrule block
--
-hrule :: Monad m => ParserT [Char] st m Blocks
+hrule :: Parser [Char] st (F Blocks)
hrule = try $ do
skipSpaces
start <- satisfy isHruleChar
@@ -570,24 +561,24 @@ hrule = try $ do
skipMany (spaceChar <|> char start)
newline
optional blanklines
- return B.horizontalRule
+ return $ return B.horizontalRule
--
-- code blocks
--
indentedLine :: MarkdownParser String
-indentedLine = indentSpaces >> ((++ "\n") <$> anyLine)
+indentedLine = indentSpaces >> anyLine >>= return . (++ "\n")
-blockDelimiter :: Monad m
- => (Char -> Bool)
+blockDelimiter :: (Char -> Bool)
-> Maybe Int
- -> ParserT [Char] st m Int
+ -> Parser [Char] st Int
blockDelimiter f len = try $ do
c <- lookAhead (satisfy f)
case len of
Just l -> count l (char c) >> many (char c) >> return l
- Nothing -> count 3 (char c) >> ((+ 3) . length <$> many (char c))
+ Nothing -> count 3 (char c) >> many (char c) >>=
+ return . (+ 3) . length
attributes :: MarkdownParser Attr
attributes = try $ do
@@ -632,7 +623,7 @@ specialAttr = do
char '-'
return $ \(id',cs,kvs) -> (id',cs ++ ["unnumbered"],kvs)
-codeBlockFenced :: MarkdownParser Blocks
+codeBlockFenced :: MarkdownParser (F Blocks)
codeBlockFenced = try $ do
c <- try (guardEnabled Ext_fenced_code_blocks >> lookAhead (char '~'))
<|> (guardEnabled Ext_backtick_code_blocks >> lookAhead (char '`'))
@@ -644,7 +635,7 @@ codeBlockFenced = try $ do
blankline
contents <- manyTill anyLine (blockDelimiter (== c) (Just size))
blanklines
- return $ B.codeBlockWith attr $ intercalate "\n" contents
+ return $ return $ B.codeBlockWith attr $ intercalate "\n" contents
-- correctly handle github language identifiers
toLanguageId :: String -> String
@@ -653,7 +644,7 @@ toLanguageId = map toLower . go
go "objective-c" = "objectivec"
go x = x
-codeBlockIndented :: MarkdownParser Blocks
+codeBlockIndented :: MarkdownParser (F Blocks)
codeBlockIndented = do
contents <- many1 (indentedLine <|>
try (do b <- blanklines
@@ -661,15 +652,15 @@ codeBlockIndented = do
return $ b ++ l))
optional blanklines
classes <- getOption readerIndentedCodeClasses
- return $ B.codeBlockWith ("", classes, []) $
+ return $ return $ B.codeBlockWith ("", classes, []) $
stripTrailingNewlines $ concat contents
-lhsCodeBlock :: MarkdownParser Blocks
+lhsCodeBlock :: MarkdownParser (F Blocks)
lhsCodeBlock = do
guardEnabled Ext_literate_haskell
- (B.codeBlockWith ("",["sourceCode","literate","haskell"],[]) <$>
+ (return . B.codeBlockWith ("",["sourceCode","literate","haskell"],[]) <$>
(lhsCodeBlockBird <|> lhsCodeBlockLaTeX))
- <|> (B.codeBlockWith ("",["sourceCode","haskell"],[]) <$>
+ <|> (return . B.codeBlockWith ("",["sourceCode","haskell"],[]) <$>
lhsCodeBlockInverseBird)
lhsCodeBlockLaTeX :: MarkdownParser String
@@ -698,7 +689,7 @@ lhsCodeBlockBirdWith c = try $ do
blanklines
return $ intercalate "\n" lns'
-birdTrackLine :: Monad m => Char -> ParserT [Char] st m String
+birdTrackLine :: Char -> Parser [Char] st String
birdTrackLine c = try $ do
char c
-- allow html tags on left margin:
@@ -726,12 +717,12 @@ emailBlockQuote = try $ do
optional blanklines
return raw
-blockQuote :: MarkdownParser Blocks
+blockQuote :: MarkdownParser (F Blocks)
blockQuote = do
raw <- emailBlockQuote
-- parse the extracted block, which may contain various block elements:
- contents <- parseFromString parseBlocks $ intercalate "\n" raw ++ "\n\n"
- return $ B.blockQuote contents
+ contents <- parseFromString parseBlocks $ (intercalate "\n" raw) ++ "\n\n"
+ return $ B.blockQuote <$> contents
--
-- list blocks
@@ -774,7 +765,7 @@ anyOrderedListStart = try $ do
return res
listStart :: MarkdownParser ()
-listStart = bulletListStart <|> void anyOrderedListStart
+listStart = bulletListStart <|> (anyOrderedListStart >> return ())
listLine :: MarkdownParser String
listLine = try $ do
@@ -829,7 +820,7 @@ listContinuationLine = try $ do
return $ result ++ "\n"
listItem :: MarkdownParser a
- -> MarkdownParser Blocks
+ -> MarkdownParser (F Blocks)
listItem start = try $ do
first <- rawListItem start
continuations <- many listContinuation
@@ -845,14 +836,14 @@ listItem start = try $ do
updateState (\st -> st {stateParserContext = oldContext})
return contents
-orderedList :: MarkdownParser Blocks
+orderedList :: MarkdownParser (F Blocks)
orderedList = try $ do
(start, style, delim) <- lookAhead anyOrderedListStart
unless (style `elem` [DefaultStyle, Decimal, Example] &&
delim `elem` [DefaultDelim, Period]) $
guardEnabled Ext_fancy_lists
when (style == Example) $ guardEnabled Ext_example_lists
- items <- many1 $ listItem
+ items <- fmap sequence $ many1 $ listItem
( try $ do
optional newline -- if preceded by Plain block in a list
startpos <- sourceColumn <$> getPosition
@@ -864,12 +855,12 @@ orderedList = try $ do
atMostSpaces (tabStop - (endpos - startpos))
return res )
start' <- option 1 $ guardEnabled Ext_startnum >> return start
- return $ B.orderedListWith (start', style, delim) (compactify' items)
+ return $ B.orderedListWith (start', style, delim) <$> fmap compactify' items
-bulletList :: MarkdownParser Blocks
+bulletList :: MarkdownParser (F Blocks)
bulletList = do
- items <- many1 $ listItem bulletListStart
- return $ B.bulletList (compactify' items)
+ items <- fmap sequence $ many1 $ listItem bulletListStart
+ return $ B.bulletList <$> fmap compactify' items
-- definition lists
@@ -884,14 +875,14 @@ defListMarker = do
else mzero
return ()
-definitionListItem :: Bool -> MarkdownParser (Inlines, [Blocks])
+definitionListItem :: Bool -> MarkdownParser (F (Inlines, [Blocks]))
definitionListItem compact = try $ do
rawLine' <- anyLine
raw <- many1 $ defRawBlock compact
- term <- parseFromString (trimInlines . mconcat <$> many inline) rawLine'
+ term <- parseFromString (trimInlinesF . mconcat <$> many inline) rawLine'
contents <- mapM (parseFromString parseBlocks) raw
optional blanklines
- return (term, contents)
+ return $ liftM2 (,) term (sequence contents)
defRawBlock :: Bool -> MarkdownParser String
defRawBlock compact = try $ do
@@ -914,34 +905,35 @@ defRawBlock compact = try $ do
return $ trimr (firstline ++ "\n" ++ unlines rawlines ++ cont) ++
if hasBlank || not (null cont) then "\n\n" else ""
-definitionList :: MarkdownParser Blocks
+definitionList :: MarkdownParser (F Blocks)
definitionList = try $ do
- lookAhead (anyLine >> optional (blankline >> notFollowedBy table) >>
+ lookAhead (anyLine >>
+ optional (blankline >> notFollowedBy (table >> return ())) >>
-- don't capture table caption as def list!
defListMarker)
compactDefinitionList <|> normalDefinitionList
-compactDefinitionList :: MarkdownParser Blocks
+compactDefinitionList :: MarkdownParser (F Blocks)
compactDefinitionList = do
guardEnabled Ext_compact_definition_lists
- items <- many1 $ definitionListItem True
- return $ B.definitionList (compactify'DL items)
+ items <- fmap sequence $ many1 $ definitionListItem True
+ return $ B.definitionList <$> fmap compactify'DL items
-normalDefinitionList :: MarkdownParser Blocks
+normalDefinitionList :: MarkdownParser (F Blocks)
normalDefinitionList = do
guardEnabled Ext_definition_lists
- items <- many1 $ definitionListItem False
- return $ B.definitionList items
+ items <- fmap sequence $ many1 $ definitionListItem False
+ return $ B.definitionList <$> items
--
-- paragraph block
--
-para :: MarkdownParser Blocks
+para :: MarkdownParser (F Blocks)
para = try $ do
exts <- getOption readerExtensions
- result <- trimInlines . mconcat <$> many1 inline
- option (B.plain result)
+ result <- trimInlinesF . mconcat <$> many1 inline
+ option (B.plain <$> result)
$ try $ do
newline
(blanklines >> return mempty)
@@ -958,17 +950,18 @@ para = try $ do
Just "div" -> () <$
lookAhead (htmlTag (~== TagClose "div"))
_ -> mzero
- return $
- case B.toList result of
+ return $ do
+ result' <- result
+ case B.toList result' of
[Image alt (src,tit)]
| Ext_implicit_figures `Set.member` exts ->
-- the fig: at beginning of title indicates a figure
- B.para $ B.singleton
+ return $ B.para $ B.singleton
$ Image alt (src,'f':'i':'g':':':tit)
- _ -> B.para result
+ _ -> return $ B.para result'
-plain :: MarkdownParser Blocks
-plain = B.plain . trimInlines . mconcat <$> many1 inline
+plain :: MarkdownParser (F Blocks)
+plain = fmap B.plain . trimInlinesF . mconcat <$> many1 inline
--
-- raw html
@@ -979,13 +972,13 @@ htmlElement = rawVerbatimBlock
<|> strictHtmlBlock
<|> liftM snd (htmlTag isBlockTag)
-htmlBlock :: MarkdownParser Blocks
+htmlBlock :: MarkdownParser (F Blocks)
htmlBlock = do
guardEnabled Ext_raw_html
try (do
(TagOpen t attrs) <- lookAhead $ fst <$> htmlTag isBlockTag
(guard (t `elem` ["pre","style","script"]) >>
- B.rawBlock "html" <$> rawVerbatimBlock)
+ (return . B.rawBlock "html") <$> rawVerbatimBlock)
<|> (do guardEnabled Ext_markdown_attribute
oldMarkdownAttribute <- stateMarkdownAttribute <$> getState
markdownAttribute <-
@@ -1004,35 +997,35 @@ htmlBlock = do
<|> (guardEnabled Ext_markdown_in_html_blocks >> rawHtmlBlocks))
<|> htmlBlock'
-htmlBlock' :: MarkdownParser Blocks
+htmlBlock' :: MarkdownParser (F Blocks)
htmlBlock' = try $ do
first <- htmlElement
skipMany spaceChar
optional blanklines
- return $ B.rawBlock "html" first
+ return $ return $ B.rawBlock "html" first
strictHtmlBlock :: MarkdownParser String
strictHtmlBlock = htmlInBalanced (not . isInlineTag)
rawVerbatimBlock :: MarkdownParser String
rawVerbatimBlock = try $ do
- (TagOpen tag _, open) <-
- htmlTag (tagOpen (`elem` ["pre", "style", "script"])
- (const True))
+ (TagOpen tag _, open) <- htmlTag (tagOpen (flip elem
+ ["pre", "style", "script"])
+ (const True))
contents <- manyTill anyChar (htmlTag (~== TagClose tag))
return $ open ++ contents ++ renderTags' [TagClose tag]
-rawTeXBlock :: MarkdownParser Blocks
+rawTeXBlock :: MarkdownParser (F Blocks)
rawTeXBlock = do
guardEnabled Ext_raw_tex
result <- (B.rawBlock "latex" . concat <$>
- generalize rawLaTeXBlock `sepEndBy1` blankline)
+ rawLaTeXBlock `sepEndBy1` blankline)
<|> (B.rawBlock "context" . concat <$>
rawConTeXtEnvironment `sepEndBy1` blankline)
spaces
- return result
+ return $ return result
-rawHtmlBlocks :: MarkdownParser Blocks
+rawHtmlBlocks :: MarkdownParser (F Blocks)
rawHtmlBlocks = do
(TagOpen tagtype _, raw) <- htmlTag isBlockTag
-- try to find closing tag
@@ -1044,10 +1037,10 @@ rawHtmlBlocks = do
contents <- mconcat <$> many (notFollowedBy' closer >> block)
result <-
(closer >>= \(_, rawcloser) -> return (
- (B.rawBlock "html" $ stripMarkdownAttribute raw) <>
+ return (B.rawBlock "html" $ stripMarkdownAttribute raw) <>
contents <>
- (B.rawBlock "html" rawcloser)))
- <|> return (B.rawBlock "html" raw <> contents)
+ return (B.rawBlock "html" rawcloser)))
+ <|> return (return (B.rawBlock "html" raw) <> contents)
updateState $ \st -> st{ stateInHtmlBlock = oldInHtmlBlock }
return result
@@ -1062,12 +1055,12 @@ stripMarkdownAttribute s = renderTags' $ map filterAttrib $ parseTags s
-- line block
--
-lineBlock :: MarkdownParser Blocks
+lineBlock :: MarkdownParser (F Blocks)
lineBlock = try $ do
guardEnabled Ext_line_blocks
lines' <- lineBlockLines >>=
- mapM (parseFromString (trimInlines . mconcat <$> many inline))
- return $ B.para (mconcat $ intersperse B.linebreak lines')
+ mapM (parseFromString (trimInlinesF . mconcat <$> many inline))
+ return $ B.para <$> (mconcat $ intersperse (return B.linebreak) lines')
--
-- Tables
@@ -1075,8 +1068,8 @@ lineBlock = try $ do
-- Parse a dashed line with optional trailing spaces; return its length
-- and the length including trailing space.
-dashedLine :: Monad m => Char
- -> ParserT [Char] st m (Int, Int)
+dashedLine :: Char
+ -> Parser [Char] st (Int, Int)
dashedLine ch = do
dashes <- many1 (char ch)
sp <- many spaceChar
@@ -1087,7 +1080,7 @@ dashedLine ch = do
-- Parse a table header with dashed lines of '-' preceded by
-- one (or zero) line of text.
simpleTableHeader :: Bool -- ^ Headerless table
- -> MarkdownParser ([Blocks], [Alignment], [Int])
+ -> MarkdownParser (F [Blocks], [Alignment], [Int])
simpleTableHeader headless = try $ do
rawContent <- if headless
then return ""
@@ -1106,8 +1099,9 @@ simpleTableHeader headless = try $ do
let rawHeads' = if headless
then replicate (length dashes) ""
else rawHeads
- heads <-
- mapM (parseFromString (mconcat <$> many plain) . trim) rawHeads'
+ heads <- fmap sequence
+ $ mapM (parseFromString (mconcat <$> many plain))
+ $ map trim rawHeads'
return (heads, aligns, indices)
-- Returns an alignment type for a table, based on a list of strings
@@ -1148,30 +1142,30 @@ rawTableLine indices = do
-- Parse a table line and return a list of lists of blocks (columns).
tableLine :: [Int]
- -> MarkdownParser [Blocks]
+ -> MarkdownParser (F [Blocks])
tableLine indices = rawTableLine indices >>=
- mapM (parseFromString (mconcat <$> many plain))
+ fmap sequence . mapM (parseFromString (mconcat <$> many plain))
-- Parse a multiline table row and return a list of blocks (columns).
multilineRow :: [Int]
- -> MarkdownParser [Blocks]
+ -> MarkdownParser (F [Blocks])
multilineRow indices = do
colLines <- many1 (rawTableLine indices)
let cols = map unlines $ transpose colLines
- mapM (parseFromString (mconcat <$> many plain)) cols
+ fmap sequence $ mapM (parseFromString (mconcat <$> many plain)) cols
-- Parses a table caption: inlines beginning with 'Table:'
-- and followed by blank lines.
-tableCaption :: MarkdownParser Inlines
+tableCaption :: MarkdownParser (F Inlines)
tableCaption = try $ do
guardEnabled Ext_table_captions
skipNonindentSpaces
string ":" <|> string "Table:"
- trimInlines . mconcat <$> many1 inline <* blanklines
+ trimInlinesF . mconcat <$> many1 inline <* blanklines
-- Parse a simple table with '---' header and one line per row.
simpleTable :: Bool -- ^ Headerless table
- -> MarkdownParser ([Alignment], [Double], [Blocks], [[Blocks]])
+ -> MarkdownParser ([Alignment], [Double], F [Blocks], F [[Blocks]])
simpleTable headless = do
(aligns, _widths, heads', lines') <-
tableWith (simpleTableHeader headless) tableLine
@@ -1185,12 +1179,12 @@ simpleTable headless = do
-- 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], [Blocks], [[Blocks]])
+ -> MarkdownParser ([Alignment], [Double], F [Blocks], F [[Blocks]])
multilineTable headless =
tableWith (multilineTableHeader headless) multilineRow blanklines tableFooter
multilineTableHeader :: Bool -- ^ Headerless table
- -> MarkdownParser ([Blocks], [Alignment], [Int])
+ -> MarkdownParser (F [Blocks], [Alignment], [Int])
multilineTableHeader headless = try $ do
unless headless $
tableSep >> notFollowedBy blankline
@@ -1212,7 +1206,7 @@ multilineTableHeader headless = try $ do
let rawHeads = if headless
then replicate (length dashes) ""
else map (unlines . map trim) rawHeadsList
- heads <-
+ heads <- fmap sequence $
mapM (parseFromString (mconcat <$> many plain)) $
map trim rawHeads
return (heads, aligns, indices)
@@ -1222,7 +1216,7 @@ multilineTableHeader headless = try $ do
-- 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], [Blocks], [[Blocks]])
+ -> MarkdownParser ([Alignment], [Double], F [Blocks], F [[Blocks]])
gridTable headless =
tableWith (gridTableHeader headless) gridTableRow
(gridTableSep '-') gridTableFooter
@@ -1231,14 +1225,14 @@ gridTableSplitLine :: [Int] -> String -> [String]
gridTableSplitLine indices line = map removeFinalBar $ tail $
splitStringByIndices (init indices) $ trimr line
-gridPart :: Monad m => Char -> ParserT [Char] st m (Int, Int)
+gridPart :: Char -> Parser [Char] st (Int, Int)
gridPart ch = do
dashes <- many1 (char ch)
char '+'
let lengthDashes = length dashes
return (lengthDashes, lengthDashes + 1)
-gridDashedLines :: Monad m => Char -> ParserT [Char] st m [(Int,Int)]
+gridDashedLines :: Char -> Parser [Char] st [(Int,Int)]
gridDashedLines ch = try $ char '+' >> many1 (gridPart ch) <* blankline
removeFinalBar :: String -> String
@@ -1251,7 +1245,7 @@ gridTableSep ch = try $ gridDashedLines ch >> return '\n'
-- | Parse header for a grid table.
gridTableHeader :: Bool -- ^ Headerless table
- -> MarkdownParser ([Blocks], [Alignment], [Int])
+ -> MarkdownParser (F [Blocks], [Alignment], [Int])
gridTableHeader headless = try $ do
optional blanklines
dashes <- gridDashedLines '-'
@@ -1260,7 +1254,9 @@ gridTableHeader headless = try $ do
else many1
(notFollowedBy (gridTableSep '=') >> char '|' >>
many1Till anyChar newline)
- unless headless (void $ gridTableSep '=')
+ if headless
+ then return ()
+ else gridTableSep '=' >> return ()
let lines' = map snd dashes
let indices = scanl (+) 0 lines'
let aligns = replicate (length lines') AlignDefault
@@ -1269,7 +1265,7 @@ gridTableHeader headless = try $ do
then replicate (length dashes) ""
else map (unlines . map trim) $ transpose
$ map (gridTableSplitLine indices) rawContent
- heads <- mapM (parseFromString parseBlocks . trim) rawHeads
+ heads <- fmap sequence $ mapM (parseFromString parseBlocks . trim) rawHeads
return (heads, aligns, indices)
gridTableRawLine :: [Int] -> MarkdownParser [String]
@@ -1280,12 +1276,12 @@ gridTableRawLine indices = do
-- | Parse row of grid table.
gridTableRow :: [Int]
- -> MarkdownParser [Blocks]
+ -> MarkdownParser (F [Blocks])
gridTableRow indices = do
colLines <- many1 (gridTableRawLine indices)
let cols = map ((++ "\n") . unlines . removeOneLeadingSpace) $
transpose colLines
- compactify' <$> mapM (parseFromString parseBlocks) cols
+ fmap compactify' <$> fmap sequence (mapM (parseFromString parseBlocks) cols)
removeOneLeadingSpace :: [String] -> [String]
removeOneLeadingSpace xs =
@@ -1311,12 +1307,12 @@ pipeBreak = try $ do
blankline
return (first:rest)
-pipeTable :: MarkdownParser ([Alignment], [Double], [Blocks], [[Blocks]])
+pipeTable :: MarkdownParser ([Alignment], [Double], F [Blocks], F [[Blocks]])
pipeTable = try $ do
(heads,aligns) <- (,) <$> pipeTableRow <*> pipeBreak
- lines' <- many pipeTableRow
+ lines' <- sequence <$> many pipeTableRow
let widths = replicate (length aligns) 0.0
- return (aligns, widths, heads, lines')
+ return $ (aligns, widths, heads, lines')
sepPipe :: MarkdownParser ()
sepPipe = try $ do
@@ -1324,7 +1320,7 @@ sepPipe = try $ do
notFollowedBy blankline
-- parse a row, also returning probable alignments for org-table cells
-pipeTableRow :: MarkdownParser [Blocks]
+pipeTableRow :: MarkdownParser (F [Blocks])
pipeTableRow = do
nonindentSpaces
openPipe <- (True <$ char '|') <|> return False
@@ -1336,14 +1332,16 @@ pipeTableRow = do
guard $ not (null rest && not openPipe)
optional (char '|')
blankline
- let cells = first:rest
- return $
- map (\ils ->
+ let cells = sequence (first:rest)
+ return $ do
+ cells' <- cells
+ return $ map
+ (\ils ->
case trimInlines ils of
ils' | B.isNull ils' -> mempty
- | otherwise -> B.plain ils') cells
+ | otherwise -> B.plain $ ils') cells'
-pipeTableHeaderPart :: Monad m => ParserT [Char] st m Alignment
+pipeTableHeaderPart :: Parser [Char] st Alignment
pipeTableHeaderPart = try $ do
skipMany spaceChar
left <- optionMaybe (char ':')
@@ -1358,7 +1356,7 @@ pipeTableHeaderPart = try $ do
(Just _,Just _) -> AlignCenter
-- Succeed only if current line contains a pipe.
-scanForPipe :: Monad m => ParserT [Char] st m ()
+scanForPipe :: Parser [Char] st ()
scanForPipe = do
inp <- getInput
case break (\c -> c == '\n' || c == '|') inp of
@@ -1368,22 +1366,22 @@ scanForPipe = do
-- | Parse a table using 'headerParser', 'rowParser',
-- 'lineParser', and 'footerParser'. Variant of the version in
-- Text.Pandoc.Parsing.
-tableWith :: MarkdownParser ([Blocks], [Alignment], [Int])
- -> ([Int] -> MarkdownParser [Blocks])
+tableWith :: MarkdownParser (F [Blocks], [Alignment], [Int])
+ -> ([Int] -> MarkdownParser (F [Blocks]))
-> MarkdownParser sep
-> MarkdownParser end
- -> MarkdownParser ([Alignment], [Double], [Blocks], [[Blocks]])
+ -> MarkdownParser ([Alignment], [Double], F [Blocks], F [[Blocks]])
tableWith headerParser rowParser lineParser footerParser = try $ do
(heads, aligns, indices) <- headerParser
- lines' <- rowParser indices `sepEndBy1` lineParser
+ lines' <- fmap sequence $ rowParser indices `sepEndBy1` lineParser
footerParser
numColumns <- getOption readerColumns
- let widths = case indices of
- [] -> replicate (length aligns) 0.0
- _ -> widthsFromIndices numColumns indices
- return (aligns, widths, heads, lines')
+ let widths = if (indices == [])
+ then replicate (length aligns) 0.0
+ else widthsFromIndices numColumns indices
+ return $ (aligns, widths, heads, lines')
-table :: MarkdownParser Blocks
+table :: MarkdownParser (F Blocks)
table = try $ do
frontCaption <- option Nothing (Just <$> tableCaption)
(aligns, widths, heads, lns) <-
@@ -1398,15 +1396,19 @@ table = try $ do
(gridTable False <|> gridTable True)) <?> "table"
optional blanklines
caption <- case frontCaption of
- Nothing -> option mempty tableCaption
+ Nothing -> option (return mempty) tableCaption
Just c -> return c
- return $ B.table caption (zip aligns widths) heads lns
+ return $ do
+ caption' <- caption
+ heads' <- heads
+ lns' <- lns
+ return $ B.table caption' (zip aligns widths) heads' lns'
--
-- inline
--
-inline :: MarkdownParser Inlines
+inline :: MarkdownParser (F Inlines)
inline = choice [ whitespace
, bareURL
, str
@@ -1429,7 +1431,7 @@ inline = choice [ whitespace
, rawLaTeXInline'
, exampleRef
, smart
- , B.singleton <$> charRef
+ , return . B.singleton <$> charRef
, symbol
, ltSign
] <?> "inline"
@@ -1440,42 +1442,43 @@ escapedChar' = try $ do
(guardEnabled Ext_all_symbols_escapable >> satisfy (not . isAlphaNum))
<|> oneOf "\\`*_{}[]()>#+-.!~\""
-escapedChar :: MarkdownParser Inlines
+escapedChar :: MarkdownParser (F Inlines)
escapedChar = do
result <- escapedChar'
case result of
- ' ' -> return $ B.str "\160" -- "\ " is a nonbreaking space
+ ' ' -> return $ return $ B.str "\160" -- "\ " is a nonbreaking space
'\n' -> guardEnabled Ext_escaped_line_breaks >>
- return B.linebreak -- "\[newline]" is a linebreak
- _ -> return $ B.str [result]
+ return (return B.linebreak) -- "\[newline]" is a linebreak
+ _ -> return $ return $ B.str [result]
-ltSign :: MarkdownParser Inlines
+ltSign :: MarkdownParser (F Inlines)
ltSign = do
guardDisabled Ext_raw_html
<|> (notFollowedByHtmlCloser >> notFollowedBy' (htmlTag isBlockTag))
char '<'
- return $ B.str "<"
+ return $ return $ B.str "<"
-exampleRef :: MarkdownParser Inlines
+exampleRef :: MarkdownParser (F Inlines)
exampleRef = try $ do
guardEnabled Ext_example_lists
char '@'
lab <- many1 (alphaNum <|> oneOf "-_")
- st <- ask
- return $ case M.lookup lab (stateExamples st) of
- Just n -> B.str (show n)
- Nothing -> B.str ('@':lab)
+ return $ do
+ st <- askF
+ return $ case M.lookup lab (stateExamples st) of
+ Just n -> B.str (show n)
+ Nothing -> B.str ('@':lab)
-symbol :: MarkdownParser Inlines
+symbol :: MarkdownParser (F Inlines)
symbol = do
result <- noneOf "<\\\n\t "
<|> try (do lookAhead $ char '\\'
notFollowedBy' (() <$ rawTeXBlock)
char '\\')
- return $ B.str [result]
+ return $ return $ B.str [result]
-- parses inline code, between n `s and n `s
-code :: MarkdownParser Inlines
+code :: MarkdownParser (F Inlines)
code = try $ do
starts <- many1 (char '`')
skipSpaces
@@ -1485,17 +1488,18 @@ code = try $ do
notFollowedBy (char '`')))
attr <- option ([],[],[]) (try $ guardEnabled Ext_inline_code_attributes >>
optional whitespace >> attributes)
- return $ B.codeWith attr $ trim $ concat result
+ return $ return $ B.codeWith attr $ trim $ concat result
-math :: MarkdownParser Inlines
-math = (B.displayMath <$> (mathDisplay >>= applyMacros'))
- <|> ((B.math <$> (mathInline >>= applyMacros')) <+?>
- ((getOption readerSmart >>= guard) *> apostrophe <* notFollowedBy space))
+math :: MarkdownParser (F Inlines)
+math = (return . B.displayMath <$> (mathDisplay >>= applyMacros'))
+ <|> (return . B.math <$> (mathInline >>= applyMacros')) <+?>
+ ((getOption readerSmart >>= guard) *> (return <$> apostrophe)
+ <* notFollowedBy space)
-- Parses material enclosed in *s, **s, _s, or __s.
-- Designed to avoid backtracking.
enclosure :: Char
- -> MarkdownParser Inlines
+ -> MarkdownParser (F Inlines)
enclosure c = do
-- we can't start an enclosure with _ if after a string and
-- the intraword_underscores extension is enabled:
@@ -1503,13 +1507,13 @@ enclosure c = do
<|> guard (c == '*')
<|> (guard =<< notAfterString)
cs <- many1 (char c)
- (B.str cs <>) <$> whitespace
- <|>
+ (return (B.str cs) <>) <$> whitespace
+ <|> do
case length cs of
3 -> three c
2 -> two c mempty
1 -> one c mempty
- _ -> return $ B.str cs
+ _ -> return (return $ B.str cs)
ender :: Char -> Int -> MarkdownParser ()
ender c n = try $ do
@@ -1522,74 +1526,74 @@ 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 Inlines
+three :: Char -> MarkdownParser (F Inlines)
three c = do
contents <- mconcat <$> many (notFollowedBy (ender c 1) >> inline)
- (ender c 3 >> return ((B.strong . B.emph) contents))
- <|> (ender c 2 >> one c (B.strong contents))
- <|> (ender c 1 >> two c (B.emph contents))
- <|> return (B.str [c,c,c] <> contents)
+ (ender c 3 >> return ((B.strong . B.emph) <$> contents))
+ <|> (ender c 2 >> one c (B.strong <$> contents))
+ <|> (ender c 1 >> two c (B.emph <$> contents))
+ <|> return (return (B.str [c,c,c]) <> contents)
-- Parse inlines til you hit two c's, and emit strong.
-- If you never do hit two cs, emit ** plus inlines parsed.
-two :: Char -> Inlines -> MarkdownParser Inlines
+two :: Char -> F Inlines -> MarkdownParser (F Inlines)
two c prefix' = do
contents <- mconcat <$> many (try $ notFollowedBy (ender c 2) >> inline)
- (ender c 2 >> return (B.strong (prefix' <> contents)))
- <|> return (B.str [c,c] <> (prefix' <> contents))
+ (ender c 2 >> return (B.strong <$> (prefix' <> contents)))
+ <|> return (return (B.str [c,c]) <> (prefix' <> contents))
-- Parse inlines til you hit a c, and emit emph.
-- If you never hit a c, emit * plus inlines parsed.
-one :: Char -> Inlines -> MarkdownParser Inlines
+one :: Char -> F Inlines -> MarkdownParser (F Inlines)
one c prefix' = do
contents <- mconcat <$> many ( (notFollowedBy (ender c 1) >> inline)
<|> try (string [c,c] >>
notFollowedBy (ender c 1) >>
two c mempty) )
- (ender c 1 >> return (B.emph (prefix' <> contents)))
- <|> return (B.str [c] <> (prefix' <> contents))
+ (ender c 1 >> return (B.emph <$> (prefix' <> contents)))
+ <|> return (return (B.str [c]) <> (prefix' <> contents))
-strongOrEmph :: MarkdownParser Inlines
+strongOrEmph :: MarkdownParser (F Inlines)
strongOrEmph = enclosure '*' <|> enclosure '_'
--- | Parses a list oInlines between start and end delimiters.
+-- | Parses a list of inlines between start and end delimiters.
inlinesBetween :: (Show b)
=> MarkdownParser a
-> MarkdownParser b
- -> MarkdownParser Inlines
+ -> MarkdownParser (F Inlines)
inlinesBetween start end =
- (trimInlines . mconcat) <$> try (start >> many1Till inner end)
+ (trimInlinesF . mconcat) <$> try (start >> many1Till inner end)
where inner = innerSpace <|> (notFollowedBy' (() <$ whitespace) >> inline)
innerSpace = try $ whitespace <* notFollowedBy' end
-strikeout :: MarkdownParser Inlines
-strikeout = B.strikeout <$>
+strikeout :: MarkdownParser (F Inlines)
+strikeout = fmap B.strikeout <$>
(guardEnabled Ext_strikeout >> inlinesBetween strikeStart strikeEnd)
where strikeStart = string "~~" >> lookAhead nonspaceChar
>> notFollowedBy (char '~')
strikeEnd = try $ string "~~"
-superscript :: MarkdownParser Inlines
-superscript = B.superscript <$> try (do
+superscript :: MarkdownParser (F Inlines)
+superscript = fmap B.superscript <$> try (do
guardEnabled Ext_superscript
char '^'
mconcat <$> many1Till (notFollowedBy spaceChar >> inline) (char '^'))
-subscript :: MarkdownParser Inlines
-subscript = B.subscript <$> try (do
+subscript :: MarkdownParser (F Inlines)
+subscript = fmap B.subscript <$> try (do
guardEnabled Ext_subscript
char '~'
mconcat <$> many1Till (notFollowedBy spaceChar >> inline) (char '~'))
-whitespace :: MarkdownParser Inlines
-whitespace = spaceChar >> (lb <|> regsp) <?> "whitespace"
+whitespace :: MarkdownParser (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 :: Monad m => ParserT [Char] st m Char
+nonEndline :: Parser [Char] st Char
nonEndline = satisfy (/='\n')
-str :: MarkdownParser Inlines
+str :: MarkdownParser (F Inlines)
str = do
result <- many1 alphaNum
updateLastStrPos
@@ -1597,14 +1601,14 @@ str = do
isSmart <- getOption readerSmart
if isSmart
then case likelyAbbrev result of
- [] -> return $ B.str result
+ [] -> return $ return $ B.str result
xs -> choice (map (\x ->
try (string x >> oneOf " \n" >>
lookAhead alphaNum >>
- return (B.str $
- result ++ spacesToNbr x ++ "\160"))) xs)
- <|> (return $ B.str result)
- else return $ B.str result
+ return (return $ B.str
+ $ result ++ spacesToNbr x ++ "\160"))) xs)
+ <|> (return $ return $ B.str result)
+ else return $ return $ B.str result
-- | if the string matches the beginning of an abbreviation (before
-- the first period, return strings that would finish the abbreviation.
@@ -1619,7 +1623,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 Inlines
+endline :: MarkdownParser (F Inlines)
endline = try $ do
newline
notFollowedBy blankline
@@ -1632,18 +1636,18 @@ endline = try $ do
notFollowedBy (() <$ (lookAhead (char '`') >> codeBlockFenced))
notFollowedByHtmlCloser
(eof >> return mempty)
- <|> (guardEnabled Ext_hard_line_breaks >> return B.linebreak)
+ <|> (guardEnabled Ext_hard_line_breaks >> return (return B.linebreak))
<|> (guardEnabled Ext_ignore_line_breaks >> return mempty)
- <|> return B.space
+ <|> (return $ return B.space)
--
-- links
--
-- a reference label for a link
-reference :: MarkdownParser (Inlines, String)
+reference :: MarkdownParser (F Inlines, String)
reference = do notFollowedBy' (string "[^") -- footnote reference
- withRaw $ trimInlines <$> inlinesInBalancedBrackets
+ withRaw $ trimInlinesF <$> inlinesInBalancedBrackets
parenthesizedChars :: MarkdownParser [Char]
parenthesizedChars = do
@@ -1671,7 +1675,7 @@ source = do
linkTitle :: MarkdownParser String
linkTitle = quotedTitle '"' <|> quotedTitle '\''
-link :: MarkdownParser Inlines
+link :: MarkdownParser (F Inlines)
link = try $ do
st <- getState
guard $ stateAllowLinks st
@@ -1681,14 +1685,14 @@ link = try $ do
regLink B.link lab <|> referenceLink B.link (lab,raw)
regLink :: (String -> String -> Inlines -> Inlines)
- -> Inlines -> MarkdownParser Inlines
+ -> F Inlines -> MarkdownParser (F Inlines)
regLink constructor lab = try $ do
(src, tit) <- source
- return $ constructor src tit lab
+ return $ constructor src tit <$> lab
-- a link like [this][ref] or [this][] or [this]
referenceLink :: (String -> String -> Inlines -> Inlines)
- -> (Inlines, String) -> MarkdownParser Inlines
+ -> (F Inlines, String) -> MarkdownParser (F Inlines)
referenceLink constructor (lab, raw) = do
sp <- (True <$ lookAhead (char ' ')) <|> return False
(ref,raw') <- option (mempty, "") $
@@ -1702,22 +1706,24 @@ referenceLink constructor (lab, raw) = do
fallback <- parseFromString (mconcat <$> many inline) $ dropBrackets raw
implicitHeaderRefs <- option False $
True <$ guardEnabled Ext_implicit_header_references
- let makeFallback =
- B.str "[" <> fallback <> B.str "]" <>
+ let makeFallback = do
+ parsedRaw' <- parsedRaw
+ fallback' <- fallback
+ return $ B.str "[" <> fallback' <> B.str "]" <>
(if sp && not (null raw) then B.space else mempty) <>
- parsedRaw
- keys <- asks stateKeys
- headers <- asks stateHeaders
- return $
- case M.lookup key keys of
- Nothing ->
- let ref' = if labIsRef then lab else ref in
- if implicitHeaderRefs
- then case M.lookup ref' headers of
- Just ident -> constructor ('#':ident) "" lab
- Nothing -> makeFallback
- else makeFallback
- Just (src,tit) -> constructor src tit lab
+ parsedRaw'
+ return $ do
+ keys <- asksF stateKeys
+ case M.lookup key keys of
+ Nothing -> do
+ headers <- asksF stateHeaders
+ ref' <- if labIsRef then lab else ref
+ if implicitHeaderRefs
+ then case M.lookup ref' headers of
+ Just ident -> constructor ('#':ident) "" <$> lab
+ Nothing -> makeFallback
+ else makeFallback
+ Just (src,tit) -> constructor src tit <$> lab
dropBrackets :: String -> String
dropBrackets = reverse . dropRB . reverse . dropLB
@@ -1726,14 +1732,14 @@ dropBrackets = reverse . dropRB . reverse . dropLB
dropLB ('[':xs) = xs
dropLB xs = xs
-bareURL :: MarkdownParser Inlines
+bareURL :: MarkdownParser (F Inlines)
bareURL = try $ do
guardEnabled Ext_autolink_bare_uris
(orig, src) <- uri <|> emailAddress
notFollowedBy $ try $ spaces >> htmlTag (~== TagClose "a")
- return $ B.link src "" (B.str orig)
+ return $ return $ B.link src "" (B.str orig)
-autoLink :: MarkdownParser Inlines
+autoLink :: MarkdownParser (F Inlines)
autoLink = try $ do
char '<'
(orig, src) <- uri <|> emailAddress
@@ -1742,9 +1748,9 @@ autoLink = try $ do
-- final punctuation. for example: in `<http://hi---there>`,
-- the URI parser will stop before the dashes.
extra <- fromEntities <$> manyTill nonspaceChar (char '>')
- return $ B.link (src ++ escapeURI extra) "" (B.str $ orig ++ extra)
+ return $ return $ B.link (src ++ escapeURI extra) "" (B.str $ orig ++ extra)
-image :: MarkdownParser Inlines
+image :: MarkdownParser (F Inlines)
image = try $ do
char '!'
(lab,raw) <- reference
@@ -1754,33 +1760,38 @@ image = try $ do
_ -> B.image src
regLink constructor lab <|> referenceLink constructor (lab,raw)
-note :: MarkdownParser Inlines
+note :: MarkdownParser (F Inlines)
note = try $ do
guardEnabled Ext_footnotes
- (stateInFootnote <$> getState) >>= guard . not
ref <- noteMarker
- notes <- asks stateNotes'
- return $
+ return $ do
+ notes <- asksF stateNotes'
case lookup ref notes of
- Nothing -> B.str $ "[^" ++ ref ++ "]"
- Just contents -> B.note contents
-
-inlineNote :: MarkdownParser Inlines
+ Nothing -> return $ B.str $ "[^" ++ ref ++ "]"
+ Just contents -> do
+ st <- askF
+ -- process the note in a context that doesn't resolve
+ -- notes, to avoid infinite looping with notes inside
+ -- notes:
+ let contents' = runF contents st{ stateNotes' = [] }
+ return $ B.note contents'
+
+inlineNote :: MarkdownParser (F Inlines)
inlineNote = try $ do
guardEnabled Ext_inline_notes
char '^'
contents <- inlinesInBalancedBrackets
- return . B.note . B.para $ contents
+ return $ B.note . B.para <$> contents
-rawLaTeXInline' :: MarkdownParser Inlines
+rawLaTeXInline' :: MarkdownParser (F Inlines)
rawLaTeXInline' = try $ do
guardEnabled Ext_raw_tex
lookAhead $ char '\\' >> notFollowedBy' (string "start") -- context env
- RawInline _ s <- generalize rawLaTeXInline
- return $ B.rawInline "tex" s
+ RawInline _ s <- rawLaTeXInline
+ return $ return $ B.rawInline "tex" s
-- "tex" because it might be context or latex
-rawConTeXtEnvironment :: Monad m => ParserT [Char] st m String
+rawConTeXtEnvironment :: Parser [Char] st String
rawConTeXtEnvironment = try $ do
string "\\start"
completion <- inBrackets (letter <|> digit <|> spaceChar)
@@ -1789,14 +1800,14 @@ rawConTeXtEnvironment = try $ do
(try $ string "\\stop" >> string completion)
return $ "\\start" ++ completion ++ concat contents ++ "\\stop" ++ completion
-inBrackets :: Monad m => (ParserT [Char] st m Char) -> ParserT [Char] st m String
+inBrackets :: (Parser [Char] st Char) -> Parser [Char] st String
inBrackets parser = do
char '['
contents <- many parser
char ']'
return $ "[" ++ contents ++ "]"
-spanHtml :: MarkdownParser Inlines
+spanHtml :: MarkdownParser (F Inlines)
spanHtml = try $ do
guardEnabled Ext_native_spans
(TagOpen _ attrs, _) <- htmlTag (~== TagOpen "span" [])
@@ -1808,10 +1819,10 @@ spanHtml = try $ do
Just s | null ident && null classes &&
map toLower (filter (`notElem` " \t;") s) ==
"font-variant:small-caps"
- -> return $ B.smallcaps contents
- _ -> return $ B.spanWith (ident, classes, keyvals) contents
+ -> return $ B.smallcaps <$> contents
+ _ -> return $ B.spanWith (ident, classes, keyvals) <$> contents
-divHtml :: MarkdownParser Blocks
+divHtml :: MarkdownParser (F Blocks)
divHtml = try $ do
guardEnabled Ext_native_divs
(TagOpen _ attrs, rawtag) <- htmlTag (~== TagOpen "div" [])
@@ -1829,11 +1840,11 @@ divHtml = try $ do
let ident = fromMaybe "" $ lookup "id" attrs
let classes = maybe [] words $ lookup "class" attrs
let keyvals = [(k,v) | (k,v) <- attrs, k /= "id" && k /= "class"]
- return $ B.divWith (ident, classes, keyvals) contents
+ return $ B.divWith (ident, classes, keyvals) <$> contents
else -- avoid backtracing
- return $ B.rawBlock "html" (rawtag <> bls) <> contents
+ return $ return (B.rawBlock "html" (rawtag <> bls)) <> contents
-rawHtmlInline :: MarkdownParser Inlines
+rawHtmlInline :: MarkdownParser (F Inlines)
rawHtmlInline = do
guardEnabled Ext_raw_html
inHtmlBlock <- stateInHtmlBlock <$> getState
@@ -1848,17 +1859,19 @@ rawHtmlInline = do
then (\x -> isInlineTag x &&
not (isCloseBlockTag x))
else not . isTextTag
- return $ B.rawInline "html" result
+ return $ return $ B.rawInline "html" result
-- Citations
-cite :: MarkdownParser Inlines
+cite :: MarkdownParser (F Inlines)
cite = do
guardEnabled Ext_citations
- textualCite <|> do (cs, raw) <- withRaw normalCite
- return $ B.cite cs (B.text raw)
+ citations <- textualCite
+ <|> do (cs, raw) <- withRaw normalCite
+ return $ (flip B.cite (B.text raw)) <$> cs
+ return citations
-textualCite :: MarkdownParser Inlines
+textualCite :: MarkdownParser (F Inlines)
textualCite = try $ do
(_, key) <- citeKey
let first = Citation{ citationId = key
@@ -1872,26 +1885,29 @@ textualCite = try $ do
case mbrest of
Just (rest, raw) ->
return $ (flip B.cite (B.text $ '@':key ++ " " ++ raw) . (first:))
- rest
+ <$> rest
Nothing ->
(do (cs, raw) <- withRaw $ bareloc first
- return $ B.cite cs (B.text $ '@':key ++ " " ++ raw))
- <|> do st <- ask
- return $ case M.lookup key (stateExamples st) of
- Just n -> B.str (show n)
- _ -> B.cite [first] $ B.str $ '@':key
+ return $ (flip B.cite (B.text $ '@':key ++ " " ++ raw)) <$> cs)
+ <|> return (do st <- askF
+ return $ case M.lookup key (stateExamples st) of
+ Just n -> B.str (show n)
+ _ -> B.cite [first] $ B.str $ '@':key)
-bareloc :: Citation -> MarkdownParser [Citation]
+bareloc :: Citation -> MarkdownParser (F [Citation])
bareloc c = try $ do
spnl
char '['
suff <- suffix
- rest <- option [] $ try $ char ';' >> citeList
+ rest <- option (return []) $ try $ char ';' >> citeList
spnl
char ']'
- return $ c{ citationSuffix = B.toList suff } : rest
+ return $ do
+ suff' <- suff
+ rest' <- rest
+ return $ c{ citationSuffix = B.toList suff' } : rest'
-normalCite :: MarkdownParser [Citation]
+normalCite :: MarkdownParser (F [Citation])
normalCite = try $ do
char '['
spnl
@@ -1900,57 +1916,60 @@ normalCite = try $ do
char ']'
return citations
-suffix :: MarkdownParser Inlines
+suffix :: MarkdownParser (F Inlines)
suffix = try $ do
hasSpace <- option False (notFollowedBy nonspaceChar >> return True)
spnl
- rest <- trimInlines . mconcat <$> many (notFollowedBy (oneOf ";]") >> inline)
+ rest <- trimInlinesF . mconcat <$> many (notFollowedBy (oneOf ";]") >> inline)
return $ if hasSpace
- then B.space <> rest
+ then (B.space <>) <$> rest
else rest
-prefix :: MarkdownParser Inlines
-prefix = trimInlines . mconcat <$>
+prefix :: MarkdownParser (F Inlines)
+prefix = trimInlinesF . mconcat <$>
manyTill inline (char ']' <|> liftM (const ']') (lookAhead citeKey))
-citeList :: MarkdownParser [Citation]
-citeList = sepBy1 citation (try $ char ';' >> spnl)
+citeList :: MarkdownParser (F [Citation])
+citeList = fmap sequence $ sepBy1 citation (try $ char ';' >> spnl)
-citation :: MarkdownParser Citation
+citation :: MarkdownParser (F Citation)
citation = try $ do
pref <- prefix
(suppress_author, key) <- citeKey
suff <- suffix
- return Citation{ citationId = key
- , citationPrefix = B.toList pref
- , citationSuffix = B.toList suff
- , citationMode = if suppress_author
- then SuppressAuthor
- else NormalCitation
- , citationNoteNum = 0
- , citationHash = 0
- }
-
-smart :: MarkdownParser Inlines
+ return $ do
+ x <- pref
+ y <- suff
+ return $ Citation{ citationId = key
+ , citationPrefix = B.toList x
+ , citationSuffix = B.toList y
+ , citationMode = if suppress_author
+ then SuppressAuthor
+ else NormalCitation
+ , citationNoteNum = 0
+ , citationHash = 0
+ }
+
+smart :: MarkdownParser (F Inlines)
smart = do
getOption readerSmart >>= guard
doubleQuoted <|> singleQuoted <|>
- choice [apostrophe, dash, ellipses]
+ choice (map (return <$>) [apostrophe, dash, ellipses])
-singleQuoted :: MarkdownParser Inlines
+singleQuoted :: MarkdownParser (F Inlines)
singleQuoted = try $ do
singleQuoteStart
withQuoteContext InSingleQuote $
- B.singleQuoted . trimInlines . mconcat <$>
+ fmap B.singleQuoted . trimInlinesF . mconcat <$>
many1Till inline singleQuoteEnd
-- 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 Inlines
+doubleQuoted :: MarkdownParser (F Inlines)
doubleQuoted = try $ do
doubleQuoteStart
contents <- mconcat <$> many (try $ notFollowedBy doubleQuoteEnd >> inline)
- (withQuoteContext InDoubleQuote doubleQuoteEnd >> return
- (B.doubleQuoted . trimInlines $ contents))
- <|> return (B.str "\8220" <> contents)
+ (withQuoteContext InDoubleQuote $ doubleQuoteEnd >> return
+ (fmap B.doubleQuoted . trimInlinesF $ contents))
+ <|> (return $ return (B.str "\8220") <> contents)
diff --git a/src/Text/Pandoc/Readers/Org.hs b/src/Text/Pandoc/Readers/Org.hs
index fc63cc11e..ad9dc3ee8 100644
--- a/src/Text/Pandoc/Readers/Org.hs
+++ b/src/Text/Pandoc/Readers/Org.hs
@@ -1,9 +1,6 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, FlexibleInstances #-}
{-
Copyright (C) 2014 Albert Krewinkel <tarleb@moltkeplatz.de>
@@ -39,7 +36,8 @@ import Text.Pandoc.Builder ( Inlines, Blocks, HasMeta(..), (<>)
import Text.Pandoc.Definition
import Text.Pandoc.Options
import qualified Text.Pandoc.Parsing as P
-import Text.Pandoc.Parsing hiding ( newline, orderedListMarker
+import Text.Pandoc.Parsing hiding ( F, unF, askF, asksF, runF
+ , newline, orderedListMarker
, parseFromString, blanklines
)
import Text.Pandoc.Readers.LaTeX (inlineCommand, rawLaTeXInline)
@@ -47,17 +45,17 @@ import Text.Pandoc.Shared (compactify', compactify'DL)
import Text.TeXMath (readTeX, writePandoc, DisplayType(..))
import qualified Text.TeXMath.Readers.MathML.EntityMap as MathMLEntityMap
-import Control.Applicative ( pure
+import Control.Applicative ( Applicative, pure
, (<$>), (<$), (<*>), (<*), (*>) )
import Control.Arrow (first)
-import Control.Monad (guard, mplus, mzero, when)
-import Control.Monad.Reader (Reader, runReader, asks, local)
+import Control.Monad (foldM, guard, liftM, liftM2, mplus, mzero, when)
+import Control.Monad.Reader (Reader, runReader, ask, asks, local)
import Data.Char (isAlphaNum, toLower)
import Data.Default
-import Data.List (intersperse, isPrefixOf, isSuffixOf, foldl')
+import Data.List (intersperse, isPrefixOf, isSuffixOf)
import qualified Data.Map as M
import Data.Maybe (fromMaybe, isJust)
-import Data.Monoid (mconcat, mempty, mappend)
+import Data.Monoid (Monoid, mconcat, mempty, mappend)
import Network.HTTP (urlEncode)
import Text.Pandoc.Error
@@ -66,28 +64,19 @@ import Text.Pandoc.Error
readOrg :: ReaderOptions -- ^ Reader options
-> String -- ^ String to parse (assuming @'\n'@ line endings)
-> Either PandocError Pandoc
-readOrg opts s = runOrg opts s parseOrg
+readOrg opts s = flip runReader def $ readWithM parseOrg def{ orgStateOptions = opts } (s ++ "\n\n")
-data OrgParserLocal = OrgParserLocal { orgLocalQuoteContext :: QuoteContext
- , finalState :: OrgParserState }
+data OrgParserLocal = OrgParserLocal { orgLocalQuoteContext :: QuoteContext }
type OrgParser = ParserT [Char] OrgParserState (Reader OrgParserLocal)
-runOrg :: ReaderOptions -> String -> OrgParser a -> Either PandocError a
-runOrg opts inp p = fst <$> res
- where
- imd = readWithM (returnState p) def{ orgStateOptions = opts } (inp ++ "\n\n")
- res = runReader imd def { finalState = s }
- s :: OrgParserState
- s = either def snd res
-
parseOrg :: OrgParser Pandoc
parseOrg = do
blocks' <- parseBlocks
st <- getState
- let meta = orgStateMeta st
+ let meta = runF (orgStateMeta' st) st
let removeUnwantedBlocks = dropCommentTrees . filter (/= Null)
- return $ Pandoc meta $ removeUnwantedBlocks (B.toList $ blocks')
+ return $ Pandoc meta $ removeUnwantedBlocks (B.toList $ runF blocks' st)
-- | Drop COMMENT headers and the document tree below those headers.
dropCommentTrees :: [Block] -> [Block]
@@ -117,7 +106,7 @@ isHeaderLevelLowerEq n blk =
-- Parser State for Org
--
-type OrgNoteRecord = (String, Blocks)
+type OrgNoteRecord = (String, F Blocks)
type OrgNoteTable = [OrgNoteRecord]
type OrgBlockAttributes = M.Map String String
@@ -136,11 +125,12 @@ data OrgParserState = OrgParserState
, orgStateLastStrPos :: Maybe SourcePos
, orgStateLinkFormatters :: OrgLinkFormatters
, orgStateMeta :: Meta
+ , orgStateMeta' :: F Meta
, orgStateNotes' :: OrgNoteTable
}
instance Default OrgParserLocal where
- def = OrgParserLocal NoQuote def
+ def = OrgParserLocal NoQuote
instance HasReaderOptions OrgParserState where
extractReaderOptions = orgStateOptions
@@ -174,13 +164,13 @@ defaultOrgParserState = OrgParserState
, orgStateLastStrPos = Nothing
, orgStateLinkFormatters = M.empty
, orgStateMeta = nullMeta
+ , orgStateMeta' = return nullMeta
, orgStateNotes' = []
}
recordAnchorId :: String -> OrgParser ()
recordAnchorId i = updateState $ \s ->
- let as = orgStateAnchorIds s in
- s{ orgStateAnchorIds = i : as }
+ s{ orgStateAnchorIds = i : (orgStateAnchorIds s) }
addBlockAttribute :: String -> String -> OrgParser ()
addBlockAttribute key val = updateState $ \s ->
@@ -259,6 +249,30 @@ parseFromString parser str' = do
-- Adaptions and specializations of parsing utilities
--
+newtype F a = F { unF :: Reader OrgParserState a
+ } deriving (Monad, Applicative, Functor)
+
+runF :: F a -> OrgParserState -> a
+runF = runReader . unF
+
+askF :: F OrgParserState
+askF = F ask
+
+asksF :: (OrgParserState -> a) -> F a
+asksF f = F $ asks f
+
+instance Monoid a => Monoid (F a) where
+ mempty = return mempty
+ mappend = liftM2 mappend
+ mconcat = fmap mconcat . sequence
+
+trimInlinesF :: F Inlines -> F Inlines
+trimInlinesF = liftM trimInlines
+
+returnF :: a -> OrgParser (F a)
+returnF = return . return
+
+
-- | Like @Text.Parsec.Char.newline@, but causes additional state changes.
newline :: OrgParser Char
newline =
@@ -277,10 +291,10 @@ blanklines =
-- parsing blocks
--
-parseBlocks :: OrgParser Blocks
+parseBlocks :: OrgParser (F Blocks)
parseBlocks = mconcat <$> manyTill block eof
-block :: OrgParser Blocks
+block :: OrgParser (F Blocks)
block = choice [ mempty <$ blanklines
, optionalAttributes $ choice
[ orgBlock
@@ -291,14 +305,14 @@ block = choice [ mempty <$ blanklines
, drawer
, specialLine
, header
- , hline
+ , return <$> hline
, list
, latexFragment
, noteBlock
, paraOrPlain
] <?> "block"
-optionalAttributes :: OrgParser Blocks -> OrgParser Blocks
+optionalAttributes :: OrgParser (F Blocks) -> OrgParser (F Blocks)
optionalAttributes parser = try $
resetBlockAttributes *> parseBlockAttributes *> parser
@@ -318,7 +332,7 @@ parseAndAddAttribute key value = do
let key' = map toLower key
() <$ addBlockAttribute key' value
-lookupInlinesAttr :: String -> OrgParser (Maybe Inlines)
+lookupInlinesAttr :: String -> OrgParser (Maybe (F Inlines))
lookupInlinesAttr attr = try $ do
val <- lookupBlockAttribute attr
maybe (return Nothing)
@@ -332,20 +346,20 @@ lookupInlinesAttr attr = try $ do
type BlockProperties = (Int, String) -- (Indentation, Block-Type)
-orgBlock :: OrgParser Blocks
+orgBlock :: OrgParser (F Blocks)
orgBlock = try $ do
blockProp@(_, blkType) <- blockHeaderStart
($ blockProp) $
case blkType of
"comment" -> withRaw' (const mempty)
- "html" -> withRaw' (B.rawBlock blkType)
- "latex" -> withRaw' (B.rawBlock blkType)
- "ascii" -> withRaw' (B.rawBlock blkType)
- "example" -> withRaw' exampleCode
- "quote" -> withParsed B.blockQuote
+ "html" -> withRaw' (return . (B.rawBlock blkType))
+ "latex" -> withRaw' (return . (B.rawBlock blkType))
+ "ascii" -> withRaw' (return . (B.rawBlock blkType))
+ "example" -> withRaw' (return . exampleCode)
+ "quote" -> withParsed (fmap B.blockQuote)
"verse" -> verseBlock
"src" -> codeBlock
- _ -> withParsed (divWithClass blkType)
+ _ -> withParsed (fmap $ divWithClass blkType)
blockHeaderStart :: OrgParser (Int, String)
blockHeaderStart = try $ (,) <$> indent <*> blockType
@@ -353,10 +367,10 @@ blockHeaderStart = try $ (,) <$> indent <*> blockType
indent = length <$> many spaceChar
blockType = map toLower <$> (stringAnyCase "#+begin_" *> orgArgWord)
-withRaw' :: (String -> Blocks) -> BlockProperties -> OrgParser Blocks
+withRaw' :: (String -> F Blocks) -> BlockProperties -> OrgParser (F Blocks)
withRaw' f blockProp = (ignHeaders *> (f <$> rawBlockContent blockProp))
-withParsed :: (Blocks -> Blocks) -> BlockProperties -> OrgParser Blocks
+withParsed :: (F Blocks -> F Blocks) -> BlockProperties -> OrgParser (F Blocks)
withParsed f blockProp = (ignHeaders *> (f <$> parsedBlockContent blockProp))
ignHeaders :: OrgParser ()
@@ -365,11 +379,11 @@ ignHeaders = (() <$ newline) <|> (() <$ anyLine)
divWithClass :: String -> Blocks -> Blocks
divWithClass cls = B.divWith ("", [cls], [])
-verseBlock :: BlockProperties -> OrgParser Blocks
+verseBlock :: BlockProperties -> OrgParser (F Blocks)
verseBlock blkProp = try $ do
ignHeaders
content <- rawBlockContent blkProp
- B.para . mconcat . intersperse B.linebreak
+ fmap B.para . mconcat . intersperse (pure B.linebreak)
<$> mapM (parseFromString parseInlines) (lines content)
exportsCode :: [(String, String)] -> Bool
@@ -386,7 +400,7 @@ followingResultsBlock =
*> blankline
*> (unlines <$> many1 exampleLine))
-codeBlock :: BlockProperties -> OrgParser Blocks
+codeBlock :: BlockProperties -> OrgParser (F Blocks)
codeBlock blkProp = do
skipSpaces
(classes, kv) <- codeHeaderArgs <|> (mempty <$ ignHeaders)
@@ -396,15 +410,17 @@ codeBlock blkProp = do
let includeCode = exportsCode kv
let includeResults = exportsResults kv
let codeBlck = B.codeBlockWith ( id', classes, kv ) content
- labelledBlck <- maybe codeBlck (labelDiv codeBlck)
+ labelledBlck <- maybe (pure codeBlck)
+ (labelDiv codeBlck)
<$> lookupInlinesAttr "caption"
- let resultBlck = maybe mempty exampleCode resultsContent
+ let resultBlck = pure $ maybe mempty (exampleCode) resultsContent
return $ (if includeCode then labelledBlck else mempty)
<> (if includeResults then resultBlck else mempty)
where
labelDiv blk value =
- B.divWith nullAttr (labelledBlock value <> blk)
- labelledBlock = B.plain . B.spanWith ("", ["label"], [])
+ B.divWith nullAttr <$> (mappend <$> labelledBlock value
+ <*> pure blk)
+ labelledBlock = fmap (B.plain . B.spanWith ("", ["label"], []))
rawBlockContent :: BlockProperties -> OrgParser String
rawBlockContent (indent, blockType) = try $
@@ -413,7 +429,7 @@ rawBlockContent (indent, blockType) = try $
indentedLine = try $ ("" <$ blankline) <|> (indentWith indent *> anyLine)
blockEnder = try $ indentWith indent *> stringAnyCase ("#+end_" <> blockType)
-parsedBlockContent :: BlockProperties -> OrgParser Blocks
+parsedBlockContent :: BlockProperties -> OrgParser (F Blocks)
parsedBlockContent blkProps = try $ do
raw <- rawBlockContent blkProps
parseFromString parseBlocks (raw ++ "\n")
@@ -504,9 +520,9 @@ commaEscaped (',':cs@('*':_)) = cs
commaEscaped (',':cs@('#':'+':_)) = cs
commaEscaped cs = cs
-example :: OrgParser Blocks
+example :: OrgParser (F Blocks)
example = try $ do
- return . exampleCode =<< unlines <$> many1 exampleLine
+ return . return . exampleCode =<< unlines <$> many1 exampleLine
exampleCode :: String -> Blocks
exampleCode = B.codeBlockWith ("", ["example"], [])
@@ -515,7 +531,7 @@ exampleLine :: OrgParser String
exampleLine = try $ skipSpaces *> string ": " *> anyLine
-- Drawers for properties or a logbook
-drawer :: OrgParser Blocks
+drawer :: OrgParser (F Blocks)
drawer = try $ do
drawerStart
manyTill drawerLine (try drawerEnd)
@@ -541,12 +557,14 @@ drawerEnd = try $
--
-- Figures (Image on a line by itself, preceded by name and/or caption)
-figure :: OrgParser Blocks
+figure :: OrgParser (F Blocks)
figure = try $ do
(cap, nam) <- nameAndCaption
src <- skipSpaces *> selfTarget <* skipSpaces <* P.newline
guard (isImageFilename src)
- return $ B.para $ B.image src nam cap
+ return $ do
+ cap' <- cap
+ return $ B.para $ B.image src nam cap'
where
nameAndCaption =
do
@@ -562,8 +580,8 @@ figure = try $ do
--
-- Comments, Options and Metadata
-specialLine :: OrgParser Blocks
-specialLine = try $ metaLine <|> commentLine
+specialLine :: OrgParser (F Blocks)
+specialLine = fmap return . try $ metaLine <|> commentLine
metaLine :: OrgParser Blocks
metaLine = try $ mempty
@@ -583,14 +601,14 @@ commentLineStart = try $ mappend <$> many spaceChar <*> string "# "
declarationLine :: OrgParser ()
declarationLine = try $ do
key <- metaKey
- inlines <- metaInlines
+ inlinesF <- metaInlines
updateState $ \st ->
- let meta' = B.setMeta key inlines nullMeta
- in st { orgStateMeta = orgStateMeta st <> meta' }
+ let meta' = B.setMeta <$> pure key <*> inlinesF <*> pure nullMeta
+ in st { orgStateMeta' = orgStateMeta' st <> meta' }
return ()
-metaInlines :: OrgParser MetaValue
-metaInlines = (MetaInlines . B.toList) <$> inlinesTillNewline
+metaInlines :: OrgParser (F MetaValue)
+metaInlines = fmap (MetaInlines . B.toList) <$> inlinesTillNewline
metaKey :: OrgParser String
metaKey = map toLower <$> many1 (noneOf ": \n\r")
@@ -631,11 +649,11 @@ parseFormat = try $ do
--
-- | Headers
-header :: OrgParser Blocks
+header :: OrgParser (F Blocks)
header = try $ do
level <- headerStart
title <- inlinesTillNewline
- return $ B.header level title
+ return $ B.header level <$> title
headerStart :: OrgParser Int
headerStart = try $
@@ -659,7 +677,7 @@ hline = try $ do
-- Tables
--
-data OrgTableRow = OrgContentRow [Blocks]
+data OrgTableRow = OrgContentRow (F [Blocks])
| OrgAlignRow [Alignment]
| OrgHlineRow
@@ -670,13 +688,13 @@ data OrgTable = OrgTable
, orgTableRows :: [[Blocks]]
}
-table :: OrgParser Blocks
+table :: OrgParser (F Blocks)
table = try $ do
lookAhead tableStart
do
rows <- tableRows
- (cptn :: Inlines) <- fromMaybe "" <$> lookupInlinesAttr "caption"
- return $ ($ cptn) . orgToPandocTable . normalizeTable . rowsToTable $ rows
+ cptn <- fromMaybe (pure "") <$> lookupInlinesAttr "caption"
+ return $ (<$> cptn) . orgToPandocTable . normalizeTable =<< rowsToTable rows
orgToPandocTable :: OrgTable
-> Inlines
@@ -692,11 +710,11 @@ tableRows = try $ many (tableAlignRow <|> tableHline <|> tableContentRow)
tableContentRow :: OrgParser OrgTableRow
tableContentRow = try $
- OrgContentRow <$> (tableStart *> manyTill tableContentCell newline)
+ OrgContentRow . sequence <$> (tableStart *> manyTill tableContentCell newline)
-tableContentCell :: OrgParser Blocks
+tableContentCell :: OrgParser (F Blocks)
tableContentCell = try $
- B.plain . trimInlines . mconcat <$> many1Till inline endOfCell
+ fmap B.plain . trimInlinesF . mconcat <$> many1Till inline endOfCell
endOfCell :: OrgParser Char
endOfCell = try $ char '|' <|> lookAhead newline
@@ -728,8 +746,8 @@ tableHline = try $
OrgHlineRow <$ (tableStart *> char '-' *> anyLine)
rowsToTable :: [OrgTableRow]
- -> OrgTable
-rowsToTable = foldl' (flip rowToContent) zeroTable
+ -> F OrgTable
+rowsToTable = foldM (flip rowToContent) zeroTable
where zeroTable = OrgTable 0 mempty mempty mempty
normalizeTable :: OrgTable
@@ -748,43 +766,45 @@ normalizeTable (OrgTable cols aligns heads lns) =
-- line as a header. All other horizontal lines are discarded.
rowToContent :: OrgTableRow
-> OrgTable
- -> OrgTable
+ -> F OrgTable
rowToContent OrgHlineRow t = maybeBodyToHeader t
-rowToContent (OrgAlignRow as) t = setLongestRow as . setAligns as $ t
-rowToContent (OrgContentRow rf) t = setLongestRow rf . appendToBody rf $ t
+rowToContent (OrgAlignRow as) t = setLongestRow as =<< setAligns as t
+rowToContent (OrgContentRow rf) t = do
+ rs <- rf
+ setLongestRow rs =<< appendToBody rs t
setLongestRow :: [a]
-> OrgTable
- -> OrgTable
+ -> F OrgTable
setLongestRow rs t =
- t{ orgTableColumns = max (length rs) (orgTableColumns t) }
+ return t{ orgTableColumns = max (length rs) (orgTableColumns t) }
maybeBodyToHeader :: OrgTable
- -> OrgTable
+ -> F OrgTable
maybeBodyToHeader t = case t of
OrgTable{ orgTableHeader = [], orgTableRows = b:[] } ->
- t{ orgTableHeader = b , orgTableRows = [] }
- _ -> t
+ return t{ orgTableHeader = b , orgTableRows = [] }
+ _ -> return t
appendToBody :: [Blocks]
-> OrgTable
- -> OrgTable
-appendToBody r t = t{ orgTableRows = orgTableRows t ++ [r] }
+ -> F OrgTable
+appendToBody r t = return t{ orgTableRows = orgTableRows t ++ [r] }
setAligns :: [Alignment]
-> OrgTable
- -> OrgTable
-setAligns aligns t = t{ orgTableAlignments = aligns }
+ -> F OrgTable
+setAligns aligns t = return $ t{ orgTableAlignments = aligns }
--
-- LaTeX fragments
--
-latexFragment :: OrgParser Blocks
+latexFragment :: OrgParser (F Blocks)
latexFragment = try $ do
envName <- latexEnvStart
content <- mconcat <$> manyTill anyLineNewline (latexEnd envName)
- return $ B.rawBlock "latex" (content `inLatexEnv` envName)
+ return . return $ B.rawBlock "latex" (content `inLatexEnv` envName)
where
c `inLatexEnv` e = mconcat [ "\\begin{", e, "}\n"
, c
@@ -814,7 +834,7 @@ latexEnvName = try $ do
--
-- Footnote defintions
--
-noteBlock :: OrgParser Blocks
+noteBlock :: OrgParser (F Blocks)
noteBlock = try $ do
ref <- noteMarker <* skipSpaces
content <- mconcat <$> blocksTillHeaderOrNote
@@ -826,37 +846,37 @@ noteBlock = try $ do
<|> () <$ lookAhead headerStart)
-- Paragraphs or Plain text
-paraOrPlain :: OrgParser Blocks
+paraOrPlain :: OrgParser (F Blocks)
paraOrPlain = try $ do
ils <- parseInlines
nl <- option False (newline >> return True)
try (guard nl >> notFollowedBy (orderedListStart <|> bulletListStart) >>
- (return $ B.para ils))
- <|> (return $ B.plain ils)
+ return (B.para <$> ils))
+ <|> (return (B.plain <$> ils))
-inlinesTillNewline :: OrgParser Inlines
-inlinesTillNewline = trimInlines . mconcat <$> manyTill inline newline
+inlinesTillNewline :: OrgParser (F Inlines)
+inlinesTillNewline = trimInlinesF . mconcat <$> manyTill inline newline
--
-- list blocks
--
-list :: OrgParser Blocks
+list :: OrgParser (F Blocks)
list = choice [ definitionList, bulletList, orderedList ] <?> "list"
-definitionList :: OrgParser Blocks
+definitionList :: OrgParser (F Blocks)
definitionList = try $ do n <- lookAhead (bulletListStart' Nothing)
- B.definitionList . compactify'DL
+ fmap B.definitionList . fmap compactify'DL . sequence
<$> many1 (definitionListItem $ bulletListStart' (Just n))
-bulletList :: OrgParser Blocks
+bulletList :: OrgParser (F Blocks)
bulletList = try $ do n <- lookAhead (bulletListStart' Nothing)
- B.bulletList . compactify'
+ fmap B.bulletList . fmap compactify' . sequence
<$> many1 (listItem (bulletListStart' $ Just n))
-orderedList :: OrgParser Blocks
-orderedList = B.orderedList . compactify'
+orderedList :: OrgParser (F Blocks)
+orderedList = fmap B.orderedList . fmap compactify' . sequence
<$> many1 (listItem orderedListStart)
genericListStart :: OrgParser String
@@ -893,7 +913,7 @@ orderedListStart = genericListStart orderedListMarker
where orderedListMarker = mappend <$> many1 digit <*> (pure <$> oneOf ".)")
definitionListItem :: OrgParser Int
- -> OrgParser (Inlines, [Blocks])
+ -> OrgParser (F (Inlines, [Blocks]))
definitionListItem parseMarkerGetLength = try $ do
markerLength <- parseMarkerGetLength
term <- manyTill (noneOf "\n\r") (try $ string "::")
@@ -902,12 +922,12 @@ definitionListItem parseMarkerGetLength = try $ do
cont <- concat <$> many (listContinuation markerLength)
term' <- parseFromString parseInlines term
contents' <- parseFromString parseBlocks $ line1 ++ blank ++ cont
- return (term', [contents'])
+ return $ (,) <$> term' <*> fmap (:[]) contents'
-- parse raw text for one list item, excluding start marker and continuations
listItem :: OrgParser Int
- -> OrgParser Blocks
+ -> OrgParser (F Blocks)
listItem start = try $ do
markerLength <- try start
firstLine <- anyLineNewline
@@ -933,7 +953,7 @@ anyLineNewline = (++ "\n") <$> anyLine
-- inline
--
-inline :: OrgParser Inlines
+inline :: OrgParser (F Inlines)
inline =
choice [ whitespace
, linebreak
@@ -960,31 +980,31 @@ inline =
] <* (guard =<< newlinesCountWithinLimits)
<?> "inline"
-parseInlines :: OrgParser Inlines
-parseInlines = trimInlines . mconcat <$> many1 inline
+parseInlines :: OrgParser (F Inlines)
+parseInlines = trimInlinesF . mconcat <$> many1 inline
-- treat these as potentially non-text when parsing inline:
specialChars :: [Char]
specialChars = "\"$'()*+-,./:<=>[\\]^_{|}~"
-whitespace :: OrgParser Inlines
-whitespace = B.space <$ skipMany1 spaceChar
+whitespace :: OrgParser (F Inlines)
+whitespace = pure B.space <$ skipMany1 spaceChar
<* updateLastPreCharPos
<* updateLastForbiddenCharPos
<?> "whitespace"
-linebreak :: OrgParser Inlines
-linebreak = try $ B.linebreak <$ string "\\\\" <* skipSpaces <* newline
+linebreak :: OrgParser (F Inlines)
+linebreak = try $ pure B.linebreak <$ string "\\\\" <* skipSpaces <* newline
-str :: OrgParser Inlines
-str = B.str <$> many1 (noneOf $ specialChars ++ "\n\r ")
+str :: OrgParser (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 Inlines
+endline :: OrgParser (F Inlines)
endline = try $ do
newline
notFollowedBy blankline
@@ -1002,72 +1022,77 @@ endline = try $ do
decEmphasisNewlinesCount
guard =<< newlinesCountWithinLimits
updateLastPreCharPos
- return $ B.space
+ return . return $ B.space
-cite :: OrgParser Inlines
+cite :: OrgParser (F Inlines)
cite = try $ do
guardEnabled Ext_citations
(cs, raw) <- withRaw normalCite
- return $ flip B.cite (B.text raw) cs
+ return $ (flip B.cite (B.text raw)) <$> cs
-normalCite :: OrgParser [Citation]
+normalCite :: OrgParser (F [Citation])
normalCite = try $ char '['
*> skipSpaces
*> citeList
<* skipSpaces
<* char ']'
-citeList :: OrgParser [Citation]
-citeList = sepBy1 citation (try $ char ';' *> skipSpaces)
+citeList :: OrgParser (F [Citation])
+citeList = sequence <$> sepBy1 citation (try $ char ';' *> skipSpaces)
-citation :: OrgParser Citation
+citation :: OrgParser (F Citation)
citation = try $ do
pref <- prefix
(suppress_author, key) <- citeKey
suff <- suffix
- return $ Citation{ citationId = key
- , citationPrefix = B.toList pref
- , citationSuffix = B.toList suff
- , citationMode = if suppress_author
- then SuppressAuthor
- else NormalCitation
- , citationNoteNum = 0
- , citationHash = 0
- }
+ return $ do
+ x <- pref
+ y <- suff
+ return $ Citation{ citationId = key
+ , citationPrefix = B.toList x
+ , citationSuffix = B.toList y
+ , citationMode = if suppress_author
+ then SuppressAuthor
+ else NormalCitation
+ , citationNoteNum = 0
+ , citationHash = 0
+ }
where
- prefix = trimInlines . mconcat <$>
+ prefix = trimInlinesF . mconcat <$>
manyTill inline (char ']' <|> (']' <$ lookAhead citeKey))
suffix = try $ do
hasSpace <- option False (notFollowedBy nonspaceChar >> return True)
skipSpaces
- rest <- trimInlines . mconcat <$>
+ rest <- trimInlinesF . mconcat <$>
many (notFollowedBy (oneOf ";]") *> inline)
- return $
- if hasSpace
- then B.space <> rest
- else rest
+ return $ if hasSpace
+ then (B.space <>) <$> rest
+ else rest
-footnote :: OrgParser Inlines
+footnote :: OrgParser (F Inlines)
footnote = try $ inlineNote <|> referencedNote
-inlineNote :: OrgParser Inlines
+inlineNote :: OrgParser (F Inlines)
inlineNote = try $ do
string "[fn:"
ref <- many alphaNum
char ':'
- note <- B.para . trimInlines . mconcat <$> many1Till inline (char ']')
+ note <- fmap B.para . trimInlinesF . mconcat <$> many1Till inline (char ']')
when (not $ null ref) $
addToNotesTable ("fn:" ++ ref, note)
- return $ B.note note
+ return $ B.note <$> note
-referencedNote :: OrgParser Inlines
+referencedNote :: OrgParser (F Inlines)
referencedNote = try $ do
ref <- noteMarker
- notes <- asks (orgStateNotes' . finalState)
- return $
+ return $ do
+ notes <- asksF orgStateNotes'
case lookup ref notes of
- Just contents -> B.note contents
- Nothing -> B.str $ "[" ++ ref ++ "]"
+ Nothing -> return $ B.str $ "[" ++ ref ++ "]"
+ Just contents -> do
+ st <- askF
+ let contents' = runF contents st{ orgStateNotes' = [] }
+ return $ B.note contents'
noteMarker :: OrgParser String
noteMarker = try $ do
@@ -1077,37 +1102,37 @@ noteMarker = try $ do
<*> many1Till (noneOf "\n\r\t ") (char ']')
]
-linkOrImage :: OrgParser Inlines
+linkOrImage :: OrgParser (F Inlines)
linkOrImage = explicitOrImageLink
<|> selflinkOrImage
<|> angleLink
<|> plainLink
<?> "link or image"
-explicitOrImageLink :: OrgParser Inlines
+explicitOrImageLink :: OrgParser (F Inlines)
explicitOrImageLink = try $ do
char '['
- src <- applyCustomLinkFormat =<< possiblyEmptyLinkTarget
+ srcF <- applyCustomLinkFormat =<< possiblyEmptyLinkTarget
title <- enclosedRaw (char '[') (char ']')
title' <- parseFromString (mconcat <$> many inline) title
char ']'
- alt <- internalLink src title'
- return $
- (if isImageFilename title
- then B.link src "" $ B.image title mempty mempty
- else fromMaybe alt (linkToInlines src title'))
+ return $ do
+ src <- srcF
+ if isImageFilename title
+ then pure $ B.link src "" $ B.image title mempty mempty
+ else linkToInlinesF src =<< title'
-selflinkOrImage :: OrgParser Inlines
+selflinkOrImage :: OrgParser (F Inlines)
selflinkOrImage = try $ do
src <- char '[' *> linkTarget <* char ']'
- return $ fromMaybe "" (linkToInlines src (B.str src))
+ return $ linkToInlinesF src (B.str src)
-plainLink :: OrgParser Inlines
+plainLink :: OrgParser (F Inlines)
plainLink = try $ do
(orig, src) <- uri
- return $ B.link src "" (B.str orig)
+ returnF $ B.link src "" (B.str orig)
-angleLink :: OrgParser Inlines
+angleLink :: OrgParser (F Inlines)
angleLink = try $ do
char '<'
link <- plainLink
@@ -1123,31 +1148,26 @@ linkTarget = enclosedByPair '[' ']' (noneOf "\n\r[]")
possiblyEmptyLinkTarget :: OrgParser String
possiblyEmptyLinkTarget = try linkTarget <|> ("" <$ string "[]")
-applyCustomLinkFormat :: String -> OrgParser String
+applyCustomLinkFormat :: String -> OrgParser (F String)
applyCustomLinkFormat link = do
let (linkType, rest) = break (== ':') link
- fmts <- asks finalState
- return $
- case M.lookup linkType (orgStateLinkFormatters fmts) of
- Just v -> (v (drop 1 rest))
- Nothing -> link
+ return $ do
+ formatter <- M.lookup linkType <$> asksF orgStateLinkFormatters
+ return $ maybe link ($ drop 1 rest) formatter
-- TODO: might be a lot smarter/cleaner to use parsec and ADTs for this kind
-- of parsing.
-linkToInlines :: String -> Inlines -> Maybe Inlines
-linkToInlines = \s ->
+linkToInlinesF :: String -> Inlines -> F Inlines
+linkToInlinesF s =
case s of
- _ | null s -> Just . B.link "" ""
- _ | isAnchor s -> Just . B.link s ""
- _ | isImageFilename s -> const . Just $ B.image s "" ""
- _ | isFileLink s -> Just . B.link (dropLinkType s) ""
- _ | isUri s -> Just . B.link s ""
- _ | isAbsoluteFilePath s -> Just . B.link ("file://" ++ s) ""
- _ | isRelativeFilePath s -> Just . B.link s ""
- _ -> const Nothing
-
-isAnchor :: String -> Bool
-isAnchor s = "#" `isPrefixOf` s
+ "" -> pure . B.link "" ""
+ ('#':_) -> pure . B.link s ""
+ _ | isImageFilename s -> const . pure $ B.image s "" ""
+ _ | isFileLink s -> pure . B.link (dropLinkType s) ""
+ _ | isUri s -> pure . B.link s ""
+ _ | isAbsoluteFilePath s -> pure . B.link ("file://" ++ s) ""
+ _ | isRelativeFilePath s -> pure . B.link s ""
+ _ -> internalLink s
isFileLink :: String -> Bool
isFileLink s = ("file:" `isPrefixOf` s) && not ("file://" `isPrefixOf` s)
@@ -1176,13 +1196,12 @@ isImageFilename filename =
imageExtensions = [ "jpeg" , "jpg" , "png" , "gif" , "svg" ]
protocols = [ "file", "http", "https" ]
-internalLink :: String -> Inlines -> OrgParser Inlines
+internalLink :: String -> Inlines -> F Inlines
internalLink link title = do
- anchorB <- asks finalState
- return $
- if link `elem` (orgStateAnchorIds anchorB)
- then B.link ('#':link) "" title
- else B.emph title
+ anchorB <- (link `elem`) <$> asksF orgStateAnchorIds
+ if anchorB
+ then return $ B.link ('#':link) "" title
+ else return $ B.emph title
-- | Parse an anchor like @<<anchor-id>>@ and return an empty span with
-- @anchor-id@ set as id. Legal anchors in org-mode are defined through
@@ -1190,11 +1209,11 @@ internalLink link title = do
-- @anchor-id@ contains spaces, we are more restrictive in what is accepted as
-- an anchor.
-anchor :: OrgParser Inlines
+anchor :: OrgParser (F Inlines)
anchor = try $ do
anchorId <- parseAnchor
recordAnchorId anchorId
- return $ B.spanWith (solidify anchorId, [], []) mempty
+ returnF $ B.spanWith (solidify anchorId, [], []) mempty
where
parseAnchor = string "<<"
*> many1 (noneOf "\t\n\r<>\"' ")
@@ -1212,7 +1231,7 @@ solidify = map replaceSpecialChar
| otherwise = '-'
-- | Parses an inline code block and marks it as an babel block.
-inlineCodeBlock :: OrgParser Inlines
+inlineCodeBlock :: OrgParser (F Inlines)
inlineCodeBlock = try $ do
string "src_"
lang <- many1 orgArgWordChar
@@ -1220,7 +1239,7 @@ inlineCodeBlock = try $ do
inlineCode <- enclosedByPair '{' '}' (noneOf "\n\r")
let attrClasses = [translateLang lang, rundocBlockClass]
let attrKeyVal = map toRundocAttrib (("language", lang) : opts)
- return $ B.codeWith ("", attrClasses, attrKeyVal) inlineCode
+ returnF $ B.codeWith ("", attrClasses, attrKeyVal) inlineCode
enclosedByPair :: Char -- ^ opening char
-> Char -- ^ closing char
@@ -1228,51 +1247,54 @@ enclosedByPair :: Char -- ^ opening char
-> OrgParser [a]
enclosedByPair s e p = char s *> many1Till p (char e)
-emph :: OrgParser Inlines
-emph = B.emph <$> emphasisBetween '/'
+emph :: OrgParser (F Inlines)
+emph = fmap B.emph <$> emphasisBetween '/'
-strong :: OrgParser Inlines
-strong = B.strong <$> emphasisBetween '*'
+strong :: OrgParser (F Inlines)
+strong = fmap B.strong <$> emphasisBetween '*'
-strikeout :: OrgParser Inlines
-strikeout = B.strikeout <$> emphasisBetween '+'
+strikeout :: OrgParser (F Inlines)
+strikeout = fmap B.strikeout <$> emphasisBetween '+'
-- There is no underline, so we use strong instead.
-underline :: OrgParser Inlines
-underline = B.strong <$> emphasisBetween '_'
+underline :: OrgParser (F Inlines)
+underline = fmap B.strong <$> emphasisBetween '_'
-verbatim :: OrgParser Inlines
-verbatim = B.code <$> verbatimBetween '='
+verbatim :: OrgParser (F Inlines)
+verbatim = return . B.code <$> verbatimBetween '='
-code :: OrgParser Inlines
-code = B.code <$> verbatimBetween '~'
+code :: OrgParser (F Inlines)
+code = return . B.code <$> verbatimBetween '~'
-subscript :: OrgParser Inlines
-subscript = B.subscript <$> try (char '_' *> subOrSuperExpr)
+subscript :: OrgParser (F Inlines)
+subscript = fmap B.subscript <$> try (char '_' *> subOrSuperExpr)
-superscript :: OrgParser Inlines
-superscript = B.superscript <$> try (char '^' *> subOrSuperExpr)
+superscript :: OrgParser (F Inlines)
+superscript = fmap B.superscript <$> try (char '^' *> subOrSuperExpr)
-math :: OrgParser Inlines
-math = B.math <$> choice [ math1CharBetween '$'
+math :: OrgParser (F Inlines)
+math = return . B.math <$> choice [ math1CharBetween '$'
, mathStringBetween '$'
, rawMathBetween "\\(" "\\)"
]
-displayMath :: OrgParser Inlines
-displayMath = B.displayMath <$> choice [ rawMathBetween "\\[" "\\]"
- , rawMathBetween "$$" "$$"
- ]
+displayMath :: OrgParser (F Inlines)
+displayMath = return . B.displayMath <$> choice [ rawMathBetween "\\[" "\\]"
+ , rawMathBetween "$$" "$$"
+ ]
+
+updatePositions :: Char
+ -> OrgParser (Char)
+updatePositions c = do
+ when (c `elem` emphasisPreChars) updateLastPreCharPos
+ when (c `elem` emphasisForbiddenBorderChars) updateLastForbiddenCharPos
+ return c
-symbol :: OrgParser Inlines
-symbol = B.str . (: "") <$> (oneOf specialChars >>= updatePositions)
- where updatePositions c = do
- when (c `elem` emphasisPreChars) updateLastPreCharPos
- when (c `elem` emphasisForbiddenBorderChars) updateLastForbiddenCharPos
- return c
+symbol :: OrgParser (F Inlines)
+symbol = return . B.str . (: "") <$> (oneOf specialChars >>= updatePositions)
emphasisBetween :: Char
- -> OrgParser Inlines
+ -> OrgParser (F Inlines)
emphasisBetween c = try $ do
startEmphasisNewlinesCounting emphasisAllowedNewlines
res <- enclosedInlines (emphasisStart c) (emphasisEnd c)
@@ -1349,9 +1371,9 @@ mathEnd c = try $ do
enclosedInlines :: OrgParser a
-> OrgParser b
- -> OrgParser Inlines
+ -> OrgParser (F Inlines)
enclosedInlines start end = try $
- trimInlines . mconcat <$> enclosed start end inline
+ trimInlinesF . mconcat <$> enclosed start end inline
enclosedRaw :: OrgParser a
-> OrgParser b
@@ -1430,7 +1452,7 @@ notAfterForbiddenBorderChar = do
return $ lastFBCPos /= Just pos
-- | Read a sub- or superscript expression
-subOrSuperExpr :: OrgParser Inlines
+subOrSuperExpr :: OrgParser (F Inlines)
subOrSuperExpr = try $
choice [ id <$> charsInBalanced '{' '}' (noneOf "\n\r")
, enclosing ('(', ')') <$> charsInBalanced '(' ')' (noneOf "\n\r")
@@ -1445,10 +1467,10 @@ simpleSubOrSuperString = try $
<*> many1 alphaNum
]
-inlineLaTeX :: OrgParser Inlines
+inlineLaTeX :: OrgParser (F Inlines)
inlineLaTeX = try $ do
cmd <- inlineLaTeXCommand
- maybe mzero return $
+ maybe mzero returnF $
parseAsMath cmd `mplus` parseAsMathMLSym cmd `mplus` parseAsInlineLaTeX cmd
where
parseAsMath :: String -> Maybe Inlines
@@ -1481,30 +1503,30 @@ inlineLaTeXCommand = try $ do
return cs
_ -> mzero
-smart :: OrgParser Inlines
+smart :: OrgParser (F Inlines)
smart = do
getOption readerSmart >>= guard
doubleQuoted <|> singleQuoted <|>
- choice [orgApostrophe, dash, ellipses]
+ choice (map (return <$>) [orgApostrophe, dash, ellipses])
where orgApostrophe =
(char '\'' <|> char '\8217') <* updateLastPreCharPos
<* updateLastForbiddenCharPos
*> return (B.str "\x2019")
-singleQuoted :: OrgParser Inlines
+singleQuoted :: OrgParser (F Inlines)
singleQuoted = try $ do
singleQuoteStart
withQuoteContext InSingleQuote $
- B.singleQuoted . trimInlines . mconcat <$>
+ fmap B.singleQuoted . trimInlinesF . mconcat <$>
many1Till inline singleQuoteEnd
-- 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 Inlines
+doubleQuoted :: OrgParser (F Inlines)
doubleQuoted = try $ do
doubleQuoteStart
contents <- mconcat <$> many (try $ notFollowedBy doubleQuoteEnd >> inline)
(withQuoteContext InDoubleQuote $ (doubleQuoteEnd <* updateLastForbiddenCharPos) >> return
- (B.doubleQuoted . trimInlines $ contents))
- <|> (return $ (B.str "\8220") <> contents)
+ (fmap B.doubleQuoted . trimInlinesF $ contents))
+ <|> (return $ return (B.str "\8220") <> contents)
diff --git a/src/Text/Pandoc/Readers/RST.hs b/src/Text/Pandoc/Readers/RST.hs
index a8112bc81..564267ee5 100644
--- a/src/Text/Pandoc/Readers/RST.hs
+++ b/src/Text/Pandoc/Readers/RST.hs
@@ -60,7 +60,7 @@ readRST :: ReaderOptions -- ^ Reader options
readRST opts s = (readWith parseRST) def{ stateOptions = opts } (s ++ "\n\n")
readRSTWithWarnings :: ReaderOptions -> String -> Either PandocError (Pandoc, [String])
-readRSTWithWarnings opts s = (readWith (returnWarnings parseRST)) def{ stateOptions = opts } (s ++ "\n\n")
+readRSTWithWarnings opts s = (readWithWarnings parseRST) def{ stateOptions = opts } (s ++ "\n\n")
type RSTParser = Parser [Char] ParserState
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-24 13:50:39 +0000