Lists.hs

{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE OverloadedStrings          #-}
{- |
Module      : Text.Pandoc.Parsing.Lists
Copyright   : © 2006-2024 John MacFarlane
License     : GPL-2.0-or-later
Maintainer  : John MacFarlane <jgm@berkeley.edu>

Parsers for list markers.
-}

module Text.Pandoc.Parsing.Lists
  ( anyOrderedListMarker
  , decimal
  , lowerAlpha
  , lowerRoman
  , orderedListMarker
  , romanNumeral
  , upperAlpha
  , upperRoman
  )
where

import Data.Char
  ( isAsciiUpper
  , isAsciiLower
  , ord
  , toLower
  )
import Data.Maybe (fromMaybe)
import Text.Pandoc.Definition
  ( ListNumberDelim(..)
  , ListAttributes
  , ListNumberStyle(..)
  )
import Text.Pandoc.Shared (safeRead)
import Text.Pandoc.Sources
import Text.Parsec
  ( (<|>)
  , ParsecT
  , Stream(..)
  , choice
  , getState
  , lookAhead
  , many
  , many1
  , option
  , try
  , updateState
  )
import Text.Pandoc.Parsing.State

import qualified Data.Map as M
import qualified Data.Text as T

-- | Parses a roman numeral (uppercase or lowercase), returns number.
romanNumeral :: (Stream s m Char, UpdateSourcePos s Char)
             => Bool                  -- ^ Uppercase if true
             -> ParsecT s st m Int
romanNumeral upperCase = do
    let rchar uc = char $ if upperCase then uc else toLower uc
    let one         = rchar 'I'
    let five        = rchar 'V'
    let ten         = rchar 'X'
    let fifty       = rchar 'L'
    let hundred     = rchar 'C'
    let fivehundred = rchar 'D'
    let thousand    = rchar 'M'
    lookAhead $ choice [one, five, ten, fifty, hundred, fivehundred, thousand]
    thousands <- (1000 *) . length <$> many thousand
    ninehundreds <- option 0 $ try $ hundred >> thousand >> return 900
    fivehundreds <- option 0 $ 500 <$ fivehundred
    fourhundreds <- option 0 $ try $ hundred >> fivehundred >> return 400
    hundreds <- (100 *) . length <$> many hundred
    nineties <- option 0 $ try $ ten >> hundred >> return 90
    fifties <- option 0 (50 <$ fifty)
    forties <- option 0 $ try $ ten >> fifty >> return 40
    tens <- (10 *) . length <$> many ten
    nines <- option 0 $ try $ one >> ten >> return 9
    fives <- option 0 (5 <$ five)
    fours <- option 0 $ try $ one >> five >> return 4
    ones <- length <$> many one
    let total = thousands + ninehundreds + fivehundreds + fourhundreds +
                hundreds + nineties + fifties + forties + tens + nines +
                fives + fours + ones
    if total == 0
       then Prelude.fail "not a roman numeral"
       else return total

-- | Parses an uppercase roman numeral and returns (UpperRoman, number).
upperRoman :: (Stream s m Char, UpdateSourcePos s Char) => ParsecT s st m (ListNumberStyle, Int)
upperRoman = do
  num <- romanNumeral True
  return (UpperRoman, num)

-- | Parses a lowercase roman numeral and returns (LowerRoman, number).
lowerRoman :: (Stream s m Char, UpdateSourcePos s Char) => ParsecT s st m (ListNumberStyle, Int)
lowerRoman = do
  num <- romanNumeral False
  return (LowerRoman, num)

-- | Parses a decimal numeral and returns (Decimal, number).
decimal :: (Stream s m Char, UpdateSourcePos s Char) => ParsecT s st m (ListNumberStyle, Int)
decimal = do
  num <- many1 digit
  return (Decimal, fromMaybe 1 $ safeRead $ T.pack 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 :: (Stream s m Char, UpdateSourcePos s Char)
           => ParsecT s ParserState m (ListNumberStyle, Int)
exampleNum = do
  char '@'
  lab <- mconcat . map T.pack <$>
                    many (many1 alphaNum <|>
                          try (do c <- char '_' <|> char '-'
                                  cs <- many1 alphaNum
                                  return (c:cs)))
  st <- getState
  case M.lookup lab (stateExamples st) of
    Nothing -> do -- new label
      let num = stateNextExample st
      let newlabels = if T.null lab
                         then stateExamples st
                         else M.insert lab num $ stateExamples st
      updateState $ \s -> s{ stateNextExample = num + 1
                           , stateExamples    = newlabels }
      return (Example, num)
    Just num -> -- reuse existing label
      return (Example, num)

-- | Parses a '#' returns (DefaultStyle, 1).
defaultNum :: (Stream s m Char, UpdateSourcePos s Char) => ParsecT s st m (ListNumberStyle, Int)
defaultNum = do
  char '#'
  return (DefaultStyle, 1)

-- | Parses a lowercase letter and returns (LowerAlpha, number).
lowerAlpha :: (Stream s m Char, UpdateSourcePos s Char) => ParsecT s st m (ListNumberStyle, Int)
lowerAlpha = do
  ch <- satisfy isAsciiLower
  return (LowerAlpha, ord ch - ord 'a' + 1)

-- | Parses an uppercase letter and returns (UpperAlpha, number).
upperAlpha :: (Stream s m Char, UpdateSourcePos s Char) => ParsecT s st m (ListNumberStyle, Int)
upperAlpha = do
  ch <- satisfy isAsciiUpper
  return (UpperAlpha, ord ch - ord 'A' + 1)

-- | Parses a roman numeral i or I
romanOne :: (Stream s m Char, UpdateSourcePos s Char) => ParsecT s st m (ListNumberStyle, Int)
romanOne = (char 'i' >> return (LowerRoman, 1)) <|>
           (char 'I' >> return (UpperRoman, 1))

-- | Parses an ordered list marker and returns list attributes.
anyOrderedListMarker :: (Stream s m Char, UpdateSourcePos s Char) => ParsecT s ParserState m 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 :: (Stream s m Char, UpdateSourcePos s Char)
         => ParsecT s st m (ListNumberStyle, Int)
         -> ParsecT s st m 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 :: (Stream s m Char, UpdateSourcePos s Char)
           => ParsecT s st m (ListNumberStyle, Int)
           -> ParsecT s st m 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 :: (Stream s m Char, UpdateSourcePos s Char)
            => ParsecT s st m (ListNumberStyle, Int)
            -> ParsecT s st m 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 :: (Stream s m Char, UpdateSourcePos s Char)
                  => ListNumberStyle
                  -> ListNumberDelim
                  -> ParsecT s ParserState m 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