{-# 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 = 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 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 = forall a. a -> Maybe a
Just Tok
t
| Bool
otherwise = 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 = forall (m :: * -> *) s.
Monad m =>
(Tok -> Bool) -> ParsecT [Tok] s m Tok
satisfyTok (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 = 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 = 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 = 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 = forall (m :: * -> *) s.
Monad m =>
(Tok -> Bool) -> ParsecT [Tok] s m Tok
satisfyTok (Bool -> Bool
not 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 = forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 forall a b. (a -> b) -> a -> b
$ 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 = 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 = 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 = 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 = forall (m :: * -> *) a. Monad m => a -> m a
return Int
0
gobbleSpaces Int
n = forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try forall a b. (a -> b) -> a -> b
$ 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 = forall (m :: * -> *) a. Monad m => a -> m a
return Int
0
gobbleUpToSpaces Int
n = 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 forall a. Ord a => a -> a -> Bool
>= Int
1 = (do
Tok TokType
Spaces SourcePos
pos Text
_ <- forall (m :: * -> *) s.
Monad m =>
(Tok -> Bool) -> ParsecT [Tok] s m Tok
satisfyTok (TokType -> Tok -> Bool
hasType TokType
Spaces)
SourcePos
pos' <- forall (m :: * -> *) s u. Monad m => ParsecT s u m SourcePos
getPosition
case SourcePos -> Int
sourceColumn SourcePos
pos' forall a. Num a => a -> a -> a
- SourcePos -> Int
sourceColumn SourcePos
pos of
Int
n | Int
n forall a. Ord a => a -> a -> Bool
< Int
numspaces -> (forall a. Num a => a -> a -> a
+ Int
n) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) u.
Monad m =>
Bool -> Int -> ParsecT [Tok] u m Int
gobble' Bool
requireAll (Int
numspaces forall a. Num a => a -> a -> a
- Int
n)
| Int
n forall a. Eq a => a -> a -> Bool
== Int
numspaces -> forall (m :: * -> *) a. Monad m => a -> m a
return 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 forall a. Num a => a -> a -> a
- Int
numspaces) Text
" ")
forall (m :: * -> *) s u. Monad m => ParsecT s u m s
getInput forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) s u. Monad m => s -> ParsecT s u m ()
setInput forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tok
newtokforall a. a -> [a] -> [a]
:)
forall (m :: * -> *) s u. Monad m => SourcePos -> ParsecT s u m ()
setPosition SourcePos
newpos
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! Int
numspaces)
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> if Bool
requireAll
then forall (m :: * -> *) a. MonadPlus m => m a
mzero
else forall (m :: * -> *) a. Monad m => a -> m a
return Int
0
| Bool
otherwise = 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 <- forall (m :: * -> *) s u. Monad m => ParsecT s u m s
getInput
a
res <- ParsecT [Tok] s m a
parser
SourcePos
newpos <- 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 forall a. Ord a => a -> a -> Bool
< SourcePos
newpos = Tok
t forall a. a -> [a] -> [a]
: [Tok] -> [Tok]
getrawtoks [Tok]
ts
getrawtoks [Tok]
_ = []
let rawtoks :: [Tok]
rawtoks = [Tok] -> [Tok]
getrawtoks [Tok]
toks
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 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' 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 = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ 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 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 = (() forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ParsecT s u m b
stop) 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 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 = forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m ()
skipMany (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 = forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *) u.
Monad m =>
(Tok -> Bool) -> ParsecT [Tok] u m ()
skipWhile (TokType -> Tok -> Bool
hasType TokType
Spaces)
forall (f :: * -> *) a. Functor f => f a -> f ()
void 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 = forall {u}. ParsecT [Tok] u m [Tok]
go
where
go :: ParsecT [Tok] u m [Tok]
go = forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option [] forall a b. (a -> b) -> a -> b
$ do
!Tok
tok <- forall (m :: * -> *) s. Monad m => ParsecT [Tok] s m Tok
anyTok
case Tok -> TokType
tokType Tok
tok of
TokType
LineEnd -> forall (m :: * -> *) a. Monad m => a -> m a
return [Tok
tok]
TokType
_ -> (Tok
tokforall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT [Tok] u m [Tok]
go
{-# INLINE restOfLine #-}