content: {-# LANGUAGE BangPatterns               #-}
  {-# LANGUAGE FlexibleContexts           #-}
  {-# LANGUAGE OverloadedStrings          #-}
  {- |
  Module      : Text.Pandoc.Parsing.General
  Copyright   : © 2006-2024 John MacFarlane
  License     : GPL-2.0-or-later
  Maintainer  : John MacFarlane <jgm@berkeley.edu>
  
  Parser combinators for pandoc format readers.
  -}
  
  module Text.Pandoc.Parsing.General
    ( (<+?>)
    , anyLine
    , anyLineNewline
    , blankline
    , blanklines
    , charRef
    , characterReference
    , charsInBalanced
    , countChar
    , emailAddress
    , enclosed
    , escaped
    , extractIdClass
    , gobbleAtMostSpaces
    , gobbleSpaces
    , indentWith
    , insertIncludedFile
    , isSpaceChar          -- not re-exported from T.P.Parsing
    , lineBlockLines
    , lineClump
    , many1Char
    , many1Till
    , many1TillChar
    , manyChar
    , manyTillChar
    , manyUntil
    , manyUntilChar
    , nonspaceChar
    , notFollowedBy'
    , oneOfStrings
    , oneOfStringsCI
    , parseFromString
    , parseFromString'
    , readWith
    , readWithM
    , registerHeader
    , sepBy1'
    , skipSpaces
    , spaceChar
    , stringAnyCase
    , testStringWith
    , textStr
    , token
    , trimInlinesF
    , uri
    , withHorizDisplacement
    , withRaw
    , fromParsecError
    )
  where
  
  import Control.Monad
    ( join
    , liftM
    , unless
    , void
    , when
    , MonadPlus(mzero)
    )
  import Control.Monad.Except ( MonadError(throwError) )
  import Control.Monad.Identity ( Identity(..) )
  import Data.Char
    ( chr
    , isAlphaNum
    , isAscii
    , isAsciiUpper
    , isSpace
    , ord
    , toLower
    , toUpper
    )
  import Data.Functor (($>))
  import Data.List (intercalate, sortOn)
  import Data.Ord (Down(..))
  import Data.Maybe (fromMaybe)
  import Data.Text (Text)
  import qualified Data.Text.Lazy.Builder as TB
  import qualified Data.Text.Lazy as TL
  import Text.Pandoc.Asciify (toAsciiText)
  import Text.Pandoc.Builder (Attr, Inline(Str), Inlines, trimInlines)
  import Text.Pandoc.Class.PandocMonad (PandocMonad, readFileFromDirs, report)
  import Text.Pandoc.Logging
    ( LogMessage(CouldNotLoadIncludeFile, DuplicateIdentifier) )
  import Text.Pandoc.Options
    ( extensionEnabled
    , Extension(Ext_auto_identifiers, Ext_ascii_identifiers)
    , ReaderOptions(readerTabStop, readerExtensions) )
  import Text.Pandoc.Shared (tshow, uniqueIdent)
  import Text.Pandoc.URI (schemes, escapeURI)
  import Text.Pandoc.Sources
  import Text.Pandoc.XML (fromEntities, lookupEntity)
  import Text.Parsec
    ( (<|>)
    , Parsec
    , ParsecT
    , SourcePos
    , sourceLine
    , sourceColumn
    , sourceName
    , ParseError
    , errorPos
    , Stream(..)
    , between
    , choice
    , count
    , getInput
    , getPosition
    , getState
    , lookAhead
    , many
    , many1
    , manyTill
    , notFollowedBy
    , option
    , runParserT
    , setInput
    , setPosition
    , skipMany
    , sourceColumn
    , sourceName
    , tokenPrim
    , try
    , unexpected
    , updateState
    )
  import Text.Parsec.Pos (initialPos, newPos)
  import Text.Pandoc.Error
    ( PandocError(PandocParseError) )
  import Text.Pandoc.Parsing.Capabilities
  import Text.Pandoc.Parsing.State
  import Text.Pandoc.Parsing.Future (Future (..))
  import qualified Data.Set as Set
  import qualified Data.Text as T
  import qualified Text.Pandoc.Builder as B
  import qualified Text.Pandoc.UTF8 as UTF8 (putStrLn)
  import qualified Data.Bifunctor as Bifunctor
  
  -- | Remove whitespace from start and end; just like @'trimInlines'@,
  -- but lifted into the 'Future' type.
  trimInlinesF :: Future s Inlines -> Future s Inlines
  trimInlinesF = liftM trimInlines
  
  -- | Like @count@, but packs its result
  countChar :: (Stream s m Char, UpdateSourcePos s Char, Monad m)
            => Int
            -> ParsecT s st m Char
            -> ParsecT s st m Text
  countChar n = fmap T.pack . count n
  
  -- | Like @string@, but uses @Text@.
  textStr :: (Stream s m Char, UpdateSourcePos s Char)
          => Text -> ParsecT s u m Text
  textStr t = string (T.unpack t) $> t
  
  
  -- | Parse any line of text, returning the contents without the
  -- final newline.
  anyLine :: Monad m => ParsecT Sources st m Text
  anyLine = do
    -- This is much faster than:
    -- manyTill anyChar newline
    inp <- getInput
    case inp of
      Sources [] -> mzero
      Sources ((fp,t):inps) ->
        -- we assume that lines don't span different input files
        case T.break (=='\n') t of
             (this, rest)
               | T.null rest
               , not (null inps) ->
                  -- line may span different input files, so do it
                   -- character by character
                   T.pack <$> manyTill anyChar newline
               | otherwise -> do --  either end of inputs or newline in rest
                   setInput $ Sources ((fp, rest):inps)
                   char '\n' -- needed so parsec knows we won't match empty string
                             -- and so source pos is updated
                   return this
  
  -- | Parse any line, include the final newline in the output
  anyLineNewline :: Monad m => ParsecT Sources st m Text
  anyLineNewline = (<> "\n") <$> anyLine
  
  -- | Parse indent by specified number of spaces (or equiv. tabs)
  indentWith :: (Stream s m Char, UpdateSourcePos s Char)
             => HasReaderOptions st
             => Int -> ParsecT s st m Text
  indentWith num = do
    tabStop <- getOption readerTabStop
    if num < tabStop
       then countChar num (char ' ')
       else choice [ try (countChar num (char ' '))
                   , try (char '\t' >> indentWith (num - tabStop)) ]
  
  -- | Like @many@, but packs its result.
  manyChar :: Stream s m t
           => ParsecT s st m Char
           -> ParsecT s st m Text
  manyChar = fmap T.pack . many
  
  -- | Like @many1@, but packs its result.
  many1Char :: Stream s m t
            => ParsecT s st m Char
            -> ParsecT s st m Text
  many1Char = fmap T.pack . many1
  
  -- | Like @manyTill@, but packs its result.
  manyTillChar :: Stream s m t
               => ParsecT s st m Char
               -> ParsecT s st m a
               -> ParsecT s st m Text
  manyTillChar p = fmap T.pack . manyTill p
  
  -- | Like @manyTill@, but reads at least one item.
  many1Till :: (Show end, Stream s m t)
            => ParsecT s st m a
            -> ParsecT s st m end
            -> ParsecT s st m [a]
  many1Till p end = do
           notFollowedBy' end
           first <- p
           rest <- manyTill p end
           return (first:rest)
  
  -- | Like @many1Till@, but packs its result
  many1TillChar :: (Show end, Stream s m t)
                => ParsecT s st m Char
                -> ParsecT s st m end
                -> ParsecT s st m Text
  many1TillChar p = fmap T.pack . many1Till p
  
  -- | Like @manyTill@, but also returns the result of end parser.
  manyUntil :: ParsecT s u m a
            -> ParsecT s u m b
            -> ParsecT s u m ([a], b)
  manyUntil p end = scan
    where scan =
            (do e <- end
                return ([], e)
            ) <|>
            (do x <- p
                (xs, e) <- scan
                return (x:xs, e))
  
  -- | Like @manyUntil@, but also packs its result.
  manyUntilChar :: ParsecT s u m Char
                -> ParsecT s u m b
                -> ParsecT s u m (Text, b)
  manyUntilChar p = fmap go . manyUntil p
    where
      go (x, y) = (T.pack x, y)
  
  -- | Like @sepBy1@ from Parsec,
  -- but does not fail if it @sep@ succeeds and @p@ fails.
  sepBy1' :: ParsecT s u m a
          -> ParsecT s u m sep
          -> ParsecT s u m [a]
  sepBy1' p sep = (:) <$> p <*> many (try $ sep >> p)
  
  -- | A more general form of @notFollowedBy@.  This one allows any
  -- type of parser to be specified, and succeeds only if that parser fails.
  -- It does not consume any input.
  notFollowedBy' :: (Show b, Stream s m a) => ParsecT s st m b -> ParsecT s st m ()
  notFollowedBy' p  = try $ join $  do  a <- try p
                                        return (unexpected (show a))
                                    <|>
                                    return (return ())
  -- (This version due to Andrew Pimlott on the Haskell mailing list.)
  
  oneOfStrings' :: (Stream s m Char, UpdateSourcePos s Char)
                 => (Char -> Char -> Bool) -> [Text] -> ParsecT s st m Text
  oneOfStrings' _ [] = Prelude.fail "no strings to match"
  oneOfStrings' matches strs =
    TL.toStrict . TB.toLazyText <$> try (go (TB.fromText mempty) strs)
   where
     go acc strs' = do
       c <- anyChar
       let strs'' = [t | Just (d, t) <- map T.uncons strs', matches c d]
       let !acc' = acc <> TB.singleton c
       case strs'' of
         []  -> Prelude.fail "not found"
         _   -> if any T.null strs''
                   then option acc' (try (go acc' strs''))
                   else go acc' strs''
  
  -- | Parses one of a list of strings.  If the list contains
  -- two strings one of which is a prefix of the other, the longer
  -- string will be matched if possible.
  oneOfStrings :: (Stream s m Char, UpdateSourcePos s Char)
               => [Text] -> ParsecT s st m Text
  oneOfStrings = oneOfStrings' (==)
  
  -- | Parses one of a list of strings (tried in order), case insensitive.
  
  -- TODO: This will not be accurate with general Unicode (neither
  -- Text.toLower nor Text.toCaseFold can be implemented with a map)
  oneOfStringsCI :: (Stream s m Char, UpdateSourcePos s Char)
                 => [Text] -> ParsecT s st m Text
  oneOfStringsCI = oneOfStrings' ciMatch
    where ciMatch x y = toLower' x == toLower' y
          -- this optimizes toLower by checking common ASCII case
          -- first, before calling the expensive unicode-aware
          -- function:
          toLower' c | isAsciiUpper c = chr (ord c + 32)
                     | isAscii c = c
                     | otherwise = toLower c
  
  -- | Parses a space or tab.
  spaceChar :: (Stream s m Char, UpdateSourcePos s Char)
            => ParsecT s st m Char
  spaceChar = satisfy $ \c -> c == ' ' || c == '\t'
  
  -- | Parses a nonspace, nonnewline character.
  nonspaceChar :: (Stream s m Char, UpdateSourcePos s Char)
               => ParsecT s st m Char
  nonspaceChar = satisfy (not . isSpaceChar)
  
  isSpaceChar :: Char -> Bool
  isSpaceChar ' '  = True
  isSpaceChar '\t' = True
  isSpaceChar '\n' = True
  isSpaceChar '\r' = True
  isSpaceChar _    = False
  
  -- | Skips zero or more spaces or tabs.
  skipSpaces :: (Stream s m Char, UpdateSourcePos s Char)
             => ParsecT s st m ()
  skipSpaces = skipMany spaceChar
  
  -- | Skips zero or more spaces or tabs, then reads a newline.
  blankline :: (Stream s m Char, UpdateSourcePos s Char)
            => ParsecT s st m Char
  blankline = try $ skipSpaces >> newline
  
  -- | Parses one or more blank lines and returns a string of newlines.
  blanklines :: (Stream s m Char, UpdateSourcePos s Char)
             => ParsecT s st m Text
  blanklines = T.pack <$> many1 blankline
  
  -- | Gobble n spaces; if tabs are encountered, expand them
  -- and gobble some or all of their spaces, leaving the rest.
  gobbleSpaces :: (HasReaderOptions st, Monad m)
               => Int -> ParsecT Sources st m ()
  gobbleSpaces 0 = return ()
  gobbleSpaces n
    | n < 0     = error "gobbleSpaces called with negative number"
    | otherwise = try $ do
        char ' ' <|> eatOneSpaceOfTab
        gobbleSpaces (n - 1)
  
  eatOneSpaceOfTab :: (HasReaderOptions st, Monad m) => ParsecT Sources st m Char
  eatOneSpaceOfTab = do
    lookAhead (char '\t')
    pos <- getPosition
    tabstop <- getOption readerTabStop
    -- replace the tab on the input stream with spaces
    let numSpaces = tabstop - ((sourceColumn pos - 1) `mod` tabstop)
    inp <- getInput
    setInput $
      case inp of
        Sources [] -> error "eatOneSpaceOfTab - empty Sources list"
        Sources ((fp,t):rest) ->
          -- drop the tab and add spaces
          Sources ((fp, T.replicate numSpaces " " <> T.drop 1 t):rest)
    char ' '
  
  -- | Gobble up to n spaces; if tabs are encountered, expand them
  -- and gobble some or all of their spaces, leaving the rest.
  gobbleAtMostSpaces :: (HasReaderOptions st, Monad m)
                     => Int -> ParsecT Sources st m Int
  gobbleAtMostSpaces 0 = return 0
  gobbleAtMostSpaces n
    | n < 0     = error "gobbleAtMostSpaces called with negative number"
    | otherwise = option 0 $ do
        char ' ' <|> eatOneSpaceOfTab
        (+ 1) <$> gobbleAtMostSpaces (n - 1)
  
  -- | Parses material enclosed between start and end parsers.
  enclosed :: (Show end, Stream s m Char, UpdateSourcePos s Char)
           => ParsecT s st m t   -- ^ start parser
           -> ParsecT s st m end  -- ^ end parser
           -> ParsecT s st m a    -- ^ content parser (to be used repeatedly)
           -> ParsecT s st m [a]
  enclosed start end parser = try $
    start >> notFollowedBy space >> many1Till parser end
  
  -- | Parse string, case insensitive.
  stringAnyCase :: (Stream s m Char, UpdateSourcePos s Char)
                => Text -> ParsecT s st m Text
  stringAnyCase = fmap T.pack . stringAnyCase' . T.unpack
  
  stringAnyCase' :: (Stream s m Char, UpdateSourcePos s Char)
                 => String -> ParsecT s st m String
  stringAnyCase' [] = string ""
  stringAnyCase' (x:xs) = do
    firstChar <- char (toUpper x) <|> char (toLower x)
    rest <- stringAnyCase' xs
    return (firstChar:rest)
  
  -- TODO rewrite by just adding to Sources stream?
  -- | Parse contents of 'str' using 'parser' and return result.
  parseFromString :: Monad m
                  => ParsecT Sources st m r
                  -> Text
                  -> ParsecT Sources st m r
  parseFromString parser str = do
    oldPos <- getPosition
    oldInput <- getInput
    setInput $ toSources str
    setPosition $ initialPos $ sourceName oldPos <> "_chunk"
    result <- parser
    setInput oldInput
    setPosition oldPos
    return result
  
  -- | Like 'parseFromString' but specialized for 'ParserState'.
  -- This resets 'stateLastStrPos', which is almost always what we want.
  parseFromString' :: (Monad m, HasLastStrPosition u)
                   => ParsecT Sources u m a
                   -> Text
                   -> ParsecT Sources u m a
  parseFromString' parser str = do
    oldLastStrPos <- getLastStrPos <$> getState
    updateState $ setLastStrPos Nothing
    res <- parseFromString parser str
    updateState $ setLastStrPos oldLastStrPos
    return res
  
  -- | Parse raw line block up to and including blank lines.
  lineClump :: Monad m => ParsecT Sources st m Text
  lineClump = blanklines
            <|> (T.unlines <$> many1 (notFollowedBy blankline >> anyLine))
  
  -- | Parse a string of characters between an open character
  -- and a close character, including text between balanced
  -- pairs of open and close, which must be different. For example,
  -- @charsInBalanced '(' ')' (Data.Text.singleton <$> anyChar)@ will parse
  -- "(hello (there))" and return "hello (there)".
  charsInBalanced :: (Stream s m Char, UpdateSourcePos s Char)
                  => Char -> Char -> ParsecT s st m Text -> ParsecT s st m Text
  charsInBalanced open close parser = try $ do
    char open
    let isDelim c = c == open || c == close
    raw <- many $ mconcat <$> many1 (notFollowedBy (satisfy isDelim) >> parser)
               <|> (do res <- charsInBalanced open close parser
                       return $ T.singleton open <> res <> T.singleton close)
    char close
    return $ mconcat raw
  
  -- Parsers for email addresses and URIs
  
  -- | Parses an email address; returns original and corresponding
  -- escaped mailto: URI.
  emailAddress :: (Stream s m Char, UpdateSourcePos s Char) => ParsecT s st m (Text, Text)
  emailAddress = try $ toResult <$> mailbox <*> (char '@' *> domain)
   where toResult mbox dom = let full = fromEntities $ T.pack $ mbox ++ '@':dom
                             in  (full, escapeURI $ "mailto:" <> full)
         mailbox           = intercalate "." <$> (emailWord `sepBy1'` dot)
         domain            = intercalate "." <$> (subdomain `sepBy1'` dot)
         dot               = char '.'
         subdomain         = many1 $ alphaNum <|> innerPunct (=='-')
         -- this excludes some valid email addresses, since an
         -- email could contain e.g. '__', but gives better results
         -- for our purposes, when combined with markdown parsing:
         innerPunct f      = try (satisfy f
                                   <* notFollowedBy (satisfy (not . isAlphaNum)))
         -- technically an email address could begin with a symbol,
         -- but allowing this creates too many problems.
         -- See e.g. https://github.com/jgm/pandoc/issues/2940
         emailWord         = do x <- satisfy isAlphaNum
                                xs <- many (satisfy isEmailChar)
                                return (x:xs)
         isEmailChar c     = isAlphaNum c || isEmailPunct c
         isEmailPunct c    = T.any (== c) "!\"#$%&'*+-/=?^_{|}~;"
  
  
  uriScheme :: (Stream s m Char, UpdateSourcePos s Char) => ParsecT s st m Text
  uriScheme = oneOfStringsCI (Set.toList schemes)
  
  -- | Parses a URI. Returns pair of original and URI-escaped version.
  uri :: (Stream s m Char, UpdateSourcePos s Char) => ParsecT s st m (Text, Text)
  uri = try $ do
    scheme <- uriScheme
    char ':'
    -- Avoid parsing e.g. "**Notes:**" as a raw URI:
    notFollowedBy $ satisfy (\c -> c == '*' || c == '_' || c == ']')
    -- We allow sentence punctuation except at the end, since
    -- we don't want the trailing '.' in 'http://google.com.' We want to allow
    -- http://en.wikipedia.org/wiki/State_of_emergency_(disambiguation)
    -- as a URL, while NOT picking up the closing paren in
    -- (http://wikipedia.org). So we include balanced parens in the URL.
    str <- T.concat <$> many1 (uriChunkBetween '(' ')'
                          <|> uriChunkBetween '{' '}'
                          <|> uriChunkBetween '[' ']'
                          <|> T.pack <$> uriChunk)
    str' <- option str $ char '/' >> return (str <> "/")
    let uri' = scheme <> ":" <> fromEntities str'
    return (uri', escapeURI uri')
    where
      isWordChar '#' = True
      isWordChar '$' = True
      isWordChar '%' = True
      isWordChar '+' = True
      isWordChar '/' = True
      isWordChar '@' = True
      isWordChar '\\' = True
      isWordChar '_' = True
      isWordChar '-' = True
      isWordChar '&' = True
      isWordChar '=' = True
      isWordChar c   = isAlphaNum c
  
      wordChar = satisfy isWordChar
      percentEscaped = try $ (:) <$> char '%' <*> many1 hexDigit
      entity = try $ T.unpack <$> characterReference
      punct = try $ many1 (char ',') <|> fmap pure (satisfy (\c -> not (isSpace c) && c /= '<' && c /= '>'))
      uriChunk = many1 wordChar
             <|> percentEscaped
             <|> entity
             <|> try (punct <* lookAhead (void wordChar <|> void percentEscaped))
      uriChunkBetween l r = try $ do chunk <- between (char l) (char r) uriChunk
                                     return (T.pack $ [l] ++ chunk ++ [r])
  
  -- | Applies a parser, returns tuple of its results and its horizontal
  -- displacement (the difference between the source column at the end
  -- and the source column at the beginning). Vertical displacement
  -- (source row) is ignored.
  withHorizDisplacement :: (Stream s m Char, UpdateSourcePos s Char)
                        => ParsecT s st m a  -- ^ Parsec to apply
                        -> ParsecT s st m (a, Int) -- ^ (result, displacement)
  withHorizDisplacement parser = do
    pos1 <- getPosition
    result <- parser
    pos2 <- getPosition
    return (result, sourceColumn pos2 - sourceColumn pos1)
  
  -- | Applies a parser and returns the raw string that was parsed,
  -- along with the value produced by the parser.
  withRaw :: Monad m
          => ParsecT Sources st m a
          -> ParsecT Sources st m (a, Text)
  withRaw parser = do
    inps1 <- getInput
    result <- parser
    inps2 <- getInput
    -- 'raw' is the difference between inps1 and inps2
    return (result, sourcesDifference inps1 inps2)
  
  sourcesDifference :: Sources -> Sources -> Text
  sourcesDifference (Sources is1) (Sources is2) = go is1 is2
   where
     go inps1 inps2 =
      case (inps1, inps2) of
        ([], _) -> mempty
        (_, []) -> mconcat $ map snd inps1
        ((p1,t1):rest1, (p2, t2):rest2)
          | p1 == p2
          , t1 == t2  -> go rest1 rest2
          | p1 == p2
          , t1 /= t2  -> fromMaybe mempty $ T.stripSuffix t2 t1
          | otherwise -> t1 <> go rest1 inps2
  
  -- | Parses backslash, then applies character parser.
  escaped :: (Stream s m Char, UpdateSourcePos s Char)
          => ParsecT s st m Char  -- ^ Parsec for character to escape
          -> ParsecT s st m Char
  escaped parser = try $ char '\\' >> parser
  
  -- | Parse character entity.
  characterReference :: (Stream s m Char, UpdateSourcePos s Char) => ParsecT s st m Text
  characterReference = try $ do
    char '&'
    ent <- many1TillChar nonspaceChar (char ';')
    case lookupEntity (ent <> ";") of
         Just t       -> return t
         _            -> Prelude.fail "entity not found"
  
  -- | Parses a character reference and returns a Str element.
  charRef :: (Stream s m Char, UpdateSourcePos s Char) => ParsecT s st m Inline
  charRef = Str <$> characterReference
  
  lineBlockLine :: Monad m => ParsecT Sources st m Text
  lineBlockLine = try $ do
    char '|'
    char ' '
    white <- T.pack <$> many (spaceChar >> return '\160')
    notFollowedBy newline
    line <- anyLine
    continuations <- many (try $ char ' ' >> anyLine)
    return $ white <> T.unwords (line : continuations)
  
  blankLineBlockLine :: (Stream s m Char, UpdateSourcePos s Char) => ParsecT s st m Char
  blankLineBlockLine = try (char '|' >> blankline)
  
  -- | Parses an RST-style line block and returns a list of strings.
  lineBlockLines :: Monad m => ParsecT Sources st m [Text]
  lineBlockLines = try $ do
    lines' <- many1 (lineBlockLine <|> (T.singleton <$> blankLineBlockLine))
    skipMany blankline
    return lines'
  
  
  -- | Removes the ParsecT layer from the monad transformer stack
  readWithM :: (Monad m, ToSources t)
            => ParsecT Sources st m a  -- ^ parser
            -> st                      -- ^ initial state
            -> t                       -- ^ input
            -> m (Either PandocError a)
  readWithM parser state input =
      Bifunctor.first (fromParsecError sources)
        <$> runParserT parser state (initialSourceName sources) sources
   where
     sources = toSources input
  
  
  -- | Parse a string with a given parser and state
  readWith :: ToSources t
           => Parsec Sources st a
           -> st
           -> t
           -> Either PandocError a
  readWith p t inp = runIdentity $ readWithM p t inp
  
  -- | Parse a string with @parser@ (for testing).
  testStringWith :: Show a
                 => ParsecT Sources ParserState Identity a
                 -> Text
                 -> IO ()
  testStringWith parser str = UTF8.putStrLn $ tshow $
                              readWith parser defaultParserState (toSources str)
  
  -- | Add header to the list of headers in state, together
  --  with its associated identifier.  If the identifier is null
  --  and the auto_identifiers extension is set, generate a new
  --  unique identifier, and update the list of identifiers
  --  in state.  Issue a warning if an explicit identifier
  --  is encountered that duplicates an earlier identifier
  --  (explicit or automatically generated).
  registerHeader :: (Stream s m a, HasReaderOptions st,
                     HasLogMessages st, HasIdentifierList st)
                 => Attr -> Inlines -> ParsecT s st m Attr
  registerHeader (ident,classes,kvs) header' = do
    ids <- extractIdentifierList <$> getState
    exts <- getOption readerExtensions
    if T.null ident && Ext_auto_identifiers `extensionEnabled` exts
       then do
         let id' = uniqueIdent exts (B.toList header') ids
         let id'' = if Ext_ascii_identifiers `extensionEnabled` exts
                       then toAsciiText id'
                       else id'
         updateState $ updateIdentifierList $ Set.insert id'
         updateState $ updateIdentifierList $ Set.insert id''
         return (id'',classes,kvs)
       else do
          unless (T.null ident) $ do
            when (ident `Set.member` ids) $ do
              pos <- getPosition
              logMessage $ DuplicateIdentifier ident pos
            updateState $ updateIdentifierList $ Set.insert ident
          return (ident,classes,kvs)
  
  token :: (Stream s m t)
        => (t -> Text)
        -> (t -> SourcePos)
        -> (t -> Maybe a)
        -> ParsecT s st m a
  token pp pos match = tokenPrim (T.unpack . pp) (\_ t _ -> pos t) match
  
  infixr 5 <+?>
  (<+?>) :: (Monoid a) => ParsecT s st m a -> ParsecT s st m a -> ParsecT s st m a
  a <+?> b = a >>= flip fmap (try b <|> return mempty) . mappend
  
  extractIdClass :: Attr -> Attr
  extractIdClass (ident, cls, kvs) = (ident', cls', kvs')
    where
      ident' = fromMaybe ident (lookup "id" kvs)
      cls'   = maybe cls T.words $ lookup "class" kvs
      kvs'   = filter (\(k,_) -> k /= "id" || k /= "class") kvs
  
  insertIncludedFile :: (PandocMonad m, HasIncludeFiles st)
                     => ParsecT a st m b -- ^ parser to apply
                     -> (Text -> a) -- ^ convert Text to stream type
                     -> [FilePath]  -- ^ search path (directories)
                     -> FilePath    -- ^ path of file to include
                     -> Maybe Int   -- ^ start line (negative counts from end)
                     -> Maybe Int   -- ^ end line (negative counts from end)
                     -> ParsecT a st m b
  insertIncludedFile parser toStream dirs f mbstartline mbendline = do
    oldPos <- getPosition
    oldInput <- getInput
    containers <- getIncludeFiles <$> getState
    when (T.pack f `elem` containers) $
      throwError $ PandocParseError $ T.pack $ "Include file loop at " ++ show oldPos
    updateState $ addIncludeFile $ T.pack f
    mbcontents <- readFileFromDirs dirs f
    contents <- case mbcontents of
                     Just s -> return $ exciseLines mbstartline mbendline s
                     Nothing -> do
                       report $ CouldNotLoadIncludeFile (T.pack f) oldPos
                       return ""
    setInput $ toStream contents
    setPosition $ newPos f (fromMaybe 1 mbstartline) 1
    result <- parser
    setInput oldInput
    setPosition oldPos
    updateState dropLatestIncludeFile
    return result
  
  exciseLines :: Maybe Int -> Maybe Int -> Text -> Text
  exciseLines Nothing Nothing t = t
  exciseLines mbstartline mbendline t =
    T.unlines $ take (endline' - (startline' - 1))
              $ drop (startline' - 1) contentLines
   where
    contentLines = T.lines t
    numLines = length contentLines
    startline' = case mbstartline of
                   Nothing -> 1
                   Just x | x >= 0 -> x
                          | otherwise -> numLines + x -- negative from end
    endline' = case mbendline of
                   Nothing -> numLines
                   Just x | x >= 0 -> x
                          | otherwise -> numLines + x -- negative from end
  
  fromParsecError :: Sources -> ParseError -> PandocError
  fromParsecError (Sources inputs) err' = PandocParseError msg
   where
    msg = "Error at " <> tshow  err' <> errorContext
    errPos = errorPos err'
    errLine = sourceLine errPos
    errColumn = sourceColumn errPos
    errFile = sourceName errPos
    errorContext =
      case sortOn (Down . sourceLine . fst)
              [ (pos,t)
                | (pos,t) <- inputs
                , sourceName pos == errFile
                , sourceLine pos <= errLine
              ] of
        []  -> ""
        ((pos,txt):_) ->
          let ls = T.lines txt <> [""]
              ln = (errLine - sourceLine pos) + 1
           in if length ls > ln && ln >= 1
                 then T.concat ["\n", ls !! (ln - 1)
                               ,"\n", T.replicate (errColumn - 1) " "
                               ,"^"]
                 else ""
  