{-# 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
satisfyTok :: Monad m => (Tok -> Bool) -> ParsecT [Tok] s m Tok
satisfyTok :: forall (m :: * -> *) s.
Monad m =>
(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 #-}
anyTok :: Monad m => ParsecT [Tok] s m Tok
anyTok :: forall (m :: * -> *) s. Monad m => 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 #-}
anySymbol :: Monad m => ParsecT [Tok] s m Tok
anySymbol :: forall (m :: * -> *) s. Monad m => 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 #-}
symbol :: Monad m => Char -> ParsecT [Tok] s m Tok
symbol :: forall (m :: * -> *) s. Monad m => 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 #-}
oneOfToks :: Monad m => [TokType] -> ParsecT [Tok] s m Tok
oneOfToks :: forall (m :: * -> *) s.
Monad m =>
[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 #-}
noneOfToks :: Monad m => [TokType] -> ParsecT [Tok] s m Tok
noneOfToks :: forall (m :: * -> *) s.
Monad m =>
[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 #-}
whitespace :: Monad m => ParsecT [Tok] s m [Tok]
whitespace :: forall (m :: * -> *) s. Monad m => 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 #-}
lineEnd :: Monad m => ParsecT [Tok] s m Tok
lineEnd :: forall (m :: * -> *) s. Monad m => 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 #-}
spaceTok :: Monad m => ParsecT [Tok] s m Tok
spaceTok :: forall (m :: * -> *) s. Monad m => 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 #-}
satisfyWord :: Monad m => (Text -> Bool) -> ParsecT [Tok] s m Tok
satisfyWord :: forall (m :: * -> *) s.
Monad m =>
(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 #-}
gobbleSpaces :: Monad m => Int -> ParsecT [Tok] u m Int
gobbleSpaces :: forall (m :: * -> *) u. Monad m => Int -> ParsecT [Tok] u m Int
gobbleSpaces Int
0 = Int -> ParsecT [Tok] u m Int
forall a. a -> ParsecT [Tok] u m a
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 #-}
gobbleUpToSpaces :: Monad m => Int -> ParsecT [Tok] u m Int
gobbleUpToSpaces :: forall (m :: * -> *) u. Monad m => Int -> ParsecT [Tok] u m Int
gobbleUpToSpaces Int
0 = Int -> ParsecT [Tok] u m Int
forall a. a -> ParsecT [Tok] u m a
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' :: forall (m :: * -> *) u.
Monad m =>
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 a. a -> ParsecT [Tok] u m a
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 a b.
ParsecT [Tok] u m a
-> (a -> ParsecT [Tok] u m b) -> ParsecT [Tok] u m b
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 a. a -> ParsecT [Tok] u m a
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 a. ParsecT [Tok] u m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
else Int -> ParsecT [Tok] u m Int
forall a. a -> ParsecT [Tok] u m a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
0
| Bool
otherwise = Int -> ParsecT [Tok] u m Int
forall a. a -> ParsecT [Tok] u m a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
0
{-# INLINE gobble' #-}
withRaw :: Monad m => ParsecT [Tok] s m a -> ParsecT [Tok] s m (a, [Tok])
withRaw :: forall (m :: * -> *) s a.
Monad m =>
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 a. a -> ParsecT [Tok] s m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
res, [Tok]
rawtoks)
{-# INLINE withRaw #-}
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 a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TokType]
tys
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 #-}
nonindentSpaces :: Monad m => ParsecT [Tok] u m ()
nonindentSpaces :: forall (m :: * -> *) u. Monad m => 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 #-}
isOneOfCI :: [Text] -> Text -> Bool
isOneOfCI :: [Text] -> Text -> Bool
isOneOfCI [Text]
ts Text
t = Text -> Text
T.toLower Text
t Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
ts
{-# INLINE isOneOfCI #-}
skipManyTill :: ParsecT s u m a -> ParsecT s u m b -> ParsecT s u m ()
skipManyTill :: forall s u (m :: * -> *) a b.
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 a b. a -> ParsecT s u m b -> ParsecT s u m a
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 a b. ParsecT s u m a -> ParsecT s u m b -> ParsecT s u m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT s u m ()
scan)
{-# INLINE skipManyTill #-}
skipWhile :: Monad m => (Tok -> Bool) -> ParsecT [Tok] u m ()
skipWhile :: forall (m :: * -> *) u.
Monad m =>
(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 #-}
blankLine :: Monad m => ParsecT [Tok] s m ()
blankLine :: forall (m :: * -> *) u. Monad m => ParsecT [Tok] u 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 #-}
restOfLine :: Monad m => ParsecT [Tok] s m [Tok]
restOfLine :: forall (m :: * -> *) s. Monad m => 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 a. a -> ParsecT [Tok] u m a
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 #-}