sparsec

commit 013c84c5eda42a2b3a499c14e091a08328eb70ce
parent fb428a5eb17abcba1337ee246fee8bd40e1d1d1e
Author: Robert Russell <robert@rr3.xyz>
Date:   Thu, 25 Dec 2025 17:37:28 -0800

Try specializing type class methods

Diffstat:
M
src/Sparsec.hs
 | 
28
+++++++++++++++++++++++++---

1 file changed, 25 insertions(+), 3 deletions(-)
diff --git a/src/Sparsec.hs b/src/Sparsec.hs
@@ -268,29 +268,50 @@ put# s p = ParseT \_ -> p `runParseT#` s
 -- Instances
 
 instance Functor (ParseT e) where
-    fmap = liftM
+    fmap f p = continue fail err (succeed . f) p
     {-# INLINE fmap #-}
+    a <$ p = continue fail err (const $ succeed a) p
+    {-# INLINE (<$) #-}
 
 instance Applicative (ParseT e) where
     pure = succeed
     {-# INLINE pure #-}
-    (<*>) = ap
+    p <*> q = continue fail err (<$> q) p
     {-# INLINE (<*>) #-}
+    p *> q = continue fail err (const q) p
+    {-# INLINE (*>) #-}
+    p <* q = continue fail err (<$ q) p
+    {-# INLINE (<*) #-}
 
 instance Monad (ParseT e) where
+    return = pure
+    {-# INLINE return #-}
     p >>= k = continue fail err k p
     {-# INLINE (>>=) #-}
+    (>>) = (*>)
+    {-# INLINE (>>) #-}
 
 instance Alternative (ParseT e) where
     empty = fail
     {-# INLINE empty #-}
     p <|> q = continue q err succeed p
     {-# INLINE (<|>) #-}
+    many p = ParseT go
+      where
+        go s = case p `runParseT#` s of
+            Utf8Error# l -> Utf8Error# l
+            Failure# -> Success# [] s
+            Error# e -> Error# e
+            Success# a s' -> case go s' of
+                Success# as s'' -> Success# (a:as) s''
+                x -> x
+    {-# INLINE many #-}
+    some p = (:) <$> p <*> many p
+    {-# INLINE some #-}
 
 --------------------------------------------------------------------------------
 -- General combinators
 
--- TODO: some_, many_
 -- TODO: Boxed variants of functions
 -- TODO: Non-CPS variants of functions
 
@@ -409,6 +430,7 @@ next ke kc = ParseT \s@(State# i l) ->
         Just (c, w)
             | c == '\xFFFD' -> Utf8Error# l
             | otherwise ->
+                -- TODO: This strictness annotation apparently does nothing.
                 let !i' = BS.drop w i
                 in kc c `runParseT#` State# i' (locAdvance# c w l)
         Nothing -> ke `runParseT#` s