commit 102afaa21ff36fc38005910f63918ac3309cf6a1
parent 87d564ed328d147683c3ed92a5ecbe762c5ddad0
Author: Robert Russell <robert@rr3.xyz>
Date: Mon, 22 Dec 2025 00:16:55 -0800
Remove monad parameter
(to test perf difference)
Diffstat:
| M | src/Sparsec.hs | | | 131 | +++++++++++++++++++++++++++++++++++++------------------------------------------ |
1 file changed, 62 insertions(+), 69 deletions(-)
diff --git a/src/Sparsec.hs b/src/Sparsec.hs
@@ -60,10 +60,6 @@ module Sparsec (
import Control.Applicative
import Control.Monad hiding (fail)
-import Control.Monad.Identity (Identity (..))
-import Control.Monad.Reader (MonadReader (..))
-import Control.Monad.State (MonadState (..))
-import Control.Monad.Trans (MonadTrans (..))
import Data.ByteString (ByteString)
import Data.ByteString qualified as BS
import Data.ByteString.UTF8 qualified as UTF8
@@ -110,6 +106,7 @@ pattern State i l = StateBox (State# i l)
instance Eq State where
StateBox s0 == StateBox s1 = s0 `stateEq#` s1
+ {-# INLINE (==) #-}
--------------------------------------------------------------------------------
-- Result#
@@ -126,6 +123,7 @@ instance (Eq e, Eq a) => Eq (Result# e a) where
Error# e0 == Error# e1 = e0 == e1
Success# a0 s0 == Success# a1 s1 = a0 == a1 && s0 `stateEq#` s1
_ == _ = False
+ {-# INLINE (==) #-}
instance (Show e, Show a) => Show (Result# e a) where
show = \case
@@ -143,6 +141,7 @@ instance Functor (Result# e) where
Failure# -> Failure#
Error# e -> Error# e
Success# a s -> Success# (f a) s
+ {-# INLINE fmap #-}
--------------------------------------------------------------------------------
-- Result
@@ -156,70 +155,69 @@ instance Functor (Result# e) where
-- and Loc state effect for the input, and an error effect (of some type e) for
-- parsing errors. Parsing *errors* are distinct from parsing *failures* in
-- that only the latter trigger backtracking in the Alternative instance.
-newtype ParseT e m a = ParseT (State# -> m (Result# e a))
+newtype ParseT e a = ParseT (State# -> Result# e a)
-runParseT# :: (Monad m) => ParseT e m a -> State# -> m (Result# e a)
+runParseT# :: ParseT e a -> State# -> Result# e a
runParseT# (ParseT f) = f
{-# INLINE runParseT# #-}
-runParseT :: (Monad m) => ParseT e m a -> ByteString -> Loc -> m (Result# e a)
+runParseT :: ParseT e a -> ByteString -> Loc -> Result# e a
runParseT p i l = p `runParseT#` State# i (locUnbox l)
{-# INLINE runParseT #-}
mapParseT ::
- (Monad m, Monad m') =>
- (m (Result# e a) -> m' (Result# e' a')) ->
- ParseT e m a ->
- ParseT e' m' a'
+ (Result# e a -> Result# e' a') ->
+ ParseT e a ->
+ ParseT e' a'
mapParseT f p = ParseT \s -> f $ p `runParseT#` s
{-# INLINE mapParseT #-}
--------------------------------------------------------------------------------
-- Parse
-type Parse e a = ParseT e Identity a
+type Parse e a = ParseT e a
runParse# :: Parse e a -> State# -> Result# e a
-runParse# p s = runIdentity $ p `runParseT#` s
+runParse# = runParseT#
{-# INLINE runParse# #-}
runParse :: Parse e a -> ByteString -> Loc -> Result# e a
-runParse p i l = p `runParse#` State# i (locUnbox l)
+runParse = runParseT
{-# INLINE runParse #-}
mapParse :: (Result# e a -> Result# e' a') -> Parse e a -> Parse e' a'
-mapParse f = mapParseT (Identity . f . runIdentity)
+mapParse = mapParseT
{-# INLINE mapParse #-}
--------------------------------------------------------------------------------
-- Core combinators
-fail :: (Monad m) => ParseT e m a
-fail = ParseT \_ -> pure Failure#
+fail :: ParseT e a
+fail = ParseT \_ -> Failure#
{-# INLINE fail #-}
-err :: (Monad m) => e -> ParseT e m a
-err e = ParseT \_ -> pure $ Error# e
+err :: e -> ParseT e a
+err e = ParseT \_ -> Error# e
{-# INLINE err #-}
-succeed :: (Monad m) => a -> ParseT e m a
-succeed a = ParseT \s -> pure $ Success# a s
+succeed :: a -> ParseT e a
+succeed a = ParseT \s -> Success# a s
{-# INLINE succeed #-}
-continue :: (Monad m) => ParseT f m b -> (e -> ParseT f m b) -> (a -> ParseT f m b) -> ParseT e m a -> ParseT f m b
+continue :: ParseT f b -> (e -> ParseT f b) -> (a -> ParseT f b) -> ParseT e a -> ParseT f b
continue kf ke ks p = ParseT \s ->
- p `runParseT#` s >>= \case
- Utf8Error# l -> pure $ Utf8Error# l
+ case p `runParseT#` s of
+ Utf8Error# l -> Utf8Error# l
Failure# -> kf `runParseT#` s
Error# e -> ke e `runParseT#` s
Success# a s' -> ks a `runParseT#` s'
{-# INLINE continue #-}
-get# :: (Monad m) => (State# -> ParseT e m a) -> ParseT e m a
+get# :: (State# -> ParseT e a) -> ParseT e a
get# f = ParseT \s -> f s `runParseT#` s
{-# INLINE get# #-}
-put# :: (Monad m) => State# -> ParseT e m a -> ParseT e m a
+put# :: State# -> ParseT e a -> ParseT e a
put# s p = ParseT \_ -> p `runParseT#` s
{-# INLINE put# #-}
@@ -255,30 +253,25 @@ put# s p = ParseT \_ -> p `runParseT#` s
--------------------------------------------------------------------------------
-- Instances
-instance (Monad m) => Functor (ParseT e m) where
+instance Functor (ParseT e) where
fmap = liftM
+ {-# INLINE fmap #-}
-instance (Monad m) => Applicative (ParseT e m) where
+instance Applicative (ParseT e) where
pure = succeed
+ {-# INLINE pure #-}
(<*>) = ap
+ {-# INLINE (<*>) #-}
-instance (Monad m) => Monad (ParseT e m) where
+instance Monad (ParseT e) where
p >>= k = continue fail err k p
+ {-# INLINE (>>=) #-}
-instance (Monad m) => Alternative (ParseT e m) where
+instance Alternative (ParseT e) where
empty = fail
+ {-# INLINE empty #-}
p <|> q = continue q err succeed p
-
-instance MonadTrans (ParseT e) where
- lift m = ParseT \s -> (`Success#` s) <$> m
-
-instance (MonadReader r m) => MonadReader r (ParseT e m) where
- ask = lift ask
- local f p = ParseT \s -> local f $ p `runParseT#` s
-
-instance (MonadState s m) => MonadState s (ParseT e m) where
- get = lift get
- put = lift . put
+ {-# INLINE (<|>) #-}
--------------------------------------------------------------------------------
-- General combinators
@@ -288,37 +281,37 @@ instance (MonadState s m) => MonadState s (ParseT e m) where
-- TODO: Non-CPS variants of functions
-- | Turn a failure into a success and vice versa.
-not :: (Monad m) => ParseT e m a -> ParseT e m ()
+not :: ParseT e a -> ParseT e ()
not = continue (succeed ()) err (const fail)
{-# INLINE not #-}
-- | Convert an error into a failure.
-try :: (Monad m) => ParseT e m a -> ParseT e m a
+try :: ParseT e a -> ParseT e a
try = continue fail (const fail) succeed
{-# INLINE try #-}
-- | Convert a failure into an error.
-cut :: (Monad m) => ParseT e m a -> e -> ParseT e m a
+cut :: ParseT e a -> e -> ParseT e a
p `cut` e = continue (err e) err succeed p
{-# INLINE cut #-}
-- | Catch an error.
-catch :: (Monad m) => ParseT e m a -> (e -> ParseT f m a) -> ParseT f m a
+catch :: ParseT e a -> (e -> ParseT f a) -> ParseT f a
p `catch` h = continue fail h succeed p
{-# INLINE catch #-}
-- | `branch p ks kf` runs p; if it succeeds, it continues with ks; if it fails,
-- it continues with kf.
-branch :: (Monad m) => ParseT e m a -> (a -> ParseT e m b) -> ParseT e m b -> ParseT e m b
+branch :: ParseT e a -> (a -> ParseT e b) -> ParseT e b -> ParseT e b
branch p ks kf = continue kf err ks p
{-# INLINE branch #-}
-- | Run a parser without changing the parser state.
-lookahead :: (Monad m) => ParseT e m a -> ParseT e m a
+lookahead :: ParseT e a -> ParseT e a
lookahead p = get# \s -> p <* put# s (pure ())
{-# INLINE lookahead #-}
-withSpan :: (Monad m) => (a -> Span# -> ParseT e m b) -> ParseT e m a -> ParseT e m b
+withSpan :: (a -> Span# -> ParseT e b) -> ParseT e a -> ParseT e b
withSpan k p =
get# \(State# _ beg) ->
p >>= \a ->
@@ -326,7 +319,7 @@ withSpan k p =
k a (Span# beg end)
{-# INLINE withSpan #-}
-withConsumed :: (Monad m) => (a -> ByteString -> ParseT e m b) -> ParseT e m a -> ParseT e m b
+withConsumed :: (a -> ByteString -> ParseT e b) -> ParseT e a -> ParseT e b
withConsumed k p =
get# \(State# i (Loc# b0 _ _)) ->
p >>= \a ->
@@ -337,49 +330,49 @@ withConsumed k p =
-- | Iterate a parsing function until it fails. I.e.,
-- @iter f a = pure a >>= f >>= f >>= ...@
-- where the chain of binds is as long as possible without failure.
-iter :: (Monad m) => (a -> ParseT e m a) -> a -> ParseT e m a
+iter :: (a -> ParseT e a) -> a -> ParseT e a
iter f a = (f a >>= iter f) <|> pure a
{-# INLINE iter #-}
-- | Parse a `b` and then zero or more `a`s, and then combine in a left-nested
-- fashion.
-chainl :: (Monad m) => (b -> a -> b) -> ParseT e m b -> ParseT e m a -> ParseT e m b
+chainl :: (b -> a -> b) -> ParseT e b -> ParseT e a -> ParseT e b
chainl f pb pa = pb >>= iter \b -> f b <$> pa
{-# INLINE chainl #-}
-- | Parse zero or more `a`s (greedily) and then a `b`, and then combine in a
-- right-nested fashion.
-chainr :: (Monad m) => (a -> b -> b) -> ParseT e m a -> ParseT e m b -> ParseT e m b
+chainr :: (a -> b -> b) -> ParseT e a -> ParseT e b -> ParseT e b
chainr f pa pb = f <$> pa <*> chainr f pa pb <|> pb
{-# INLINE chainr #-}
-many_ :: (Monad m) => ParseT e m a -> ParseT e m ()
+many_ :: ParseT e a -> ParseT e ()
many_ p = some_ p <|> pure ()
{-# INLINE many_ #-}
-some_ :: (Monad m) => ParseT e m a -> ParseT e m ()
+some_ :: ParseT e a -> ParseT e ()
some_ p = p *> many_ p
{-# INLINE some_ #-}
-manySepBy :: (Monad m) => ParseT e m a -> ParseT e m b -> ParseT e m [a]
+manySepBy :: ParseT e a -> ParseT e b -> ParseT e [a]
manySepBy p sep = someSepBy p sep <|> pure []
{-# INLINE manySepBy #-}
-someSepBy :: (Monad m) => ParseT e m a -> ParseT e m b -> ParseT e m [a]
+someSepBy :: ParseT e a -> ParseT e b -> ParseT e [a]
someSepBy p sep = (:) <$> p <*> many (sep *> p)
{-# INLINE someSepBy #-}
-choose :: (Monad m, Foldable t) => t (ParseT e m a) -> ParseT e m a
+choose :: (Foldable t) => t (ParseT e a) -> ParseT e a
choose = asum
{-# INLINE choose #-}
-- | `match scrut cases` binds scrut to the first non-failing case and returns
-- the result.
match ::
- (Monad m, Functor t, Foldable t) =>
- ParseT e m a ->
- t (a -> ParseT e m b) ->
- ParseT e m b
+ (Functor t, Foldable t) =>
+ ParseT e a ->
+ t (a -> ParseT e b) ->
+ ParseT e b
match scrut cases = choose $ (scrut >>=) <$> cases
{-# INLINE match #-}
@@ -389,36 +382,36 @@ match scrut cases = choose $ (scrut >>=) <$> cases
-- TODO: Try writing custom utf8 decoder that doesn't allocate Maybes.
-- TODO: Non-CPS version of next?
-next :: (Monad m) => ParseT e m a -> (Char -> ParseT e m a) -> ParseT e m a
+next :: ParseT e a -> (Char -> ParseT e a) -> ParseT e a
next ke kc = ParseT \s@(State# i l) ->
case UTF8.decode i of
Just (c, w)
- | c == '\xFFFD' -> pure $ Utf8Error# l
+ | c == '\xFFFD' -> Utf8Error# l
| otherwise -> kc c `runParseT#` State# (BS.drop w i) (locAdvance# c w l)
Nothing -> ke `runParseT#` s
{-# INLINE next #-}
-eof :: (Monad m) => ParseT e m ()
+eof :: ParseT e ()
eof = get# \(State# i _) -> guard (BS.null i)
{-# INLINE eof #-}
-anyChar :: (Monad m) => ParseT e m Char
+anyChar :: ParseT e Char
anyChar = next fail succeed
{-# INLINE anyChar #-}
-charIf :: (Monad m) => (Char -> Bool) -> ParseT e m Char
+charIf :: (Char -> Bool) -> ParseT e Char
charIf want = next fail (\c -> guard (want c) $> c)
{-# INLINE charIf #-}
-char :: (Monad m) => Char -> ParseT e m ()
+char :: Char -> ParseT e ()
char c = void $ charIf (== c)
{-# INLINE char #-}
-string :: (Monad m) => String -> ParseT e m ()
+string :: String -> ParseT e ()
string = traverse_ char
{-# INLINE string #-}
-natural :: (Monad m) => Int -> ParseT e m Natural
+natural :: Int -> ParseT e Natural
natural = \case
0 ->
let prefix l u = char '0' *> (char l <|> char u)
