content: {-# LANGUAGE LambdaCase #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE ViewPatterns #-}
  
  -- |
  -- Module      :  Documentation.Haddock.Parser
  -- Copyright   :  (c) Mateusz Kowalczyk 2013-2014,
  --                    Simon Hengel      2013
  -- License     :  BSD-like
  --
  -- Maintainer  :  haddock@projects.haskell.org
  -- Stability   :  experimental
  -- Portability :  portable
  --
  -- Parser used for Haddock comments. For external users of this
  -- library, the most commonly used combination of functions is going
  -- to be
  --
  -- @'toRegular' . '_doc' . 'parseParas'@
  module Documentation.Haddock.Parser
    ( parseString
    , parseParas
    , overIdentifier
    , toRegular
    , Identifier
    ) where
  
  import Control.Applicative
  import Control.Arrow (first)
  import Control.Monad
  import Data.Char (chr, isAlpha, isSpace, isUpper)
  import Data.Functor (($>))
  import Data.List (elemIndex, intercalate, intersperse, unfoldr)
  import Data.Maybe (fromMaybe, mapMaybe)
  import Data.Monoid
  import qualified Data.Set as Set
  import Data.Text (Text)
  import qualified Data.Text as T
  import Text.Parsec (try)
  import qualified Text.Parsec as Parsec
  import Prelude hiding (takeWhile)
  import qualified Prelude as P
  
  import Documentation.Haddock.Doc
  import Documentation.Haddock.Markup (markup, plainMarkup)
  import Documentation.Haddock.Parser.Identifier
  import Documentation.Haddock.Parser.Monad
  import Documentation.Haddock.Parser.Util
  import Documentation.Haddock.Types
  
  -- $setup
  -- >>> :set -XOverloadedStrings
  
  -- | Drops the quotes/backticks around all identifiers, as if they
  -- were valid but still 'String's.
  toRegular :: DocH mod Identifier -> DocH mod String
  toRegular = fmap (\(Identifier _ _ x _) -> x)
  
  -- | Maps over 'DocIdentifier's over 'String' with potentially failing
  -- conversion using user-supplied function. If the conversion fails,
  -- the identifier is deemed to not be valid and is treated as a
  -- regular string.
  overIdentifier
    :: (Namespace -> String -> Maybe a)
    -> DocH mod Identifier
    -> DocH mod a
  overIdentifier f d = g d
    where
      g (DocIdentifier (Identifier ns o x e)) = case f ns x of
        Nothing -> DocString $ renderNs ns ++ [o] ++ x ++ [e]
        Just x' -> DocIdentifier x'
      g DocEmpty = DocEmpty
      g (DocAppend x x') = DocAppend (g x) (g x')
      g (DocString x) = DocString x
      g (DocParagraph x) = DocParagraph $ g x
      g (DocIdentifierUnchecked x) = DocIdentifierUnchecked x
      g (DocModule (ModLink m x)) = DocModule (ModLink m (fmap g x))
      g (DocWarning x) = DocWarning $ g x
      g (DocEmphasis x) = DocEmphasis $ g x
      g (DocMonospaced x) = DocMonospaced $ g x
      g (DocBold x) = DocBold $ g x
      g (DocUnorderedList x) = DocUnorderedList $ fmap g x
      g (DocOrderedList x) = DocOrderedList $ fmap (\(index, a) -> (index, g a)) x
      g (DocDefList x) = DocDefList $ fmap (\(y, z) -> (g y, g z)) x
      g (DocCodeBlock x) = DocCodeBlock $ g x
      g (DocHyperlink (Hyperlink u x)) = DocHyperlink (Hyperlink u (fmap g x))
      g (DocPic x) = DocPic x
      g (DocMathInline x) = DocMathInline x
      g (DocMathDisplay x) = DocMathDisplay x
      g (DocAName x) = DocAName x
      g (DocProperty x) = DocProperty x
      g (DocExamples x) = DocExamples x
      g (DocHeader (Header l x)) = DocHeader . Header l $ g x
      g (DocTable (Table h b)) = DocTable (Table (map (fmap g) h) (map (fmap g) b))
  
  choice' :: [Parser a] -> Parser a
  choice' [] = empty
  choice' [p] = p
  choice' (p : ps) = try p <|> choice' ps
  
  parse :: Parser a -> Text -> (ParserState, a)
  parse p = either err id . parseOnly (p <* Parsec.eof)
    where
      err = error . ("Haddock.Parser.parse: " ++)
  
  -- | Main entry point to the parser. Appends the newline character
  -- to the input string.
  parseParas
    :: Maybe Package
    -> String
    -- ^ String to parse
    -> MetaDoc mod Identifier
  parseParas pkg input = case parseParasState input of
    (state, a) ->
      let defaultPackage s = s{sincePackage = sincePackage s <|> pkg}
       in MetaDoc
            { _meta = Meta{_metaSince = defaultPackage <$> parserStateSince state}
            , _doc = a
            }
  
  parseParasState :: String -> (ParserState, DocH mod Identifier)
  parseParasState = parse (emptyLines *> p) . T.pack . (++ "\n") . filter (/= '\r')
    where
      p :: Parser (DocH mod Identifier)
      p = docConcat <$> many (paragraph <* emptyLines)
  
      emptyLines :: Parser ()
      emptyLines = void $ many (try (skipHorizontalSpace *> "\n"))
  
  parseParagraphs :: String -> Parser (DocH mod Identifier)
  parseParagraphs input = case parseParasState input of
    (state, a) -> Parsec.putState state *> pure a
  
  -- | Variant of 'parseText' for 'String' instead of 'Text'
  parseString :: String -> DocH mod Identifier
  parseString = parseText . T.pack
  
  -- | Parse a text paragraph. Actually just a wrapper over 'parseParagraph' which
  -- drops leading whitespace.
  parseText :: Text -> DocH mod Identifier
  parseText = parseParagraph . T.dropWhile isSpace . T.filter (/= '\r')
  
  parseParagraph :: Text -> DocH mod Identifier
  parseParagraph = snd . parse p
    where
      p :: Parser (DocH mod Identifier)
      p =
        docConcat
          <$> many
            ( choice'
                [ monospace
                , anchor
                , identifier
                , moduleName
                , picture
                , mathDisplay
                , mathInline
                , markdownImage
                , markdownLink
                , hyperlink
                , bold
                , emphasis
                , encodedChar
                , string'
                , skipSpecialChar
                ]
            )
  
  -- | Parses and processes
  -- <https://en.wikipedia.org/wiki/Numeric_character_reference Numeric character references>
  --
  -- >>> parseString "&#65;"
  -- DocString "A"
  encodedChar :: Parser (DocH mod a)
  encodedChar = "&#" *> c <* ";"
    where
      c = DocString . return . chr <$> num
      num = hex <|> decimal
      hex = ("x" <|> "X") *> hexadecimal
  
  -- | List of characters that we use to delimit any special markup.
  -- Once we have checked for any of these and tried to parse the
  -- relevant markup, we can assume they are used as regular text.
  specialChar :: [Char]
  specialChar = "_/<@\"&'`#[ "
  
  -- | Plain, regular parser for text. Called as one of the last parsers
  -- to ensure that we have already given a chance to more meaningful parsers
  -- before capturing their characters.
  string' :: Parser (DocH mod a)
  string' =
    DocString
      <$> ((:) <$> rawOrEscChar "" <*> many (rawOrEscChar "(["))
      -- After the first character, stop for @\(@ or @\[@ math starters. (The
      -- first character won't start a valid math string because this parser
      -- should follow math parsers. But this parser is expected to accept at
      -- least one character from all inputs that don't start with special
      -- characters, so the first character parser can't have the @"(["@
      -- restriction.)
    where
      -- | Parse a single logical character, either raw or escaped. Don't accept
      -- escaped characters from the argument string.
      rawOrEscChar :: [Char] -> Parser Char
      rawOrEscChar restrictedEscapes = try $ Parsec.noneOf specialChar >>= \case
        -- Handle backslashes:
        --   - Fail on forbidden escape characters.
        --   - Non-forbidden characters: simply unescape, e.g. parse "\b" as 'b',
        --   - Trailing backslash: treat it as a raw backslash, not an escape
        --     sequence. (This is the logic that this parser followed when this
        --     comment was written; it is not necessarily intentional but now I
        --     don't want to break anything relying on it.)
        '\\' -> Parsec.noneOf restrictedEscapes <|> Parsec.eof $> '\\'
        c -> pure c
  
  -- | Skips a single special character and treats it as a plain string.
  -- This is done to skip over any special characters belonging to other
  -- elements but which were not deemed meaningful at their positions.
  skipSpecialChar :: Parser (DocH mod a)
  skipSpecialChar = DocString . return <$> Parsec.oneOf specialChar
  
  -- | Emphasis parser.
  --
  -- >>> parseString "/Hello world/"
  -- DocEmphasis (DocString "Hello world")
  emphasis :: Parser (DocH mod Identifier)
  emphasis =
    DocEmphasis . parseParagraph
      <$> disallowNewline ("/" *> takeWhile1_ (/= '/') <* "/")
  
  -- | Bold parser.
  --
  -- >>> parseString "__Hello world__"
  -- DocBold (DocString "Hello world")
  bold :: Parser (DocH mod Identifier)
  bold = DocBold . parseParagraph <$> disallowNewline ("__" *> takeUntil "__")
  
  disallowNewline :: Parser Text -> Parser Text
  disallowNewline = mfilter (T.all (/= '\n'))
  
  -- | Like `takeWhile`, but unconditionally take escaped characters.
  takeWhile_ :: (Char -> Bool) -> Parser Text
  takeWhile_ p = scan p_ False
    where
      p_ escaped c
        | escaped = Just False
        | not $ p c = Nothing
        | otherwise = Just (c == '\\')
  
  -- | Like 'takeWhile1', but unconditionally take escaped characters.
  takeWhile1_ :: (Char -> Bool) -> Parser Text
  takeWhile1_ = mfilter (not . T.null) . takeWhile_
  
  -- | Text anchors to allow for jumping around the generated documentation.
  --
  -- >>> parseString "#Hello world#"
  -- DocAName "Hello world"
  anchor :: Parser (DocH mod a)
  anchor =
    DocAName . T.unpack
      <$> ("#" *> takeWhile1_ (\x -> x /= '#' && not (isSpace x)) <* "#")
  
  -- | Monospaced strings.
  --
  -- >>> parseString "@cruel@"
  -- DocMonospaced (DocString "cruel")
  monospace :: Parser (DocH mod Identifier)
  monospace =
    DocMonospaced . parseParagraph
      <$> ("@" *> takeWhile1_ (/= '@') <* "@")
  
  -- | Module names.
  --
  -- Note that we allow '#' and '\' to support anchors (old style anchors are of
  -- the form "SomeModule\#anchor").
  moduleName :: Parser (DocH mod a)
  moduleName = DocModule . flip ModLink Nothing <$> ("\"" *> moduleNameString <* "\"")
  
  -- | A module name, optionally with an anchor
  moduleNameString :: Parser String
  moduleNameString = modid `maybeFollowedBy` anchor_
    where
      modid = intercalate "." <$> conid `Parsec.sepBy1` "."
      anchor_ =
        (++)
          <$> (Parsec.string "#" <|> Parsec.string "\\#")
          <*> many (Parsec.satisfy (\c -> c /= '"' && not (isSpace c)))
  
      maybeFollowedBy pre suf = (\x -> maybe x (x ++)) <$> pre <*> optional suf
      conid :: Parser String
      conid =
        (:)
          <$> Parsec.satisfy (\c -> isAlpha c && isUpper c)
          <*> many conChar
  
      conChar = Parsec.alphaNum <|> Parsec.char '_'
  
  -- | A labeled link to an indentifier, module or url using markdown
  -- syntax.
  markdownLink :: Parser (DocH mod Identifier)
  markdownLink = do
    lbl <- markdownLinkText
    choice' [markdownModuleName lbl, markdownURL lbl]
    where
      markdownModuleName lbl = do
        mn <-
          "("
            *> skipHorizontalSpace
            *> "\""
            *> moduleNameString
            <* "\""
            <* skipHorizontalSpace
            <* ")"
        pure $ DocModule (ModLink mn (Just lbl))
  
      markdownURL lbl = do
        target <- markdownLinkTarget
        pure $ DocHyperlink $ Hyperlink target (Just lbl)
  
  -- | Picture parser, surrounded by \<\< and \>\>. It's possible to specify
  -- a title for the picture.
  --
  -- >>> parseString "<<hello.png>>"
  -- DocPic (Picture {pictureUri = "hello.png", pictureTitle = Nothing})
  -- >>> parseString "<<hello.png world>>"
  -- DocPic (Picture {pictureUri = "hello.png", pictureTitle = Just "world"})
  picture :: Parser (DocH mod a)
  picture =
    DocPic . makeLabeled Picture
      <$> disallowNewline ("<<" *> takeUntil ">>")
  
  -- | Inline math parser, surrounded by \\( and \\).
  --
  -- >>> parseString "\\(\\int_{-\\infty}^{\\infty} e^{-x^2/2} = \\sqrt{2\\pi}\\)"
  -- DocMathInline "\\int_{-\\infty}^{\\infty} e^{-x^2/2} = \\sqrt{2\\pi}"
  mathInline :: Parser (DocH mod a)
  mathInline =
    DocMathInline . T.unpack
      <$> disallowNewline ("\\(" *> takeUntil "\\)")
  
  -- | Display math parser, surrounded by \\[ and \\].
  --
  -- >>> parseString "\\[\\int_{-\\infty}^{\\infty} e^{-x^2/2} = \\sqrt{2\\pi}\\]"
  -- DocMathDisplay "\\int_{-\\infty}^{\\infty} e^{-x^2/2} = \\sqrt{2\\pi}"
  mathDisplay :: Parser (DocH mod a)
  mathDisplay =
    DocMathDisplay . T.unpack
      <$> ("\\[" *> takeUntil "\\]")
  
  -- | Markdown image parser. As per the commonmark reference recommendation, the
  -- description text for an image converted to its a plain string representation.
  --
  -- >>> parseString "![some /emphasis/ in a description](www.site.com)"
  -- DocPic (Picture "www.site.com" (Just "some emphasis in a description"))
  markdownImage :: Parser (DocH mod Identifier)
  markdownImage = do
    text <- markup stringMarkup <$> ("!" *> markdownLinkText)
    url <- markdownLinkTarget
    pure $ DocPic (Picture url (Just text))
    where
      stringMarkup = plainMarkup (const "") renderIdent
      renderIdent (Identifier ns l c r) = renderNs ns <> [l] <> c <> [r]
  
  -- | Paragraph parser, called by 'parseParas'.
  paragraph :: Parser (DocH mod Identifier)
  paragraph =
    choice'
      [ examples
      , table
      , do
          indent <- takeIndent
          choice'
            [ since
            , unorderedList indent
            , orderedList indent
            , birdtracks
            , codeblock
            , property
            , header
            , textParagraphThatStartsWithMarkdownLink
            , definitionList indent
            , docParagraph <$> textParagraph
            ]
      ]
  
  -- | Provides support for grid tables.
  --
  -- Tables are composed by an optional header and body. The header is composed by
  -- a single row. The body is composed by a non-empty list of rows.
  --
  -- Example table with header:
  --
  -- > +----------+----------+
  -- > | /32bit/  |   64bit  |
  -- > +==========+==========+
  -- > |  0x0000  | @0x0000@ |
  -- > +----------+----------+
  --
  -- Algorithms loosely follows ideas in
  -- http://docutils.sourceforge.net/docutils/parsers/rst/tableparser.py
  table :: Parser (DocH mod Identifier)
  table = do
    -- first we parse the first row, which determines the width of the table
    firstRow <- parseFirstRow
    let len = T.length firstRow
  
    -- then we parse all consecutive rows starting and ending with + or |,
    -- of the width `len`.
    restRows <- many (try (parseRestRows len))
  
    -- Now we gathered the table block, the next step is to split the block
    -- into cells.
    DocTable <$> tableStepTwo len (firstRow : restRows)
    where
      parseFirstRow :: Parser Text
      parseFirstRow = do
        skipHorizontalSpace
        cs <- takeWhile (\c -> c == '-' || c == '+')
  
        -- upper-left and upper-right corners are `+`
        guard
          ( T.length cs >= 2
              && T.head cs == '+'
              && T.last cs == '+'
          )
  
        -- trailing space
        skipHorizontalSpace
        _ <- Parsec.newline
  
        return cs
  
      parseRestRows :: Int -> Parser Text
      parseRestRows l = do
        skipHorizontalSpace
        bs <- scan predicate l
  
        -- Left and right edges are `|` or `+`
        guard
          ( T.length bs >= 2
              && (T.head bs == '|' || T.head bs == '+')
              && (T.last bs == '|' || T.last bs == '+')
          )
  
        -- trailing space
        skipHorizontalSpace
        _ <- Parsec.newline
  
        return bs
        where
          predicate n c
            | n <= 0 = Nothing
            | c == '\n' = Nothing
            | otherwise = Just (n - 1)
  
  -- Second step searchs for row of '+' and '=' characters, records it's index
  -- and changes to '=' to '-'.
  tableStepTwo
    :: Int
    -- ^ width
    -> [Text]
    -- ^ rows
    -> Parser (Table (DocH mod Identifier))
  tableStepTwo width = go 0 []
    where
      go _ left [] = tableStepThree width (reverse left) Nothing
      go n left (r : rs)
        | T.all (`elem` ['+', '=']) r =
            tableStepThree width (reverse left ++ r' : rs) (Just n)
        | otherwise =
            go (n + 1) (r : left) rs
        where
          r' = T.map (\c -> if c == '=' then '-' else c) r
  
  -- Third step recognises cells in the table area, returning a list of TC, cells.
  tableStepThree
    :: Int
    -- ^ width
    -> [Text]
    -- ^ rows
    -> Maybe Int
    -- ^ index of header separator
    -> Parser (Table (DocH mod Identifier))
  tableStepThree width rs hdrIndex = do
    cells <- loop (Set.singleton (0, 0))
    tableStepFour rs hdrIndex cells
    where
      height = length rs
  
      loop :: Set.Set (Int, Int) -> Parser [TC]
      loop queue = case Set.minView queue of
        Nothing -> return []
        Just ((y, x), queue')
          | y + 1 >= height || x + 1 >= width -> loop queue'
          | otherwise -> case scanRight x y of
              Nothing -> loop queue'
              Just (x2, y2) -> do
                let tc = TC y x y2 x2
                fmap (tc :) $
                  loop $
                    queue'
                      `Set.union` Set.fromList
                        [(y, x2), (y2, x), (y2, x2)]
  
      -- scan right looking for +, then try scan down
      --
      -- do we need to record + saw on the way left and down?
      scanRight :: Int -> Int -> Maybe (Int, Int)
      scanRight x y = go (x + 1)
        where
          bs = rs !! y
          go x'
            | x' >= width = fail "overflow right "
            | T.index bs x' == '+' = scanDown x y x' <|> go (x' + 1)
            | T.index bs x' == '-' = go (x' + 1)
            | otherwise = fail $ "not a border (right) " ++ show (x, y, x')
  
      -- scan down looking for +
      scanDown :: Int -> Int -> Int -> Maybe (Int, Int)
      scanDown x y x2 = go (y + 1)
        where
          go y'
            | y' >= height = fail "overflow down"
            | T.index (rs !! y') x2 == '+' = scanLeft x y x2 y' <|> go (y' + 1)
            | T.index (rs !! y') x2 == '|' = go (y' + 1)
            | otherwise = fail $ "not a border (down) " ++ show (x, y, x2, y')
  
      -- check that at y2 x..x2 characters are '+' or '-'
      scanLeft :: Int -> Int -> Int -> Int -> Maybe (Int, Int)
      scanLeft x y x2 y2
        | all (\x' -> T.index bs x' `elem` ['+', '-']) [x .. x2] = scanUp x y x2 y2
        | otherwise = fail $ "not a border (left) " ++ show (x, y, x2, y2)
        where
          bs = rs !! y2
  
      -- check that at y2 x..x2 characters are '+' or '-'
      scanUp :: Int -> Int -> Int -> Int -> Maybe (Int, Int)
      scanUp x y x2 y2
        | all (\y' -> T.index (rs !! y') x `elem` ['+', '|']) [y .. y2] = return (x2, y2)
        | otherwise = fail $ "not a border (up) " ++ show (x, y, x2, y2)
  
  -- | table cell: top left bottom right
  data TC = TC !Int !Int !Int !Int
    deriving (Show)
  
  tcXS :: TC -> [Int]
  tcXS (TC _ x _ x2) = [x, x2]
  
  tcYS :: TC -> [Int]
  tcYS (TC y _ y2 _) = [y, y2]
  
  -- | Fourth step. Given the locations of cells, forms 'Table' structure.
  tableStepFour :: [Text] -> Maybe Int -> [TC] -> Parser (Table (DocH mod Identifier))
  tableStepFour rs hdrIndex cells = case hdrIndex of
    Nothing -> return $ Table [] rowsDoc
    Just i -> case elemIndex i yTabStops of
      Nothing -> return $ Table [] rowsDoc
      Just i' -> return $ uncurry Table $ splitAt i' rowsDoc
    where
      xTabStops = sortNub $ concatMap tcXS cells
      yTabStops = sortNub $ concatMap tcYS cells
  
      sortNub :: Ord a => [a] -> [a]
      sortNub = Set.toList . Set.fromList
  
      init' :: [a] -> [a]
      init' [] = []
      init' [_] = []
      init' (x : xs) = x : init' xs
  
      rowsDoc = (fmap . fmap) parseParagraph rows
  
      rows = map makeRow (init' yTabStops)
        where
          makeRow y = TableRow $ mapMaybe (makeCell y) cells
          makeCell y (TC y' x y2 x2)
            | y /= y' = Nothing
            | otherwise = Just $ TableCell xts yts (extract (x + 1) (y + 1) (x2 - 1) (y2 - 1))
            where
              xts = length $ P.takeWhile (< x2) $ dropWhile (< x) xTabStops
              yts = length $ P.takeWhile (< y2) $ dropWhile (< y) yTabStops
  
      -- extract cell contents given boundaries
      extract :: Int -> Int -> Int -> Int -> Text
      extract x y x2 y2 =
        T.intercalate
          "\n"
          [ T.stripEnd $ T.stripStart $ T.take (x2 - x + 1) $ T.drop x $ rs !! y'
          | y' <- [y .. y2]
          ]
  
  -- | Parse \@since annotations.
  since :: Parser (DocH mod a)
  since = do
    ("@since " *> version <* skipHorizontalSpace <* endOfLine) >>= setSince
    return DocEmpty
    where
      version = do
        pkg <- Parsec.optionMaybe $ Parsec.try $ package
        ver <- decimal `Parsec.sepBy1` "."
        return (MetaSince pkg ver)
  
      package = combine <$> (Parsec.many1 (Parsec.letter <|> Parsec.char '_')) `Parsec.endBy1` (Parsec.char '-')
      combine = concat . intersperse "-"
  
  -- | Headers inside the comment denoted with @=@ signs, up to 6 levels
  -- deep.
  --
  -- >>> snd <$> parseOnly header "= Hello"
  -- Right (DocHeader (Header {headerLevel = 1, headerTitle = DocString "Hello"}))
  -- >>> snd <$> parseOnly header "== World"
  -- Right (DocHeader (Header {headerLevel = 2, headerTitle = DocString "World"}))
  header :: Parser (DocH mod Identifier)
  header = do
    let psers = map (string . flip T.replicate "=") [6, 5 .. 1]
        pser = Parsec.choice psers
    depth <- T.length <$> pser
    line <- parseText <$> (skipHorizontalSpace *> nonEmptyLine)
    rest <- try paragraph <|> return DocEmpty
    return $ DocHeader (Header depth line) `docAppend` rest
  
  textParagraph :: Parser (DocH mod Identifier)
  textParagraph = parseText . T.intercalate "\n" <$> some nonEmptyLine
  
  textParagraphThatStartsWithMarkdownLink :: Parser (DocH mod Identifier)
  textParagraphThatStartsWithMarkdownLink = docParagraph <$> (docAppend <$> markdownLink <*> optionalTextParagraph)
    where
      optionalTextParagraph :: Parser (DocH mod Identifier)
      optionalTextParagraph =
        choice'
          [ docAppend <$> whitespace <*> textParagraph
          , pure DocEmpty
          ]
  
      whitespace :: Parser (DocH mod a)
      whitespace = DocString <$> (f <$> takeHorizontalSpace <*> optional "\n")
        where
          f :: Text -> Maybe Text -> String
          f xs (fromMaybe "" -> x)
            | T.null (xs <> x) = ""
            | otherwise = " "
  
  -- | Parses unordered (bullet) lists.
  unorderedList :: Text -> Parser (DocH mod Identifier)
  unorderedList indent = DocUnorderedList <$> p
    where
      p = ("*" <|> "-") *> innerList indent p
  
  -- | Parses ordered lists (numbered or dashed).
  orderedList :: Text -> Parser (DocH mod Identifier)
  orderedList indent = DocOrderedList <$> p
    where
      p = do
        index <- paren <|> dot
        innerList' indent p index
      dot = (decimal :: Parser Int) <* "."
      paren = "(" *> decimal <* ")"
  
  -- | Like 'innerList' but takes the parsed index of the list item
  innerList'
    :: Text
    -> Parser [(Int, DocH mod Identifier)]
    -> Int
    -> Parser [(Int, DocH mod Identifier)]
  innerList' indent item index = do
    c <- takeLine
    (cs, items) <- more indent item
    let contents = docParagraph . parseText . dropNLs . T.unlines $ c : cs
    return $ case items of
      Left p -> [(index, contents `docAppend` p)]
      Right i -> (index, contents) : i
  
  -- | Generic function collecting any further lines belonging to the
  -- list entry and recursively collecting any further lists in the
  -- same paragraph. Usually used as
  --
  -- > someListFunction = listBeginning *> innerList someListFunction
  innerList
    :: Text
    -> Parser [DocH mod Identifier]
    -> Parser [DocH mod Identifier]
  innerList indent item = do
    c <- takeLine
    (cs, items) <- more indent item
    let contents = docParagraph . parseText . dropNLs . T.unlines $ c : cs
    return $ case items of
      Left p -> [contents `docAppend` p]
      Right i -> contents : i
  
  -- | Parses definition lists.
  definitionList :: Text -> Parser (DocH mod Identifier)
  definitionList indent = DocDefList <$> p
    where
      p = do
        label <- "[" *> (parseParagraph <$> takeWhile1_ (`notElem` ("]\n" :: String))) <* ("]" <* optional ":")
        c <- takeLine
        (cs, items) <- more indent p
        let contents = parseText . dropNLs . T.unlines $ c : cs
        return $ case items of
          Left x -> [(label, contents `docAppend` x)]
          Right i -> (label, contents) : i
  
  -- | Drops all trailing newlines.
  dropNLs :: Text -> Text
  dropNLs = T.dropWhileEnd (== '\n')
  
  -- | Main worker for 'innerList' and 'definitionList'.
  -- We need the 'Either' here to be able to tell in the respective functions
  -- whether we're dealing with the next list or a nested paragraph.
  more
    :: Monoid a
    => Text
    -> Parser a
    -> Parser ([Text], Either (DocH mod Identifier) a)
  more indent item =
    choice'
      [ innerParagraphs indent
      , moreListItems indent item
      , moreContent indent item
      , pure ([], Right mempty)
      ]
  
  -- | Used by 'innerList' and 'definitionList' to parse any nested paragraphs.
  innerParagraphs
    :: Text
    -> Parser ([Text], Either (DocH mod Identifier) a)
  innerParagraphs indent = (,) [] . Left <$> ("\n" *> indentedParagraphs indent)
  
  -- | Attempts to fetch the next list if possibly. Used by 'innerList' and
  -- 'definitionList' to recursively grab lists that aren't separated by a whole
  -- paragraph.
  moreListItems
    :: Text
    -> Parser a
    -> Parser ([Text], Either (DocH mod Identifier) a)
  moreListItems indent item = (,) [] . Right <$> indentedItem
    where
      indentedItem = string indent *> Parsec.spaces *> item
  
  -- | Helper for 'innerList' and 'definitionList' which simply takes
  -- a line of text and attempts to parse more list content with 'more'.
  moreContent
    :: Monoid a
    => Text
    -> Parser a
    -> Parser ([Text], Either (DocH mod Identifier) a)
  moreContent indent item = first . (:) <$> nonEmptyLine <*> more indent item
  
  -- | Parses an indented paragraph.
  -- The indentation is 4 spaces.
  indentedParagraphs :: Text -> Parser (DocH mod Identifier)
  indentedParagraphs indent =
    (T.unpack . T.concat <$> dropFrontOfPara indent') >>= parseParagraphs
    where
      indent' = string $ indent <> "    "
  
  -- | Grab as many fully indented paragraphs as we can.
  dropFrontOfPara :: Parser Text -> Parser [Text]
  dropFrontOfPara sp = do
    currentParagraph <- some (try (sp *> takeNonEmptyLine))
    followingParagraphs <-
      choice'
        [ skipHorizontalSpace *> nextPar -- we have more paragraphs to take
        , skipHorizontalSpace *> nlList -- end of the ride, remember the newline
        , Parsec.eof *> return [] -- nothing more to take at all
        ]
    return (currentParagraph ++ followingParagraphs)
    where
      nextPar = (++) <$> nlList <*> dropFrontOfPara sp
      nlList = "\n" *> return ["\n"]
  
  nonSpace :: Text -> Parser Text
  nonSpace xs
    | T.all isSpace xs = fail "empty line"
    | otherwise = return xs
  
  -- | Takes a non-empty, not fully whitespace line.
  --
  --  Doesn't discard the trailing newline.
  takeNonEmptyLine :: Parser Text
  takeNonEmptyLine = do
    l <- takeWhile1 (/= '\n') >>= nonSpace
    _ <- "\n"
    pure (l <> "\n")
  
  -- | Takes indentation of first non-empty line.
  --
  -- More precisely: skips all whitespace-only lines and returns indentation
  -- (horizontal space, might be empty) of that non-empty line.
  takeIndent :: Parser Text
  takeIndent = do
    indent <- takeHorizontalSpace
    choice'
      [ "\n" *> takeIndent
      , return indent
      ]
  
  -- | Blocks of text of the form:
  --
  -- >> foo
  -- >> bar
  -- >> baz
  birdtracks :: Parser (DocH mod a)
  birdtracks = DocCodeBlock . DocString . T.unpack . T.intercalate "\n" . stripSpace <$> some line
    where
      line = try (skipHorizontalSpace *> ">" *> takeLine)
  
  stripSpace :: [Text] -> [Text]
  stripSpace = fromMaybe <*> mapM strip'
    where
      strip' t = case T.uncons t of
        Nothing -> Just ""
        Just (' ', t') -> Just t'
        _ -> Nothing
  
  -- | Parses examples. Examples are a paragraph level entity (separated by an empty line).
  -- Consecutive examples are accepted.
  examples :: Parser (DocH mod a)
  examples = DocExamples <$> (many (try (skipHorizontalSpace *> "\n")) *> go Nothing)
    where
      go :: Maybe Text -> Parser [Example]
      go mbInitialIndent = do
        prefix <- takeHorizontalSpace <* ">>>"
        initialIndent <- maybe takeHorizontalSpace pure mbInitialIndent
        expr <- takeLine
        (rs, es) <- resultAndMoreExamples (Just initialIndent)
        return (makeExample prefix initialIndent expr rs : es)
  
      resultAndMoreExamples :: Maybe Text -> Parser ([Text], [Example])
      resultAndMoreExamples mbInitialIndent = choice' [moreExamples, result, pure ([], [])]
        where
          moreExamples :: Parser ([Text], [Example])
          moreExamples = (,) [] <$> go mbInitialIndent
  
          result :: Parser ([Text], [Example])
          result = first . (:) <$> nonEmptyLine <*> resultAndMoreExamples Nothing
  
      makeExample :: Text -> Text -> Text -> [Text] -> Example
      makeExample prefix indent expression res =
        Example (T.unpack (tryStripIndent (T.stripEnd expression))) result
        where
          result = map (T.unpack . substituteBlankLine . tryStripPrefix) res
  
          tryStripPrefix xs = fromMaybe xs (T.stripPrefix prefix xs)
          tryStripIndent = liftA2 fromMaybe T.stripStart (T.stripPrefix indent)
  
          substituteBlankLine "<BLANKLINE>" = ""
          substituteBlankLine xs = xs
  
  nonEmptyLine :: Parser Text
  nonEmptyLine = try (mfilter (T.any (not . isSpace)) takeLine)
  
  takeLine :: Parser Text
  takeLine = try (takeWhile (/= '\n') <* endOfLine)
  
  endOfLine :: Parser ()
  endOfLine = void "\n" <|> Parsec.eof
  
  -- | Property parser.
  --
  -- >>> snd <$> parseOnly property "prop> hello world"
  -- Right (DocProperty "hello world")
  property :: Parser (DocH mod a)
  property = DocProperty . T.unpack . T.strip <$> ("prop>" *> takeWhile1 (/= '\n'))
  
  -- |
  -- Paragraph level codeblock. Anything between the two delimiting \@ is parsed
  -- for markup.
  codeblock :: Parser (DocH mod Identifier)
  codeblock =
    DocCodeBlock . parseParagraph . dropSpaces
      <$> ("@" *> skipHorizontalSpace *> "\n" *> block' <* "@")
    where
      dropSpaces xs =
        case splitByNl xs of
          [] -> xs
          ys -> case T.uncons (last ys) of
            Just (' ', _) -> case mapM dropSpace ys of
              Nothing -> xs
              Just zs -> T.intercalate "\n" zs
            _ -> xs
  
      -- This is necessary because ‘lines’ swallows up a trailing newline
      -- and we lose information about whether the last line belongs to @ or to
      -- text which we need to decide whether we actually want to be dropping
      -- anything at all.
      splitByNl =
        unfoldr
          ( \x -> case T.uncons x of
              Just ('\n', x') -> Just (T.span (/= '\n') x')
              _ -> Nothing
          )
          . ("\n" <>)
  
      dropSpace t = case T.uncons t of
        Nothing -> Just ""
        Just (' ', t') -> Just t'
        _ -> Nothing
  
      block' = scan p False
        where
          p isNewline c
            | isNewline && c == '@' = Nothing
            | isNewline && isSpace c = Just isNewline
            | otherwise = Just $ c == '\n'
  
  hyperlink :: Parser (DocH mod Identifier)
  hyperlink = choice' [angleBracketLink, autoUrl]
  
  angleBracketLink :: Parser (DocH mod a)
  angleBracketLink =
    DocHyperlink . makeLabeled (\s -> Hyperlink s . fmap DocString)
      <$> disallowNewline ("<" *> takeUntil ">")
  
  -- | The text for a markdown link, enclosed in square brackets.
  markdownLinkText :: Parser (DocH mod Identifier)
  markdownLinkText = parseParagraph . T.strip <$> ("[" *> takeUntil "]")
  
  -- | The target for a markdown link, enclosed in parenthesis.
  markdownLinkTarget :: Parser String
  markdownLinkTarget = whitespace *> url
    where
      whitespace :: Parser ()
      whitespace = skipHorizontalSpace <* optional ("\n" *> skipHorizontalSpace)
  
      url :: Parser String
      url = rejectWhitespace (decode <$> ("(" *> takeUntil ")"))
  
      rejectWhitespace :: MonadPlus m => m String -> m String
      rejectWhitespace = mfilter (all (not . isSpace))
  
      decode :: Text -> String
      decode = T.unpack . removeEscapes
  
  -- | Looks for URL-like things to automatically hyperlink even if they
  -- weren't marked as links.
  autoUrl :: Parser (DocH mod a)
  autoUrl = mkLink <$> url
    where
      url = mappend <$> choice' ["http://", "https://", "ftp://"] <*> takeWhile1 (not . isSpace)
  
      mkLink :: Text -> DocH mod a
      mkLink s = case T.unsnoc s of
        Just (xs, x) | x `elem` (",.!?" :: String) -> DocHyperlink (mkHyperlink xs) `docAppend` DocString [x]
        _ -> DocHyperlink (mkHyperlink s)
  
      mkHyperlink :: Text -> Hyperlink (DocH mod a)
      mkHyperlink lnk = Hyperlink (T.unpack lnk) Nothing
  
  -- | Parses identifiers with help of 'parseValid'.
  identifier :: Parser (DocH mod Identifier)
  identifier = DocIdentifier <$> parseValid
  