    {-# LANGUAGE GeneralizedNewtypeDeriving, TypeSynonymInstances,
        FlexibleInstances#-}
    {-
    Copyright (C) 2006-2010 John MacFarlane <jgm@berkeley.edu>

    This program is free software; you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation; either version 2 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program; if not, write to the Free Software
    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
    -}

    {- |
       Module      : Text.Pandoc.Parsing
       Copyright   : Copyright (C) 2006-2010 John MacFarlane
       License     : GNU GPL, version 2 or above

       Maintainer  : John MacFarlane <jgm@berkeley.edu>
       Stability   : alpha
       Portability : portable

    A utility library with parsers used in pandoc readers.
    -}
    module Text.Pandoc.Parsing ( (>>~),
                                 anyLine,
                                 many1Till,
                                 notFollowedBy',
                                 oneOfStrings,
                                 oneOfStringsCI,
                                 spaceChar,
                                 nonspaceChar,
                                 skipSpaces,
                                 blankline,
                                 blanklines,
                                 enclosed,
                                 stringAnyCase,
                                 parseFromString,
                                 lineClump,
                                 charsInBalanced,
                                 romanNumeral,
                                 emailAddress,
                                 uri,
                                 mathInline,
                                 mathDisplay,
                                 withHorizDisplacement,
                                 withRaw,
                                 escaped,
                                 characterReference,
                                 updateLastStrPos,
                                 anyOrderedListMarker,
                                 orderedListMarker,
                                 charRef,
                                 lineBlockLines,
                                 tableWith,
                                 widthsFromIndices,
                                 gridTableWith,
                                 readWith,
                                 testStringWith,
                                 getOption,
                                 guardEnabled,
                                 guardDisabled,
                                 ParserState (..),
                                 HasReaderOptions (..),
                                 HasHeaderMap (..),
                                 HasIdentifierList (..),
                                 defaultParserState,
                                 HeaderType (..),
                                 ParserContext (..),
                                 QuoteContext (..),
                                 NoteTable,
                                 NoteTable',
                                 KeyTable,
                                 SubstTable,
                                 Key (..),
                                 toKey,
                                 registerHeader,
                                 smartPunctuation,
                                 withQuoteContext,
                                 singleQuoteStart,
                                 singleQuoteEnd,
                                 doubleQuoteStart,
                                 doubleQuoteEnd,
                                 ellipses,
                                 apostrophe,
                                 dash,
                                 nested,
                                 macro,
                                 applyMacros',
                                 Parser,
                                 F(..),
                                 runF,
                                 askF,
                                 asksF,
                                 -- * Re-exports from Text.Pandoc.Parsec
                                 runParser,
                                 parse,
                                 anyToken,
                                 getInput,
                                 setInput,
                                 unexpected,
                                 char,
                                 letter,
                                 digit,
                                 alphaNum,
                                 skipMany,
                                 skipMany1,
                                 spaces,
                                 space,
                                 anyChar,
                                 satisfy,
                                 newline,
                                 string,
                                 count,
                                 eof,
                                 noneOf,
                                 oneOf,
                                 lookAhead,
                                 notFollowedBy,
                                 many,
                                 many1,
                                 manyTill,
                                 (<|>),
                                 (<?>),
                                 choice,
                                 try,
                                 sepBy,
                                 sepBy1,
                                 sepEndBy,
                                 sepEndBy1,
                                 endBy,
                                 endBy1,
                                 option,
                                 optional,
                                 optionMaybe,
                                 getState,
                                 setState,
                                 updateState,
                                 SourcePos,
                                 getPosition,
                                 setPosition,
                                 sourceColumn,
                                 sourceLine,
                                 setSourceColumn,
                                 setSourceLine,
                                 newPos,
                                 token
                                 )
    where

    import Text.Pandoc.Definition
    import Text.Pandoc.Options
    import Text.Pandoc.Builder (Blocks, Inlines, rawBlock, HasMeta(..))
    import qualified Text.Pandoc.Builder as B
    import Text.Pandoc.XML (fromEntities)
    import qualified Text.Pandoc.UTF8 as UTF8 (putStrLn)
    import Text.Parsec
    import Text.Parsec.Pos (newPos)
    import Data.Char ( toLower, toUpper, ord, chr, isAscii, isAlphaNum, isDigit,
                       isHexDigit, isSpace )
    import Data.List ( intercalate, transpose )
    import Text.Pandoc.Shared
    import qualified Data.Map as M
    import Text.TeXMath.Macros (applyMacros, Macro, parseMacroDefinitions)
    import Text.Pandoc.Compat.TagSoupEntity ( lookupEntity )
    import Text.Pandoc.Asciify (toAsciiChar)
    import Data.Default
    import qualified Data.Set as Set
    import Control.Monad.Reader
    import Control.Applicative ((*>), (<*), (<$), liftA2)
    import Data.Monoid
    import Data.Maybe (catMaybes)

    type Parser t s = Parsec t s

    newtype F a = F { unF :: Reader ParserState a } deriving (Monad, Functor)

    runF :: F a -> ParserState -> a
    runF = runReader . unF

    askF :: F ParserState
    askF = F ask

    asksF :: (ParserState -> a) -> F a
    asksF f = F $ asks f

    instance Monoid a => Monoid (F a) where
      mempty = return mempty
      mappend = liftM2 mappend
      mconcat = liftM mconcat . sequence

    -- | Like >>, but returns the operation on the left.
    -- (Suggested by Tillmann Rendel on Haskell-cafe list.)
    (>>~) :: (Monad m) => m a -> m b -> m a
    a >>~ b = a >>= \x -> b >> return x

    -- | Parse any line of text
    anyLine :: Parser [Char] st [Char]
    anyLine = do
      -- This is much faster than:
      -- manyTill anyChar newline
      inp <- getInput
      pos <- getPosition
      case break (=='\n') inp of
           (this, '\n':rest) -> do
             -- needed to persuade parsec that this won't match an empty string:
             anyChar
             setInput rest
             setPosition $ incSourceLine (setSourceColumn pos 1) 1
             return this
           _ -> mzero

    -- | Like @manyTill@, but reads at least one item.
    many1Till :: Parser [tok] st a
              -> Parser [tok] st end
              -> Parser [tok] st [a]
    many1Till p end = do
             first <- p
             rest <- manyTill p end
             return (first:rest)

    -- | 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 => Parser [a] st b -> Parser [a] st ()
    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' :: (Char -> Char -> Bool) -> [String] -> Parser [Char] st String
    oneOfStrings' _ []   = fail "no strings"
    oneOfStrings' matches strs = try $ do
      c <- anyChar
      let strs' = [xs | (x:xs) <- strs, x `matches` c]
      case strs' of
           []  -> fail "not found"
           _   -> (c:) `fmap` oneOfStrings' matches strs'
                   <|> if "" `elem` strs'
                          then return [c]
                          else fail "not found"

    -- | 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 :: [String] -> Parser [Char] st String
    oneOfStrings = oneOfStrings' (==)

    -- | Parses one of a list of strings (tried in order), case insensitive.
    oneOfStringsCI :: [String] -> Parser [Char] st String
    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 | c >= 'A' && c <= 'Z' = chr (ord c + 32)
                       | isAscii c = c
                       | otherwise = toLower c

    -- | Parses a space or tab.
    spaceChar :: Parser [Char] st Char
    spaceChar = satisfy $ \c -> c == ' ' || c == '\t'

    -- | Parses a nonspace, nonnewline character.
    nonspaceChar :: Parser [Char] st Char
    nonspaceChar = satisfy $ \x -> x /= '\t' && x /= '\n' && x /= ' ' && x /= '\r'

    -- | Skips zero or more spaces or tabs.
    skipSpaces :: Parser [Char] st ()
    skipSpaces = skipMany spaceChar

    -- | Skips zero or more spaces or tabs, then reads a newline.
    blankline :: Parser [Char] st Char
    blankline = try $ skipSpaces >> newline

    -- | Parses one or more blank lines and returns a string of newlines.
    blanklines :: Parser [Char] st [Char]
    blanklines = many1 blankline

    -- | Parses material enclosed between start and end parsers.
    enclosed :: Parser [Char] st t   -- ^ start parser
             -> Parser [Char] st end  -- ^ end parser
             -> Parser [Char] st a    -- ^ content parser (to be used repeatedly)
             -> Parser [Char] st [a]
    enclosed start end parser = try $
      start >> notFollowedBy space >> many1Till parser end

    -- | Parse string, case insensitive.
    stringAnyCase :: [Char] -> Parser [Char] st String
    stringAnyCase [] = string ""
    stringAnyCase (x:xs) = do
      firstChar <- char (toUpper x) <|> char (toLower x)
      rest <- stringAnyCase xs
      return (firstChar:rest)

    -- | Parse contents of 'str' using 'parser' and return result.
    parseFromString :: Parser [tok] st a -> [tok] -> Parser [tok] st a
    parseFromString parser str = do
      oldPos <- getPosition
      oldInput <- getInput
      setInput str
      result <- parser
      setInput oldInput
      setPosition oldPos
      return result

    -- | Parse raw line block up to and including blank lines.
    lineClump :: Parser [Char] st String
    lineClump = blanklines
              <|> (many1 (notFollowedBy blankline >> anyLine) >>= return . unlines)

    -- | 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 '(' ')' anyChar@ will parse "(hello (there))"
    -- and return "hello (there)".
    charsInBalanced :: Char -> Char -> Parser [Char] st Char
                    -> Parser [Char] st String
    charsInBalanced open close parser = try $ do
      char open
      let isDelim c = c == open || c == close
      raw <- many $  many1 (notFollowedBy (satisfy isDelim) >> parser)
                 <|> (do res <- charsInBalanced open close parser
                         return $ [open] ++ res ++ [close])
      char close
      return $ concat raw

    -- old charsInBalanced would be:
    -- charsInBalanced open close (noneOf "\n" <|> char '\n' >> notFollowedBy blankline)
    -- old charsInBalanced' would be:
    -- charsInBalanced open close anyChar

    -- Auxiliary functions for romanNumeral:

    lowercaseRomanDigits :: [Char]
    lowercaseRomanDigits = ['i','v','x','l','c','d','m']

    uppercaseRomanDigits :: [Char]
    uppercaseRomanDigits = map toUpper lowercaseRomanDigits

    -- | Parses a roman numeral (uppercase or lowercase), returns number.
    romanNumeral :: Bool                  -- ^ Uppercase if true
                 -> Parser [Char] st Int
    romanNumeral upperCase = do
        let romanDigits = if upperCase
                             then uppercaseRomanDigits
                             else lowercaseRomanDigits
        lookAhead $ oneOf romanDigits
        let [one, five, ten, fifty, hundred, fivehundred, thousand] =
              map char romanDigits
        thousands <- many thousand >>= (return . (1000 *) . length)
        ninehundreds <- option 0 $ try $ hundred >> thousand >> return 900
        fivehundreds <- many fivehundred >>= (return . (500 *) . length)
        fourhundreds <- option 0 $ try $ hundred >> fivehundred >> return 400
        hundreds <- many hundred >>= (return . (100 *) . length)
        nineties <- option 0 $ try $ ten >> hundred >> return 90
        fifties <- many fifty >>= (return . (50 *) . length)
        forties <- option 0 $ try $ ten >> fifty >> return 40
        tens <- many ten >>= (return . (10 *) . length)
        nines <- option 0 $ try $ one >> ten >> return 9
        fives <- many five >>= (return . (5 *) . length)
        fours <- option 0 $ try $ one >> five >> return 4
        ones <- many one >>= (return . length)
        let total = thousands + ninehundreds + fivehundreds + fourhundreds +
                    hundreds + nineties + fifties + forties + tens + nines +
                    fives + fours + ones
        if total == 0
           then fail "not a roman numeral"
           else return total

    -- Parsers for email addresses and URIs

    -- | Parses an email address; returns original and corresponding
    -- escaped mailto: URI.
    emailAddress :: Parser [Char] st (String, String)
    emailAddress = try $ liftA2 toResult mailbox (char '@' *> domain)
     where toResult mbox dom = let full = fromEntities $ mbox ++ '@':dom
                               in  (full, escapeURI $ "mailto:" ++ full)
           mailbox           = intercalate "." `fmap` (emailWord `sepby1` dot)
           domain            = intercalate "." `fmap` (subdomain `sepby1` dot)
           dot               = char '.'
           subdomain         = many1 $ alphaNum <|> innerPunct
           innerPunct        = try (satisfy (\c -> isEmailPunct c || c == '@') <*
                                     notFollowedBy space)
           emailWord         = many1 $ satisfy isEmailChar
           isEmailChar c     = isAlphaNum c || isEmailPunct c
           isEmailPunct c    = c `elem` "!\"#$%&'*+-/=?^_{|}~;"
           -- note: sepBy1 from parsec consumes input when sep
           -- succeeds and p fails, so we use this variant here.
           sepby1 p sep      = liftA2 (:) p (many (try $ sep >> p))

    -- Schemes from http://www.iana.org/assignments/uri-schemes.html plus
    -- the unofficial schemes coap, doi, javascript.
    schemes :: [String]
    schemes = ["coap","doi","javascript","aaa","aaas","about","acap","cap","cid",
               "crid","data","dav","dict","dns","file","ftp","geo","go","gopher",
               "h323","http","https","iax","icap","im","imap","info","ipp","iris",
               "iris.beep","iris.xpc","iris.xpcs","iris.lwz","ldap","mailto","mid",
               "msrp","msrps","mtqp","mupdate","news","nfs","ni","nih","nntp",
               "opaquelocktoken","pop","pres","rtsp","service","session","shttp","sieve",
               "sip","sips","sms","snmp","soap.beep","soap.beeps","tag","tel","telnet",
               "tftp","thismessage","tn3270","tip","tv","urn","vemmi","ws","wss","xcon",
               "xcon-userid","xmlrpc.beep","xmlrpc.beeps","xmpp","z39.50r","z39.50s",
               "adiumxtra","afp","afs","aim","apt","attachment","aw","beshare","bitcoin",
               "bolo","callto","chrome","chrome-extension","com-eventbrite-attendee",
               "content", "cvs","dlna-playsingle","dlna-playcontainer","dtn","dvb",
               "ed2k","facetime","feed","finger","fish","gg","git","gizmoproject",
               "gtalk","hcp","icon","ipn","irc","irc6","ircs","itms","jar","jms",
               "keyparc","lastfm","ldaps","magnet","maps","market","message","mms",
               "ms-help","msnim","mumble","mvn","notes","oid","palm","paparazzi",
               "platform","proxy","psyc","query","res","resource","rmi","rsync",
               "rtmp","secondlife","sftp","sgn","skype","smb","soldat","spotify",
               "ssh","steam","svn","teamspeak","things","udp","unreal","ut2004",
               "ventrilo","view-source","webcal","wtai","wyciwyg","xfire","xri",
               "ymsgr"]

    uriScheme :: Parser [Char] st String
    uriScheme = oneOfStringsCI schemes

    -- | Parses a URI. Returns pair of original and URI-escaped version.
    uri :: Parser [Char] st (String, String)
    uri = try $ do
      scheme <- uriScheme
      char ':'
      -- We allow 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.
      let isWordChar c = isAlphaNum c || c == '_' || c == '/' || c == '+' ||
                             not (isAscii c)
      let wordChar = satisfy isWordChar
      let percentEscaped = try $ char '%' >> skipMany1 (satisfy isHexDigit)
      let entity = () <$ characterReference
      let punct = skipMany1 (char ',')
              <|> () <$ (satisfy (\c -> not (isSpace c) && c /= '<'))
      let uriChunk =  skipMany1 wordChar
                  <|> percentEscaped
                  <|> entity
                  <|> (try $ punct >>
                        lookAhead (void (satisfy isWordChar) <|> percentEscaped))
      str <- snd `fmap` withRaw (skipMany1 ( () <$
                                             (enclosed (char '(') (char ')') uriChunk
                                             <|> enclosed (char '{') (char '}') uriChunk
                                             <|> enclosed (char '[') (char ']') uriChunk)
                                             <|> uriChunk))
      str' <- option str $ char '/' >> return (str ++ "/")
      let uri' = scheme ++ ":" ++ fromEntities str'
      return (uri', escapeURI uri')

    mathInlineWith :: String -> String -> Parser [Char] st String
    mathInlineWith op cl = try $ do
      string op
      notFollowedBy space
      words' <- many1Till (count 1 (noneOf "\n\\")
                       <|> (char '\\' >> anyChar >>= \c -> return ['\\',c])
                       <|> count 1 newline <* notFollowedBy' blankline
                           *> return " ")
                  (try $ string cl)
      notFollowedBy digit  -- to prevent capture of $5
      return $ concat words'

    mathDisplayWith :: String -> String -> Parser [Char] st String
    mathDisplayWith op cl = try $ do
      string op
      many1Till (noneOf "\n" <|> (newline >>~ notFollowedBy' blankline)) (try $ string cl)

    mathDisplay :: Parser [Char] ParserState String
    mathDisplay =
          (guardEnabled Ext_tex_math_dollars >> mathDisplayWith "$$" "$$")
      <|> (guardEnabled Ext_tex_math_single_backslash >>
           mathDisplayWith "\\[" "\\]")
      <|> (guardEnabled Ext_tex_math_double_backslash >>
           mathDisplayWith "\\\\[" "\\\\]")

    mathInline :: Parser [Char] ParserState String
    mathInline =
          (guardEnabled Ext_tex_math_dollars >> mathInlineWith "$" "$")
      <|> (guardEnabled Ext_tex_math_single_backslash >>
           mathInlineWith "\\(" "\\)")
      <|> (guardEnabled Ext_tex_math_double_backslash >>
           mathInlineWith "\\\\(" "\\\\)")

    -- | 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 :: Parser [Char] st a  -- ^ Parser to apply
                          -> Parser [Char] st (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 :: Parser [Char] st a -> Parser [Char] st (a, [Char])
    withRaw parser = do
      pos1 <- getPosition
      inp <- getInput
      result <- parser
      pos2 <- getPosition
      let (l1,c1) = (sourceLine pos1, sourceColumn pos1)
      let (l2,c2) = (sourceLine pos2, sourceColumn pos2)
      let inplines = take ((l2 - l1) + 1) $ lines inp
      let raw = case inplines of
                    []   -> ""
                    [l]  -> take (c2 - c1) l
                    ls   -> unlines (init ls) ++ take (c2 - 1) (last ls)
      return (result, raw)

    -- | Parses backslash, then applies character parser.
    escaped :: Parser [Char] st Char  -- ^ Parser for character to escape
            -> Parser [Char] st Char
    escaped parser = try $ char '\\' >> parser

    -- | Parse character entity.
    characterReference :: Parser [Char] st Char
    characterReference = try $ do
      char '&'
      ent <- many1Till nonspaceChar (char ';')
      case lookupEntity ent of
           Just c  -> return c
           Nothing -> fail "entity not found"

    -- | Parses an uppercase roman numeral and returns (UpperRoman, number).
    upperRoman :: Parser [Char] st (ListNumberStyle, Int)
    upperRoman = do
      num <- romanNumeral True
      return (UpperRoman, num)

    -- | Parses a lowercase roman numeral and returns (LowerRoman, number).
    lowerRoman :: Parser [Char] st (ListNumberStyle, Int)
    lowerRoman = do
      num <- romanNumeral False
      return (LowerRoman, num)

    -- | Parses a decimal numeral and returns (Decimal, number).
    decimal :: Parser [Char] st (ListNumberStyle, Int)
    decimal = do
      num <- many1 digit
      return (Decimal, read num)

    -- | Parses a '@' and optional label and
    -- returns (DefaultStyle, [next example number]).  The next
    -- example number is incremented in parser state, and the label
    -- (if present) is added to the label table.
    exampleNum :: Parser [Char] ParserState (ListNumberStyle, Int)
    exampleNum = do
      char '@'
      lab <- many (alphaNum <|> satisfy (\c -> c == '_' || c == '-'))
      st <- getState
      let num = stateNextExample st
      let newlabels = if null lab
                         then stateExamples st
                         else M.insert lab num $ stateExamples st
      updateState $ \s -> s{ stateNextExample = num + 1
                           , stateExamples    = newlabels }
      return (Example, num)

    -- | Parses a '#' returns (DefaultStyle, 1).
    defaultNum :: Parser [Char] st (ListNumberStyle, Int)
    defaultNum = do
      char '#'
      return (DefaultStyle, 1)

    -- | Parses a lowercase letter and returns (LowerAlpha, number).
    lowerAlpha :: Parser [Char] st (ListNumberStyle, Int)
    lowerAlpha = do
      ch <- oneOf ['a'..'z']
      return (LowerAlpha, ord ch - ord 'a' + 1)

    -- | Parses an uppercase letter and returns (UpperAlpha, number).
    upperAlpha :: Parser [Char] st (ListNumberStyle, Int)
    upperAlpha = do
      ch <- oneOf ['A'..'Z']
      return (UpperAlpha, ord ch - ord 'A' + 1)

    -- | Parses a roman numeral i or I
    romanOne :: Parser [Char] st (ListNumberStyle, Int)
    romanOne = (char 'i' >> return (LowerRoman, 1)) <|>
               (char 'I' >> return (UpperRoman, 1))

    -- | Parses an ordered list marker and returns list attributes.
    anyOrderedListMarker :: Parser [Char] ParserState ListAttributes
    anyOrderedListMarker = choice $
      [delimParser numParser | delimParser <- [inPeriod, inOneParen, inTwoParens],
                               numParser <- [decimal, exampleNum, defaultNum, romanOne,
                               lowerAlpha, lowerRoman, upperAlpha, upperRoman]]

    -- | Parses a list number (num) followed by a period, returns list attributes.
    inPeriod :: Parser [Char] st (ListNumberStyle, Int)
             -> Parser [Char] st ListAttributes
    inPeriod num = try $ do
      (style, start) <- num
      char '.'
      let delim = if style == DefaultStyle
                     then DefaultDelim
                     else Period
      return (start, style, delim)

    -- | Parses a list number (num) followed by a paren, returns list attributes.
    inOneParen :: Parser [Char] st (ListNumberStyle, Int)
               -> Parser [Char] st ListAttributes
    inOneParen num = try $ do
      (style, start) <- num
      char ')'
      return (start, style, OneParen)

    -- | Parses a list number (num) enclosed in parens, returns list attributes.
    inTwoParens :: Parser [Char] st (ListNumberStyle, Int)
                -> Parser [Char] st ListAttributes
    inTwoParens num = try $ do
      char '('
      (style, start) <- num
      char ')'
      return (start, style, TwoParens)

    -- | Parses an ordered list marker with a given style and delimiter,
    -- returns number.
    orderedListMarker :: ListNumberStyle
                      -> ListNumberDelim
                      -> Parser [Char] ParserState Int
    orderedListMarker style delim = do
      let num = defaultNum <|>  -- # can continue any kind of list
                case style of
                   DefaultStyle -> decimal
                   Example      -> exampleNum
                   Decimal      -> decimal
                   UpperRoman   -> upperRoman
                   LowerRoman   -> lowerRoman
                   UpperAlpha   -> upperAlpha
                   LowerAlpha   -> lowerAlpha
      let context = case delim of
                   DefaultDelim -> inPeriod
                   Period       -> inPeriod
                   OneParen     -> inOneParen
                   TwoParens    -> inTwoParens
      (start, _, _) <- context num
      return start

    -- | Parses a character reference and returns a Str element.
    charRef :: Parser [Char] st Inline
    charRef = do
      c <- characterReference
      return $ Str [c]

    lineBlockLine :: Parser [Char] st String
    lineBlockLine = try $ do
      char '|'
      char ' '
      white <- many (spaceChar >> return '\160')
      notFollowedBy newline
      line <- anyLine
      continuations <- many (try $ char ' ' >> anyLine)
      return $ white ++ unwords (line : continuations)

    -- | Parses an RST-style line block and returns a list of strings.
    lineBlockLines :: Parser [Char] st [String]
    lineBlockLines = try $ do
      lines' <- many1 lineBlockLine
      skipMany1 $ blankline <|> try (char '|' >> blankline)
      return lines'

    -- | Parse a table using 'headerParser', 'rowParser',
    -- 'lineParser', and 'footerParser'.
    tableWith :: Parser [Char] ParserState ([[Block]], [Alignment], [Int])
              -> ([Int] -> Parser [Char] ParserState [[Block]])
              -> Parser [Char] ParserState sep
              -> Parser [Char] ParserState end
              -> Parser [Char] ParserState Block
    tableWith headerParser rowParser lineParser footerParser = try $ do
        (heads, aligns, indices) <- headerParser
        lines' <- rowParser indices `sepEndBy1` lineParser
        footerParser
        numColumns <- getOption readerColumns
        let widths = if (indices == [])
                        then replicate (length aligns) 0.0
                        else widthsFromIndices numColumns indices
        return $ Table [] aligns widths heads lines'

    -- Calculate relative widths of table columns, based on indices
    widthsFromIndices :: Int      -- Number of columns on terminal
                      -> [Int]    -- Indices
                      -> [Double] -- Fractional relative sizes of columns
    widthsFromIndices _ [] = []
    widthsFromIndices numColumns' indices =
      let numColumns = max numColumns' (if null indices then 0 else last indices)
          lengths' = zipWith (-) indices (0:indices)
          lengths  = reverse $
                     case reverse lengths' of
                          []       -> []
                          [x]      -> [x]
                          -- compensate for the fact that intercolumn
                          -- spaces are counted in widths of all columns
                          -- but the last...
                          (x:y:zs) -> if x < y && y - x <= 2
                                         then y:y:zs
                                         else x:y:zs
          totLength = sum lengths
          quotient = if totLength > numColumns
                       then fromIntegral totLength
                       else fromIntegral numColumns
          fracs = map (\l -> (fromIntegral l) / quotient) lengths in
      tail fracs

    ---

    -- Parse a grid table:  starts with row of '-' on top, then header
    -- (which may be grid), then the rows,
    -- which may be grid, separated by blank lines, and
    -- ending with a footer (dashed line followed by blank line).
    gridTableWith :: Parser [Char] ParserState [Block]   -- ^ Block list parser
                  -> Bool                                -- ^ Headerless table
                  -> Parser [Char] ParserState Block
    gridTableWith blocks headless =
      tableWith (gridTableHeader headless blocks) (gridTableRow blocks)
                (gridTableSep '-') gridTableFooter

    gridTableSplitLine :: [Int] -> String -> [String]
    gridTableSplitLine indices line = map removeFinalBar $ tail $
      splitStringByIndices (init indices) $ trimr line

    gridPart :: Char -> Parser [Char] st (Int, Int)
    gridPart ch = do
      dashes <- many1 (char ch)
      char '+'
      return (length dashes, length dashes + 1)

    gridDashedLines :: Char -> Parser [Char] st [(Int,Int)]
    gridDashedLines ch = try $ char '+' >> many1 (gridPart ch) >>~ blankline

    removeFinalBar :: String -> String
    removeFinalBar =
      reverse . dropWhile (`elem` " \t") . dropWhile (=='|') . reverse

    -- | Separator between rows of grid table.
    gridTableSep :: Char -> Parser [Char] ParserState Char
    gridTableSep ch = try $ gridDashedLines ch >> return '\n'

    -- | Parse header for a grid table.
    gridTableHeader :: Bool -- ^ Headerless table
                    -> Parser [Char] ParserState [Block]
                    -> Parser [Char] ParserState ([[Block]], [Alignment], [Int])
    gridTableHeader headless blocks = try $ do
      optional blanklines
      dashes <- gridDashedLines '-'
      rawContent  <- if headless
                        then return $ repeat ""
                        else many1
                             (notFollowedBy (gridTableSep '=') >> char '|' >>
                               many1Till anyChar newline)
      if headless
         then return ()
         else gridTableSep '=' >> return ()
      let lines'   = map snd dashes
      let indices  = scanl (+) 0 lines'
      let aligns   = replicate (length lines') AlignDefault
      -- RST does not have a notion of alignments
      let rawHeads = if headless
                        then replicate (length dashes) ""
                        else map (intercalate " ") $ transpose
                           $ map (gridTableSplitLine indices) rawContent
      heads <- mapM (parseFromString blocks) $ map trim rawHeads
      return (heads, aligns, indices)

    gridTableRawLine :: [Int] -> Parser [Char] ParserState [String]
    gridTableRawLine indices = do
      char '|'
      line <- many1Till anyChar newline
      return (gridTableSplitLine indices line)

    -- | Parse row of grid table.
    gridTableRow :: Parser [Char] ParserState [Block]
                 -> [Int]
                 -> Parser [Char] ParserState [[Block]]
    gridTableRow blocks indices = do
      colLines <- many1 (gridTableRawLine indices)
      let cols = map ((++ "\n") . unlines . removeOneLeadingSpace) $
                   transpose colLines
      mapM (liftM compactifyCell . parseFromString blocks) cols

    removeOneLeadingSpace :: [String] -> [String]
    removeOneLeadingSpace xs =
      if all startsWithSpace xs
         then map (drop 1) xs
         else xs
       where startsWithSpace ""     = True
             startsWithSpace (y:_) = y == ' '

    compactifyCell :: [Block] -> [Block]
    compactifyCell bs = head $ compactify [bs]

    -- | Parse footer for a grid table.
    gridTableFooter :: Parser [Char] ParserState [Char]
    gridTableFooter = blanklines

    ---

    -- | Parse a string with a given parser and state.
    readWith :: Parser [Char] st a       -- ^ parser
             -> st                       -- ^ initial state
             -> [Char]                   -- ^ input
             -> a
    readWith parser state input =
        case runParser parser state "source" input of
          Left err'    ->
            let errPos = errorPos err'
                errLine = sourceLine errPos
                errColumn = sourceColumn errPos
                theline = (lines input ++ [""]) !! (errLine - 1)
            in  error $ "\nError at " ++ show  err' ++ "\n" ++
                    theline ++ "\n" ++ replicate (errColumn - 1) ' ' ++
                    "^"
          Right result -> result

    -- | Parse a string with @parser@ (for testing).
    testStringWith :: (Show a) => Parser [Char] ParserState a
                   -> String
                   -> IO ()
    testStringWith parser str = UTF8.putStrLn $ show $
                                readWith parser defaultParserState str

    -- | Parsing options.
    data ParserState = ParserState
        { stateOptions         :: ReaderOptions, -- ^ User options
          stateParserContext   :: ParserContext, -- ^ Inside list?
          stateQuoteContext    :: QuoteContext,  -- ^ Inside quoted environment?
          stateAllowLinks      :: Bool,          -- ^ Allow parsing of links
          stateMaxNestingLevel :: Int,           -- ^ Max # of nested Strong/Emph
          stateLastStrPos      :: Maybe SourcePos, -- ^ Position after last str parsed
          stateKeys            :: KeyTable,      -- ^ List of reference keys (with fallbacks)
          stateSubstitutions   :: SubstTable,    -- ^ List of substitution references
          stateNotes           :: NoteTable,     -- ^ List of notes (raw bodies)
          stateNotes'          :: NoteTable',    -- ^ List of notes (parsed bodies)
          stateMeta            :: Meta,          -- ^ Document metadata
          stateMeta'           :: F Meta,        -- ^ Document metadata
          stateHeaderTable     :: [HeaderType],  -- ^ Ordered list of header types used
          stateHeaders         :: M.Map Inlines String, -- ^ List of headers and ids (used for implicit ref links)
          stateIdentifiers     :: [String],      -- ^ List of header identifiers used
          stateNextExample     :: Int,           -- ^ Number of next example
          stateExamples        :: M.Map String Int, -- ^ Map from example labels to numbers
          stateHasChapters     :: Bool,          -- ^ True if \chapter encountered
          stateMacros          :: [Macro],       -- ^ List of macros defined so far
          stateRstDefaultRole  :: String,        -- ^ Current rST default interpreted text role
          stateWarnings        :: [String]       -- ^ Warnings generated by the parser
        }

    instance Default ParserState where
      def = defaultParserState

    instance HasMeta ParserState where
      setMeta field val st =
        st{ stateMeta = setMeta field val $ stateMeta st }
      deleteMeta field st =
        st{ stateMeta = deleteMeta field $ stateMeta st }

    class Monad m => HasReaderOptions m where
      askReaderOption :: (ReaderOptions -> b) -> m b

    class Monad m => HasHeaderMap m where
      getHeaderMap    :: m (M.Map Inlines String)
      putHeaderMap    :: M.Map Inlines String -> m ()
      modifyHeaderMap :: (M.Map Inlines String -> M.Map Inlines String) -> m ()
      -- default
      modifyHeaderMap f = getHeaderMap >>= putHeaderMap . f

    class Monad m => HasIdentifierList m where
      getIdentifierList    :: m [String]
      putIdentifierList    :: [String] -> m ()
      modifyIdentifierList :: ([String] -> [String]) -> m ()
      -- default
      modifyIdentifierList f = getIdentifierList >>= putIdentifierList . f

    instance HasReaderOptions (Parser s ParserState) where
      askReaderOption = getOption

    instance HasHeaderMap (Parser s ParserState) where
      getHeaderMap      = fmap stateHeaders getState
      putHeaderMap hm   = updateState $ \st -> st{ stateHeaders = hm }

    instance HasIdentifierList (Parser s ParserState) where
      getIdentifierList   = fmap stateIdentifiers  getState
      putIdentifierList l = updateState $ \st -> st{ stateIdentifiers = l }

    defaultParserState :: ParserState
    defaultParserState =
        ParserState { stateOptions         = def,
                      stateParserContext   = NullState,
                      stateQuoteContext    = NoQuote,
                      stateAllowLinks      = True,
                      stateMaxNestingLevel = 6,
                      stateLastStrPos      = Nothing,
                      stateKeys            = M.empty,
                      stateSubstitutions   = M.empty,
                      stateNotes           = [],
                      stateNotes'          = [],
                      stateMeta            = nullMeta,
                      stateMeta'           = return nullMeta,
                      stateHeaderTable     = [],
                      stateHeaders         = M.empty,
                      stateIdentifiers     = [],
                      stateNextExample     = 1,
                      stateExamples        = M.empty,
                      stateHasChapters     = False,
                      stateMacros          = [],
                      stateRstDefaultRole  = "title-reference",
                      stateWarnings        = []}

    getOption :: (ReaderOptions -> a) -> Parser s ParserState a
    getOption f = (f . stateOptions) `fmap` getState

    -- | Succeed only if the extension is enabled.
    guardEnabled :: Extension -> Parser s ParserState ()
    guardEnabled ext = getOption readerExtensions >>= guard . Set.member ext

    -- | Succeed only if the extension is disabled.
    guardDisabled :: Extension -> Parser s ParserState ()
    guardDisabled ext = getOption readerExtensions >>= guard . not . Set.member ext

    data HeaderType
        = SingleHeader Char  -- ^ Single line of characters underneath
        | DoubleHeader Char  -- ^ Lines of characters above and below
        deriving (Eq, Show)

    data ParserContext
        = ListItemState   -- ^ Used when running parser on list item contents
        | NullState       -- ^ Default state
        deriving (Eq, Show)

    data QuoteContext
        = InSingleQuote   -- ^ Used when parsing inside single quotes
        | InDoubleQuote   -- ^ Used when parsing inside double quotes
        | NoQuote         -- ^ Used when not parsing inside quotes
        deriving (Eq, Show)

    type NoteTable = [(String, String)]

    type NoteTable' = [(String, F Blocks)]  -- used in markdown reader

    newtype Key = Key String deriving (Show, Read, Eq, Ord)

    toKey :: String -> Key
    toKey = Key . map toLower . unwords . words

    type KeyTable = M.Map Key Target

    type SubstTable = M.Map Key Inlines

    --  | Add header to the list of headers in state, together
    --  with its associated identifier.  If the identifier is null
    --  and the auto_identifers extension is set, generate a new
    --  unique identifier, and update the list of identifiers
    --  in state.
    registerHeader :: (HasReaderOptions m, HasHeaderMap m, HasIdentifierList m)
                   => Attr -> Inlines -> m Attr
    registerHeader (ident,classes,kvs) header' = do
      ids <- getIdentifierList
      exts <- askReaderOption readerExtensions
      let insert' = M.insertWith (\_new old -> old)
      if null ident && Ext_auto_identifiers `Set.member` exts
         then do
           let id' = uniqueIdent (B.toList header') ids
           let id'' = if Ext_ascii_identifiers `Set.member` exts
                         then catMaybes $ map toAsciiChar id'
                         else id'
           putIdentifierList $ if id' == id''
                                  then id' : ids
                                  else id' : id'' : ids
           modifyHeaderMap $ insert' header' id'
           return (id'',classes,kvs)
         else do
            unless (null ident) $ modifyHeaderMap $ insert' header' ident
            return (ident,classes,kvs)

    -- | Fail unless we're in "smart typography" mode.
    failUnlessSmart :: Parser [tok] ParserState ()
    failUnlessSmart = getOption readerSmart >>= guard

    smartPunctuation :: Parser [Char] ParserState Inline
                     -> Parser [Char] ParserState Inline
    smartPunctuation inlineParser = do
      failUnlessSmart
      choice [ quoted inlineParser, apostrophe, dash, ellipses ]

    apostrophe :: Parser [Char] ParserState Inline
    apostrophe = (char '\'' <|> char '\8217') >> return (Str "\x2019")

    quoted :: Parser [Char] ParserState Inline
           -> Parser [Char] ParserState Inline
    quoted inlineParser = doubleQuoted inlineParser <|> singleQuoted inlineParser

    withQuoteContext :: QuoteContext
                     -> Parser [tok] ParserState a
                     -> Parser [tok] ParserState a
    withQuoteContext context parser = do
      oldState <- getState
      let oldQuoteContext = stateQuoteContext oldState
      setState oldState { stateQuoteContext = context }
      result <- parser
      newState <- getState
      setState newState { stateQuoteContext = oldQuoteContext }
      return result

    singleQuoted :: Parser [Char] ParserState Inline
                 -> Parser [Char] ParserState Inline
    singleQuoted inlineParser = try $ do
      singleQuoteStart
      withQuoteContext InSingleQuote $ many1Till inlineParser singleQuoteEnd >>=
        return . Quoted SingleQuote . normalizeSpaces

    doubleQuoted :: Parser [Char] ParserState Inline
                 -> Parser [Char] ParserState Inline
    doubleQuoted inlineParser = try $ do
      doubleQuoteStart
      withQuoteContext InDoubleQuote $ do
        contents <- manyTill inlineParser doubleQuoteEnd
        return . Quoted DoubleQuote . normalizeSpaces $ contents

    failIfInQuoteContext :: QuoteContext -> Parser [tok] ParserState ()
    failIfInQuoteContext context = do
      st <- getState
      if stateQuoteContext st == context
         then fail "already inside quotes"
         else return ()

    charOrRef :: [Char] -> Parser [Char] st Char
    charOrRef cs =
      oneOf cs <|> try (do c <- characterReference
                           guard (c `elem` cs)
                           return c)

    updateLastStrPos :: Parser [Char] ParserState ()
    updateLastStrPos = getPosition >>= \p ->
      updateState $ \s -> s{ stateLastStrPos = Just p }

    singleQuoteStart :: Parser [Char] ParserState ()
    singleQuoteStart = do
      failIfInQuoteContext InSingleQuote
      pos <- getPosition
      st <- getState
      -- single quote start can't be right after str
      guard $ stateLastStrPos st /= Just pos
      () <$ charOrRef "'\8216\145"

    singleQuoteEnd :: Parser [Char] st ()
    singleQuoteEnd = try $ do
      charOrRef "'\8217\146"
      notFollowedBy alphaNum

    doubleQuoteStart :: Parser [Char] ParserState ()
    doubleQuoteStart = do
      failIfInQuoteContext InDoubleQuote
      try $ do charOrRef "\"\8220\147"
               notFollowedBy (satisfy (\c -> c == ' ' || c == '\t' || c == '\n'))

    doubleQuoteEnd :: Parser [Char] st ()
    doubleQuoteEnd = do
      charOrRef "\"\8221\148"
      return ()

    ellipses :: Parser [Char] st Inline
    ellipses = do
      try (charOrRef "\8230\133") <|> try (string "..." >> return '…')
      return (Str "\8230")

    dash :: Parser [Char] ParserState Inline
    dash = do
      oldDashes <- getOption readerOldDashes
      if oldDashes
         then emDashOld <|> enDashOld
         else Str `fmap` (hyphenDash <|> emDash <|> enDash)

    -- Two hyphens = en-dash, three = em-dash
    hyphenDash :: Parser [Char] st String
    hyphenDash = do
      try $ string "--"
      option "\8211" (char '-' >> return "\8212")

    emDash :: Parser [Char] st String
    emDash = do
      try (charOrRef "\8212\151")
      return "\8212"

    enDash :: Parser [Char] st String
    enDash = do
      try (charOrRef "\8212\151")
      return "\8211"

    enDashOld :: Parser [Char] st Inline
    enDashOld = do
      try (charOrRef "\8211\150") <|>
        try (char '-' >> lookAhead (satisfy isDigit) >> return '–')
      return (Str "\8211")

    emDashOld :: Parser [Char] st Inline
    emDashOld = do
      try (charOrRef "\8212\151") <|> (try $ string "--" >> optional (char '-') >> return '-')
      return (Str "\8212")

    -- This is used to prevent exponential blowups for things like:
    -- a**a*a**a*a**a*a**a*a**a*a**a*a**
    nested :: Parser s ParserState a
           -> Parser s ParserState a
    nested p = do
      nestlevel <- stateMaxNestingLevel `fmap` getState
      guard $ nestlevel > 0
      updateState $ \st -> st{ stateMaxNestingLevel = stateMaxNestingLevel st - 1 }
      res <- p
      updateState $ \st -> st{ stateMaxNestingLevel = nestlevel }
      return res

    --
    -- Macros
    --

    -- | Parse a \newcommand or \renewcommand macro definition.
    macro :: Parser [Char] ParserState Blocks
    macro = do
      apply <- getOption readerApplyMacros
      inp <- getInput
      case parseMacroDefinitions inp of
           ([], _)    -> mzero
           (ms, rest) -> do def' <- count (length inp - length rest) anyChar
                            if apply
                               then do
                                 updateState $ \st ->
                                   st { stateMacros = ms ++ stateMacros st }
                                 return mempty
                               else return $ rawBlock "latex" def'

    -- | Apply current macros to string.
    applyMacros' :: String -> Parser [Char] ParserState String
    applyMacros' target = do
      apply <- getOption readerApplyMacros
      if apply
         then do macros <- liftM stateMacros getState
                 return $ applyMacros macros target
         else return target