path: root/src/Text/Pandoc/Readers/RST.hs

{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns        #-}
{- |
   Module      : Text.Pandoc.Readers.RST
   Copyright   : Copyright (C) 2006-2024 John MacFarlane
   License     : GNU GPL, version 2 or above

   Maintainer  : John MacFarlane <[email protected]>
   Stability   : alpha
   Portability : portable

Conversion from reStructuredText to 'Pandoc' document.
-}
module Text.Pandoc.Readers.RST ( readRST ) where
import Control.Arrow (second)
import Control.Monad (forM_, guard, liftM, mplus, mzero, when, unless, void)
import Control.Monad.Except (throwError)
import Control.Monad.Identity (Identity (..))
import Data.Char (isHexDigit, isSpace, toUpper, isAlphaNum, generalCategory,
                  GeneralCategory(OpenPunctuation, InitialQuote, FinalQuote,
                                  DashPunctuation, OtherSymbol))
import Data.List (deleteFirstsBy, elemIndex, nub, partition, sort, transpose)
import qualified Data.Map as M
import Data.Maybe (fromMaybe, maybeToList, isJust, isNothing, catMaybes)
import Data.Sequence (ViewR (..), viewr)
import Data.Text (Text)
import qualified Data.Text as T
import Text.Printf (printf)
import Text.Pandoc.Builder (Blocks, Inlines, fromList, setMeta, trimInlines)
import qualified Text.Pandoc.Builder as B
import Text.Pandoc.Class (PandocMonad, readFileFromDirs, fetchItem, getTimestamp)
import Text.Pandoc.CSV (CSVOptions (..), defaultCSVOptions, parseCSV)
import Text.Pandoc.Definition
import Text.Pandoc.Error
import Text.Pandoc.ImageSize (lengthToDim, scaleDimension)
import Text.Pandoc.Logging
import Text.Pandoc.Options
import Text.Pandoc.Parsing
import Text.Pandoc.Shared
import Text.Pandoc.URI
import Text.Pandoc.Walk (walkM)
import qualified Text.Pandoc.UTF8 as UTF8
import Data.Time.Format
import System.FilePath (takeDirectory)

-- TODO:
-- [ ] .. parsed-literal

-- | Parse reStructuredText string and return Pandoc document.
readRST :: (PandocMonad m, ToSources a)
        => ReaderOptions -- ^ Reader options
        -> a
        -> m Pandoc
readRST opts s = do
  parsed <- readWithM parseRST def{ stateOptions = opts }
               (ensureFinalNewlines 2 (toSources s))
  case parsed of
    Right result -> return result
    Left e       -> throwError e

type RSTParser m = ParsecT Sources ParserState m

--
-- Constants and data structure definitions
---

bulletListMarkers :: [Char]
bulletListMarkers = "*+-•‣⁃"

underlineChars :: [Char]
underlineChars = "!\"#$%&'()*+,-./:;<=>?@[\\]^_`{|}~"

-- treat these as potentially non-text when parsing inline:
specialChars :: [Char]
specialChars = "\\`|*_<>$:/[]{}()-.\"'\8216\8217\8220\8221"

--
-- parsing documents
--

isHeader :: Int -> Block -> Bool
isHeader n (Header x _ _) = x == n
isHeader _ _              = False

-- | Promote all headers in a list of blocks.  (Part of
-- title transformation for RST.)
promoteHeaders :: Int -> [Block] -> [Block]
promoteHeaders num (Header level attr text:rest) =
    Header (level - num) attr text:promoteHeaders num rest
promoteHeaders num (other:rest) = other:promoteHeaders num rest
promoteHeaders _   [] = []

-- | If list of blocks starts with a header (or a header and subheader)
-- of level that are not found elsewhere, return it as a title and
-- promote all the other headers.  Also process a definition list right
-- after the title block as metadata.
titleTransform :: ([Block], Meta)  -- ^ list of blocks, metadata
               -> ([Block], Meta)  -- ^ modified list of blocks, metadata
titleTransform (bs, meta) =
  let (bs', meta') =
       case bs of
          (Header 1 _ head1:Header 2 _ head2:rest)
           | not (any (isHeader 1) rest || any (isHeader 2) rest) -> -- tit/sub
            (promoteHeaders 2 rest, setMeta "title" (fromList head1) $
              setMeta "subtitle" (fromList head2) meta)
          (Header 1 _ head1:rest)
           | not (any (isHeader 1) rest) -> -- title only
            (promoteHeaders 1 rest,
                setMeta "title" (fromList head1) meta)
          _ -> (bs, meta)
  in   case bs' of
          (DefinitionList ds : rest) ->
            (rest, metaFromDefList ds meta')
          _ -> (bs', meta')

metaFromDefList :: [([Inline], [[Block]])] -> Meta -> Meta
metaFromDefList ds meta = adjustAuthors $ foldr f meta ds
 where f (k,v) =
         case v of
           [[Plain ils]] ->  setMeta (T.toLower (stringify k)) $ MetaInlines ils
           _ -> setMeta (T.toLower (stringify k)) $ mconcat $ map fromList v
       adjustAuthors (Meta metamap) = Meta $ M.adjust splitAuthors "author"
                                           $ M.mapKeys (\k ->
                                                 if k == "authors"
                                                    then "author"
                                                    else k) metamap
       splitAuthors (MetaInlines xs)  = MetaList $ map MetaInlines
                                                 $ splitAuthors' xs
       splitAuthors x                 = x
       splitAuthors'                  = map normalizeSpaces .
                                         splitOnSemi . concatMap factorSemi
       normalizeSpaces                = reverse . dropWhile isSp . reverse .
                                         dropWhile isSp
       isSp Space     = True
       isSp SoftBreak = True
       isSp LineBreak = True
       isSp _         = False
       splitOnSemi                    = splitBy (==Str ";")
       factorSemi (Str "")            = []
       factorSemi (Str s)             = case T.break (==';') s of
                                          (xs,"") -> [Str xs]
                                          (xs,T.uncons -> Just (';',ys)) -> Str xs : Str ";" :
                                            factorSemi (Str ys)
                                          (xs,ys) -> Str xs :
                                            factorSemi (Str ys)
       factorSemi x                   = [x]

parseRST :: PandocMonad m => RSTParser m Pandoc
parseRST = do
  standalone <- getOption readerStandalone
  optional blanklines -- skip blank lines at beginning of file
  blocks <- B.toList <$> parseBlocks
  citations <- sort . M.toList . stateCitations <$> getState
  citationItems <- mapM parseCitation citations
  let refBlock = [Div ("citations",[],[]) $
                 B.toList $ B.definitionList citationItems | not (null citationItems)]
  state <- getState
  let meta = stateMeta state
  let (blocks', meta') = if standalone
                            then titleTransform (blocks, meta)
                            else (blocks, meta)
  let reversedNotes = stateNotes state
  updateState $ \s -> s { stateNotes = reverse reversedNotes }
  doc <- walkM resolveReferences =<<
         walkM resolveBlockSubstitutions
         (Pandoc meta' (blocks' ++ refBlock))
  reportLogMessages
  return doc

resolveBlockSubstitutions :: PandocMonad m => Block -> RSTParser m Block
resolveBlockSubstitutions x@(Para [Link _attr _ (s,_)])
  | Just ref <- T.stripPrefix "##SUBST##" s = do
          substTable <- stateSubstitutions <$> getState
          let key@(Key key') = toKey $ stripFirstAndLast ref
          case M.lookup key substTable of
               Nothing     -> do
                 pos <- getPosition
                 logMessage $ ReferenceNotFound (tshow key') pos
                 return x
               Just target -> case
                 B.toList target of
                   [bl] -> return bl
                   bls -> return $ Div nullAttr bls
resolveBlockSubstitutions x = return x

resolveReferences :: PandocMonad m => Inline -> RSTParser m Inline
resolveReferences x@(Link _ ils (s,_))
  | Just ref <- T.stripPrefix "##REF##" s = do
      let isAnonKey (Key (T.uncons -> Just ('_',_))) = True
          isAnonKey _                                = False
      state <- getState
      let keyTable = stateKeys state
      let anonKeys = sort $ filter isAnonKey $ M.keys keyTable
      key <-  if ref == "_" -- anonymous key
                then
                  case anonKeys of
                    []    -> mzero -- TODO log?
                    (k:_) -> return k
                else return $ toKey ref
      ((src,tit), attr) <- lookupKey [] key
      -- if anonymous link, remove key so it won't be used again
      when (isAnonKey key) $ updateState $ \st ->
                              st{ stateKeys = M.delete key keyTable }
      return $ Link attr ils (src, tit)
  | Just ref <- T.stripPrefix "##NOTE##" s = do
      state <- getState
      let notes = stateNotes state
      case lookup ref notes of
        Nothing   -> do
          pos <- getPosition
          logMessage $ ReferenceNotFound ref pos
          return x
        Just raw  -> do
          -- We temporarily empty the note list while parsing the note,
          -- so that we don't get infinite loops with notes inside notes...
          -- Note references inside other notes are allowed in reST, but
          -- not yet in this implementation.
          updateState $ \st -> st{ stateNotes = [] }
          contents <- parseFromString' parseBlocks raw
          let newnotes = if ref == "*" || ref == "#" -- auto-numbered
                            -- delete the note so the next auto-numbered note
                            -- doesn't get the same contents:
                            then deleteFirstsBy (==) notes [(ref,raw)]
                            else notes
          updateState $ \st -> st{ stateNotes = newnotes }
          return $ Note (B.toList contents)
  | Just ref <- T.stripPrefix "##SUBST##" s = do
          substTable <- stateSubstitutions <$> getState
          let key@(Key key') = toKey $ stripFirstAndLast ref
          case M.lookup key substTable of
               Nothing     -> do
                 pos <- getPosition
                 logMessage $ ReferenceNotFound (tshow key') pos
                 return x
               Just target -> case
                 B.toList target of
                   [Para [t]] -> return t
                   [Para xs] -> return $ Span nullAttr xs
                   bls -> return $ Span nullAttr $ blocksToInlines bls
  | otherwise = return x
resolveReferences x = return x

parseCitation :: PandocMonad m
              => (Text, Text) -> RSTParser m (Inlines, [Blocks])
parseCitation (ref, raw) = do
  contents <- parseFromString' parseBlocks raw
  return (B.spanWith (ref, ["citation-label"], []) (B.str ref),
           [contents])


--
-- parsing blocks
--

parseBlocks :: PandocMonad m => RSTParser m Blocks
parseBlocks = mconcat <$> manyTill block eof

block :: PandocMonad m => RSTParser m Blocks
block = choice [ codeBlock
               , blockQuote
               , fieldList
               , optionList
               , referenceKey
               , noteBlock
               , citationBlock
               , directive
               , anchor
               , comment
               , header
               , hrule
               , lineBlock     -- must go before definitionList
               , table
               , list
               , lhsCodeBlock
               , para
               , mempty <$ blanklines
               ] <?> "block"

--
-- field list
--

rawFieldListItem :: Monad m => Int -> RSTParser m (Text, Text)
rawFieldListItem minIndent = try $ do
  indent <- length <$> many (char ' ')
  guard $ indent >= minIndent
  char ':'
  name <- many1TillChar (noneOf "\n") (char ':')
  (void (lookAhead newline)) <|> skipMany1 spaceChar
  first <- anyLine
  rest <- option "" $ try $ do lookAhead (count indent (char ' ') >> spaceChar)
                               indentedBlock
  let raw = (if T.null first then "" else first <> "\n") <> rest <>
            (if T.null first && T.null rest then "" else "\n")
  return (name, raw)

fieldListItem :: PandocMonad m => Int -> RSTParser m (Inlines, [Blocks])
fieldListItem minIndent = try $ do
  (name, raw) <- rawFieldListItem minIndent
  term <- parseInlineFromText name
  contents <- parseFromString' parseBlocks raw
  optional blanklines
  let defn = case B.toList contents of
                [Para ils] -> [B.plain $ B.fromList ils] -- see #7766
                _ -> [contents]
  return (term, defn)

fieldList :: PandocMonad m => RSTParser m Blocks
fieldList = try $ do
  indent <- length <$> lookAhead (many spaceChar)
  items <- many1 $ fieldListItem indent
  case items of
     []     -> return mempty
     items' -> return $ B.definitionList items'

optionList :: PandocMonad m => RSTParser m Blocks
optionList = B.definitionList <$> many1 optionListItem

optionListItem :: PandocMonad m => RSTParser m (Inlines, [Blocks])
optionListItem = try $ do
  opts <- snd <$> withRaw (do
     let anyOpt = shortOpt <|> longOpt <|> dosOpt
     anyOpt
     many $ try (char ',' <* many spaceChar *> anyOpt))
  -- at least two spaces
  rawfirst <- try (char ' ' *> many1 (char ' ') *> anyLineNewline)
                    <|> try (mempty <$ skipMany spaceChar <* newline)
  bodyElements <- do
    raw <- option "" indentedBlock
    parseFromString' parseBlocks $ (rawfirst <> raw) <> "\n\n"
  optional blanklines
  pure (B.code opts, [bodyElements])

shortOpt :: PandocMonad m => RSTParser m ()
shortOpt = try $ do
  char '-'
  alphaNum
  optional $ try (optional (char ' ') *> optArg)

optArg :: PandocMonad m => RSTParser m ()
optArg = do
  c <- letter <|> char '<'
  if c == '<'
     then void $ manyTill (noneOf "<>") (char '>')
     else skipMany (alphaNum <|> char '_' <|> char '-')

longOpt :: PandocMonad m => RSTParser m ()
longOpt = try $ do
  char '-'
  char '-'
  alphaNum
  skipMany1 (alphaNum <|> char '-' <|> char '_')
  optional $ try (oneOf " =" *> optArg)

dosOpt :: PandocMonad m => RSTParser m ()
dosOpt = try $ do
  char '/'
  alphaNum <|> char '?'
  optional $ try (char ' ' *> optArg)

--
-- line block
--

lineBlock :: PandocMonad m => RSTParser m Blocks
lineBlock = try $ do
  lines' <- lineBlockLines
  lines'' <- mapM parseInlineFromText lines'
  return $ B.lineBlock lines''

lineBlockDirective :: PandocMonad m => Text -> RSTParser m Blocks
lineBlockDirective body = do
  lines' <- mapM parseInlineFromText $ T.lines $ stripTrailingNewlines body
  return $ B.lineBlock lines'

--
-- paragraph block
--

-- note: paragraph can end in a :: starting a code block
para :: PandocMonad m => RSTParser m Blocks
para = try $ do
  result <- trimInlines . mconcat <$> many1 inline
  option (B.plain result) $ try $ do
    newline
    blanklines
    case viewr (B.unMany result) of
         ys :> Str xs | "::" `T.isSuffixOf` xs -> do
              raw <- option mempty codeBlockBody
              return $ B.para (B.Many ys <> B.str (T.take (T.length xs - 1) xs))
                         <> raw
         _ -> return (B.para result)

plain :: PandocMonad m => RSTParser m Blocks
plain = B.plain . trimInlines . mconcat <$> many1 inline

--
-- header blocks
--

header :: PandocMonad m => RSTParser m Blocks
header = doubleHeader <|> singleHeader <?> "header"

-- a header with lines on top and bottom
doubleHeader :: PandocMonad m => RSTParser m Blocks
doubleHeader = do
  (txt, c) <- doubleHeader'
  -- check to see if we've had this kind of header before.
  -- if so, get appropriate level.  if not, add to list.
  state <- getState
  let headerTable = stateHeaderTable state
  let (headerTable',level) = case elemIndex (DoubleHeader c) headerTable of
        Just ind -> (headerTable, ind + 1)
        Nothing  -> (headerTable ++ [DoubleHeader c], length headerTable + 1)
  setState (state { stateHeaderTable = headerTable' })
  attr@(ident,_,_) <- registerHeader nullAttr txt
  let key = toKey (stringify txt)
  updateState $ \s ->
    s { stateKeys = M.insert key (("#" <> ident,""), nullAttr) $ stateKeys s }
  return $ B.headerWith attr level txt

doubleHeader' :: PandocMonad m => RSTParser m (Inlines, Char)
doubleHeader' = try $ do
  c <- oneOf underlineChars
  rest <- many (char c)  -- the top line
  let lenTop = length (c:rest)
  skipSpaces
  newline
  txt <- trimInlines . mconcat <$> many1 (notFollowedBy blankline >> inline)
  pos <- getPosition
  let len = sourceColumn pos - 1
  when (len > lenTop) $ Prelude.fail "title longer than border"
  blankline              -- spaces and newline
  count lenTop (char c)  -- the bottom line
  blanklines
  return (txt, c)

-- a header with line on the bottom only
singleHeader :: PandocMonad m => RSTParser m Blocks
singleHeader = do
  (txt, c) <- singleHeader'
  state <- getState
  let headerTable = stateHeaderTable state
  let (headerTable',level) = case elemIndex (SingleHeader c) headerTable of
        Just ind -> (headerTable, ind + 1)
        Nothing  -> (headerTable ++ [SingleHeader c], length headerTable + 1)
  setState (state { stateHeaderTable = headerTable' })
  attr@(ident,_,_) <- registerHeader nullAttr txt
  let key = toKey (stringify txt)
  updateState $ \s ->
    s { stateKeys = M.insert key (("#" <> ident,""), nullAttr) $ stateKeys s }
  return $ B.headerWith attr level txt

singleHeader' :: PandocMonad m => RSTParser m (Inlines, Char)
singleHeader' = try $ do
  notFollowedBy' whitespace
  lookAhead $ anyLine >> oneOf underlineChars
  txt <- trimInlines . mconcat <$> many1 (notFollowedBy blankline >> inline)
  pos <- getPosition
  let len = sourceColumn pos - 1
  blankline
  c <- oneOf underlineChars
  count (len - 1) (char c)
  many (char c)
  blanklines
  return (txt, c)

--
-- hrule block
--

hrule :: Monad m => ParsecT Sources st m Blocks
hrule = try $ do
  chr <- oneOf underlineChars
  count 3 (char chr)
  skipMany (char chr)
  blankline
  blanklines
  return B.horizontalRule

--
-- code blocks
--

-- read a line indented by a given string
indentedLine :: (HasReaderOptions st, Monad m)
             => Int -> ParsecT Sources st m Text
indentedLine indents = try $ do
  lookAhead spaceChar
  gobbleAtMostSpaces indents
  anyLine

-- one or more indented lines, possibly separated by blank lines.
-- any amount of indentation will work.
indentedBlock :: (HasReaderOptions st, Monad m)
              => ParsecT Sources st m Text
indentedBlock = try $ do
  indents <- length <$> lookAhead (many1 spaceChar)
  lns <- many1 $ try $ do b <- option "" blanklines
                          l <- indentedLine indents
                          return (b <> l)
  optional blanklines
  return $ T.unlines lns

quotedBlock :: Monad m => ParsecT Sources st m Text
quotedBlock = try $ do
    quote <- lookAhead $ oneOf "!\"#$%&'()*+,-./:;<=>?@[\\]^_`{|}~"
    lns <- many1 $ lookAhead (char quote) >> anyLine
    optional blanklines
    return $ T.unlines lns

codeBlockStart :: Monad m => ParsecT Sources st m Char
codeBlockStart = string "::" >> blankline >> blankline

codeBlock :: Monad m => ParsecT Sources ParserState m Blocks
codeBlock = try $ codeBlockStart >> codeBlockBody

codeBlockBody :: Monad m => ParsecT Sources ParserState m Blocks
codeBlockBody = do
  lang <- stateRstHighlight <$> getState
  try $ B.codeBlockWith ("", maybeToList lang, []) . stripTrailingNewlines <$>
                (indentedBlock <|> quotedBlock)

lhsCodeBlock :: Monad m => RSTParser m Blocks
lhsCodeBlock = try $ do
  getPosition >>= guard . (==1) . sourceColumn
  guardEnabled Ext_literate_haskell
  optional codeBlockStart
  lns <- latexCodeBlock <|> birdCodeBlock
  blanklines
  return $ B.codeBlockWith ("", ["haskell","literate"], [])
         $ T.intercalate "\n" lns

latexCodeBlock :: Monad m => ParsecT Sources st m [Text]
latexCodeBlock = try $ do
  try (latexBlockLine "\\begin{code}")
  many1Till anyLine (try $ latexBlockLine "\\end{code}")
 where
  latexBlockLine s = skipMany spaceChar >> string s >> blankline

birdCodeBlock :: Monad m => ParsecT Sources st m [Text]
birdCodeBlock = filterSpace <$> many1 birdTrackLine
  where filterSpace lns =
            -- if (as is normal) there is always a space after >, drop it
            if all (\ln -> T.null ln || T.take 1 ln == " ") lns
               then map (T.drop 1) lns
               else lns

birdTrackLine :: Monad m => ParsecT Sources st m Text
birdTrackLine = char '>' >> anyLine

--
-- block quotes
--

blockQuote :: PandocMonad m => RSTParser m Blocks
blockQuote = do
  raw <- indentedBlock
  -- parse the extracted block, which may contain various block elements:
  contents <- parseFromString' parseBlocks $ raw <> "\n\n"
  return $ B.blockQuote contents

{-
Unsupported options for include:
tab-width
encoding
-}

includeDirective :: PandocMonad m
                 => Text
                 -> [(Text, Text)]
                 -> Text
                 -> RSTParser m Blocks
includeDirective top fields body = do
  let f = T.unpack $ trim top
  guard $ not $ null f
  guard $ T.null (trim body)
  let startLine = lookup "start-line" fields >>= safeRead
  let endLine = lookup "end-line" fields >>= safeRead
  let classes =  maybe [] T.words (lookup "class" fields)
  let ident = maybe "" trimr $ lookup "name" fields
  let parser =
       case lookup "code" fields `mplus` lookup "literal" fields of
         Just lang ->
           (codeblock ident classes fields (trimr lang) False
            . sourcesToText) <$> getInput
         Nothing   -> parseBlocks
  let isLiteral = isJust (lookup "code" fields `mplus` lookup "literal" fields)
  let selectLines =
        (case trim <$> lookup "end-before" fields of
                         Just patt -> takeWhile (not . (patt `T.isInfixOf`))
                         Nothing   -> id) .
        (case trim <$> lookup "start-after" fields of
                         Just patt -> drop 1 .
                                        dropWhile (not . (patt `T.isInfixOf`))
                         Nothing   -> id)

  let toStream t =
        Sources [(initialPos f,
                   (T.unlines . selectLines . T.lines $ t) <>
                    if isLiteral then mempty else "\n")]  -- see #7436
  currentDir <- takeDirectory . sourceName <$> getPosition
  insertIncludedFile parser toStream [currentDir] f startLine endLine

--
-- list blocks
--

list :: PandocMonad m => RSTParser m Blocks
list = choice [ bulletList, orderedList, definitionList ] <?> "list"

definitionListItem :: PandocMonad m => RSTParser m (Inlines, [Blocks])
definitionListItem = try $ do
  -- avoid capturing a directive or comment
  notFollowedBy (try $ char '.' >> char '.')
  term <- trimInlines . mconcat <$> many1Till inline endline
  raw <- indentedBlock
  -- parse the extracted block, which may contain various block elements:
  contents <- parseFromString' parseBlocks $ raw <> "\n"
  return (term, [contents])

definitionList :: PandocMonad m => RSTParser m Blocks
definitionList = B.definitionList <$> many1 definitionListItem

-- parses bullet list start and returns its length (inc. following whitespace)
bulletListStart :: Monad m => ParsecT Sources st m Int
bulletListStart = try $ do
  notFollowedBy' hrule  -- because hrules start out just like lists
  marker <- oneOf bulletListMarkers
  white <- many1 spaceChar <|> "" <$ lookAhead (char '\n')
  return $ length (marker:white)

-- parses ordered list start and returns its length (inc following whitespace)
orderedListStart :: Monad m => ListNumberStyle
                 -> ListNumberDelim
                 -> RSTParser m Int
orderedListStart style delim = try $ do
  (_, markerLen) <- withHorizDisplacement (orderedListMarker style delim)
  white <- many1 spaceChar <|> "" <$ lookAhead (char '\n')
  return $ markerLen + length white

-- parse a line of a list item
listLine :: Monad m => Int -> RSTParser m Text
listLine markerLength = try $ do
  notFollowedBy blankline
  indentWith markerLength
  anyLineNewline

-- parse raw text for one list item, excluding start marker and continuations
rawListItem :: Monad m => RSTParser m Int
            -> RSTParser m (Int, Text)
rawListItem start = try $ do
  markerLength <- start
  firstLine <- anyLineNewline
  restLines <- many (listLine markerLength)
  return (markerLength, firstLine <> T.concat restLines)

-- continuation of a list item - indented and separated by blankline or
-- (in compact lists) endline.
-- Note: nested lists are parsed as continuations.
listContinuation :: Monad m => Int -> RSTParser m Text
listContinuation markerLength = try $ do
  blanks <- many1Char blankline
  result <- many1 (listLine markerLength)
  return $ blanks <> T.concat result

listItem :: PandocMonad m
         => RSTParser m Int
         -> RSTParser m Blocks
listItem start = try $ do
  (markerLength, first) <- rawListItem start
  rest <- many (listContinuation markerLength)
  skipMany1 blankline <|> void (lookAhead start)
  -- parsing with ListItemState forces markers at beginning of lines to
  -- count as list item markers, even if not separated by blank space.
  -- see definition of "endline"
  state <- getState
  let oldContext = stateParserContext state
  setState $ state {stateParserContext = ListItemState}
  -- parse the extracted block, which may itself contain block elements
  parsed <- parseFromString' parseBlocks $ T.concat (first:rest) <> "\n"
  updateState (\st -> st {stateParserContext = oldContext})
  return $ case B.toList parsed of
                [Para xs] ->
                   B.singleton $ Plain xs
                [Para xs, BulletList ys] ->
                   B.fromList [Plain xs, BulletList ys]
                [Para xs, OrderedList s ys] ->
                   B.fromList [Plain xs, OrderedList s ys]
                [Para xs, DefinitionList ys] ->
                   B.fromList [Plain xs, DefinitionList ys]
                _         -> parsed

orderedList :: PandocMonad m => RSTParser m Blocks
orderedList = try $ do
  (start, style, delim) <- lookAhead (anyOrderedListMarker <* spaceChar)
  items <- many1 (listItem (orderedListStart style delim))
  let items' = compactify items
  return $ B.orderedListWith (start, style, delim) items'

bulletList :: PandocMonad m => RSTParser m Blocks
bulletList = B.bulletList . compactify <$> many1 (listItem bulletListStart)

--
-- directive (e.g. comment, container, compound-paragraph)
--

comment :: Monad m => RSTParser m Blocks
comment = try $ do
  string ".."
  skipMany1 spaceChar <|> void (lookAhead newline)
  -- notFollowedBy' directiveLabel -- comment comes after directive so unnec.
  _ <- anyLine
  optional indentedBlock
  optional blanklines
  return mempty

directiveLabel :: Monad m => RSTParser m Text
directiveLabel = T.toLower
  <$> many1TillChar (letter <|> char '-') (try $ string "::")

directive :: PandocMonad m => RSTParser m Blocks
directive = try $ do
  string ".."
  directive'

directive' :: PandocMonad m => RSTParser m Blocks
directive' = do
  skipMany1 spaceChar
  label <- directiveLabel
  skipMany spaceChar
  top <- manyChar $ satisfy (/='\n')
             <|> try (char '\n' <*
                      notFollowedBy' (rawFieldListItem 1) <*
                      many1 (char ' ') <*
                      notFollowedBy blankline)
  newline
  fields <- do
    fieldIndent <- length <$> lookAhead (many (char ' '))
    if fieldIndent == 0
       then return []
       else many $ rawFieldListItem fieldIndent
  let mbfile = trim <$> lookup "file" fields
  body <- case mbfile of
            Just f | label == "raw" -> do
               currentDir <- takeDirectory . sourceName <$> getPosition
               fromMaybe mempty <$> readFileFromDirs [currentDir] (T.unpack f)
            _ -> option "" $ try $ blanklines >> indentedBlock
  optional blanklines
  let body' = body <> "\n\n"
      name = trim $ fromMaybe "" (lookup "name" fields)
      classes = T.words $ maybe "" trim (lookup "class" fields)
      keyvals = [(k, trim v) | (k, v) <- fields, k /= "name", k /= "class"]
      imgAttr cl = (name, classes, alignClasses, widthAttr ++ heightAttr)
        where
          alignClasses = T.words $ maybe "" trim (lookup cl fields) <>
                          maybe "" (\x -> "align-" <> trim x)
                          (lookup "align" fields)
          scale = case trim <$> lookup "scale" fields of
                    Just v -> case T.unsnoc v of
                      Just (vv, '%') -> case safeRead vv of
                                          Just (percent :: Double)
                                            -> percent / 100.0
                                          Nothing -> 1.0
                      _ -> case safeRead v of
                             Just (s :: Double) -> s
                             Nothing            -> 1.0
                    Nothing -> 1.0
          widthAttr = maybe [] (\x -> [("width",
                                        tshow $ scaleDimension scale x)])
                        $ lookup "width" fields >>=
                          (lengthToDim . T.filter (not . isSpace))
          heightAttr = maybe [] (\x -> [("height",
                                         tshow $ scaleDimension scale x)])
                        $ lookup "height" fields >>=
                          (lengthToDim . T.filter (not . isSpace))
  case label of
        "include" -> includeDirective top fields body'
        "table" -> tableDirective top fields body'
        "list-table" -> listTableDirective top fields body'
        "csv-table" -> csvTableDirective top fields body'
        "line-block" -> lineBlockDirective body'
        "raw" -> return $ B.rawBlock (trim top) (stripTrailingNewlines body)
        "role" -> addNewRole top $ map (second trim) fields
        "container" -> B.divWith
                         (name, "container" : T.words top ++ classes, []) <$>
                          parseFromString' parseBlocks body'
        "replace" -> B.para <$>  -- consumed by substKey
                   parseInlineFromText (trim top)
        "date" -> B.para <$> do  -- consumed by substKey
                     t <- getTimestamp
                     let format = case T.unpack (T.strip top) of
                                    [] -> "%Y-%m-%d"
                                    x  -> x
                     return $ B.text $
                              T.pack $ formatTime defaultTimeLocale format t
        "unicode" -> B.para <$>  -- consumed by substKey
                   parseInlineFromText (trim $ unicodeTransform top)
        "compound" -> parseFromString' parseBlocks body'
        "pull-quote" -> B.blockQuote <$> parseFromString' parseBlocks body'
        "epigraph" -> B.blockQuote <$> parseFromString' parseBlocks body'
        "highlights" -> B.blockQuote <$> parseFromString' parseBlocks body'
        "rubric" -> B.para . B.strong <$> parseInlineFromText top
        _ | label `elem` ["attention","caution","danger","error","hint",
                          "important","note","tip","warning","admonition"] ->
           do bod <- parseFromString' parseBlocks $ top <> "\n\n" <> body'
              let lab = case label of
                          "admonition" -> mempty
                          (T.uncons -> Just (l, ls))
                            -> B.divWith ("",["title"],[])
                                          (B.para (B.str $ T.cons (toUpper l)  ls))
                          _ -> mempty
              return $ B.divWith (name,label:classes,keyvals) (lab <> bod)
        "sidebar" ->
           do let subtit = maybe "" trim $ lookup "subtitle" fields
              tit <- B.para . B.strong <$> parseInlineFromText
                          (trim top <> if T.null subtit
                                          then ""
                                          else ":  " <> subtit)
              bod <- parseFromString' parseBlocks body'
              return $ B.divWith (name,"sidebar":classes,keyvals) $ tit <> bod
        "topic" ->
           do tit <- B.para . B.strong <$> parseInlineFromText top
              bod <- parseFromString' parseBlocks body'
              return $ B.divWith (name,"topic":classes,keyvals) $ tit <> bod
        "default-role" -> mempty <$ updateState (\s ->
                              s { stateRstDefaultRole =
                                  case trim top of
                                     ""   -> stateRstDefaultRole def
                                     role -> role })
        "highlight" -> mempty <$ updateState (\s ->
                              s { stateRstHighlight =
                                  case trim top of
                                     ""   -> stateRstHighlight def
                                     lang -> Just lang })
        x | x == "code" || x == "code-block" || x == "sourcecode" ->
          return $ codeblock name classes (map (second trimr) fields)
             (trim top) True body
        "aafig" -> do
          let attribs = (name, ["aafig"], map (second trimr) fields)
          return $ B.codeBlockWith attribs $ stripTrailingNewlines body
        "math" -> return $ B.para
                  $ (case mkAttr name classes fields of
                       attr | attr == nullAttr -> id
                            | otherwise        -> B.spanWith attr)
                  $ mconcat $ map B.displayMath
                  $ toChunks $ top <> "\n\n" <> body
        "figure" -> do
           (caption, legend) <- parseFromString' extractCaption body'
           let src = escapeURI $ trim top
           let (imgident, imgcls, aligncls, imgkvs) = imgAttr "class"
           let (figclasskv, _) = partition ((== "figclass") . fst) keyvals
           let figcls = concatMap (T.words . snd) figclasskv
           let figattr = ("", figcls ++ aligncls, [])
           let capt = B.caption Nothing (B.plain caption <> legend)
           let alt = maybe caption (B.text . trim) (lookup "alt" fields)
           return $ B.figureWith figattr capt $
             B.plain (B.imageWith (imgident, imgcls, imgkvs) src "" alt)
        "image" -> do
           let src = escapeURI $ trim top
           let alt = B.str $ maybe "image" trim $ lookup "alt" fields
           let attr = (ident, cls ++ align, dims) where
                 (ident, cls, align, dims) = imgAttr "class"
           return $ B.para
                  $ case lookup "target" fields of
                          Just t  -> B.link (escapeURI $ trim t) ""
                                     $ B.imageWith attr src "" alt
                          Nothing -> B.imageWith attr src "" alt
        "bibliography" -> pure $ B.divWith ("refs",[],[]) mempty
        "class" -> do
            let attrs = (name, T.words (trim top), map (second trimr) fields)
            --  directive content or the first immediately following element
            children <- case body of
                "" -> block
                _  -> parseFromString' parseBlocks  body'
            return $
              case B.toList children of
                [Header lev attrs' ils]
                  | T.null body -> -- # see #6699
                     B.headerWith (attrs' <> attrs) lev (B.fromList ils)
                _ -> B.divWith attrs children
        other     -> do
            pos <- getPosition
            logMessage $ SkippedContent (".. " <> other) pos
            bod <- parseFromString' parseBlocks $ top <> "\n\n" <> body'
            return $ B.divWith (name, other:classes, keyvals) bod

tableDirective :: PandocMonad m
               => Text -> [(Text, Text)] -> Text -> RSTParser m Blocks
tableDirective top fields body = do
  bs <- parseFromString' parseBlocks body
  case B.toList bs of
       [Table attr _ tspecs' thead@(TableHead _ thrs) tbody tfoot] -> do
         let (aligns', widths') = unzip tspecs'
         title <- parseFromString' (trimInlines . mconcat <$> many inline) top
         columns <- getOption readerColumns
         let numOfCols = case thrs of
               [] -> 0
               (r:_) -> rowLength r
         let normWidths ws =
                strictPos . (/ max 1.0 (fromIntegral (columns - numOfCols))) <$> ws
         let widths = case trim <$> lookup "widths" fields of
                           Just "auto" -> replicate numOfCols ColWidthDefault
                           Just "grid" -> widths'
                           Just specs -> normWidths
                               $ map (fromMaybe (0 :: Double) . safeRead)
                               $ splitTextBy (`elem` (" ," :: String)) specs
                           Nothing -> widths'
         -- align is not applicable since we can't represent whole table align
         let tspecs = zip aligns' widths
         return $ B.singleton $ Table attr (B.caption Nothing (B.plain title))
                                  tspecs thead tbody tfoot
       _ -> do
         pos <- getPosition
         logMessage $ SkippedContent body pos
         return mempty
  where
    -- only valid on the very first row of a table section
    rowLength (Row _ rb) = sum $ cellLength <$> rb
    cellLength (Cell _ _ _ (ColSpan w) _) = max 1 w
    strictPos w
      | w > 0     = ColWidth w
      | otherwise = ColWidthDefault

-- TODO: :stub-columns:.
-- Only the first row becomes the header even if header-rows: > 1,
-- since Pandoc doesn't support a table with multiple header rows.
-- We don't need to parse :align: as it represents the whole table align.
listTableDirective :: PandocMonad m
                   => Text -> [(Text, Text)] -> Text
                   -> RSTParser m Blocks
listTableDirective top fields body = do
  bs <- parseFromString' parseBlocks body
  title <- parseFromString' (trimInlines . mconcat <$> many inline) top
  let rows = takeRows $ B.toList bs
      headerRowsNum = fromMaybe (0 :: Int) $
         lookup "header-rows" fields >>= safeRead
      (headerRow,bodyRows,numOfCols) = case rows of
        x:xs -> if headerRowsNum > 0
                   then (x, xs, length x)
                   else ([], rows, length x)
        _ -> ([],[],0)
      widths = case trim <$> lookup "widths" fields of
        Just "auto" -> replicate numOfCols ColWidthDefault
        Just specs -> normWidths $ map (fromMaybe (0 :: Double) . safeRead) $
                           splitTextBy (`elem` (" ," :: String)) specs
        _ -> replicate numOfCols ColWidthDefault
      toRow = Row nullAttr . map B.simpleCell
      toHeaderRow l = [toRow l | not (null l)]
  return $ B.table (B.simpleCaption $ B.plain title)
             (zip (replicate numOfCols AlignDefault) widths)
             (TableHead nullAttr $ toHeaderRow headerRow)
             [TableBody nullAttr 0 [] $ map toRow bodyRows]
             (TableFoot nullAttr [])
    where takeRows [BulletList rows] = map takeCells rows
          takeRows _                 = []
          takeCells [BulletList cells] = map B.fromList cells
          takeCells _                  = []
          normWidths ws = strictPos . (/ max 1 (sum ws)) <$> ws
          strictPos w
            | w > 0     = ColWidth w
            | otherwise = ColWidthDefault

csvTableDirective :: PandocMonad m
                   => Text -> [(Text, Text)] -> Text
                   -> RSTParser m Blocks
csvTableDirective top fields rawcsv = do
  let explicitHeader = trim <$> lookup "header" fields
  let opts = defaultCSVOptions{
                csvDelim = case trim <$> lookup "delim" fields of
                                Just "tab"   -> '\t'
                                Just "space" -> ' '
                                Just (T.unpack -> [c])
                                             -> c
                                _            -> ','
              , csvQuote = case trim <$> lookup "quote" fields of
                                Just (T.unpack -> [c])
                                  -> Just c
                                _ -> Just '"'
              , csvEscape = case trim <$> lookup "escape" fields of
                                Just (T.unpack -> [c])
                                  -> Just c
                                _ -> Nothing
              , csvKeepSpace = case trim <$> lookup "keepspace" fields of
                                       Just "true" -> True
                                       _           -> False
              }
  let headerRowsNum = fromMaybe (case explicitHeader of
                                       Just _  -> 1 :: Int
                                       Nothing -> 0 :: Int) $
           lookup "header-rows" fields >>= safeRead
  rawcsv' <- case trim <$>
                    lookup "file" fields `mplus` lookup "url" fields of
                  Just u  -> do
                    (bs, _) <- fetchItem u
                    return $ UTF8.toText bs
                  Nothing -> return rawcsv
  let header' = case explicitHeader of
                  Just h  -> parseCSV defaultCSVOptions h
                  Nothing -> Right []
  let res = parseCSV opts rawcsv'
  case (<>) <$> header' <*> res of
       Left e  ->
         throwError $ fromParsecError (toSources rawcsv') e
       Right rawrows -> do
         let parseRow = mapM parseCell
         rows <- mapM parseRow rawrows
         let (headerRow,bodyRows,numOfCols) =
              case rows of
                   x:xs -> if headerRowsNum > 0
                          then (x, xs, length x)
                          else ([], rows, length x)
                   _ -> ([],[],0)
         title <- parseFromString' (trimInlines . mconcat <$> many inline) top
         let strictPos w
               | w > 0     = ColWidth w
               | otherwise = ColWidthDefault
         let normWidths ws = strictPos . (/ max 1 (sum ws)) <$> ws
         let widths =
               case trim <$> lookup "widths" fields of
                 Just "auto" -> replicate numOfCols ColWidthDefault
                 Just specs -> normWidths
                               $ map (fromMaybe (0 :: Double) . safeRead)
                               $ splitTextBy (`elem` (" ," :: String)) specs
                 _ -> replicate numOfCols ColWidthDefault
         let toRow = Row nullAttr . map B.simpleCell
             toHeaderRow l = [toRow l | not (null l)]
         return $ B.table (B.simpleCaption $ B.plain title)
                          (zip (replicate numOfCols AlignDefault) widths)
                          (TableHead nullAttr $ toHeaderRow headerRow)
                          [TableBody nullAttr 0 [] $ map toRow bodyRows]
                          (TableFoot nullAttr [])

singleParaToPlain :: Blocks -> Blocks
singleParaToPlain bs =
  case B.toList bs of
    [Para ils] -> B.fromList [Plain ils]
    _          -> bs

parseCell :: PandocMonad m => Text -> RSTParser m Blocks
parseCell t = singleParaToPlain
   <$> parseFromString' parseBlocks (trim t <> "\n\n")


-- TODO:
--  - Only supports :format: fields with a single format for :raw: roles,
--    change Text.Pandoc.Definition.Format to fix
addNewRole :: PandocMonad m
           => Text -> [(Text, Text)] -> RSTParser m Blocks
addNewRole roleText fields = do
    pos <- getPosition
    (role, parentRole) <- parseFromString' inheritedRole roleText
    customRoles <- stateRstCustomRoles <$> getState
    let getBaseRole (r, f, a) roles =
            case M.lookup r roles of
                 Just (r', f', a') -> getBaseRole (r', f', a') roles
                 Nothing           -> (r, f, a)
        (baseRole, baseFmt, baseAttr) =
               getBaseRole (parentRole, Nothing, nullAttr) customRoles
        fmt = if parentRole == "raw" then lookup "format" fields else baseFmt

        updateClasses :: [Text] -> [Text]
        updateClasses oldClasses = let

          codeLanguageClass = if baseRole == "code"
            then maybeToList (lookup "language" fields)
            else []

          -- if no ":class:" field is given, the default is the role name
          classFieldClasses = maybe [role] T.words (lookup "class" fields)

          -- nub in case role name & language class are the same
          in nub (classFieldClasses ++ codeLanguageClass ++ oldClasses)

        attr = let (ident, baseClasses, keyValues) = baseAttr
               in (ident, updateClasses baseClasses, keyValues)

    -- warn about syntax we ignore
    forM_ fields $ \(key, _) -> case key of
                 "language" -> when (baseRole /= "code") $ logMessage $
                     SkippedContent ":language: [because parent of role is not :code:]"
                        pos
                 "format" -> when (baseRole /= "raw") $ logMessage $
                     SkippedContent ":format: [because parent of role is not :raw:]" pos
                 _ -> logMessage $ SkippedContent (":" <> key <> ":") pos
    when (parentRole == "raw" && countKeys "format" > 1) $
        logMessage $ SkippedContent
                  ":format: [after first in definition of role]"
                  pos
    when (parentRole == "code" && countKeys "language" > 1) $
        logMessage $ SkippedContent
          ":language: [after first in definition of role]" pos

    updateState $ \s -> s {
        stateRstCustomRoles =
          M.insert role (baseRole, fmt, attr) customRoles
    }

    return mempty
  where
    countKeys k = length . filter (== k) . map fst $ fields
    inheritedRole =
        (,) <$> roleName <*> ((char '(' *> roleName <* char ')')
                            <|> pure "span")


-- Can contain character codes as decimal numbers or
-- hexadecimal numbers, prefixed by 0x, x, \x, U+, u, or \u
-- or as XML-style hexadecimal character entities, e.g. &#x1a2b;
-- or text, which is used as-is.  Comments start with ..
unicodeTransform :: Text -> Text
unicodeTransform t
  | Just xs <- T.stripPrefix ".." t  = unicodeTransform $ T.dropWhile (/= '\n') xs -- comment
  | Just xs <- T.stripPrefix "0x" t  = go "0x" xs
  | Just xs <- T.stripPrefix "x" t   = go "x" xs
  | Just xs <- T.stripPrefix "\\x" t = go "\\x" xs
  | Just xs <- T.stripPrefix "U+" t  = go "U+" xs
  | Just xs <- T.stripPrefix "u" t   = go "u" xs
  | Just xs <- T.stripPrefix "\\u" t = go "\\u" xs
  | Just xs <- T.stripPrefix "&#x" t = maybe ("&#x" <> unicodeTransform xs)
                                       -- drop semicolon
                                       (\(c,s) -> T.cons c $ unicodeTransform $ T.drop 1 s)
                                       $ extractUnicodeChar xs
  | Just (x, xs) <- T.uncons t       = T.cons x $ unicodeTransform xs
  | otherwise                        = ""
  where go pref zs = maybe (pref <> unicodeTransform zs)
                     (\(c,s) -> T.cons c $ unicodeTransform s)
                     $ extractUnicodeChar zs

extractUnicodeChar :: Text -> Maybe (Char, Text)
extractUnicodeChar s = fmap (\c -> (c,rest)) mbc
  where (ds,rest) = T.span isHexDigit s
        mbc = safeRead ("'\\x" <> ds <> "'")

extractCaption :: PandocMonad m => RSTParser m (Inlines, Blocks)
extractCaption = do
  capt <- trimInlines . mconcat <$> many inline
  legend <- optional blanklines >> (mconcat <$> many block)
  return (capt,legend)

-- divide string by blanklines, and surround with
-- \begin{aligned}...\end{aligned} if needed.
toChunks :: Text -> [Text]
toChunks = dropWhile T.null
           . map (addAligned . trim . T.unlines)
           . splitBy (T.all (`elem` (" \t" :: String))) . T.lines
  -- we put this in an aligned environment if it contains \\, see #4254
  where addAligned s = if "\\\\" `T.isInfixOf` s
                          then "\\begin{aligned}\n" <> s <> "\n\\end{aligned}"
                          else s

codeblock :: Text -> [Text] -> [(Text, Text)] -> Text -> Bool -> Text
          -> Blocks
codeblock ident classes fields lang rmTrailingNewlines body =
  B.codeBlockWith attribs $ stripTrailingNewlines' body
    where stripTrailingNewlines' = if rmTrailingNewlines
                                     then stripTrailingNewlines
                                     else id
          attribs = (ident, classes', kvs)
          classes' = lang
                    : ["numberLines" | isJust (lookup "number-lines" fields)]
                    ++ classes
          kvs = [(k,v) | (k,v) <- fields, k /= "number-lines", k /= "class",
                                          k /= "id", k /= "name"]
                ++ case lookup "number-lines" fields of
                     Just v | not (T.null v) -> [("startFrom", v)]
                     _ -> []

-- | Creates element attributes from a name, list of classes, and fields.
-- Removes fields named @name@, @id@, or @class@.
mkAttr :: Text -> [Text] -> [(Text, Text)] -> Attr
mkAttr ident classes fields = (ident, classes, fields')
  where fields' = [(k, v') | (k, v) <- fields
                           , let v' = trimr v
                           , k /= "name", k /= "id", k /= "class"]

---
--- note block
---

noteBlock :: Monad m => RSTParser m Blocks
noteBlock = try $ do
  (ref, raw) <- noteBlock' noteMarker
  updateState $ \s -> s { stateNotes = (ref, raw) : stateNotes s }
  return mempty

citationBlock :: Monad m => RSTParser m Blocks
citationBlock = try $ do
  (ref, raw) <- noteBlock' citationMarker
  updateState $ \s ->
     s { stateCitations = M.insert ref raw (stateCitations s),
         stateKeys = M.insert (toKey ref) (("#" <> ref,""), ("",["citation"],[]))
                               (stateKeys s) }
  return mempty

noteBlock' :: Monad m
           => RSTParser m Text -> RSTParser m (Text, Text)
noteBlock' marker = try $ do
  string ".."
  spaceChar >> skipMany spaceChar
  ref <- marker
  first <- (spaceChar >> skipMany spaceChar >> anyLine)
        <|> (newline >> return "")
  blanks <- option "" blanklines
  rest <- option "" indentedBlock
  let raw = first <> "\n" <> blanks <> rest <> "\n"
  return (ref, raw)

citationMarker :: Monad m => RSTParser m Text
citationMarker = do
  char '['
  res <- simpleReferenceName
  char ']'
  return res

noteMarker :: Monad m => RSTParser m Text
noteMarker = do
  char '['
  res <- many1Char digit
      <|>
                  try (char '#' >> liftM ("#" <>) simpleReferenceName)
      <|> countChar 1 (oneOf "#*")
  char ']'
  return res

--
-- reference key
--

quotedReferenceName :: PandocMonad m => RSTParser m Text
quotedReferenceName = try $ do
  char '`' >> notFollowedBy (char '`') -- `` means inline code!
  manyTillChar anyChar (char '`')

-- Simple reference names are single words consisting of alphanumerics
-- plus isolated (no two adjacent) internal hyphens, underscores,
-- periods, colons and plus signs; no whitespace or other characters
-- are allowed.
simpleReferenceName :: Monad m => ParsecT Sources st m Text
simpleReferenceName = do
  x <- alphaNum
  xs <- many $  alphaNum
            <|> try (oneOf "-_:+." <* lookAhead alphaNum)
  return $ T.pack (x:xs)

referenceName :: PandocMonad m => RSTParser m Text
referenceName = quotedReferenceName <|> simpleReferenceName

referenceKey :: PandocMonad m => RSTParser m Blocks
referenceKey = do
  choice [substKey, anonymousKey, regularKey]
  optional blanklines
  return mempty

targetURI :: Monad m => ParsecT Sources st m Text
targetURI = do
  skipSpaces
  optional $ try $ newline >> notFollowedBy blankline
  contents <- trim <$>
     many1Char (satisfy (/='\n')
     <|> try (newline >> many1 spaceChar >> noneOf " \t\n"))
  blanklines
  return $ stripBackticks contents
  where
    stripBackticks t
      | Just xs <- T.stripSuffix "`_" t = T.dropWhile (=='`') xs <> "_"
      | Just _  <- T.stripSuffix "_"  t = t
      | otherwise                       = escapeURI t

substKey :: PandocMonad m => RSTParser m ()
substKey = try $ do
  string ".."
  skipMany1 spaceChar
  (alt,ref) <- withRaw $ trimInlines . mconcat
                      <$> enclosed (char '|') (char '|') inline
  res <- B.toList <$> directive'
  bls <- case res of
             -- use alt unless :alt: attribute on image:
             [Para [Image attr [Str "image"] (src,tit)]] ->
                return $ B.para $ B.imageWith attr src tit alt
             [Para [Link _ [Image attr [Str "image"] (src,tit)] (src',tit')]] ->
                return $ B.para $ B.link src' tit' (B.imageWith attr src tit alt)
             _          -> return $ B.fromList res
  let key = toKey $ stripFirstAndLast ref
  updateState $ \s -> s{ stateSubstitutions =
                          M.insert key bls $ stateSubstitutions s }

anonymousKey :: PandocMonad m => RSTParser m ()
anonymousKey = try $ do
  oneOfStrings [".. __:", "__"]
  skipMany1 spaceChar
  src <- targetURI
  -- we need to ensure that the keys are ordered by occurrence in
  -- the document.
  numKeys <- M.size . stateKeys <$> getState
  let key = toKey $ "_" <> T.pack (printf "%04d" numKeys)
  updateState $ \s -> s { stateKeys = M.insert key ((src,""), nullAttr) $
                          stateKeys s }

referenceNames :: PandocMonad m => RSTParser m [Text]
referenceNames = do
  let rn = try $ do
             string ".. _"
             ref <- quotedReferenceName
                  <|> manyChar (  noneOf "\\:\n"
                              <|> try (char '\n' <*
                                       string "   " <*
                                       notFollowedBy blankline)
                              <|> try (char '\\' *> char ':')
                              <|> try (char ':' <* lookAhead alphaNum)
                               )
             char ':'
             return ref
  first <- rn
  rest  <- many (try (blanklines *> rn))
  return (first:rest)

regularKey :: PandocMonad m => RSTParser m ()
regularKey = try $ do
  -- we allow several references to the same URL, e.g.
  -- .. _hello:
  -- .. _goodbye: url.com
  refs <- referenceNames
  src <- targetURI
  guard $ not (T.null src)
  let keys = map toKey refs
  forM_ keys $ \key ->
    updateState $ \s -> s { stateKeys = M.insert key ((src,""), nullAttr) $
                            stateKeys s }

anchor :: PandocMonad m => RSTParser m Blocks
anchor = try $ do
  refs <- referenceNames
  blanklines
  forM_ refs $ \rawkey ->
    updateState $ \s -> s { stateKeys =
       M.insert (toKey rawkey) (("#" <> rawkey,""), nullAttr)
         (stateKeys s) }
  b <- block
  let addDiv ref = B.divWith (ref, [], [])
  let emptySpanWithId id' = Span (id',[],[]) []
  -- put identifier on next block:
  case B.toList b of
       [Header lev (_,classes,kvs) txt] ->
         case reverse refs of
              [] -> return b
              (r:rs) -> return $ B.singleton $
                           Header lev (r,classes,kvs)
                             (txt ++ map emptySpanWithId rs)
                -- we avoid generating divs for headers,
                -- because it hides them from promoteHeader, see #4240
       _ -> return $ foldr addDiv b refs

--
-- tables
--

-- General tables TODO:
--  - figure out if leading spaces are acceptable and if so, add
--    support for them
--
-- Simple tables TODO:
--  - multiline support
--  - ensure that rightmost column span does not need to reach end
--  - require at least 2 columns

dashedLine :: Monad m => Char -> ParsecT Sources st m (Int, Int)
dashedLine ch = do
  dashes <- many1 (char ch)
  sp     <- many (char ' ')
  return (length dashes, length sp)

simpleDashedLines :: Monad m => Char -> ParsecT Sources st m [(Int,Int)]
simpleDashedLines ch = try $ do
  lines' <- many1 (dashedLine ch)
  skipMany spaceChar
  newline
  return $ addSpaces lines'
 where
  addSpaces [] = []
  addSpaces [(dashes, _)] = [(dashes, dashes)] -- Don't count trailing whitespaces
  addSpaces ((dashes, sp) : moreLines) =
    (dashes, dashes + sp) : addSpaces moreLines

-- Parse a table row separator
simpleTableSep :: Monad m => Char -> RSTParser m ()
simpleTableSep ch = void (simpleDashedLines ch)

-- Parse a table footer
simpleTableFooter :: Monad m => RSTParser m ()
simpleTableFooter = try $ simpleTableSep '=' >> void blanklines

-- Parse a raw line and split it into chunks by indices.
simpleTableRawLine :: Monad m => [Int] -> RSTParser m [(Text, ColSpan)]
simpleTableRawLine indices = do
  row <- rowWithOptionalColSpan

  case simpleTableSplitLine indices row of
    Just rowLine -> return rowLine
    Nothing -> Prelude.fail "col spans don't match"

simpleTableRawLineWithInitialEmptyCell :: Monad m => [Int] -> RSTParser m [(Text, ColSpan)]
simpleTableRawLineWithInitialEmptyCell indices = try $ do
  cs <- simpleTableRawLine indices
  let isEmptyCell = T.all (\c -> c == ' ' || c == '\t')
  case cs of
    c:_ | isEmptyCell (fst c) -> return cs
    _ -> mzero

-- Parse a table row and return a list of blocks (columns).
simpleTableRow :: PandocMonad m => [Int] -> RSTParser m [(Blocks, RowSpan, ColSpan)]
simpleTableRow indices = do
  notFollowedBy' (void blanklines <|> simpleTableFooter)
  firstLine <- simpleTableRawLine indices
  conLines  <- many $ simpleTableRawLineWithInitialEmptyCell indices
  let cols = map T.unlines . transpose $ (map fst firstLine) : (map (map fst) conLines) ++
                                  [replicate (length indices) ""
                                    | not (null conLines)]
  let rowParser = mapM parseCell cols
  fmap (\blocks -> zip3 blocks (repeat 1) (map snd firstLine)) rowParser

simpleTableSplitLine :: [Int] -> (Text, Maybe [Int]) -> Maybe [(Text, ColSpan)]
simpleTableSplitLine indices (line, maybeColspanIndices) =
  fmap (zip tableLines) columnSpans
 where
  splitTableLines lineIndices = map trimr $ drop 1 $ splitTextByIndices (init lineIndices) line
  (tableLines, columnSpans) = case maybeColspanIndices of
      Nothing -> (splitTableLines indices, Just $ repeat 1)
      Just colSpanIndices -> (splitTableLines colSpanIndices, colSpans indices colSpanIndices)

simpleTableHeader :: PandocMonad m
                  => Bool  -- ^ Headerless table
                  -> RSTParser m ([[(Blocks, RowSpan, ColSpan)]], [Alignment], [Int])
simpleTableHeader headless = try $ do
  optional blanklines
  dashes <- simpleDashedLines '='

  rawContent  <- if headless
                    then return [("", Nothing)]
                    else many1 $ notFollowedBy (simpleDashedLines '=') >> rowWithOptionalColSpan

  unless headless $ simpleTableSep '='

  let (lines', indices) = dashedLinesToLinesWithIndices dashes
  let aligns   = replicate (length lines') AlignDefault
  let rawHeads = if headless
                    then []
                    else map (simpleTableSplitLine indices) rawContent

  when (any isNothing rawHeads) $ Prelude.fail "col spans don't match"

  let justRawHeads  = catMaybes rawHeads
  let rawHeads'     = map fst <$> justRawHeads
  let columnSpans   = map snd <$> justRawHeads
  heads <- mapM (mapM $ parseFromString' (mconcat <$> many plain) . trim) rawHeads'
  let headsWithSpans = zipWith3 zip3 heads singleRowSpans columnSpans
  return (headsWithSpans, aligns, indices)

rowWithOptionalColSpan :: Monad m
                       => RSTParser m (Text, Maybe [Int])
rowWithOptionalColSpan = do
  line <- anyLine
  colSpanHyphens <- optionMaybe $ simpleDashedLines '-'

  let colSpan = fmap colSpanFromHyphens colSpanHyphens
  return (line, colSpan)
 where
  colSpanFromHyphens colSpanHyphens = snd $ dashedLinesToLinesWithIndices colSpanHyphens

-- Parse a simple table.
simpleTable :: PandocMonad m
            => Bool  -- ^ Headerless table
            -> RSTParser m Blocks
simpleTable headless = do
  let wrapIdFst (a, b, c) = (Identity a, b, c)
      wrapId = fmap Identity
  tbl <- runIdentity <$> tableWithSpans
           (wrapIdFst <$> simpleTableHeader headless)
           (wrapId <$> simpleTableRow)
           sep simpleTableFooter
  -- Simple tables get 0s for relative column widths (i.e., use default)
  case B.toList tbl of
       [Table attr cap spec th tb tf] -> return $ B.singleton $
                                         Table attr cap (rewidth spec) th tb tf
       _ ->
         throwError $ PandocShouldNeverHappenError
            "tableWith returned something unexpected"
 where
  sep = return () -- optional (simpleTableSep '-')
  rewidth = fmap $ fmap $ const ColWidthDefault

gridTable :: PandocMonad m
          => RSTParser m Blocks
gridTable = runIdentity <$>
  gridTableWith (Identity <$> parseBlocks)

table :: PandocMonad m => RSTParser m Blocks
table = gridTable <|> simpleTable False <|> simpleTable True <?> "table"

--
-- inline
--

inline :: PandocMonad m => RSTParser m Inlines
inline =
  (note          -- can start with whitespace, so try before ws
    <|> do notAfterString >>= guard
           (link <|> inlineAnchor <|> strong <|> emph)
    <|> code
    <|> subst
    <|> interpretedRole
    <|> inlineContent) <?> "inline"

-- strings, spaces and other characters that can appear either by
-- themselves or within inline markup
inlineContent :: PandocMonad m => RSTParser m Inlines
inlineContent = choice [ whitespace
                       , str
                       , endline
                       , smart
                       , hyphens
                       , escapedChar
                       , symbol ] <?> "inline content"

parseInlineFromText :: PandocMonad m => Text -> RSTParser m Inlines
parseInlineFromText = parseFromString' (trimInlines . mconcat <$> many inline)

hyphens :: Monad m => RSTParser m Inlines
hyphens = do
  result <- many1Char (char '-')
  optional endline
  -- don't want to treat endline after hyphen or dash as a space
  return $ B.str result

escapedChar :: Monad m => RSTParser m Inlines
escapedChar = do c <- escaped anyChar
                 if c == ' ' || c == '\n' || c == '\r'
                    -- '\ ' is null in RST
                    then return mempty
                    else do
                      unless (canPrecedeOpener c) updateLastStrPos
                      return $ B.str $ T.singleton c

canPrecedeOpener :: Char -> Bool
canPrecedeOpener c =
  generalCategory c `elem`
   [OpenPunctuation, InitialQuote, FinalQuote, DashPunctuation, OtherSymbol]

symbol :: Monad m => RSTParser m Inlines
symbol = do
  c <- oneOf specialChars
  unless (canPrecedeOpener c) updateLastStrPos
  return $ B.str $ T.singleton c

-- parses inline code, between codeStart and codeEnd
code :: Monad m => RSTParser m Inlines
code = try $ do
  string "``"
  result <- manyTillChar anyChar (try (string "``"))
  return $ B.code
         $ trim $ T.unwords $ T.lines result

-- succeeds only if we're not right after a str (ie. in middle of word)
atStart :: Monad m => RSTParser m a -> RSTParser m a
atStart p = do
  pos <- getPosition
  st <- getState
  -- single quote start can't be right after str
  guard $ stateLastStrPos st /= Just pos
  p

emph :: PandocMonad m => RSTParser m Inlines
emph = B.emph . trimInlines . mconcat <$>
         enclosed (atStart $ char '*') (char '*') inlineContent

strong :: PandocMonad m => RSTParser m Inlines
strong = B.strong . trimInlines . mconcat <$>
          enclosed (atStart $ string "**") (try $ string "**") inlineContent

-- Note, this doesn't precisely implement the complex rule in
-- http://docutils.sourceforge.net/docs/ref/rst/restructuredtext.html#inline-markup-recognition-rules
-- but it should be good enough for most purposes
--
-- TODO:
--  - Classes are silently discarded in addNewRole
--  - Allows direct use of the :raw: role, rST only allows inherited use.
interpretedRole :: PandocMonad m => RSTParser m Inlines
interpretedRole = try $ do
  (role, contents) <- roleBefore <|> roleAfter
  renderRole contents Nothing role nullAttr

renderRole :: PandocMonad m
           => Text -> Maybe Text -> Text -> Attr -> RSTParser m Inlines
renderRole contents fmt role attr = case role of
    "sup"  -> return $ B.superscript $ treatAsText contents
    "superscript" -> return $ B.superscript $ treatAsText contents
    "sub"  -> return $ B.subscript $ treatAsText contents
    "subscript"  -> return $ B.subscript $ treatAsText contents
    "mark"  -> return $ B.spanWith ("",["mark"],[]) $ treatAsText contents
    "emphasis" -> return $ B.emph $ treatAsText contents
    "strong" -> return $ B.strong $ treatAsText contents
    "rfc-reference" -> return $ rfcLink contents
    "RFC" -> return $ rfcLink contents
    "pep-reference" -> return $ pepLink contents
    "PEP" -> return $ pepLink contents
    "literal" -> return $ B.codeWith attr contents
    "math" -> return $ B.math contents
    "title-reference" -> titleRef contents
    "title" -> titleRef contents
    "t" -> titleRef contents
    "code" -> return $ B.codeWith attr contents
    "span" -> return $ B.spanWith attr $ treatAsText contents
    "raw" -> return $ B.rawInline (fromMaybe "" fmt) contents
    custom
     | Just citeType <- T.stripPrefix "cite" custom
       -> cite citeType contents
     | otherwise -> do
        customRoles <- stateRstCustomRoles <$> getState
        case M.lookup custom customRoles of
            Just (newRole, newFmt, newAttr) ->
                renderRole contents newFmt newRole newAttr
            Nothing -> -- undefined role
                return $ B.codeWith ("",["interpreted-text"],[("role",role)])
                          contents
 where
   titleRef ref = return $ B.spanWith ("",["title-ref"],[]) $ treatAsText ref
   rfcLink rfcNo = B.link rfcUrl ("RFC " <> rfcNo) $ B.str ("RFC " <> rfcNo)
     where rfcUrl = "http://www.faqs.org/rfcs/rfc" <> rfcNo <> ".html"
   pepLink pepNo = B.link pepUrl ("PEP " <> pepNo) $ B.str ("PEP " <> pepNo)
     where padNo = T.replicate (4 - T.length pepNo) "0" <> pepNo
           pepUrl = "http://www.python.org/dev/peps/pep-" <> padNo <> "/"
   treatAsText = B.text . handleEscapes
   handleEscapes = T.concat . removeSpace . T.splitOn "\\"
     where headSpace t = fromMaybe t $ T.stripPrefix " " t
           removeSpace (x:xs) = x : map headSpace xs
           removeSpace []     = []

cite :: PandocMonad m => Text -> Text -> RSTParser m Inlines
cite citeType rawcite = do
  let citations =
        case map parseCite (T.splitOn "," rawcite) of
                (c:cs)
                  | citeType == ":t" || citeType == ":ct"
                     -> c{ citationMode = AuthorInText } : cs
                  | citeType == ":year" || citeType == ":yearpar"
                     -> c{ citationMode = SuppressAuthor } : cs
                cs -> cs
  pure $ B.cite citations (B.str rawcite)

parseCite :: Text -> Citation
parseCite t =
  let (_, pref, suff, ident) = T.foldl go (ParseStart, "", "", "") t
  in  Citation{citationId = ident
              ,citationPrefix = B.toList $ B.text pref
              ,citationSuffix = B.toList $ B.text suff
              ,citationMode = NormalCitation
              ,citationNoteNum = 0
              ,citationHash = 0}
 where
   go (ParseStart, p, s, i) '{' = (ParsePrefix, p, s, i)
   go (ParseStart, p, s, i) c = (ParseId, p, s, T.snoc i c)
   go (ParsePrefix, p, s, i) '}' = (ParseId, p, s, i)
   go (ParsePrefix, p, s, i) c = (ParsePrefix, T.snoc p c, s, i)
   go (ParseId, p, s, i) '{' = (ParseSuffix, p, s, i)
   go (ParseId, p, s, i) c = (ParseId, p, s, T.snoc i c)
   go (ParseSuffix, p, s, i) '}' = (ParseSuffix, p, s, i)
   go (ParseSuffix, p, s, i) c = (ParseSuffix, p, T.snoc s c, i)

data ParseCiteState = ParseStart | ParsePrefix | ParseSuffix | ParseId
  deriving (Show)

-- single words consisting of alphanumerics plus isolated (no two adjacent)
-- internal hyphens, underscores, periods, colons and plus signs;
-- no whitespace or other characters are allowed
roleName :: PandocMonad m => RSTParser m Text
roleName = many1Char (alphaNum <|> try (oneOf "-_.:+" <* lookAhead alphaNum))

roleMarker :: PandocMonad m => RSTParser m Text
roleMarker = char ':' *> roleName <* char ':'

roleBefore :: PandocMonad m => RSTParser m (Text,Text)
roleBefore = try $ do
  role <- roleMarker
  contents <- unmarkedInterpretedText
  return (role,contents)

roleAfter :: PandocMonad m => RSTParser m (Text,Text)
roleAfter = try $ do
  contents <- unmarkedInterpretedText
  role <- roleMarker <|> (stateRstDefaultRole <$> getState)
  return (role,contents)

unmarkedInterpretedText :: PandocMonad m => RSTParser m Text
unmarkedInterpretedText = try $ do
  atStart (char '`')
  contents <- mconcat <$> many1
       (  many1 (noneOf "`\\\n")
      <|> (char '\\' >> ((\c -> ['\\',c]) <$> noneOf "\n"))
      <|> (string "\n" <* notFollowedBy blankline)
      <|> try (string "`" <*
                notFollowedBy (void roleMarker) <*
                lookAhead (satisfy isAlphaNum))
       )
  char '`'
  return $ T.pack contents

whitespace :: PandocMonad m => RSTParser m Inlines
whitespace = B.space <$ skipMany1 spaceChar <?> "whitespace"

str :: Monad m => RSTParser m Inlines
str = do
  let strChar = noneOf ("\t\n " ++ specialChars)
  result <- many1Char strChar
  updateLastStrPos
  return $ B.str result

-- an endline character that can be treated as a space, not a structural break
endline :: Monad m => RSTParser m Inlines
endline = try $ do
  newline
  notFollowedBy blankline
  -- parse potential list-starts at beginning of line differently in a list:
  st <- getState
  when (stateParserContext st == ListItemState) $ notFollowedBy (anyOrderedListMarker >> spaceChar) >>
          notFollowedBy' bulletListStart
  return B.softbreak

--
-- links
--

link :: PandocMonad m => RSTParser m Inlines
link = choice [explicitLink, referenceLink, autoLink]  <?> "link"

explicitLink :: PandocMonad m => RSTParser m Inlines
explicitLink = try $ do
  char '`'
  notFollowedBy (char '`') -- `` marks start of inline code
  label' <- trimInlines . mconcat <$>
              manyTill (notFollowedBy (char '`') >> inlineContent) (char '<')
  src <- trim . T.pack . filter (/= '\n') <$> -- see #10279
           manyTill (noneOf ">\n" <|> (char '\n' <* notFollowedBy blankline))
                    (char '>')
  skipSpaces
  string "`_"
  optional $ char '_' -- anonymous form
  let src' | isURI src = escapeURI src
           | otherwise =
              case T.unsnoc src of
                 Just (xs, '_') -> "##REF##" <> xs
                 _              -> src
  let label'' = if label' == mempty
                   then B.str src
                   else label'
  let key = toKey $ stringify label'
  unless (key == Key mempty) $ do
    updateState $ \s -> s{
      stateKeys = M.insert key ((src',""), nullAttr) $ stateKeys s }
  return $ B.linkWith nullAttr src' "" label''

citationName :: PandocMonad m => RSTParser m Text
citationName = do
  raw <- citationMarker
  return $ "[" <> raw <> "]"

-- We store the reference link label as the link target,
-- preceded by '##REF##'. This is replaced after the AST
-- has been built by the resolved reference.
referenceLink :: PandocMonad m => RSTParser m Inlines
referenceLink = try $ do
  ref <- (referenceName <|> citationName) <* char '_'
  isAnonymous <- (True <$ char '_') <|> pure False
  eof <|> notFollowedBy alphaNum
  let ref' = if isAnonymous
                then "_"
                else ref
  pure $ B.linkWith nullAttr ("##REF##" <> ref') "" (B.text ref)

-- We keep a list of oldkeys so we can detect lookup loops.
lookupKey :: PandocMonad m
          => [Key] -> Key -> RSTParser m ((Text, Text), Attr)
lookupKey oldkeys key = do
  pos <- getPosition
  state <- getState
  let keyTable = stateKeys state
  case M.lookup key keyTable of
       Nothing  -> do
         let Key key' = key
         logMessage $ ReferenceNotFound key' pos
         return (("",""),nullAttr)
       -- check for keys of the form link_, which need to be resolved:
       Just ((u, ""),_) | T.length u > 1, T.last u == '_', T.head u /= '#' -> do
         let rawkey = T.init u
         let newkey = toKey rawkey
         if newkey `elem` oldkeys
            then do
              -- TODO the pos is not going to be accurate
              -- because we're calling this after the AST is
              -- constructed. Probably good to remove that
              -- parameter form CircularReference at some point.
              logMessage $ CircularReference rawkey pos
              return (("",""),nullAttr)
            else lookupKey (key:oldkeys) newkey
       Just val -> return val

autoURI :: Monad m => RSTParser m Inlines
autoURI = do
  (orig, src) <- uri
  return $ B.link src "" $ B.str orig

autoEmail :: Monad m => RSTParser m Inlines
autoEmail = do
  (orig, src) <- emailAddress
  return $ B.link src "" $ B.str orig

autoLink :: PandocMonad m => RSTParser m Inlines
autoLink = autoURI <|> autoEmail

subst :: PandocMonad m => RSTParser m Inlines
subst = try $ do
  (_,ref) <- withRaw $ enclosed (char '|') (char '|') inline
  let substlink = B.linkWith nullAttr ("##SUBST##" <> ref) "" (B.text ref)
  reflink <- option False (True <$ char '_')
  if reflink
     then do
       let linkref = T.drop 1 $ T.dropEnd 1 ref
       return $ B.linkWith nullAttr ("##REF##" <> linkref) "" substlink
     else return substlink

note :: PandocMonad m => RSTParser m Inlines
note = try $ do
  optional whitespace
  ref <- noteMarker
  char '_'
  pure $ B.linkWith nullAttr ("##NOTE##" <> ref) "" (B.text ref)

smart :: PandocMonad m => RSTParser m Inlines
smart = smartPunctuation inline

inlineAnchor :: PandocMonad m => RSTParser m Inlines
inlineAnchor = try $ do
  char '_'
  name <- quotedReferenceName <|> simpleReferenceName
  let ident = textToIdentifier mempty name
  updateState $ \s ->
    s{ stateKeys = M.insert (toKey name) (("#" <> ident, ""), nullAttr)
                    (stateKeys s) }
  pure $ B.spanWith (ident,[],[]) (B.text name)

dashedLinesToLinesWithIndices :: [(Int, Int)] -> ([Int], [Int])
dashedLinesToLinesWithIndices dashes =
  let lines'  = map snd dashes
      indices = scanl (+) 0 lines'
  in  (lines', indices)

-- | Determines column spans by appying indices of a table border with column span indices.
--
-- The indices need to align.
colSpans :: [Int] -> [Int] -> Maybe [ColSpan]
colSpans [] []  = Just []
colSpans [] _   = Nothing
colSpans _ []   = Nothing
colSpans (index : indices) colSpanIndices@(colIndex : colSpanIndicesTail)
    | index /= colIndex = colSpans indices colSpanIndices
    | otherwise =
        -- For a matching index start counting the column spans.
        let (spanCount, remainingIndices, remainingColSpanindices) = colSpanCount indices colSpanIndicesTail 1
        in  (:) spanCount <$> colSpans remainingIndices remainingColSpanindices

-- | Counts column spans by consuming all non-matching indices until a matching one is encountered.
--
-- If the indices match, the end of a column span has been encountered and the
-- column count can be returned. Otherwise, if the indices don't match, add to
-- the span count until a matching index is found.
colSpanCount :: [Int] -> [Int] -> ColSpan -> (ColSpan, [Int], [Int])
colSpanCount [] colSpanIndices spanCount = (spanCount, [], colSpanIndices)
colSpanCount _ [] spanCount = (spanCount, [], [])
colSpanCount indices@(index : indicesTail) colSpanIndices@(colIndex : colSpanIndicesTail) spanCount
    | index == colIndex = case colSpanIndicesTail of
        [] -> (spanCount, indicesTail, colSpanIndicesTail)
        _ -> (spanCount, indices, colSpanIndices)
    | otherwise = colSpanCount indicesTail colSpanIndices $ spanCount + 1