content: {-# LANGUAGE FlexibleInstances #-}
  {-# LANGUAGE FlexibleContexts #-}
  {-# LANGUAGE UndecidableInstances #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  
  
  module Commonmark.Extensions.FancyList
    ( fancyListSpec
    )
  where
  import Commonmark.Types
  import Commonmark.Tokens
  import Commonmark.Syntax
  import Commonmark.TokParsers
  import Commonmark.Blocks
  import qualified Data.Text as T
  import Control.Monad (mzero, guard, when)
  import Text.Parsec
  import qualified Data.Text.Read as TR
  import Data.Char (isAlpha, isDigit, isLower, isUpper, ord, toLower)
  
  fancyListSpec :: (Monad m, IsBlock il bl, IsInline il)
                 => SyntaxSpec m il bl
  fancyListSpec = mempty
    { syntaxBlockSpecs =
       [ listItemSpec (bulletListMarker <|> fancyOrderedListMarker) ]
    }
  
  fancyOrderedListMarker :: Monad m => BlockParser m il bl ListType
  fancyOrderedListMarker = do
    mbListType <- getParentListType
    -- first try to parse an item like the parent
    let pInSeries = case mbListType of
                       Just (OrderedList _ e d) -> try (pMarker e d)
                       _ -> mzero
    pInSeries <|>
        do initialParen <- option False $ True <$ symbol '('
           (start, enumtype) <- pDecimal <|>
                                (case mbListType of
                                   Nothing -> pLowerRomanOne <|> pUpperRomanOne
                                   _ -> mzero) <|>
                                pLowerAlpha <|> pUpperAlpha <|>
                                pLowerRoman <|> pUpperRoman
           delimtype <- if initialParen
                           then TwoParens <$ symbol ')'
                           else Period <$ symbol '.' <|> OneParen <$ symbol ')'
           when (delimtype == Period &&
                (enumtype == UpperRoman || enumtype == UpperAlpha)) $ checkSpace
           return $! OrderedList start enumtype delimtype
  
    where
      checkSpace = do
          Tok tt _ t <- lookAhead anyTok
          guard $ case tt of
                    Spaces  -> T.length t > 1
                    LineEnd -> True
                    _       -> False
      pMarker e d = do
        when (d == TwoParens) $ () <$ symbol '('
        (start, enumtype) <- case e of
          Decimal -> pDecimal
          LowerRoman -> pLowerRoman
          UpperRoman -> pUpperRoman
          LowerAlpha -> pLowerAlpha
          UpperAlpha -> pUpperAlpha
        delimtype <- case d of
          TwoParens -> TwoParens <$ symbol ')'
          OneParen  -> OneParen <$ symbol ')'
          Period    -> Period <$ symbol '.'
        when (delimtype == Period &&
             (enumtype == UpperRoman || enumtype == UpperAlpha)) $ checkSpace
        return $! OrderedList start enumtype delimtype
      pDecimal = do
        Tok WordChars _ ds <- satisfyWord (\t ->
                                T.all isDigit t && T.length t < 10)
        case TR.decimal ds of
          Left e -> fail e
          Right (x,_) -> return $! (x, Decimal)
  
      pLowerAlpha = do
        Tok WordChars _ ds <- satisfyWord (\t ->
                                T.length t == 1 &&
                                T.all isAlpha t &&
                                T.all isLower t)
        case T.uncons ds of
          Nothing    -> mzero
          Just (c,_) -> return $! (1 + ord c - ord 'a', LowerAlpha)
  
      pUpperAlpha = do
        Tok WordChars _ ds <- satisfyWord (\t ->
                                T.length t == 1 &&
                                T.all isAlpha t &&
                                T.all isUpper t)
        case T.uncons ds of
          Nothing    -> mzero
          Just (c,_) -> return $! (1 + ord c - ord 'A', UpperAlpha)
  
      pLowerRomanOne = (1, LowerRoman) <$ satisfyWord (== "i")
      pUpperRomanOne = (1, UpperRoman) <$ satisfyWord (== "I")
  
      pLowerRoman = do
        Tok WordChars _ ds <- satisfyWord (\t ->
                                T.length t < 10 &&
                                T.all isLowerRoman t)
        case parse (romanNumeral False) "" ds of
          Left _     -> mzero
          Right x    -> return $! (x, LowerRoman)
  
      pUpperRoman = do
        Tok WordChars _ ds <- satisfyWord (\t ->
                                T.length t < 10 &&
                                T.all isUpperRoman t)
        case parse (romanNumeral True) "" ds of
          Left _     -> mzero
          Right x    -> return $! (x, UpperRoman)
  
  isLowerRoman :: Char -> Bool
  isLowerRoman c = c `elem` ['i','v','x','l','c','d','m']
  
  isUpperRoman :: Char -> Bool
  isUpperRoman c = c `elem` ['I','V','X','L','C','D','M']
  
  -- from pandoc:
  romanNumeral :: Stream s m 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 fail "not a roman numeral"
         else return $! total
  