Turn the Zepto parser into a monad transformer

Data/Attoparsec/Zepto.hs

@@ -2,7 +2,7 @@
 #if __GLASGOW_HASKELL__ >= 702
 {-# LANGUAGE Trustworthy #-} -- Data.ByteString.Unsafe
 #endif
-{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples #-}
+{-# LANGUAGE BangPatterns #-}
 
 -- |
 -- Module      :  Data.Attoparsec.Zepto
@@ -27,109 +27,135 @@
 module Data.Attoparsec.Zepto
     (
       Parser
+    , ZeptoT
     , parse
+    , parseT
     , atEnd
     , string
     , take
     , takeWhile
     ) where
 
-import Data.Word (Word8)
 import Control.Applicative
-import Control.Monad
-import Data.Monoid
-import qualified Data.ByteString as B
-import qualified Data.ByteString.Unsafe as B
+import Control.Monad (MonadPlus(..), ap)
+import Control.Monad.IO.Class (MonadIO(..))
 import Data.ByteString (ByteString)
+import Data.Functor.Identity (Identity(runIdentity))
+import Data.Monoid (Monoid(..))
+import Data.Word (Word8)
 import Prelude hiding (take, takeWhile)
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Unsafe as B
 
 newtype S = S {
       input :: ByteString
     }
 
 data Result a = Fail String
-              | OK !a
+              | OK !a S
 
 -- | A simple parser.
 --
 -- This monad is strict in its state, and the monadic bind operator
 -- ('>>=') evaluates each result to weak head normal form before
 -- passing it along.
-newtype Parser a = Parser {
-      runParser :: S -> (# Result a, S #)
+newtype ZeptoT m a = Parser {
+      runParser :: S -> m (Result a)
     }
 
-instance Functor Parser where
-    fmap f m = Parser $ \s -> case runParser m s of
-                                (# OK a, s' #)     -> (# OK (f a), s' #)
-                                (# Fail err, s' #) -> (# Fail err, s' #)
+type Parser a = ZeptoT Identity a
+
+instance Monad m => Functor (ZeptoT m) where
+    fmap f m = Parser $ \s -> do
+      result <- runParser m s
+      case result of
+        OK a s'  -> return (OK (f a) s')
+        Fail err -> return (Fail err)
     {-# INLINE fmap #-}
 
-instance Monad Parser where
-    return a = Parser $ \s -> (# OK a, s #)
+instance MonadIO m => MonadIO (ZeptoT m) where
+  liftIO act = Parser $ \s -> do
+    result <- liftIO act
+    return (OK result s)
+  {-# INLINE liftIO #-}
+
+instance Monad m => Monad (ZeptoT m) where
+    return a = Parser $ \s -> return (OK a s)
     {-# INLINE return #-}
 
-    m >>= k   = Parser $ \s -> case runParser m s of
-                                 (# OK a, s' #) -> runParser (k a) s'
-                                 (# Fail err, s' #) -> (# Fail err, s' #)
+    m >>= k   = Parser $ \s -> do
+      result <- runParser m s
+      case result of
+        OK a s'  -> runParser (k a) s'
+        Fail err -> return (Fail err)
     {-# INLINE (>>=) #-}
 
-    fail msg = Parser $ \s -> (# Fail msg, s #)
+    fail msg = Parser $ \_ -> return (Fail msg)
+    {-# INLINE fail #-}
 
-instance MonadPlus Parser where
+instance Monad m => MonadPlus (ZeptoT m) where
     mzero = fail "mzero"
     {-# INLINE mzero #-}
 
-    mplus a b = Parser $ \s ->
-                case runParser a s of
-                  (# ok@(OK _), s' #) -> (# ok, s' #)
-                  (# _, _ #) -> case runParser b s of
-                                   (# ok@(OK _), s'' #) -> (# ok, s'' #)
-                                   (# err, s'' #) -> (# err, s'' #)
+    mplus a b = Parser $ \s -> do
+      result <- runParser a s
+      case result of
+        ok@(OK _ _) -> return ok
+        _           -> runParser b s
     {-# INLINE mplus #-}
 
-instance Applicative Parser where
+instance (Monad m) => Applicative (ZeptoT m) where
     pure   = return
     {-# INLINE pure #-}
     (<*>)  = ap
     {-# INLINE (<*>) #-}
 
-gets :: (S -> a) -> Parser a
-gets f = Parser $ \s -> (# OK (f s), s #)
+gets :: Monad m => (S -> a) -> ZeptoT m a
+gets f = Parser $ \s -> return (OK (f s) s)
 {-# INLINE gets #-}
 
-put :: S -> Parser ()
-put s = Parser $ \_ -> (# OK (), s #)
+put :: Monad m => S -> ZeptoT m ()
+put s = Parser $ \_ -> return (OK () s)
 {-# INLINE put #-}
 
 -- | Run a parser.
 parse :: Parser a -> ByteString -> Either String a
-parse p bs = case runParser p (S bs) of
-               (# OK a, _ #) -> Right a
-               (# Fail err, _ #) -> Left err
-
-instance Monoid (Parser a) where
+parse p bs = case runIdentity (runParser p (S bs)) of
+               (OK a _)   -> Right a
+               (Fail err) -> Left err
+{-# INLINE parse #-}
+
+-- | Run a parser on top of the given base monad.
+parseT :: Monad m => ZeptoT m a -> ByteString -> m (Either String a)
+parseT p bs = do
+  result <- runParser p (S bs)
+  case result of
+    OK a _   -> return (Right a)
+    Fail err -> return (Left err)
+{-# INLINE parseT #-}
+
+instance Monad m => Monoid (ZeptoT m a) where
     mempty  = fail "mempty"
     {-# INLINE mempty #-}
     mappend = mplus
     {-# INLINE mappend #-}
 
-instance Alternative Parser where
+instance Monad m => Alternative (ZeptoT m) where
     empty = fail "empty"
     {-# INLINE empty #-}
     (<|>) = mplus
     {-# INLINE (<|>) #-}
 
 -- | Consume input while the predicate returns 'True'.
-takeWhile :: (Word8 -> Bool) -> Parser ByteString
+takeWhile :: Monad m => (Word8 -> Bool) -> ZeptoT m ByteString
 takeWhile p = do
   (h,t) <- gets (B.span p . input)
   put (S t)
   return h
 {-# INLINE takeWhile #-}
 
 -- | Consume @n@ bytes of input.
-take :: Int -> Parser ByteString
+take :: Monad m => Int -> ZeptoT m ByteString
 take !n = do
   s <- gets input
   if B.length s >= n
@@ -138,7 +164,7 @@ take !n = do
 {-# INLINE take #-}
 
 -- | Match a string exactly.
-string :: ByteString -> Parser ()
+string :: Monad m => ByteString -> ZeptoT m ()
 string s = do
   i <- gets input
   if s `B.isPrefixOf` i
@@ -147,7 +173,7 @@ string s = do
 {-# INLINE string #-}
 
 -- | Indicate whether the end of the input has been reached.
-atEnd :: Parser Bool
+atEnd :: Monad m => ZeptoT m Bool
 atEnd = do
   i <- gets input
   return $! B.null i

attoparsec.cabal

@@ -43,6 +43,7 @@ library
                  containers,
                  deepseq,
                  scientific >= 0.3.1 && < 0.4,
+                 transformers,
                  text >= 1.1.1.3
   if impl(ghc < 7.4)
     build-depends:
@@ -106,6 +107,7 @@ test-suite tests
     test-framework >= 0.8.0.2,
     test-framework-quickcheck2 >= 0.3.0.3,
     text,
+    transformers,
     vector
 
 benchmark benchmarks