mmark-0.1.0.0: Text/MMark/Parser.hs
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
-- |
-- Module : Text.MMark.Parser
-- Copyright : © 2017–present Mark Karpov
-- License : BSD 3 clause
--
-- Maintainer : Mark Karpov <markkarpov92@gmail.com>
-- Stability : experimental
-- Portability : portable
--
-- MMark markdown parser.
module Text.MMark.Parser
( MMarkErr (..),
parse,
)
where
import Control.Applicative hiding (many, some)
import Control.Monad
import Control.Monad.Combinators.NonEmpty qualified as NE
import Data.Aeson qualified as Aeson
import Data.Bifunctor (Bifunctor (..))
import Data.Bool (bool)
import Data.Char qualified as Char
import Data.DList qualified as DList
import Data.HTML.Entities (htmlEntityMap)
import Data.HashMap.Strict qualified as HM
import Data.List (delete)
import Data.List.NonEmpty (NonEmpty (..), (<|))
import Data.List.NonEmpty qualified as NE
import Data.Maybe (catMaybes, fromJust, isJust, isNothing)
import Data.Monoid (Any (..))
import Data.Ratio ((%))
import Data.Set qualified as E
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.Encoding qualified as TE
import Lens.Micro ((^.))
import Text.Email.Validate qualified as Email
import Text.MMark.Internal.Type
import Text.MMark.Parser.Internal
import Text.MMark.Util
import Text.Megaparsec hiding (State (..), parse)
import Text.Megaparsec.Char hiding (eol)
import Text.Megaparsec.Char.Lexer qualified as L
import Text.URI (URI)
import Text.URI qualified as URI
import Text.URI.Lens (uriPath)
#if !defined(ghcjs_HOST_OS)
import qualified Data.Yaml as Yaml
#endif
----------------------------------------------------------------------------
-- Top-level API
-- | Parse a markdown document in the form of a strict 'Text' value and
-- either report parse errors or return an 'MMark' document.
parse ::
-- | File name (only to be used in error messages), may be empty
FilePath ->
-- | Input to parse
Text ->
-- | Parse errors or parsed document
Either (ParseErrorBundle Text MMarkErr) MMark
parse file input =
case runBParser pMMark file input of
Left bundle -> Left bundle
Right ((myaml, rawBlocks), defs) ->
let parsed = doInline <$> rawBlocks
doInline =
fmap $
first (replaceEof "end of inline block")
. runIParser defs pInlinesTop
e2p = either DList.singleton (const DList.empty)
in case NE.nonEmpty . DList.toList $ foldMap (foldMap e2p) parsed of
Nothing ->
Right
MMark
{ mmarkYaml = myaml,
mmarkBlocks = fmap fromRight <$> parsed,
mmarkSource = initialPosState file input
}
Just errs ->
Left
ParseErrorBundle
{ bundleErrors = errs,
bundlePosState = initialPosState file input
}
-- | The 'PosState' that lets us render errors against the source, both the
-- parser's own and the ones extensions report later on.
initialPosState :: FilePath -> Text -> PosState Text
initialPosState file input =
PosState
{ pstateInput = input,
pstateOffset = 0,
pstateSourcePos = initialPos file,
pstateTabWidth = mkPos 4,
pstateLinePrefix = ""
}
-- | The placeholder that block and inline parsers construct their results
-- with. 'pBlock' and 'pInlines' replace it with the real span of the source
-- the node was parsed from.
noSpan :: Span
noSpan = Span 0 0
----------------------------------------------------------------------------
-- Block parser
-- | Parse an MMark document on block level.
pMMark :: BParser (Maybe Aeson.Value, [Block Isp])
pMMark = do
meyaml <- optional pYamlBlock
blocks <- pBlocks
eof
return $ case meyaml of
Nothing ->
(Nothing, blocks)
Just (Left (o, err)) ->
(Nothing, prependErr o (YamlParseError err) blocks)
Just (Right yaml) ->
(Just yaml, blocks)
-- | Parse a YAML block. On success return the actual parsed 'Aeson.Value' in
-- 'Right', otherwise return 'SourcePos' of parse error and 'String'
-- describing the error as generated by the @yaml@ package in 'Left'.
pYamlBlock :: BParser (Either (Int, String) Aeson.Value)
pYamlBlock = do
string "---" *> sc' *> eol
let go acc = do
l <- takeWhileP Nothing notNewline
void (optional eol)
e <- atEnd
if e || T.stripEnd l == "---"
then return acc
else go (acc . (l :))
doffset <- getOffset
ls <- go id <*> ([] <$ sc)
return $ decodeYaml ls doffset
-- | Parse several (possibly zero) blocks in a row.
pBlocks :: BParser [Block Isp]
pBlocks = scQ *> (catMaybes <$> many pBlock)
-- | Parse a single block of a markdown document, recording the span of the
-- source it was parsed from.
pBlock :: BParser (Maybe (Block Isp))
pBlock = do
o <- getOffset
r <- pBlock'
o' <- getOffset
return (setBlockSpan (Span o o') <$> r)
-- | Parse a single block of a markdown document.
pBlock' :: BParser (Maybe (Block Isp))
pBlock' = do
rlevel <- refLevel
alevel <- indentLevel'
done <- atEnd
-- 'scQ' stops in front of a line ending when the next line does not
-- continue the block quote we are in, and it does not move at all when the
-- line we are on is not a part of it either. Both mean that the block
-- quote ends here.
inQuote <- quoteOk
atLineEnd <- succeeds (void (lookAhead eol))
let quoteEnded = not inQuote || atLineEnd
if done || quoteEnded || alevel < rlevel
then empty
else case compare alevel (ilevel rlevel) of
LT ->
choice
[ Just <$> pThematicBreak,
Just <$> pAtxHeading,
Just <$> pFencedCodeBlock,
-- NOTE This has to be tried before 'pTable', otherwise a line
-- such as @> | a | b |@ is taken for the header of a table
-- whose first cell happens to begin with a @>@ character.
Just <$> pBlockquote,
Just <$> pTable,
Just <$> pUnorderedList,
Just <$> pOrderedList,
pReferenceDef,
Just <$> pParagraph
]
_ ->
Just <$> pIndentedCodeBlock
-- | Parse a thematic break.
pThematicBreak :: BParser (Block Isp)
pThematicBreak = do
l' <- lookAhead nonEmptyLine
let l = T.filter (not . isSpace) l'
if T.length l >= 3
&& ( T.all (== '*') l
|| T.all (== '-') l
|| T.all (== '_') l
)
then ThematicBreak noSpan <$ nonEmptyLine <* scQ
else empty
-- | Parse an ATX heading.
pAtxHeading :: BParser (Block Isp)
pAtxHeading = do
(void . lookAhead . try) hashIntro
withRecovery recover $ do
hlevel <- length <$> hashIntro
sc1'
ispOffset <- getOffset
r <-
someTill (satisfy notNewline <?> "heading character") . try $
optional (sc1' *> some (char '#') *> sc')
*> (eof <|> void (lookAhead eol))
let toBlock = case hlevel of
1 -> Heading1 noSpan
2 -> Heading2 noSpan
3 -> Heading3 noSpan
4 -> Heading4 noSpan
5 -> Heading5 noSpan
_ -> Heading6 noSpan
toBlock (IspSpan ispOffset (T.strip (T.pack r))) <$ scQ
where
hashIntro = count' 1 6 (char '#')
recover err =
Heading1 noSpan (IspError err) <$ takeWhileP Nothing notNewline <* scQ
-- | Parse a fenced code block.
pFencedCodeBlock :: BParser (Block Isp)
pFencedCodeBlock = do
alevel <- indentLevel'
(ch, n, infoString) <- pOpeningFence
let content = label "code block content" $ do
quoteOk >>= guard
l <- option "" nonEmptyLine
done <- atEnd
-- The last line of the input may lack a line ending, but only when
-- it is not empty, otherwise we would keep producing empty lines
-- forever.
let lastLine = done && not (T.null l)
unless lastLine eolLazy
return l
ls <- manyTill content (pClosingFence ch n)
CodeBlock noSpan infoString (assembleCodeBlock alevel ls) <$ scQ
-- | Parse the opening fence of a fenced code block.
pOpeningFence :: BParser (Char, Int, Maybe Text)
pOpeningFence = p '`' <|> p '~'
where
p ch = try $ do
void $ count 3 (char ch)
n <- (+ 3) . length <$> many (char ch)
ml <-
optional
(T.strip <$> someEscapedWith notNewline <?> "info string")
-- A backtick in the info string of a backtick fence would be
-- ambiguous with the fence itself. Tilde fences have no such problem.
when (ch == '`') $
guard (maybe True (not . T.any (== '`')) ml)
( ch,
n,
case ml of
Nothing -> Nothing
Just l ->
if T.null l
then Nothing
else Just l
)
<$ eolLazy
-- | Parse the closing fence of a fenced code block.
pClosingFence :: Char -> Int -> BParser ()
pClosingFence ch n = tryB . label "closing code fence" $ do
quoteOk >>= guard
clevel <- ilevel <$> refLevel
sc'
alevel <- indentLevel'
guard (alevel < clevel)
void $ count n (char ch)
(void . many . char) ch
sc'
eof <|> eolLazy
-- | Parse an indented code block.
pIndentedCodeBlock :: BParser (Block Isp)
pIndentedCodeBlock = do
alevel <- indentLevel'
clevel <- ilevel <$> refLevel
let go ls = do
indented <- lookAheadB $ do
scQ
inQuote <- quoteOk
done <- atEnd
atLineEnd <- succeeds (void (lookAhead eol))
if not inQuote || done || atLineEnd
then return False
else do
nextLevel <- indentLevel'
return (nextLevel >= clevel)
if indented
then do
l <- option "" nonEmptyLine
continue <- eolLazy'
let ls' = ls . (l :)
if continue
then go ls'
else return ls'
else return ls
-- NOTE This is a bit unfortunate, but it's difficult to guarantee
-- that preceding space is not yet consumed when we get to
-- interpreting input as an indented code block, so we need to restore
-- the space this way.
f x = T.replicate (unPos alevel - 1) " " <> x
g [] = []
g (x : xs) = f x : xs
ls <- g . ($ []) <$> go id
CodeBlock noSpan Nothing (assembleCodeBlock clevel ls) <$ scQ
-- | Parse an unordered list.
pUnorderedList :: BParser (Block Isp)
pUnorderedList = do
(bullet, bulletPos, minLevel, indLevel) <-
pListBullet Nothing
x <- innerBlocks bulletPos minLevel indLevel
xs <- many $ do
-- A list cannot continue past the end of the block quote it is in.
quoteOk >>= guard
(_, bulletPos', minLevel', indLevel') <-
pListBullet (Just (bullet, bulletPos))
innerBlocks bulletPos' minLevel' indLevel'
UnorderedList noSpan (normalizeListItems (x :| xs)) <$ scQ
where
innerBlocks bulletPos minLevel indLevel = do
p <- sourcePos'
let tooFar = sourceLine p > sourceLine bulletPos <> pos1
rlevel = slevel minLevel indLevel
if tooFar || sourceColumn p < minLevel
then return [bool Naked Paragraph tooFar noSpan emptyIspSpan]
else subEnv True rlevel pBlocks
-- | Parse a list bullet. Return a tuple with the following components (in
-- order):
--
-- * 'Char' used to represent the bullet
-- * 'SourcePos' at which the bullet was located
-- * the closest column position where content could start
-- * the indentation level after the bullet
pListBullet ::
-- | Bullet 'Char' and start position of the first bullet in a list
Maybe (Char, SourcePos) ->
BParser (Char, SourcePos, Pos, Pos)
pListBullet mbullet = tryB $ do
pos <- sourcePos'
l <- (<> mkPos 2) <$> indentLevel'
bullet <-
case mbullet of
Nothing -> char '-' <|> char '+' <|> char '*'
Just (bullet, bulletPos) -> do
guard (sourceColumn pos >= sourceColumn bulletPos)
char bullet
eof <|> sc1Q
l' <- indentLevel'
return (bullet, pos, l, l')
-- | Parse an ordered list.
pOrderedList :: BParser (Block Isp)
pOrderedList = do
startOffset <- getOffset
(startIx, del, startPos, minLevel, indLevel) <-
pListIndex Nothing
x <- innerBlocks startPos minLevel indLevel
xs <- manyIndexed (startIx + 1) $ \expectedIx -> do
-- A list cannot continue past the end of the block quote it is in.
quoteOk >>= guard
startOffset' <- getOffset
(actualIx, _, startPos', minLevel', indLevel') <-
pListIndex (Just (del, startPos))
let f blocks =
if actualIx == expectedIx
then blocks
else
prependErr
startOffset'
(ListIndexOutOfOrder actualIx expectedIx)
blocks
f <$> innerBlocks startPos' minLevel' indLevel'
( OrderedList noSpan startIx . normalizeListItems $
( if startIx <= 999999999
then x
else prependErr startOffset (ListStartIndexTooBig startIx) x
)
:| xs
)
<$ scQ
where
innerBlocks indexPos minLevel indLevel = do
p <- sourcePos'
let tooFar = sourceLine p > sourceLine indexPos <> pos1
rlevel = slevel minLevel indLevel
if tooFar || sourceColumn p < minLevel
then return [bool Naked Paragraph tooFar noSpan emptyIspSpan]
else subEnv True rlevel pBlocks
-- | Parse a list index. Return a tuple with the following components (in
-- order):
--
-- * 'Word' parsed numeric index
-- * 'Char' used as delimiter after the numeric index
-- * 'SourcePos' at which the index was located
-- * the closest column position where content could start
-- * the indentation level after the index
pListIndex ::
-- | Delimiter 'Char' and start position of the first index in a list
Maybe (Char, SourcePos) ->
BParser (Word, Char, SourcePos, Pos, Pos)
pListIndex mstart = tryB $ do
pos <- sourcePos'
i <- L.decimal
del <- case mstart of
Nothing -> char '.' <|> char ')'
Just (del, startPos) -> do
guard (sourceColumn pos >= sourceColumn startPos)
char del
l <- (<> pos1) <$> indentLevel'
eof <|> sc1Q
l' <- indentLevel'
return (i, del, pos, l, l')
-- | Parse a block quote.
pBlockquote :: BParser (Block Isp)
pBlockquote = do
-- The marker that opens the block quote is consumed here, the markers
-- that continue it on the following lines are consumed by 'eolQ' and
-- friends, which know how many of them to expect from 'quoteDepth'.
ls <- try (pQuoteMarkersAll 1)
ldepth <- lineDepth
setLineState (mkLineState (ldepth + 1) (ls ^. lsBase))
-- The content of a block quote always starts in the first (virtual)
-- column of the quote, whatever the width of the marker on any particular
-- line.
xs <- subQuote (subEnv False pos1 pBlocks)
Blockquote noSpan xs <$ scQ
-- | Parse a link\/image reference definition and register it.
pReferenceDef :: BParser (Maybe (Block Isp))
pReferenceDef = do
(o, dlabel) <- try (pRefLabel <* char ':')
withRecovery recover $ do
sc' <* optional eolQ <* sc'
uri <- pUri
hadSpN <-
optional $
(sc1' *> option False (True <$ eolQ)) <|> (True <$ (sc' <* eolQ))
sc'
mtitle <-
if isJust hadSpN
then optional pTitle <* sc'
else return Nothing
case (hadSpN, mtitle) of
(Just True, Nothing) -> return ()
_ -> hidden eof <|> void (lookAhead eol)
conflict <- registerReference dlabel (uri, mtitle)
when conflict $
customFailure' o (DuplicateReferenceDefinition dlabel)
Nothing <$ scQ
where
recover err =
Just (Naked noSpan (IspError err)) <$ takeWhileP Nothing notNewline <* scQ
-- | Parse a pipe table.
pTable :: BParser (Block Isp)
pTable = do
(n, headerRow) <- tryB $ do
pos <- indentLevel'
option False (T.any (== '|') <$> lookAhead nonEmptyLine) >>= guard
let pipe' = option False (True <$ pipe)
l <- pipe'
headerRow <- NE.sepBy1 cell (try (pipe <* notFollowedBy eol))
r <- pipe'
let n = NE.length headerRow
guard (n > 1 || l || r)
eolQ <* sc'
indentLevel' >>= \i -> guard (i == pos || i == (pos <> pos1))
lookAhead nonEmptyLine >>= guard . isHeaderLike
return (n, headerRow)
withRecovery recover $ do
sc'
caligns <- rowWrapper (NE.fromList <$> sepByCount n calign pipe)
otherRows <- many $ do
endOfTable >>= guard . not
rowWrapper (NE.fromList <$> sepByCount n cell pipe)
Table noSpan caligns (headerRow :| otherRows) <$ scQ
where
cell = do
o <- getOffset
txt <-
fmap (T.stripEnd . T.pack) . foldMany' . choice $
[ (++) . T.unpack <$> hidden (string "\\|"),
(++) . T.unpack <$> pCodeSpanB,
(:) <$> label "inline content" (satisfy cellChar)
]
return (IspSpan o txt)
cellChar x = x /= '|' && notNewline x
rowWrapper p = do
void (optional pipe)
r <- p
void (optional pipe)
eof <|> eolLazy
sc'
return r
pipe = char '|' <* sc'
calign = do
let colon' = option False (True <$ char ':')
l <- colon'
void (count 3 (char '-') <* many (char '-'))
r <- colon'
sc'
return $
case (l, r) of
(False, False) -> CellAlignDefault
(True, False) -> CellAlignLeft
(False, True) -> CellAlignRight
(True, True) -> CellAlignCenter
isHeaderLike txt =
T.length (T.filter isHeaderConstituent txt) % T.length txt
> 8 % 10
isHeaderConstituent x =
isSpace x || x == '|' || x == '-' || x == ':'
endOfTable = do
inQuote <- quoteOk
if inQuote
then lookAhead (option True (isBlank <$> nonEmptyLine))
else return True
recover err =
Naked noSpan (IspError (replaceEof "end of table block" err))
<$ manyTill
(optional nonEmptyLine)
(endOfTable >>= guard)
<* scQ
-- | Parse a paragraph or naked text (in some cases).
pParagraph :: BParser (Block Isp)
pParagraph = do
startOffset <- getOffset
allowNaked <- isNakedAllowed
rlevel <- refLevel
let go ls pad = do
l <- lookAhead (option "" nonEmptyLine)
-- A line that does not carry all the block quote markers it should
-- may still continue this paragraph: CommonMark calls such lines
-- lazy continuation lines. Since the missing markers are simply
-- assumed to be there, such a line is judged as if it were at the
-- top level of the document.
lazy <- not <$> quoteOk
let rlevel' = if lazy then pos1 else rlevel
broken <- succeeds . lookAheadB $ do
sc'
alevel <- indentLevel'
guard (alevel < ilevel rlevel')
unless (alevel < rlevel') . choice $
[ void (char '>'),
void pThematicBreak,
void pAtxHeading,
void pOpeningFence,
void (pListBullet Nothing),
void (pListIndex Nothing)
]
if isBlank l
then return (ls, Paragraph noSpan)
else
if broken
then return (ls, Naked noSpan)
else do
void nonEmptyLine
mpad <- eolLazyPad
let ls' = ls . ((pad <> l) :)
case mpad of
Just pad' -> go ls' pad'
Nothing -> return (ls', Naked noSpan)
l <- nonEmptyLine
mpad <- eolLazyPad
(ls, toBlock) <-
case mpad of
Just pad -> go id pad
Nothing -> return (id, Naked noSpan)
(if allowNaked then toBlock else Paragraph noSpan)
(IspSpan startOffset (assembleParagraph (l : ls [])))
<$ scQ
----------------------------------------------------------------------------
-- Block quote prefixes and virtual columns
-- Every line inside a block quote must begin with a @>@ marker per level of
-- nesting (CommonMark calls this the block quote's continuation). Since the
-- markers may be of different width on different lines, the block parser
-- cannot work with real columns; instead it works with /virtual/ columns
-- which are obtained by subtracting from a real column the width of the
-- block quote markers of the line in question, see @bstLineBase@. At the
-- top level of a document the two coincide.
-- | Convert a real column into a virtual one.
toVirtual :: Pos -> Pos -> Pos
toVirtual base c = mkPos (max 1 (unPos c - unPos base + 1))
-- | Like 'L.indentLevel', but the level is virtual.
indentLevel' :: BParser Pos
indentLevel' = toVirtual <$> lineBase <*> L.indentLevel
-- | Like 'getSourcePos', but 'sourceColumn' of the result is virtual.
sourcePos' :: BParser SourcePos
sourcePos' = do
base <- lineBase
p <- getSourcePos
return p {sourceColumn = toVirtual base (sourceColumn p)}
-- | Consume up to the given number of block quote markers starting at the
-- beginning of the current line. Return the number of markers that were
-- found and the column at which the content of the line begins. This does
-- not update 'LineState', it is up to the caller to do that once it has
-- decided to commit to the result.
pQuoteMarkers :: Int -> BParser LineState
pQuoteMarkers n = go 0 pos1
where
go !k base
| k >= n = return (mkLineState k base)
| otherwise = do
r <- optional . try . label "block quote marker" $ do
c0 <- L.indentLevel
sc'
c1 <- L.indentLevel
-- Just like the other block level constructs, a block quote
-- marker may be preceded by up to three spaces.
guard (unPos c1 - unPos c0 < 4)
void (char '>')
c2 <- L.indentLevel
-- A single space after the marker is a part of it. A tab is not
-- consumed, but one column of it belongs to the marker all the
-- same, which is why we only shift the base here.
padded <-
option False . choice $
[ True <$ char ' ',
True <$ lookAhead (char '\t')
]
return (if padded then c2 <> pos1 else c2)
case r of
Nothing -> return (mkLineState k base)
Just base' -> go (k + 1) base'
-- | Like 'pQuoteMarkers', but fail unless all the markers are found. Since
-- some of them may have been consumed before the failure, this should be
-- used inside 'try'.
pQuoteMarkersAll :: Int -> BParser LineState
pQuoteMarkersAll n = do
ls <- pQuoteMarkers n
guard (ls ^. lsDepth == n)
return ls
-- | Check that the line we are on begins with all the block quote markers
-- that the current container requires.
quoteOk :: BParser Bool
quoteOk = (>=) <$> lineDepth <*> quoteDepth
-- | Cross a line ending and consume the block quote markers of the new
-- line. Fail without consuming input if the line ending is not there or the
-- new line does not begin with all the required markers.
eolQ :: BParser ()
eolQ = do
d <- quoteDepth
ls <- try (eol *> pQuoteMarkersAll d)
setLineState ls
-- | Cross a line ending and consume as many of the block quote markers of
-- the new line as happen to be there. This is what makes lazy continuation
-- lines possible: the caller can inspect 'lineDepth' and decide for itself
-- whether the missing markers matter.
eolLazy :: BParser ()
eolLazy = do
d <- quoteDepth
void eol
ls <- pQuoteMarkers d
setLineState ls
-- | 'eolLazy' returning 'False' instead of failing at the end of input.
eolLazy' :: BParser Bool
eolLazy' = option False (True <$ eolLazy)
-- | Like 'eolLazy'', but instead of a 'Bool' return the block quote markers
-- of the new line replaced by that many spaces. Paragraphs collect their
-- lines with this padding in place of the markers so that the offsets inside
-- the collected text still match the original input.
eolLazyPad :: BParser (Maybe Text)
eolLazyPad = optional $ do
d <- quoteDepth
void eol
o <- getOffset
ls <- pQuoteMarkers d
setLineState ls
o' <- getOffset
return (T.replicate (o' - o) " ")
-- | White space, including blank lines, the block quote markers of every
-- line we cross being consumed. Stops before a line ending that is not
-- followed by the required markers, as well as when the line we are on does
-- not belong to the current block quote in the first place.
scQ :: BParser ()
scQ = do
inQuote <- quoteOk
sc'
when inQuote . void . many $ eolQ <* sc'
-- | 'scQ' that requires at least some white space to be consumed.
sc1Q :: BParser ()
sc1Q = do
o <- getOffset
scQ
o' <- getOffset
guard (o' > o)
-- | Like 'try', but 'LineState' is restored in case of failure too. Parsers
-- that consume block quote markers and may fail afterwards must use this,
-- because 'LineState' lives in the state monad underlying 'BParser' and so
-- is not subject to backtracking.
tryB :: BParser a -> BParser a
tryB m = do
ls <- getLineState
observing (try m) >>= \case
Right x -> return x
Left err -> do
setLineState ls
parseError err
-- | Like 'lookAhead', but 'LineState' is restored as well and failure never
-- consumes input.
lookAheadB :: BParser a -> BParser a
lookAheadB m = do
ls <- getLineState
r <- observing (lookAhead (try m))
setLineState ls
either parseError return r
----------------------------------------------------------------------------
-- Auxiliary block-level parsers
-- | 'match' a code span, this is a specialised and adjusted version of
-- 'pCodeSpan'.
pCodeSpanB :: BParser Text
pCodeSpanB = fmap fst . match . hidden $ do
n <- try (length <$> some (char '`'))
let finalizer = try $ do
void $ count n (char '`')
notFollowedBy (char '`')
skipManyTill
( label "code span content" $
takeWhile1P Nothing (== '`')
<|> takeWhile1P Nothing (\x -> x /= '`' && notNewline x)
)
finalizer
----------------------------------------------------------------------------
-- Inline parser
-- | The top level inline parser.
pInlinesTop :: IParser (NonEmpty Inline)
pInlinesTop = do
inlines <- pInlines
eof <|> void pLfdr
return inlines
-- | Parse inlines using the settings in the inline parser state.
pInlines :: IParser (NonEmpty Inline)
pInlines = do
done <- atEnd
allowsEmpty <- isEmptyAllowed
if done
then
if allowsEmpty
then (return . nes . Plain noSpan) ""
else unexpEic EndOfInput
else NE.some $ do
o <- getOffset
r <- pInline
o' <- getOffset
return (setInlineSpan (Span o o') r)
-- | Parse a single inline of a markdown document.
pInline :: IParser Inline
pInline = do
mch <- lookAhead (anySingle <?> "inline content")
case mch of
'`' -> pCodeSpan
'[' -> do
allowsLinks <- isLinksAllowed
if allowsLinks
then pLink
else unexpEic (Tokens $ nes '[')
'!' -> do
gotImage <- (succeeds . void . lookAhead . string) "!["
allowsImages <- isImagesAllowed
if gotImage
then
if allowsImages
then pImage
else unexpEic (Tokens . NE.fromList $ "![")
else pPlain
'<' -> do
allowsLinks <- isLinksAllowed
if allowsLinks
then try pAutolink <|> pPlain
else pPlain
'\\' ->
try pHardLineBreak <|> pPlain
ch ->
if isFrameConstituent ch
then do
literal <- lookingAtWordUnderscores
if literal then pPlain else pEnclosedInline
else pPlain
-- | Parse a code span.
--
-- See also: 'pCodeSpanB'.
pCodeSpan :: IParser Inline
pCodeSpan = do
n <- try (length <$> some (char '`'))
let finalizer = try $ do
void $ count n (char '`')
notFollowedBy (char '`')
r <-
CodeSpan noSpan . normalizeCodeSpan . T.concat
<$> manyTill
( label "code span content" $
takeWhile1P Nothing (== '`')
<|> takeWhile1P Nothing (/= '`')
)
finalizer
r <$ lastChar OtherChar
-- | Parse a link.
pLink :: IParser Inline
pLink = do
void (char '[')
o <- getOffset
txt <- outsideFrames (disallowLinks (disallowEmpty pInlines))
void (char ']')
(dest, mtitle) <- pLocation o txt
Link noSpan txt dest mtitle <$ lastChar OtherChar
-- | Parse an image.
pImage :: IParser Inline
pImage = do
(pos, alt) <- emptyAlt <|> nonEmptyAlt
(src, mtitle) <- pLocation pos alt
Image noSpan alt src mtitle <$ lastChar OtherChar
where
emptyAlt = do
o <- getOffset
void (string "![]")
return (o + 2, nes (Plain noSpan ""))
nonEmptyAlt = do
void (string "![")
o <- getOffset
alt <- outsideFrames (disallowImages (disallowEmpty pInlines))
void (char ']')
return (o, alt)
-- | Parse an autolink.
pAutolink :: IParser Inline
pAutolink = between (char '<') (char '>') $ do
notFollowedBy (char '>')
uri' <- URI.parser
let (txt, uri) =
case isEmailUri uri' of
Nothing ->
( (nes . Plain noSpan . URI.render) uri',
uri'
)
Just email ->
( nes (Plain noSpan email),
URI.makeAbsolute mailtoScheme uri'
)
Link noSpan txt uri Nothing <$ lastChar OtherChar
-- | Parse inline content inside an enclosing construction such as emphasis,
-- strikeout, superscript, and\/or subscript markup.
pEnclosedInline :: IParser Inline
pEnclosedInline = disallowEmpty $ do
frames <- pLfdr
inlines <- insideFrames frames pInlines
go frames inlines
where
-- The frames of one group close in whatever order the closing runs
-- dictate, and the one that closes first ends up innermost. This is
-- what makes both @***foo** bar*@ and @***foo* bar**@ work.
go frames inlines = do
frame <- choice (pRfdr <$> frames)
let frames' = delete frame frames
inline = liftFrame frame inlines
if null frames'
then return inline
else do
minlines <- optional (insideFrames frames' pInlines)
go frames' $ case minlines of
Nothing -> nes inline
Just inlines' -> inline <| inlines'
-- | Parse a hard line break.
pHardLineBreak :: IParser Inline
pHardLineBreak = do
void (char '\\')
eol
notFollowedBy eof
sc'
lastChar SpaceChar
return (LineBreak noSpan)
-- | Parse plain text.
pPlain :: IParser Inline
pPlain = fmap (Plain noSpan . bakeText) . foldSome $ do
ch <- lookAhead (anySingle <?> "inline content")
let newline' =
(('\n' :) . dropWhile isSpace) <$ eol <* sc' <* lastChar SpaceChar
case ch of
'\\' ->
(:)
<$> ( (escapedChar <* lastChar OtherChar)
<|> try (char '\\' <* notFollowedBy eol <* lastChar OtherChar)
)
'\n' ->
newline'
'\r' ->
newline'
'!' -> do
notFollowedBy (string "![")
(:) <$> char '!' <* lastChar PunctChar
'<' -> do
notFollowedBy pAutolink
(:) <$> char '<' <* lastChar PunctChar
'&' ->
choice
[ (:) <$> numRef,
(++) . reverse <$> entityRef,
(:) <$> char '&'
]
<* lastChar PunctChar
'_' -> do
literal <- lookingAtWordUnderscores
if literal
then do
run <- takeWhile1P Nothing (== '_')
lastChar OtherChar
return ((++) (reverse (T.unpack run)))
else unexpEic (Tokens (nes ch))
_ ->
(:)
<$> if Char.isSpace ch
then char ch <* lastChar SpaceChar
else
if isSpecialChar ch
then
failure
(Just . Tokens . nes $ ch)
(E.singleton . Label . NE.fromList $ "inline content")
else
if isPunctuationChar ch
then char ch <* lastChar PunctChar
else char ch <* lastChar OtherChar
----------------------------------------------------------------------------
-- Auxiliary inline-level parsers
-- | Parse an inline and reference-style link\/image location.
pLocation ::
-- | Offset where the content inlines start
Int ->
-- | The inner content inlines
NonEmpty Inline ->
-- | URI and optionally title
IParser (URI, Maybe Text)
pLocation innerOffset inner = do
mr <- optional (inplace <|> withRef)
case mr of
Nothing ->
collapsed innerOffset inner <|> shortcut innerOffset inner
Just (dest, mtitle) ->
return (dest, mtitle)
where
inplace = do
void (char '(')
sc'
dest <- pUri
hadSpace <- option False (True <$ sc1)
mtitle <-
if hadSpace
then optional pTitle <* sc'
else return Nothing
void (char ')')
return (dest, mtitle)
withRef =
pRefLabel >>= uncurry lookupRef
collapsed o inlines = do
region (setErrorOffset o) $
(void . hidden . string) "[]"
lookupRef o (mkLabel inlines)
shortcut o inlines =
lookupRef o (mkLabel inlines)
lookupRef o dlabel =
lookupReference dlabel >>= \case
Left names ->
customFailure' o (CouldNotFindReferenceDefinition dlabel names)
Right x ->
return x
mkLabel = T.unwords . T.words . asPlainText
-- | Parse a URI.
pUri :: (MonadParsec e Text m) => m URI
pUri = between (char '<') (char '>') URI.parser <|> naked
where
naked = do
let f x = not (isSpaceN x || x == ')')
l = "end of URI"
(s, s') <- T.span f <$> getInput
when (T.null s) . void $
(satisfy f <?> "URI") -- this will now fail
setInput s
r <- region (replaceEof l) (URI.parser <* label l eof)
setInput s'
return r
-- | Parse a title of a link or an image.
pTitle :: (MonadParsec MMarkErr Text m) => m Text
pTitle =
choice
[ p '\"' '\"',
p '\'' '\'',
p '(' ')'
]
where
p start end =
between (char start) (char end) $
let f x = x /= end
in manyEscapedWith f "unescaped character"
-- | Parse label of a reference link.
pRefLabel :: (MonadParsec MMarkErr Text m) => m (Int, Text)
pRefLabel = do
try $ do
void (char '[')
notFollowedBy (char ']')
o <- getOffset
sc
let f x = x /= '[' && x /= ']'
dlabel <- someEscapedWith f <?> "reference label"
void (char ']')
return (o, dlabel)
-- | Parse an opening markup sequence, that is, a delimiter run that opens a
-- group of inline frames. The whole run is consumed, however long it is.
pLfdr :: IParser [InlineFrame]
pLfdr = try $ do
o <- getOffset
(ch, run, rch) <- lookAhead $ do
ch <- satisfy isFrameConstituent
run <- T.cons ch <$> takeWhileP Nothing (== ch)
rch <- getNextChar OtherChar
return (ch, run, rch)
let failNow e = customFailure' o (e (toNesTokens run))
open = runFrames ch (T.length run) <$ takeWhile1P Nothing (== ch)
lch <- getLastChar
frames <- getFrames
case flanking lch rch of
OpensFrame ->
open
NotFlanking ->
failNow NonFlankingDelimiterRun
ClosesFrame ->
if null frames
then failNow UnmatchedClosingDelimiterRun
else empty
AmbiguousFrame ->
if closesFrames run frames
then empty
else open
-- | The frames that a delimiter run of the given character and length
-- opens, in the order in which we prefer to close them. Preferring the
-- longer delimiters is what puts the strong emphasis inside the emphasis in
-- @***foo***@ and, more generally, leaves the odd delimiter of a run on the
-- outside.
runFrames :: Char -> Int -> [InlineFrame]
runFrames ch n = case ch of
'*' -> pairsThenSingle StrongFrame EmphasisFrame
'_' -> pairsThenSingle StrongFrame_ EmphasisFrame_
'~' -> pairsThenSingle StrikeoutFrame SubscriptFrame
'^' -> replicate n SuperscriptFrame
_ -> []
where
pairsThenSingle paired odd' =
replicate (n `div` 2) paired ++ replicate (n `mod` 2) odd'
-- | Parse a closing markup sequence corresponding to given 'InlineFrame'.
pRfdr :: InlineFrame -> IParser InlineFrame
pRfdr frame = try $ do
let dels = inlineFrameDel frame
expectingInlineContent = region $ \case
TrivialError pos us es ->
TrivialError pos us $
E.insert (Label $ NE.fromList "inline content") es
other -> other
o <- getOffset
(void . expectingInlineContent . string) dels
let failNow =
customFailure' o (NonFlankingDelimiterRun (toNesTokens dels))
lch <- getLastChar
rch <- getNextChar SpaceChar
case flanking lch rch of
ClosesFrame -> return frame
-- We only get here when 'pLfdr' has already decided that an ambiguous
-- run closes the frame we are in.
AmbiguousFrame -> return frame
_ -> failNow
-- | Check whether the given delimiter run is exactly what the given open
-- frames are waiting for, innermost first. A run that closes a frame only
-- partially, as the @**@ does in @*foo**bar**baz*@, is not a closing run:
-- there it opens strong emphasis inside the emphasis instead.
closesFrames :: Text -> [InlineFrame] -> Bool
closesFrames dels = \case
[] -> False
f : fs ->
case T.stripPrefix (inlineFrameDel f) dels of
Nothing -> False
Just dels' -> T.null dels' || closesFrames dels' fs
-- | Check whether the input begins with a run of underscores that has word
-- characters on both sides. Underscores are common inside words, so such a
-- run is not markup at all but literal text; this is the one place where a
-- markup character does not have to be escaped to be taken literally.
lookingAtWordUnderscores :: IParser Bool
lookingAtWordUnderscores = do
lch <- getLastChar
if lch /= OtherChar
then return False
else lookAhead . option False $ do
void (takeWhile1P Nothing (== '_'))
-- Markup characters do not count as word characters here: in
-- @*_foo_*@ the closing @_@ is markup, not part of a word.
rch <- getNextChar SpaceChar
return (rch == OtherChar)
-- | Get 'CharType' of the next char in the input stream.
getNextChar ::
-- | What we should consider frame constituent characters
CharType ->
IParser CharType
getNextChar frameType = lookAhead (option SpaceChar (charType <$> anySingle))
where
charType ch
| isFrameConstituent ch = frameType
| Char.isSpace ch = SpaceChar
| ch == '\\' = OtherChar
| isPunctuationChar ch = PunctChar
| otherwise = OtherChar
----------------------------------------------------------------------------
-- Parsing helpers
manyIndexed :: (Alternative m, Num n) => n -> (n -> m a) -> m [a]
manyIndexed n' m = go n'
where
go !n = liftA2 (:) (m n) (go (n + 1)) <|> pure []
foldMany :: (MonadPlus m) => m (a -> a) -> m (a -> a)
foldMany f = go id
where
go g =
optional f >>= \case
Nothing -> pure g
Just h -> go (h . g)
foldMany' :: (MonadPlus m) => m ([a] -> [a]) -> m [a]
foldMany' f = ($ []) <$> go id
where
go g =
optional f >>= \case
Nothing -> pure g
Just h -> go (g . h)
foldSome :: (MonadPlus m) => m (a -> a) -> m (a -> a)
foldSome f = liftA2 (flip (.)) f (foldMany f)
foldSome' :: (MonadPlus m) => m ([a] -> [a]) -> m [a]
foldSome' f = liftA2 ($) f (foldMany' f)
sepByCount :: (MonadPlus m) => Int -> m a -> m sep -> m [a]
sepByCount 0 _ _ = pure []
sepByCount n p sep = liftA2 (:) p (count (n - 1) (sep *> p))
nonEmptyLine :: BParser Text
nonEmptyLine = takeWhile1P Nothing notNewline
manyEscapedWith ::
(MonadParsec MMarkErr Text m) =>
(Char -> Bool) ->
String ->
m Text
manyEscapedWith f l =
fmap T.pack . foldMany' . choice $
[ (:) <$> escapedChar,
(:) <$> numRef,
(++) . reverse <$> entityRef,
(:) <$> satisfy f <?> l
]
someEscapedWith ::
(MonadParsec MMarkErr Text m) =>
(Char -> Bool) ->
m Text
someEscapedWith f =
fmap T.pack . foldSome' . choice $
[ (:) <$> escapedChar,
(:) <$> numRef,
(++) . reverse <$> entityRef,
(:) <$> satisfy f
]
escapedChar :: (MonadParsec e Text m) => m Char
escapedChar =
label "escaped character" $
try (char '\\' *> satisfy isAsciiPunctuation)
-- | Parse an HTML5 entity reference.
entityRef :: (MonadParsec MMarkErr Text m) => m String
entityRef = do
o <- getOffset
let f (TrivialError _ us es) = TrivialError o us es
f (FancyError _ xs) = FancyError o xs
name <-
try . region f $
between
(char '&')
(char ';')
(takeWhile1P Nothing Char.isAlphaNum <?> "HTML5 entity name")
case HM.lookup name htmlEntityMap of
Nothing ->
customFailure' o (UnknownHtmlEntityName name)
Just txt -> return (T.unpack txt)
-- | Parse a numeric character using the given numeric parser.
numRef :: (MonadParsec MMarkErr Text m) => m Char
numRef = do
o <- getOffset
let f = between (string "&#") (char ';')
n <- try (f (char' 'x' *> L.hexadecimal)) <|> f L.decimal
if n == 0 || n > fromEnum (maxBound :: Char)
then customFailure' o (InvalidNumericCharacter n)
else return (Char.chr n)
sc :: (MonadParsec e Text m) => m ()
sc = void $ takeWhileP (Just "white space") isSpaceN
sc1 :: (MonadParsec e Text m) => m ()
sc1 = void $ takeWhile1P (Just "white space") isSpaceN
sc' :: (MonadParsec e Text m) => m ()
sc' = void $ takeWhileP (Just "white space") isSpace
sc1' :: (MonadParsec e Text m) => m ()
sc1' = void $ takeWhile1P (Just "white space") isSpace
eol :: (MonadParsec e Text m) => m ()
eol =
void . label "newline" $
choice
[ string "\n",
string "\r\n",
string "\r"
]
----------------------------------------------------------------------------
-- Char classification
isSpace :: Char -> Bool
isSpace x = x == ' ' || x == '\t'
isSpaceN :: Char -> Bool
isSpaceN x = isSpace x || isNewline x
isNewline :: Char -> Bool
isNewline x = x == '\n' || x == '\r'
notNewline :: Char -> Bool
notNewline = not . isNewline
isFrameConstituent :: Char -> Bool
isFrameConstituent = \case
'*' -> True
'^' -> True
'_' -> True
'~' -> True
_ -> False
isMarkupChar :: Char -> Bool
isMarkupChar x = isFrameConstituent x || f x
where
f = \case
'[' -> True
']' -> True
'`' -> True
_ -> False
isSpecialChar :: Char -> Bool
isSpecialChar x = isMarkupChar x || x == '\\' || x == '!' || x == '<'
-- | Check whether the character is a punctuation character in the sense of
-- the CommonMark specification, which counts the Unicode symbol categories
-- as punctuation in addition to the punctuation categories proper. This is
-- what @$@ in @*$*alpha@ is: emphasis cannot hang on it.
isPunctuationChar :: Char -> Bool
isPunctuationChar x = Char.isPunctuation x || Char.isSymbol x
isAsciiPunctuation :: Char -> Bool
isAsciiPunctuation x =
(x >= '!' && x <= '/')
|| (x >= ':' && x <= '@')
|| (x >= '[' && x <= '`')
|| (x >= '{' && x <= '~')
----------------------------------------------------------------------------
-- Other helpers
slevel :: Pos -> Pos -> Pos
slevel a l = if l >= ilevel a then a else l
ilevel :: Pos -> Pos
ilevel = (<> mkPos 4)
isBlank :: Text -> Bool
isBlank = T.all isSpace
assembleCodeBlock :: Pos -> [Text] -> Text
assembleCodeBlock indent ls = T.unlines (stripIndent indent <$> ls)
stripIndent :: Pos -> Text -> Text
stripIndent indent txt = T.drop m txt
where
m = snd $ T.foldl' f (0, 0) (T.takeWhile isSpace txt)
f (!j, !n) ch
| j >= i = (j, n)
| ch == ' ' = (j + 1, n + 1)
| ch == '\t' = (j + 4, n + 1)
| otherwise = (j, n)
i = unPos indent - 1
assembleParagraph :: [Text] -> Text
assembleParagraph = go
where
go [] = ""
go [x] = T.dropWhileEnd isSpace x
go (x : xs) = x <> "\n" <> go xs
-- | Normalize the contents of a code span the way the CommonMark
-- specification prescribes: every line ending becomes a space, and when the
-- result both begins and ends with a space but does not consist of spaces
-- alone, one space is removed from each end. Everything else is preserved
-- verbatim, so a code span is the one place where the exact spelling of the
-- input survives.
--
-- The indentation of a continuation line goes with its line ending because
-- it belongs to the block that contains the paragraph, not to the code
-- span: it is the indentation of a list item or the padding that replaced
-- the markers of a block quote.
normalizeCodeSpan :: Text -> Text
normalizeCodeSpan txt =
if padded && not (T.all (== ' ') oneLine)
then (T.init . T.tail) oneLine
else oneLine
where
padded = " " `T.isPrefixOf` oneLine && " " `T.isSuffixOf` oneLine
oneLine = T.intercalate " " (unindent (T.splitOn "\n" unified))
unindent = \case
[] -> []
x : xs -> x : fmap (T.dropWhile isSpace) xs
unified = T.replace "\r" "\n" (T.replace "\r\n" "\n" txt)
liftFrame :: InlineFrame -> NonEmpty Inline -> Inline
liftFrame = \case
StrongFrame -> Strong noSpan
EmphasisFrame -> Emphasis noSpan
StrongFrame_ -> Strong noSpan
EmphasisFrame_ -> Emphasis noSpan
StrikeoutFrame -> Strikeout noSpan
SubscriptFrame -> Subscript noSpan
SuperscriptFrame -> Superscript noSpan
replaceEof :: String -> ParseError Text e -> ParseError Text e
replaceEof altLabel = \case
TrivialError pos us es -> TrivialError pos (f <$> us) (E.map f es)
FancyError pos xs -> FancyError pos xs
where
f EndOfInput = Label (NE.fromList altLabel)
f x = x
isEmailUri :: URI -> Maybe Text
isEmailUri uri =
case URI.unRText <$> uri ^. uriPath of
[x] ->
if Email.isValid (TE.encodeUtf8 x)
&& ( isNothing (URI.uriScheme uri)
|| URI.uriScheme uri == Just mailtoScheme
)
then Just x
else Nothing
_ -> Nothing
-- | Decode the yaml block to an 'Aeson.Value'. On GHCJS, without access to
-- libyaml, we just return an empty object. It's worth using a pure Haskell
-- parser later if this is unacceptable for someone's needs.
decodeYaml :: [T.Text] -> Int -> (Either (Int, String) Aeson.Value)
#ifdef ghcjs_HOST_OS
decodeYaml _ _ = pure $ Aeson.object []
#else
decodeYaml ls doffset =
case (Yaml.decodeEither' . TE.encodeUtf8 . T.intercalate "\n") ls of
Left err' ->
let (moffset, err) = splitYamlError err'
in Left (maybe doffset (+ doffset) moffset, err)
Right v -> Right v
splitYamlError ::
Yaml.ParseException ->
(Maybe Int, String)
splitYamlError = \case
Yaml.NonScalarKey -> (Nothing, "non scalar key")
Yaml.UnknownAlias anchor -> (Nothing, "unknown alias \"" ++ anchor ++ "\"")
Yaml.UnexpectedEvent exptd unexptd ->
( Nothing,
"unexpected event: expected " ++ show exptd
++ ", but received "
++ show unexptd
)
Yaml.InvalidYaml myerror -> case myerror of
Nothing -> (Nothing, "unspecified error")
Just yerror -> case yerror of
Yaml.YamlException s -> (Nothing, s)
Yaml.YamlParseException problem context mark ->
( Just (Yaml.yamlIndex mark),
case context of
"" -> problem
_ -> context ++ ", " ++ problem
)
Yaml.AesonException s -> (Nothing, s)
Yaml.OtherParseException exc -> (Nothing, show exc)
Yaml.NonStringKeyAlias anchor value ->
( Nothing,
"non-string key alias; anchor name: " ++ anchor
++ ", value: "
++ show value
)
Yaml.CyclicIncludes -> (Nothing, "cyclic includes")
Yaml.LoadSettingsException _ _ -> (Nothing, "loading settings exception")
Yaml.NonStringKey _ -> (Nothing, "non string key")
Yaml.MultipleDocuments -> (Nothing, "multiple documents")
#endif
emptyIspSpan :: Isp
emptyIspSpan = IspSpan 0 ""
normalizeListItems :: NonEmpty [Block Isp] -> NonEmpty [Block Isp]
normalizeListItems xs' =
if getAny $ foldMap (foldMap (Any . isParagraph)) (drop 1 x :| xs)
then fmap toParagraph <$> xs'
else case x of
[] -> xs'
(y : ys) -> r $ (toNaked y : ys) :| xs
where
(x :| xs) = r xs'
r = NE.reverse . fmap reverse
isParagraph = \case
OrderedList {} -> False
UnorderedList {} -> False
Naked {} -> False
_ -> True
toParagraph (Naked ann inner) = Paragraph ann inner
toParagraph other = other
toNaked (Paragraph ann inner) = Naked ann inner
toNaked other = other
succeeds :: (Alternative m) => m () -> m Bool
succeeds m = True <$ m <|> pure False
prependErr :: Int -> MMarkErr -> [Block Isp] -> [Block Isp]
prependErr o custom blocks = Naked noSpan (IspError err) : blocks
where
err = FancyError o (E.singleton $ ErrorCustom custom)
mailtoScheme :: URI.RText 'URI.Scheme
mailtoScheme = fromJust (URI.mkScheme "mailto")
toNesTokens :: Text -> NonEmpty Char
toNesTokens = NE.fromList . T.unpack
unexpEic :: (MonadParsec e Text m) => ErrorItem Char -> m a
unexpEic x =
failure
(Just x)
(E.singleton . Label . NE.fromList $ "inline content")
nes :: a -> NonEmpty a
nes a = a :| []
fromRight :: Either a b -> b
fromRight (Right x) = x
fromRight _ =
error "Text.MMark.Parser.fromRight: the impossible happened"
bakeText :: (String -> String) -> Text
bakeText = T.pack . reverse . ($ [])
-- | Report custom failure at specified location.
customFailure' ::
(MonadParsec MMarkErr Text m) =>
Int ->
MMarkErr ->
m a
customFailure' o e =
parseError $
FancyError
o
(E.singleton (ErrorCustom e))