General.hs

{-# 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 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 t = TL.toStrict . TB.toLazyText <$> go (T.unpack t)
  where
    go [] = string "" $> mempty
    go (x:xs) = do
      c <- char (toUpper x) <|> char (toLower x)
      rest <- go xs
      pure $ TB.singleton c <> 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    = c `Set.member` emailPunctChars

emailPunctChars :: Set.Set Char
emailPunctChars = Set.fromList "!\"#$%&'*+-/=?^_{|}~;"

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.singleton l <> T.pack chunk <> T.singleton 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 case drop (ln - 1) ls of
               (l:_) | ln >= 1 ->
                 T.concat ["\n", l
                          ,"\n", T.replicate (errColumn - 1) " "
                          ,"^"]
               _ -> ""