{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE BangPatterns #-}
module Commonmark.TokParsers
  ( satisfyTok
  , satisfyWord
  , anyTok
  , anySymbol
  , symbol
  , whitespace
  , lineEnd
  , spaceTok
  , oneOfToks
  , noneOfToks
  , gobbleSpaces
  , gobbleUpToSpaces
  , withRaw
  , hasType
  , textIs
  , blankLine
  , restOfLine
  , isOneOfCI
  , nonindentSpaces
  , skipManyTill
  , skipWhile
  )
  where
import           Control.Monad   (mzero, void)
import           Data.Text       (Text)
import qualified Data.Text       as T
import           Text.Parsec
import           Text.Parsec.Pos (updatePosString)
import           Commonmark.Tokens

-- | Parses a single 'Tok' satisfying a predicate.
satisfyTok :: Monad m => (Tok -> Bool) -> ParsecT [Tok] s m Tok
satisfyTok :: (Tok -> Bool) -> ParsecT [Tok] s m Tok
satisfyTok Tok -> Bool
f = (Tok -> String)
-> (SourcePos -> Tok -> [Tok] -> SourcePos)
-> (Tok -> Maybe Tok)
-> ParsecT [Tok] s m Tok
forall s (m :: * -> *) t a u.
Stream s m t =>
(t -> String)
-> (SourcePos -> t -> s -> SourcePos)
-> (t -> Maybe a)
-> ParsecT s u m a
tokenPrim (Text -> String
T.unpack (Text -> String) -> (Tok -> Text) -> Tok -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tok -> Text
tokContents) SourcePos -> Tok -> [Tok] -> SourcePos
updatePos Tok -> Maybe Tok
matcher
  where matcher :: Tok -> Maybe Tok
matcher Tok
t | Tok -> Bool
f Tok
t       = Tok -> Maybe Tok
forall a. a -> Maybe a
Just Tok
t
                  | Bool
otherwise = Maybe Tok
forall a. Maybe a
Nothing
        updatePos :: SourcePos -> Tok -> [Tok] -> SourcePos
        updatePos :: SourcePos -> Tok -> [Tok] -> SourcePos
updatePos SourcePos
_spos Tok
_ (Tok TokType
_ !SourcePos
pos Text
_ : [Tok]
_) = SourcePos
pos
        updatePos !SourcePos
spos (Tok TokType
_ SourcePos
_pos !Text
t) []    =
          SourcePos -> String -> SourcePos
updatePosString SourcePos
spos (Text -> String
T.unpack Text
t)
{-# INLINE satisfyTok #-}

-- | Parses any 'Tok'.
anyTok :: Monad m => ParsecT [Tok] s m Tok
anyTok :: ParsecT [Tok] s m Tok
anyTok = (Tok -> Bool) -> ParsecT [Tok] s m Tok
forall (m :: * -> *) s.
Monad m =>
(Tok -> Bool) -> ParsecT [Tok] s m Tok
satisfyTok (Bool -> Tok -> Bool
forall a b. a -> b -> a
const Bool
True)
{-# INLINE anyTok #-}

-- | Parses any 'Symbol' 'Tok'.
anySymbol :: Monad m => ParsecT [Tok] s m Tok
anySymbol :: ParsecT [Tok] s m Tok
anySymbol = (Tok -> Bool) -> ParsecT [Tok] s m Tok
forall (m :: * -> *) s.
Monad m =>
(Tok -> Bool) -> ParsecT [Tok] s m Tok
satisfyTok (\Tok
t -> case Tok -> TokType
tokType Tok
t of
                                    Symbol Char
_ -> Bool
True
                                    TokType
_        -> Bool
False)
{-# INLINE anySymbol #-}

-- | Parses a 'Symbol' with character @c@.
symbol ::  Monad m => Char -> ParsecT [Tok] s m Tok
symbol :: Char -> ParsecT [Tok] s m Tok
symbol Char
c = (Tok -> Bool) -> ParsecT [Tok] s m Tok
forall (m :: * -> *) s.
Monad m =>
(Tok -> Bool) -> ParsecT [Tok] s m Tok
satisfyTok (TokType -> Tok -> Bool
hasType (Char -> TokType
Symbol Char
c))
{-# INLINE symbol #-}

-- | Parses a 'Tok' with one of the listed types.
oneOfToks ::  Monad m => [TokType] -> ParsecT [Tok] s m Tok
oneOfToks :: [TokType] -> ParsecT [Tok] s m Tok
oneOfToks [TokType]
toktypes = (Tok -> Bool) -> ParsecT [Tok] s m Tok
forall (m :: * -> *) s.
Monad m =>
(Tok -> Bool) -> ParsecT [Tok] s m Tok
satisfyTok ([TokType] -> Tok -> Bool
hasTypeIn [TokType]
toktypes)
{-# INLINE oneOfToks #-}

-- | Parses a 'Tok' with none of the listed types.
noneOfToks ::  Monad m => [TokType] -> ParsecT [Tok] s m Tok
noneOfToks :: [TokType] -> ParsecT [Tok] s m Tok
noneOfToks [TokType]
toktypes = (Tok -> Bool) -> ParsecT [Tok] s m Tok
forall (m :: * -> *) s.
Monad m =>
(Tok -> Bool) -> ParsecT [Tok] s m Tok
satisfyTok (Bool -> Bool
not (Bool -> Bool) -> (Tok -> Bool) -> Tok -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TokType] -> Tok -> Bool
hasTypeIn [TokType]
toktypes)
{-# INLINE noneOfToks #-}

-- | Parses one or more whitespace 'Tok's.
whitespace ::  Monad m => ParsecT [Tok] s m [Tok]
whitespace :: ParsecT [Tok] s m [Tok]
whitespace = ParsecT [Tok] s m Tok -> ParsecT [Tok] s m [Tok]
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (ParsecT [Tok] s m Tok -> ParsecT [Tok] s m [Tok])
-> ParsecT [Tok] s m Tok -> ParsecT [Tok] s m [Tok]
forall a b. (a -> b) -> a -> b
$ (Tok -> Bool) -> ParsecT [Tok] s m Tok
forall (m :: * -> *) s.
Monad m =>
(Tok -> Bool) -> ParsecT [Tok] s m Tok
satisfyTok (\Tok
t -> case Tok -> TokType
tokType Tok
t of
                                         TokType
Spaces  -> Bool
True
                                         TokType
LineEnd -> Bool
True
                                         TokType
_       -> Bool
False)
{-# INLINE whitespace #-}

-- | Parses a 'LineEnd' token.
lineEnd ::  Monad m => ParsecT [Tok] s m Tok
lineEnd :: ParsecT [Tok] s m Tok
lineEnd = (Tok -> Bool) -> ParsecT [Tok] s m Tok
forall (m :: * -> *) s.
Monad m =>
(Tok -> Bool) -> ParsecT [Tok] s m Tok
satisfyTok (TokType -> Tok -> Bool
hasType TokType
LineEnd)
{-# INLINE lineEnd #-}

-- | Parses a 'Spaces' token.
spaceTok :: Monad m => ParsecT [Tok] s m Tok
spaceTok :: ParsecT [Tok] s m Tok
spaceTok = (Tok -> Bool) -> ParsecT [Tok] s m Tok
forall (m :: * -> *) s.
Monad m =>
(Tok -> Bool) -> ParsecT [Tok] s m Tok
satisfyTok (TokType -> Tok -> Bool
hasType TokType
Spaces)
{-# INLINE spaceTok #-}

-- | Parses a 'WordChars' token matching a predicate.
satisfyWord ::  Monad m => (Text -> Bool) -> ParsecT [Tok] s m Tok
satisfyWord :: (Text -> Bool) -> ParsecT [Tok] s m Tok
satisfyWord Text -> Bool
f = (Tok -> Bool) -> ParsecT [Tok] s m Tok
forall (m :: * -> *) s.
Monad m =>
(Tok -> Bool) -> ParsecT [Tok] s m Tok
satisfyTok (\Tok
t -> TokType -> Tok -> Bool
hasType TokType
WordChars Tok
t Bool -> Bool -> Bool
&& (Text -> Bool) -> Tok -> Bool
textIs Text -> Bool
f Tok
t)
{-# INLINE satisfyWord #-}

-- | Parses exactly @n@ spaces. If tabs are encountered,
-- they are split into spaces before being consumed; so
-- a tab may be partially consumed by this parser.
gobbleSpaces :: Monad m => Int -> ParsecT [Tok] u m Int
gobbleSpaces :: Int -> ParsecT [Tok] u m Int
gobbleSpaces Int
0 = Int -> ParsecT [Tok] u m Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
0
gobbleSpaces Int
n = ParsecT [Tok] u m Int -> ParsecT [Tok] u m Int
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (ParsecT [Tok] u m Int -> ParsecT [Tok] u m Int)
-> ParsecT [Tok] u m Int -> ParsecT [Tok] u m Int
forall a b. (a -> b) -> a -> b
$ Bool -> Int -> ParsecT [Tok] u m Int
forall (m :: * -> *) u.
Monad m =>
Bool -> Int -> ParsecT [Tok] u m Int
gobble' Bool
True Int
n
{-# INLINE gobbleSpaces #-}

-- | Parses up to @n@ spaces.
gobbleUpToSpaces :: Monad m => Int -> ParsecT [Tok] u m Int
gobbleUpToSpaces :: Int -> ParsecT [Tok] u m Int
gobbleUpToSpaces Int
0 = Int -> ParsecT [Tok] u m Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
0
gobbleUpToSpaces Int
n = Bool -> Int -> ParsecT [Tok] u m Int
forall (m :: * -> *) u.
Monad m =>
Bool -> Int -> ParsecT [Tok] u m Int
gobble' Bool
False Int
n
{-# INLINE gobbleUpToSpaces #-}

gobble' :: Monad m => Bool -> Int -> ParsecT [Tok] u m Int
gobble' :: Bool -> Int -> ParsecT [Tok] u m Int
gobble' Bool
requireAll Int
numspaces
  | Int
numspaces Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1 = (do
    Tok TokType
Spaces SourcePos
pos Text
_ <- (Tok -> Bool) -> ParsecT [Tok] u m Tok
forall (m :: * -> *) s.
Monad m =>
(Tok -> Bool) -> ParsecT [Tok] s m Tok
satisfyTok (TokType -> Tok -> Bool
hasType TokType
Spaces)
    SourcePos
pos' <- ParsecT [Tok] u m SourcePos
forall (m :: * -> *) s u. Monad m => ParsecT s u m SourcePos
getPosition
    case SourcePos -> Int
sourceColumn SourcePos
pos' Int -> Int -> Int
forall a. Num a => a -> a -> a
- SourcePos -> Int
sourceColumn SourcePos
pos of
         Int
n | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
numspaces  -> (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n) (Int -> Int) -> ParsecT [Tok] u m Int -> ParsecT [Tok] u m Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Int -> ParsecT [Tok] u m Int
forall (m :: * -> *) u.
Monad m =>
Bool -> Int -> ParsecT [Tok] u m Int
gobble' Bool
requireAll (Int
numspaces Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n)
           | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
numspaces -> Int -> ParsecT [Tok] u m Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> ParsecT [Tok] u m Int) -> Int -> ParsecT [Tok] u m Int
forall a b. (a -> b) -> a -> b
$! Int
n
           | Bool
otherwise      -> do
               let newpos :: SourcePos
newpos = SourcePos -> Int -> SourcePos
incSourceColumn SourcePos
pos Int
numspaces
               let newtok :: Tok
newtok = TokType -> SourcePos -> Text -> Tok
Tok TokType
Spaces SourcePos
newpos
                      (Int -> Text -> Text
T.replicate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
numspaces) Text
" ")
               ParsecT [Tok] u m [Tok]
forall (m :: * -> *) s u. Monad m => ParsecT s u m s
getInput ParsecT [Tok] u m [Tok]
-> ([Tok] -> ParsecT [Tok] u m ()) -> ParsecT [Tok] u m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Tok] -> ParsecT [Tok] u m ()
forall (m :: * -> *) s u. Monad m => s -> ParsecT s u m ()
setInput ([Tok] -> ParsecT [Tok] u m ())
-> ([Tok] -> [Tok]) -> [Tok] -> ParsecT [Tok] u m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tok
newtokTok -> [Tok] -> [Tok]
forall a. a -> [a] -> [a]
:)
               SourcePos -> ParsecT [Tok] u m ()
forall (m :: * -> *) s u. Monad m => SourcePos -> ParsecT s u m ()
setPosition SourcePos
newpos
               Int -> ParsecT [Tok] u m Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> ParsecT [Tok] u m Int) -> Int -> ParsecT [Tok] u m Int
forall a b. (a -> b) -> a -> b
$! Int
numspaces)
    ParsecT [Tok] u m Int
-> ParsecT [Tok] u m Int -> ParsecT [Tok] u m Int
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> if Bool
requireAll
           then ParsecT [Tok] u m Int
forall (m :: * -> *) a. MonadPlus m => m a
mzero
           else Int -> ParsecT [Tok] u m Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
0
  | Bool
otherwise     = Int -> ParsecT [Tok] u m Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
0
{-# INLINE gobble' #-}

-- | Applies a parser and returns its value (if successful)
-- plus a list of the raw tokens parsed.
withRaw :: Monad m => ParsecT [Tok] s m a -> ParsecT [Tok] s m (a, [Tok])
withRaw :: ParsecT [Tok] s m a -> ParsecT [Tok] s m (a, [Tok])
withRaw ParsecT [Tok] s m a
parser = do
  [Tok]
toks <- ParsecT [Tok] s m [Tok]
forall (m :: * -> *) s u. Monad m => ParsecT s u m s
getInput
  a
res <- ParsecT [Tok] s m a
parser
  SourcePos
newpos <- ParsecT [Tok] s m SourcePos
forall (m :: * -> *) s u. Monad m => ParsecT s u m SourcePos
getPosition
  let getrawtoks :: [Tok] -> [Tok]
getrawtoks (Tok
t:[Tok]
ts)
        | Tok -> SourcePos
tokPos Tok
t SourcePos -> SourcePos -> Bool
forall a. Ord a => a -> a -> Bool
< SourcePos
newpos = Tok
t Tok -> [Tok] -> [Tok]
forall a. a -> [a] -> [a]
: [Tok] -> [Tok]
getrawtoks [Tok]
ts
      getrawtoks [Tok]
_ = []
  let rawtoks :: [Tok]
rawtoks = [Tok] -> [Tok]
getrawtoks [Tok]
toks
  (a, [Tok]) -> ParsecT [Tok] s m (a, [Tok])
forall (m :: * -> *) a. Monad m => a -> m a
return (a
res, [Tok]
rawtoks)
{-# INLINE withRaw #-}

-- | Filters tokens of a certain type.
hasType :: TokType -> Tok -> Bool
hasType :: TokType -> Tok -> Bool
hasType TokType
ty (Tok TokType
ty' SourcePos
_ Text
_) = TokType
ty TokType -> TokType -> Bool
forall a. Eq a => a -> a -> Bool
== TokType
ty'
{-# INLINE hasType #-}

hasTypeIn :: [TokType] -> Tok -> Bool
hasTypeIn :: [TokType] -> Tok -> Bool
hasTypeIn [TokType]
tys (Tok TokType
ty' SourcePos
_ Text
_) = TokType
ty' TokType -> [TokType] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TokType]
tys

-- | Filters tokens with certain contents.
textIs :: (Text -> Bool) -> Tok -> Bool
textIs :: (Text -> Bool) -> Tok -> Bool
textIs Text -> Bool
f (Tok TokType
_ SourcePos
_ Text
t) = Text -> Bool
f Text
t
{-# INLINE textIs #-}

-- | Gobble up to 3 spaces (may be part of a tab).
nonindentSpaces :: Monad m => ParsecT [Tok] u m ()
nonindentSpaces :: ParsecT [Tok] u m ()
nonindentSpaces = ParsecT [Tok] u m Int -> ParsecT [Tok] u m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT [Tok] u m Int -> ParsecT [Tok] u m ())
-> ParsecT [Tok] u m Int -> ParsecT [Tok] u m ()
forall a b. (a -> b) -> a -> b
$ Int -> ParsecT [Tok] u m Int
forall (m :: * -> *) u. Monad m => Int -> ParsecT [Tok] u m Int
gobbleUpToSpaces Int
3
{-# INLINE nonindentSpaces #-}

-- | Case-insensitive membership in a list of 'Text's.
isOneOfCI :: [Text] -> Text -> Bool
isOneOfCI :: [Text] -> Text -> Bool
isOneOfCI [Text]
ts Text
t = Text -> Text
T.toLower Text
t Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
ts
{-# INLINE isOneOfCI #-}

-- | Apply @p@ many times until @stop@ succeeds, discarding results.
skipManyTill :: ParsecT s u m a -> ParsecT s u m b -> ParsecT s u m ()
skipManyTill :: ParsecT s u m a -> ParsecT s u m b -> ParsecT s u m ()
skipManyTill ParsecT s u m a
p ParsecT s u m b
stop = ParsecT s u m ()
scan
    where scan :: ParsecT s u m ()
scan = (() () -> ParsecT s u m b -> ParsecT s u m ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ParsecT s u m b
stop) ParsecT s u m () -> ParsecT s u m () -> ParsecT s u m ()
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> (ParsecT s u m a
p ParsecT s u m a -> ParsecT s u m () -> ParsecT s u m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT s u m ()
scan)
{-# INLINE skipManyTill #-}

-- | Efficiently skip 'Tok's satisfying a certain condition.
skipWhile :: Monad m => (Tok -> Bool) -> ParsecT [Tok] u m ()
skipWhile :: (Tok -> Bool) -> ParsecT [Tok] u m ()
skipWhile Tok -> Bool
f = ParsecT [Tok] u m Tok -> ParsecT [Tok] u m ()
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m ()
skipMany ((Tok -> Bool) -> ParsecT [Tok] u m Tok
forall (m :: * -> *) s.
Monad m =>
(Tok -> Bool) -> ParsecT [Tok] s m Tok
satisfyTok Tok -> Bool
f)
{-# INLINE skipWhile #-}

-- | Parse optional spaces and an endline.
blankLine :: Monad m => ParsecT [Tok] s m ()
blankLine :: ParsecT [Tok] s m ()
blankLine = ParsecT [Tok] s m () -> ParsecT [Tok] s m ()
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (ParsecT [Tok] s m () -> ParsecT [Tok] s m ())
-> ParsecT [Tok] s m () -> ParsecT [Tok] s m ()
forall a b. (a -> b) -> a -> b
$ do
  (Tok -> Bool) -> ParsecT [Tok] s m ()
forall (m :: * -> *) u.
Monad m =>
(Tok -> Bool) -> ParsecT [Tok] u m ()
skipWhile (TokType -> Tok -> Bool
hasType TokType
Spaces)
  ParsecT [Tok] s m Tok -> ParsecT [Tok] s m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ParsecT [Tok] s m Tok
forall (m :: * -> *) s. Monad m => ParsecT [Tok] s m Tok
lineEnd
{-# INLINE blankLine #-}

-- | Efficiently parse the remaining tokens on a line,
-- including the LineEnd (if any).
restOfLine :: Monad m => ParsecT [Tok] s m [Tok]
restOfLine :: ParsecT [Tok] s m [Tok]
restOfLine = ParsecT [Tok] s m [Tok]
forall u. ParsecT [Tok] u m [Tok]
go
  where
   go :: ParsecT [Tok] u m [Tok]
go = [Tok] -> ParsecT [Tok] u m [Tok] -> ParsecT [Tok] u m [Tok]
forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option [] (ParsecT [Tok] u m [Tok] -> ParsecT [Tok] u m [Tok])
-> ParsecT [Tok] u m [Tok] -> ParsecT [Tok] u m [Tok]
forall a b. (a -> b) -> a -> b
$ do
     !Tok
tok <- ParsecT [Tok] u m Tok
forall (m :: * -> *) s. Monad m => ParsecT [Tok] s m Tok
anyTok
     case Tok -> TokType
tokType Tok
tok of
       TokType
LineEnd -> [Tok] -> ParsecT [Tok] u m [Tok]
forall (m :: * -> *) a. Monad m => a -> m a
return [Tok
tok]
       TokType
_       -> (Tok
tokTok -> [Tok] -> [Tok]
forall a. a -> [a] -> [a]
:) ([Tok] -> [Tok])
-> ParsecT [Tok] u m [Tok] -> ParsecT [Tok] u m [Tok]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT [Tok] u m [Tok]
go
{-# INLINE restOfLine #-}