{-# 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))
