{-# 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 :: forall (m :: * -> *) il bl.
(Monad m, IsBlock il bl, IsInline il) =>
SyntaxSpec m il bl
fancyListSpec = SyntaxSpec m il bl
forall a. Monoid a => a
mempty
  { syntaxBlockSpecs =
     [ listItemSpec (bulletListMarker <|> fancyOrderedListMarker) ]
  }

fancyOrderedListMarker :: Monad m => BlockParser m il bl ListType
fancyOrderedListMarker :: forall (m :: * -> *) il bl. Monad m => BlockParser m il bl ListType
fancyOrderedListMarker = do
  Maybe ListType
mbListType <- BlockParser m il bl (Maybe ListType)
forall (m :: * -> *) il bl.
Monad m =>
BlockParser m il bl (Maybe ListType)
getParentListType
  -- first try to parse an item like the parent
  let pInSeries :: ParsecT [Tok] u m ListType
pInSeries = case Maybe ListType
mbListType of
                     Just (OrderedList Int
_ EnumeratorType
e DelimiterType
d) -> ParsecT [Tok] u m ListType -> ParsecT [Tok] u m ListType
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (EnumeratorType -> DelimiterType -> ParsecT [Tok] u m ListType
forall {s}.
EnumeratorType -> DelimiterType -> ParsecT [Tok] s m ListType
pMarker EnumeratorType
e DelimiterType
d)
                     Maybe ListType
_ -> ParsecT [Tok] u m ListType
forall a. ParsecT [Tok] u m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
  BlockParser m il bl ListType
forall {u}. ParsecT [Tok] u m ListType
pInSeries BlockParser m il bl ListType
-> BlockParser m il bl ListType -> BlockParser m il bl ListType
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
      do Bool
initialParen <- Bool
-> ParsecT [Tok] (BPState m il bl) m Bool
-> ParsecT [Tok] (BPState m il bl) m Bool
forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option Bool
False (ParsecT [Tok] (BPState m il bl) m Bool
 -> ParsecT [Tok] (BPState m il bl) m Bool)
-> ParsecT [Tok] (BPState m il bl) m Bool
-> ParsecT [Tok] (BPState m il bl) m Bool
forall a b. (a -> b) -> a -> b
$ Bool
True Bool
-> ParsecT [Tok] (BPState m il bl) m Tok
-> ParsecT [Tok] (BPState m il bl) m Bool
forall a b.
a
-> ParsecT [Tok] (BPState m il bl) m b
-> ParsecT [Tok] (BPState m il bl) m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> ParsecT [Tok] (BPState m il bl) m Tok
forall (m :: * -> *) s. Monad m => Char -> ParsecT [Tok] s m Tok
symbol Char
'('
         (Int
start, EnumeratorType
enumtype) <- ParsecT [Tok] (BPState m il bl) m (Int, EnumeratorType)
forall {s}. ParsecT [Tok] s m (Int, EnumeratorType)
pDecimal ParsecT [Tok] (BPState m il bl) m (Int, EnumeratorType)
-> ParsecT [Tok] (BPState m il bl) m (Int, EnumeratorType)
-> ParsecT [Tok] (BPState m il bl) m (Int, EnumeratorType)
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
                              (case Maybe ListType
mbListType of
                                 Maybe ListType
Nothing -> ParsecT [Tok] (BPState m il bl) m (Int, EnumeratorType)
forall {s}. ParsecT [Tok] s m (Int, EnumeratorType)
pLowerRomanOne ParsecT [Tok] (BPState m il bl) m (Int, EnumeratorType)
-> ParsecT [Tok] (BPState m il bl) m (Int, EnumeratorType)
-> ParsecT [Tok] (BPState m il bl) m (Int, EnumeratorType)
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ParsecT [Tok] (BPState m il bl) m (Int, EnumeratorType)
forall {s}. ParsecT [Tok] s m (Int, EnumeratorType)
pUpperRomanOne
                                 Maybe ListType
_ -> ParsecT [Tok] (BPState m il bl) m (Int, EnumeratorType)
forall a. ParsecT [Tok] (BPState m il bl) m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero) ParsecT [Tok] (BPState m il bl) m (Int, EnumeratorType)
-> ParsecT [Tok] (BPState m il bl) m (Int, EnumeratorType)
-> ParsecT [Tok] (BPState m il bl) m (Int, EnumeratorType)
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
                              ParsecT [Tok] (BPState m il bl) m (Int, EnumeratorType)
forall {s}. ParsecT [Tok] s m (Int, EnumeratorType)
pLowerAlpha ParsecT [Tok] (BPState m il bl) m (Int, EnumeratorType)
-> ParsecT [Tok] (BPState m il bl) m (Int, EnumeratorType)
-> ParsecT [Tok] (BPState m il bl) m (Int, EnumeratorType)
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ParsecT [Tok] (BPState m il bl) m (Int, EnumeratorType)
forall {s}. ParsecT [Tok] s m (Int, EnumeratorType)
pUpperAlpha ParsecT [Tok] (BPState m il bl) m (Int, EnumeratorType)
-> ParsecT [Tok] (BPState m il bl) m (Int, EnumeratorType)
-> ParsecT [Tok] (BPState m il bl) m (Int, EnumeratorType)
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
                              ParsecT [Tok] (BPState m il bl) m (Int, EnumeratorType)
forall {s}. ParsecT [Tok] s m (Int, EnumeratorType)
pLowerRoman ParsecT [Tok] (BPState m il bl) m (Int, EnumeratorType)
-> ParsecT [Tok] (BPState m il bl) m (Int, EnumeratorType)
-> ParsecT [Tok] (BPState m il bl) m (Int, EnumeratorType)
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ParsecT [Tok] (BPState m il bl) m (Int, EnumeratorType)
forall {s}. ParsecT [Tok] s m (Int, EnumeratorType)
pUpperRoman
         DelimiterType
delimtype <- if Bool
initialParen
                         then DelimiterType
TwoParens DelimiterType
-> ParsecT [Tok] (BPState m il bl) m Tok
-> ParsecT [Tok] (BPState m il bl) m DelimiterType
forall a b.
a
-> ParsecT [Tok] (BPState m il bl) m b
-> ParsecT [Tok] (BPState m il bl) m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> ParsecT [Tok] (BPState m il bl) m Tok
forall (m :: * -> *) s. Monad m => Char -> ParsecT [Tok] s m Tok
symbol Char
')'
                         else DelimiterType
Period DelimiterType
-> ParsecT [Tok] (BPState m il bl) m Tok
-> ParsecT [Tok] (BPState m il bl) m DelimiterType
forall a b.
a
-> ParsecT [Tok] (BPState m il bl) m b
-> ParsecT [Tok] (BPState m il bl) m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> ParsecT [Tok] (BPState m il bl) m Tok
forall (m :: * -> *) s. Monad m => Char -> ParsecT [Tok] s m Tok
symbol Char
'.' ParsecT [Tok] (BPState m il bl) m DelimiterType
-> ParsecT [Tok] (BPState m il bl) m DelimiterType
-> ParsecT [Tok] (BPState m il bl) m DelimiterType
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> DelimiterType
OneParen DelimiterType
-> ParsecT [Tok] (BPState m il bl) m Tok
-> ParsecT [Tok] (BPState m il bl) m DelimiterType
forall a b.
a
-> ParsecT [Tok] (BPState m il bl) m b
-> ParsecT [Tok] (BPState m il bl) m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> ParsecT [Tok] (BPState m il bl) m Tok
forall (m :: * -> *) s. Monad m => Char -> ParsecT [Tok] s m Tok
symbol Char
')'
         Bool
-> ParsecT [Tok] (BPState m il bl) m ()
-> ParsecT [Tok] (BPState m il bl) m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DelimiterType
delimtype DelimiterType -> DelimiterType -> Bool
forall a. Eq a => a -> a -> Bool
== DelimiterType
Period Bool -> Bool -> Bool
&&
              (EnumeratorType
enumtype EnumeratorType -> EnumeratorType -> Bool
forall a. Eq a => a -> a -> Bool
== EnumeratorType
UpperRoman Bool -> Bool -> Bool
|| EnumeratorType
enumtype EnumeratorType -> EnumeratorType -> Bool
forall a. Eq a => a -> a -> Bool
== EnumeratorType
UpperAlpha)) (ParsecT [Tok] (BPState m il bl) m ()
 -> ParsecT [Tok] (BPState m il bl) m ())
-> ParsecT [Tok] (BPState m il bl) m ()
-> ParsecT [Tok] (BPState m il bl) m ()
forall a b. (a -> b) -> a -> b
$ ParsecT [Tok] (BPState m il bl) m ()
forall {u}. ParsecT [Tok] u m ()
checkSpace
         ListType -> BlockParser m il bl ListType
forall a. a -> ParsecT [Tok] (BPState m il bl) m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ListType -> BlockParser m il bl ListType)
-> ListType -> BlockParser m il bl ListType
forall a b. (a -> b) -> a -> b
$! Int -> EnumeratorType -> DelimiterType -> ListType
OrderedList Int
start EnumeratorType
enumtype DelimiterType
delimtype

  where
    checkSpace :: ParsecT [Tok] u m ()
checkSpace = do
        Tok TokType
tt SourcePos
_ Text
t <- ParsecT [Tok] u m Tok -> ParsecT [Tok] u m Tok
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m a
lookAhead ParsecT [Tok] u m Tok
forall (m :: * -> *) s. Monad m => ParsecT [Tok] s m Tok
anyTok
        Bool -> ParsecT [Tok] u m ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> ParsecT [Tok] u m ()) -> Bool -> ParsecT [Tok] u m ()
forall a b. (a -> b) -> a -> b
$ case TokType
tt of
                  TokType
Spaces  -> Text -> Int
T.length Text
t Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1
                  TokType
LineEnd -> Bool
True
                  TokType
_       -> Bool
False
    pMarker :: EnumeratorType -> DelimiterType -> ParsecT [Tok] s m ListType
pMarker EnumeratorType
e DelimiterType
d = do
      Bool -> ParsecT [Tok] s m () -> ParsecT [Tok] s m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DelimiterType
d DelimiterType -> DelimiterType -> Bool
forall a. Eq a => a -> a -> Bool
== DelimiterType
TwoParens) (ParsecT [Tok] s m () -> ParsecT [Tok] s m ())
-> ParsecT [Tok] s m () -> ParsecT [Tok] s m ()
forall a b. (a -> b) -> a -> b
$ () () -> ParsecT [Tok] s m Tok -> ParsecT [Tok] s m ()
forall a b. a -> ParsecT [Tok] s m b -> ParsecT [Tok] s m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> ParsecT [Tok] s m Tok
forall (m :: * -> *) s. Monad m => Char -> ParsecT [Tok] s m Tok
symbol Char
'('
      (Int
start, EnumeratorType
enumtype) <- case EnumeratorType
e of
        EnumeratorType
Decimal -> ParsecT [Tok] s m (Int, EnumeratorType)
forall {s}. ParsecT [Tok] s m (Int, EnumeratorType)
pDecimal
        EnumeratorType
LowerRoman -> ParsecT [Tok] s m (Int, EnumeratorType)
forall {s}. ParsecT [Tok] s m (Int, EnumeratorType)
pLowerRoman
        EnumeratorType
UpperRoman -> ParsecT [Tok] s m (Int, EnumeratorType)
forall {s}. ParsecT [Tok] s m (Int, EnumeratorType)
pUpperRoman
        EnumeratorType
LowerAlpha -> ParsecT [Tok] s m (Int, EnumeratorType)
forall {s}. ParsecT [Tok] s m (Int, EnumeratorType)
pLowerAlpha
        EnumeratorType
UpperAlpha -> ParsecT [Tok] s m (Int, EnumeratorType)
forall {s}. ParsecT [Tok] s m (Int, EnumeratorType)
pUpperAlpha
      DelimiterType
delimtype <- case DelimiterType
d of
        DelimiterType
TwoParens -> DelimiterType
TwoParens DelimiterType
-> ParsecT [Tok] s m Tok -> ParsecT [Tok] s m DelimiterType
forall a b. a -> ParsecT [Tok] s m b -> ParsecT [Tok] s m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> ParsecT [Tok] s m Tok
forall (m :: * -> *) s. Monad m => Char -> ParsecT [Tok] s m Tok
symbol Char
')'
        DelimiterType
OneParen  -> DelimiterType
OneParen DelimiterType
-> ParsecT [Tok] s m Tok -> ParsecT [Tok] s m DelimiterType
forall a b. a -> ParsecT [Tok] s m b -> ParsecT [Tok] s m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> ParsecT [Tok] s m Tok
forall (m :: * -> *) s. Monad m => Char -> ParsecT [Tok] s m Tok
symbol Char
')'
        DelimiterType
Period    -> DelimiterType
Period DelimiterType
-> ParsecT [Tok] s m Tok -> ParsecT [Tok] s m DelimiterType
forall a b. a -> ParsecT [Tok] s m b -> ParsecT [Tok] s m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> ParsecT [Tok] s m Tok
forall (m :: * -> *) s. Monad m => Char -> ParsecT [Tok] s m Tok
symbol Char
'.'
      Bool -> ParsecT [Tok] s m () -> ParsecT [Tok] s m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DelimiterType
delimtype DelimiterType -> DelimiterType -> Bool
forall a. Eq a => a -> a -> Bool
== DelimiterType
Period Bool -> Bool -> Bool
&&
           (EnumeratorType
enumtype EnumeratorType -> EnumeratorType -> Bool
forall a. Eq a => a -> a -> Bool
== EnumeratorType
UpperRoman Bool -> Bool -> Bool
|| EnumeratorType
enumtype EnumeratorType -> EnumeratorType -> Bool
forall a. Eq a => a -> a -> Bool
== EnumeratorType
UpperAlpha)) (ParsecT [Tok] s m () -> ParsecT [Tok] s m ())
-> ParsecT [Tok] s m () -> ParsecT [Tok] s m ()
forall a b. (a -> b) -> a -> b
$ ParsecT [Tok] s m ()
forall {u}. ParsecT [Tok] u m ()
checkSpace
      ListType -> ParsecT [Tok] s m ListType
forall a. a -> ParsecT [Tok] s m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ListType -> ParsecT [Tok] s m ListType)
-> ListType -> ParsecT [Tok] s m ListType
forall a b. (a -> b) -> a -> b
$! Int -> EnumeratorType -> DelimiterType -> ListType
OrderedList Int
start EnumeratorType
enumtype DelimiterType
delimtype
    pDecimal :: ParsecT [Tok] s m (Int, EnumeratorType)
pDecimal = do
      Tok TokType
WordChars SourcePos
_ Text
ds <- (Text -> Bool) -> ParsecT [Tok] s m Tok
forall (m :: * -> *) s.
Monad m =>
(Text -> Bool) -> ParsecT [Tok] s m Tok
satisfyWord (\Text
t ->
                              (Char -> Bool) -> Text -> Bool
T.all Char -> Bool
isDigit Text
t Bool -> Bool -> Bool
&& Text -> Int
T.length Text
t Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
10)
      case Reader Int
forall a. Integral a => Reader a
TR.decimal Text
ds of
        Left String
e -> String -> ParsecT [Tok] s m (Int, EnumeratorType)
forall a. String -> ParsecT [Tok] s m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
e
        Right (Int
x,Text
_) -> (Int, EnumeratorType) -> ParsecT [Tok] s m (Int, EnumeratorType)
forall a. a -> ParsecT [Tok] s m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Int, EnumeratorType) -> ParsecT [Tok] s m (Int, EnumeratorType))
-> (Int, EnumeratorType) -> ParsecT [Tok] s m (Int, EnumeratorType)
forall a b. (a -> b) -> a -> b
$! (Int
x, EnumeratorType
Decimal)

    pLowerAlpha :: ParsecT [Tok] s m (Int, EnumeratorType)
pLowerAlpha = do
      Tok TokType
WordChars SourcePos
_ Text
ds <- (Text -> Bool) -> ParsecT [Tok] s m Tok
forall (m :: * -> *) s.
Monad m =>
(Text -> Bool) -> ParsecT [Tok] s m Tok
satisfyWord (\Text
t ->
                              Text -> Int
T.length Text
t Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&&
                              (Char -> Bool) -> Text -> Bool
T.all Char -> Bool
isAlpha Text
t Bool -> Bool -> Bool
&&
                              (Char -> Bool) -> Text -> Bool
T.all Char -> Bool
isLower Text
t)
      case Text -> Maybe (Char, Text)
T.uncons Text
ds of
        Maybe (Char, Text)
Nothing    -> ParsecT [Tok] s m (Int, EnumeratorType)
forall a. ParsecT [Tok] s m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
        Just (Char
c,Text
_) -> (Int, EnumeratorType) -> ParsecT [Tok] s m (Int, EnumeratorType)
forall a. a -> ParsecT [Tok] s m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Int, EnumeratorType) -> ParsecT [Tok] s m (Int, EnumeratorType))
-> (Int, EnumeratorType) -> ParsecT [Tok] s m (Int, EnumeratorType)
forall a b. (a -> b) -> a -> b
$! (Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
ord Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
ord Char
'a', EnumeratorType
LowerAlpha)

    pUpperAlpha :: ParsecT [Tok] s m (Int, EnumeratorType)
pUpperAlpha = do
      Tok TokType
WordChars SourcePos
_ Text
ds <- (Text -> Bool) -> ParsecT [Tok] s m Tok
forall (m :: * -> *) s.
Monad m =>
(Text -> Bool) -> ParsecT [Tok] s m Tok
satisfyWord (\Text
t ->
                              Text -> Int
T.length Text
t Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&&
                              (Char -> Bool) -> Text -> Bool
T.all Char -> Bool
isAlpha Text
t Bool -> Bool -> Bool
&&
                              (Char -> Bool) -> Text -> Bool
T.all Char -> Bool
isUpper Text
t)
      case Text -> Maybe (Char, Text)
T.uncons Text
ds of
        Maybe (Char, Text)
Nothing    -> ParsecT [Tok] s m (Int, EnumeratorType)
forall a. ParsecT [Tok] s m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
        Just (Char
c,Text
_) -> (Int, EnumeratorType) -> ParsecT [Tok] s m (Int, EnumeratorType)
forall a. a -> ParsecT [Tok] s m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Int, EnumeratorType) -> ParsecT [Tok] s m (Int, EnumeratorType))
-> (Int, EnumeratorType) -> ParsecT [Tok] s m (Int, EnumeratorType)
forall a b. (a -> b) -> a -> b
$! (Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
ord Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
ord Char
'A', EnumeratorType
UpperAlpha)

    pLowerRomanOne :: ParsecT [Tok] s m (Int, EnumeratorType)
pLowerRomanOne = (Int
1, EnumeratorType
LowerRoman) (Int, EnumeratorType)
-> ParsecT [Tok] s m Tok -> ParsecT [Tok] s m (Int, EnumeratorType)
forall a b. a -> ParsecT [Tok] s m b -> ParsecT [Tok] s m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (Text -> Bool) -> ParsecT [Tok] s m Tok
forall (m :: * -> *) s.
Monad m =>
(Text -> Bool) -> ParsecT [Tok] s m Tok
satisfyWord (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"i")
    pUpperRomanOne :: ParsecT [Tok] s m (Int, EnumeratorType)
pUpperRomanOne = (Int
1, EnumeratorType
UpperRoman) (Int, EnumeratorType)
-> ParsecT [Tok] s m Tok -> ParsecT [Tok] s m (Int, EnumeratorType)
forall a b. a -> ParsecT [Tok] s m b -> ParsecT [Tok] s m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (Text -> Bool) -> ParsecT [Tok] s m Tok
forall (m :: * -> *) s.
Monad m =>
(Text -> Bool) -> ParsecT [Tok] s m Tok
satisfyWord (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"I")

    pLowerRoman :: ParsecT [Tok] s m (Int, EnumeratorType)
pLowerRoman = do
      Tok TokType
WordChars SourcePos
_ Text
ds <- (Text -> Bool) -> ParsecT [Tok] s m Tok
forall (m :: * -> *) s.
Monad m =>
(Text -> Bool) -> ParsecT [Tok] s m Tok
satisfyWord (\Text
t ->
                              Text -> Int
T.length Text
t Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
10 Bool -> Bool -> Bool
&&
                              (Char -> Bool) -> Text -> Bool
T.all Char -> Bool
isLowerRoman Text
t)
      case Parsec Text () Int -> String -> Text -> Either ParseError Int
forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse (Bool -> Parsec Text () Int
forall s (m :: * -> *) st.
Stream s m Char =>
Bool -> ParsecT s st m Int
romanNumeral Bool
False) String
"" Text
ds of
        Left ParseError
_     -> ParsecT [Tok] s m (Int, EnumeratorType)
forall a. ParsecT [Tok] s m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
        Right Int
x    -> (Int, EnumeratorType) -> ParsecT [Tok] s m (Int, EnumeratorType)
forall a. a -> ParsecT [Tok] s m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Int, EnumeratorType) -> ParsecT [Tok] s m (Int, EnumeratorType))
-> (Int, EnumeratorType) -> ParsecT [Tok] s m (Int, EnumeratorType)
forall a b. (a -> b) -> a -> b
$! (Int
x, EnumeratorType
LowerRoman)

    pUpperRoman :: ParsecT [Tok] s m (Int, EnumeratorType)
pUpperRoman = do
      Tok TokType
WordChars SourcePos
_ Text
ds <- (Text -> Bool) -> ParsecT [Tok] s m Tok
forall (m :: * -> *) s.
Monad m =>
(Text -> Bool) -> ParsecT [Tok] s m Tok
satisfyWord (\Text
t ->
                              Text -> Int
T.length Text
t Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
10 Bool -> Bool -> Bool
&&
                              (Char -> Bool) -> Text -> Bool
T.all Char -> Bool
isUpperRoman Text
t)
      case Parsec Text () Int -> String -> Text -> Either ParseError Int
forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse (Bool -> Parsec Text () Int
forall s (m :: * -> *) st.
Stream s m Char =>
Bool -> ParsecT s st m Int
romanNumeral Bool
True) String
"" Text
ds of
        Left ParseError
_     -> ParsecT [Tok] s m (Int, EnumeratorType)
forall a. ParsecT [Tok] s m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
        Right Int
x    -> (Int, EnumeratorType) -> ParsecT [Tok] s m (Int, EnumeratorType)
forall a. a -> ParsecT [Tok] s m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Int, EnumeratorType) -> ParsecT [Tok] s m (Int, EnumeratorType))
-> (Int, EnumeratorType) -> ParsecT [Tok] s m (Int, EnumeratorType)
forall a b. (a -> b) -> a -> b
$! (Int
x, EnumeratorType
UpperRoman)

isLowerRoman :: Char -> Bool
isLowerRoman :: Char -> Bool
isLowerRoman Char
c = Char
c Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'i',Char
'v',Char
'x',Char
'l',Char
'c',Char
'd',Char
'm']

isUpperRoman :: Char -> Bool
isUpperRoman :: Char -> Bool
isUpperRoman Char
c = Char
c Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'I',Char
'V',Char
'X',Char
'L',Char
'C',Char
'D',Char
'M']

-- from pandoc:
romanNumeral :: Stream s m Char
             => Bool                  -- ^ Uppercase if true
             -> ParsecT s st m Int
romanNumeral :: forall s (m :: * -> *) st.
Stream s m Char =>
Bool -> ParsecT s st m Int
romanNumeral Bool
upperCase = do
    let rchar :: Char -> ParsecT s u m Char
rchar Char
uc = Char -> ParsecT s u m Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char (Char -> ParsecT s u m Char) -> Char -> ParsecT s u m Char
forall a b. (a -> b) -> a -> b
$ if Bool
upperCase then Char
uc else Char -> Char
toLower Char
uc
    let one :: ParsecT s u m Char
one         = Char -> ParsecT s u m Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
rchar Char
'I'
    let five :: ParsecT s u m Char
five        = Char -> ParsecT s u m Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
rchar Char
'V'
    let ten :: ParsecT s u m Char
ten         = Char -> ParsecT s u m Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
rchar Char
'X'
    let fifty :: ParsecT s u m Char
fifty       = Char -> ParsecT s u m Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
rchar Char
'L'
    let hundred :: ParsecT s u m Char
hundred     = Char -> ParsecT s u m Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
rchar Char
'C'
    let fivehundred :: ParsecT s u m Char
fivehundred = Char -> ParsecT s u m Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
rchar Char
'D'
    let thousand :: ParsecT s u m Char
thousand    = Char -> ParsecT s u m Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
rchar Char
'M'
    ParsecT s st m Char -> ParsecT s st m Char
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m a
lookAhead (ParsecT s st m Char -> ParsecT s st m Char)
-> ParsecT s st m Char -> ParsecT s st m Char
forall a b. (a -> b) -> a -> b
$ [ParsecT s st m Char] -> ParsecT s st m Char
forall s (m :: * -> *) t u a.
Stream s m t =>
[ParsecT s u m a] -> ParsecT s u m a
choice [ParsecT s st m Char
forall {u}. ParsecT s u m Char
one, ParsecT s st m Char
forall {u}. ParsecT s u m Char
five, ParsecT s st m Char
forall {u}. ParsecT s u m Char
ten, ParsecT s st m Char
forall {u}. ParsecT s u m Char
fifty, ParsecT s st m Char
forall {u}. ParsecT s u m Char
hundred, ParsecT s st m Char
forall {u}. ParsecT s u m Char
fivehundred, ParsecT s st m Char
forall {u}. ParsecT s u m Char
thousand]
    Int
thousands <- ((Int
1000 Int -> Int -> Int
forall a. Num a => a -> a -> a
*) (Int -> Int) -> (String -> Int) -> String -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length) (String -> Int) -> ParsecT s st m String -> ParsecT s st m Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT s st m Char -> ParsecT s st m String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many ParsecT s st m Char
forall {u}. ParsecT s u m Char
thousand
    Int
ninehundreds <- Int -> ParsecT s st m Int -> ParsecT s st m Int
forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option Int
0 (ParsecT s st m Int -> ParsecT s st m Int)
-> ParsecT s st m Int -> ParsecT s st m Int
forall a b. (a -> b) -> a -> b
$ ParsecT s st m Int -> ParsecT s st m Int
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (ParsecT s st m Int -> ParsecT s st m Int)
-> ParsecT s st m Int -> ParsecT s st m Int
forall a b. (a -> b) -> a -> b
$ ParsecT s st m Char
forall {u}. ParsecT s u m Char
hundred ParsecT s st m Char -> ParsecT s st m Char -> ParsecT s st m Char
forall a b.
ParsecT s st m a -> ParsecT s st m b -> ParsecT s st m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT s st m Char
forall {u}. ParsecT s u m Char
thousand ParsecT s st m Char -> ParsecT s st m Int -> ParsecT s st m Int
forall a b.
ParsecT s st m a -> ParsecT s st m b -> ParsecT s st m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> ParsecT s st m Int
forall a. a -> ParsecT s st m a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
900
    Int
fivehundreds <- Int -> ParsecT s st m Int -> ParsecT s st m Int
forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option Int
0 (ParsecT s st m Int -> ParsecT s st m Int)
-> ParsecT s st m Int -> ParsecT s st m Int
forall a b. (a -> b) -> a -> b
$ Int
500 Int -> ParsecT s st m Char -> ParsecT s st m Int
forall a b. a -> ParsecT s st m b -> ParsecT s st m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ParsecT s st m Char
forall {u}. ParsecT s u m Char
fivehundred
    Int
fourhundreds <- Int -> ParsecT s st m Int -> ParsecT s st m Int
forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option Int
0 (ParsecT s st m Int -> ParsecT s st m Int)
-> ParsecT s st m Int -> ParsecT s st m Int
forall a b. (a -> b) -> a -> b
$ ParsecT s st m Int -> ParsecT s st m Int
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (ParsecT s st m Int -> ParsecT s st m Int)
-> ParsecT s st m Int -> ParsecT s st m Int
forall a b. (a -> b) -> a -> b
$ ParsecT s st m Char
forall {u}. ParsecT s u m Char
hundred ParsecT s st m Char -> ParsecT s st m Char -> ParsecT s st m Char
forall a b.
ParsecT s st m a -> ParsecT s st m b -> ParsecT s st m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT s st m Char
forall {u}. ParsecT s u m Char
fivehundred ParsecT s st m Char -> ParsecT s st m Int -> ParsecT s st m Int
forall a b.
ParsecT s st m a -> ParsecT s st m b -> ParsecT s st m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> ParsecT s st m Int
forall a. a -> ParsecT s st m a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
400
    Int
hundreds <- ((Int
100 Int -> Int -> Int
forall a. Num a => a -> a -> a
*) (Int -> Int) -> (String -> Int) -> String -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length) (String -> Int) -> ParsecT s st m String -> ParsecT s st m Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT s st m Char -> ParsecT s st m String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many ParsecT s st m Char
forall {u}. ParsecT s u m Char
hundred
    Int
nineties <- Int -> ParsecT s st m Int -> ParsecT s st m Int
forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option Int
0 (ParsecT s st m Int -> ParsecT s st m Int)
-> ParsecT s st m Int -> ParsecT s st m Int
forall a b. (a -> b) -> a -> b
$ ParsecT s st m Int -> ParsecT s st m Int
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (ParsecT s st m Int -> ParsecT s st m Int)
-> ParsecT s st m Int -> ParsecT s st m Int
forall a b. (a -> b) -> a -> b
$ ParsecT s st m Char
forall {u}. ParsecT s u m Char
ten ParsecT s st m Char -> ParsecT s st m Char -> ParsecT s st m Char
forall a b.
ParsecT s st m a -> ParsecT s st m b -> ParsecT s st m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT s st m Char
forall {u}. ParsecT s u m Char
hundred ParsecT s st m Char -> ParsecT s st m Int -> ParsecT s st m Int
forall a b.
ParsecT s st m a -> ParsecT s st m b -> ParsecT s st m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> ParsecT s st m Int
forall a. a -> ParsecT s st m a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
90
    Int
fifties <- Int -> ParsecT s st m Int -> ParsecT s st m Int
forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option Int
0 (Int
50 Int -> ParsecT s st m Char -> ParsecT s st m Int
forall a b. a -> ParsecT s st m b -> ParsecT s st m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ParsecT s st m Char
forall {u}. ParsecT s u m Char
fifty)
    Int
forties <- Int -> ParsecT s st m Int -> ParsecT s st m Int
forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option Int
0 (ParsecT s st m Int -> ParsecT s st m Int)
-> ParsecT s st m Int -> ParsecT s st m Int
forall a b. (a -> b) -> a -> b
$ ParsecT s st m Int -> ParsecT s st m Int
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (ParsecT s st m Int -> ParsecT s st m Int)
-> ParsecT s st m Int -> ParsecT s st m Int
forall a b. (a -> b) -> a -> b
$ ParsecT s st m Char
forall {u}. ParsecT s u m Char
ten ParsecT s st m Char -> ParsecT s st m Char -> ParsecT s st m Char
forall a b.
ParsecT s st m a -> ParsecT s st m b -> ParsecT s st m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT s st m Char
forall {u}. ParsecT s u m Char
fifty ParsecT s st m Char -> ParsecT s st m Int -> ParsecT s st m Int
forall a b.
ParsecT s st m a -> ParsecT s st m b -> ParsecT s st m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> ParsecT s st m Int
forall a. a -> ParsecT s st m a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
40
    Int
tens <- ((Int
10 Int -> Int -> Int
forall a. Num a => a -> a -> a
*) (Int -> Int) -> (String -> Int) -> String -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length) (String -> Int) -> ParsecT s st m String -> ParsecT s st m Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT s st m Char -> ParsecT s st m String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many ParsecT s st m Char
forall {u}. ParsecT s u m Char
ten
    Int
nines <- Int -> ParsecT s st m Int -> ParsecT s st m Int
forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option Int
0 (ParsecT s st m Int -> ParsecT s st m Int)
-> ParsecT s st m Int -> ParsecT s st m Int
forall a b. (a -> b) -> a -> b
$ ParsecT s st m Int -> ParsecT s st m Int
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (ParsecT s st m Int -> ParsecT s st m Int)
-> ParsecT s st m Int -> ParsecT s st m Int
forall a b. (a -> b) -> a -> b
$ ParsecT s st m Char
forall {u}. ParsecT s u m Char
one ParsecT s st m Char -> ParsecT s st m Char -> ParsecT s st m Char
forall a b.
ParsecT s st m a -> ParsecT s st m b -> ParsecT s st m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT s st m Char
forall {u}. ParsecT s u m Char
ten ParsecT s st m Char -> ParsecT s st m Int -> ParsecT s st m Int
forall a b.
ParsecT s st m a -> ParsecT s st m b -> ParsecT s st m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> ParsecT s st m Int
forall a. a -> ParsecT s st m a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
9
    Int
fives <- Int -> ParsecT s st m Int -> ParsecT s st m Int
forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option Int
0 (Int
5 Int -> ParsecT s st m Char -> ParsecT s st m Int
forall a b. a -> ParsecT s st m b -> ParsecT s st m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ParsecT s st m Char
forall {u}. ParsecT s u m Char
five)
    Int
fours <- Int -> ParsecT s st m Int -> ParsecT s st m Int
forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option Int
0 (ParsecT s st m Int -> ParsecT s st m Int)
-> ParsecT s st m Int -> ParsecT s st m Int
forall a b. (a -> b) -> a -> b
$ ParsecT s st m Int -> ParsecT s st m Int
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (ParsecT s st m Int -> ParsecT s st m Int)
-> ParsecT s st m Int -> ParsecT s st m Int
forall a b. (a -> b) -> a -> b
$ ParsecT s st m Char
forall {u}. ParsecT s u m Char
one ParsecT s st m Char -> ParsecT s st m Char -> ParsecT s st m Char
forall a b.
ParsecT s st m a -> ParsecT s st m b -> ParsecT s st m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT s st m Char
forall {u}. ParsecT s u m Char
five ParsecT s st m Char -> ParsecT s st m Int -> ParsecT s st m Int
forall a b.
ParsecT s st m a -> ParsecT s st m b -> ParsecT s st m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> ParsecT s st m Int
forall a. a -> ParsecT s st m a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
4
    Int
ones <- String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (String -> Int) -> ParsecT s st m String -> ParsecT s st m Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT s st m Char -> ParsecT s st m String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many ParsecT s st m Char
forall {u}. ParsecT s u m Char
one
    let total :: Int
total = Int
thousands Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
ninehundreds Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
fivehundreds Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
fourhundreds Int -> Int -> Int
forall a. Num a => a -> a -> a
+
                Int
hundreds Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
nineties Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
fifties Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
forties Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
tens Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
nines Int -> Int -> Int
forall a. Num a => a -> a -> a
+
                Int
fives Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
fours Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
ones
    if Int
total Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
       then String -> ParsecT s st m Int
forall a. String -> ParsecT s st m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"not a roman numeral"
       else Int -> ParsecT s st m Int
forall a. a -> ParsecT s st m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> ParsecT s st m Int) -> Int -> ParsecT s st m Int
forall a b. (a -> b) -> a -> b
$! Int
total