@@ -2,7 +2,7 @@
22#if __GLASGOW_HASKELL__ >= 702
33{-# LANGUAGE Trustworthy #-} -- Data.ByteString.Unsafe
44#endif
5−{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples #-}
5+{-# LANGUAGE BangPatterns #-}
66
77-- |
88-- Module : Data.Attoparsec.Zepto
@@ -27,101 +27,127 @@
2727module Data.Attoparsec.Zepto
2828 (
2929 Parser
30+ , ZeptoT
3031 , parse
32+ , parseT
3133 , atEnd
3234 , string
3335 , take
3436 , takeWhile
3537 ) where
3638
37−import Data.Word (Word8)
3839import Control.Applicative
39−import Control.Monad
40−import Data.Monoid
41−import qualified Data.ByteString as B
42−import qualified Data.ByteString.Unsafe as B
40+import Control.Monad (MonadPlus(..), ap)
41+import Control.Monad.IO.Class (MonadIO(..))
4342import Data.ByteString (ByteString)
43+import Data.Functor.Identity (Identity(runIdentity))
44+import Data.Monoid (Monoid(..))
45+import Data.Word (Word8)
4446import Prelude hiding (take, takeWhile)
47+import qualified Data.ByteString as B
48+import qualified Data.ByteString.Unsafe as B
4549
4650newtype S = S {
4751 input :: ByteString
4852 }
4953
5054data Result a = Fail String
51− | OK !a
55+ | OK !a S
5256
5357-- | A simple parser.
5458--
5559-- This monad is strict in its state, and the monadic bind operator
5660-- ('>>=') evaluates each result to weak head normal form before
5761-- passing it along.
58−newtype Parser a = Parser {
59− runParser :: S -> (# Result a, S #)
62+newtype ZeptoT m a = Parser {
63+ runParser :: S -> m (Result a)
6064 }
6165
62−instance Functor Parser where
63− fmap f m = Parser $ \s -> case runParser m s of
64− (# OK a, s' #) -> (# OK (f a), s' #)
65− (# Fail err, s' #) -> (# Fail err, s' #)
66+type Parser a = ZeptoT Identity a
67+
68+instance Monad m => Functor (ZeptoT m) where
69+ fmap f m = Parser $ \s -> do
70+ result <- runParser m s
71+ case result of
72+ OK a s' -> return (OK (f a) s')
73+ Fail err -> return (Fail err)
6674 {-# INLINE fmap #-}
6775
68−instance Monad Parser where
69− return a = Parser $ \s -> (# OK a, s #)
76+instance MonadIO m => MonadIO (ZeptoT m) where
77+ liftIO act = Parser $ \s -> do
78+ result <- liftIO act
79+ return (OK result s)
80+ {-# INLINE liftIO #-}
81+
82+instance Monad m => Monad (ZeptoT m) where
83+ return a = Parser $ \s -> return (OK a s)
7084 {-# INLINE return #-}
7185
72− m >>= k = Parser $ \s -> case runParser m s of
73− (# OK a, s' #) -> runParser (k a) s'
74− (# Fail err, s' #) -> (# Fail err, s' #)
86+ m >>= k = Parser $ \s -> do
87+ result <- runParser m s
88+ case result of
89+ OK a s' -> runParser (k a) s'
90+ Fail err -> return (Fail err)
7591 {-# INLINE (>>=) #-}
7692
77− fail msg = Parser $ \s -> (# Fail msg, s #)
93+ fail msg = Parser $ \_ -> return (Fail msg)
94+ {-# INLINE fail #-}
7895
79−instance MonadPlus Parser where
96+instance Monad m => MonadPlus (ZeptoT m) where
8097 mzero = fail "mzero"
8198 {-# INLINE mzero #-}
8299
83− mplus a b = Parser $ \s ->
84− case runParser a s of
85− (# ok@(OK _), s' #) -> (# ok, s' #)
86− (# _, _ #) -> case runParser b s of
87− (# ok@(OK _), s'' #) -> (# ok, s'' #)
88− (# err, s'' #) -> (# err, s'' #)
100+ mplus a b = Parser $ \s -> do
101+ result <- runParser a s
102+ case result of
103+ ok@(OK _ _) -> return ok
104+ _ -> runParser b s
89105 {-# INLINE mplus #-}
90106
91−instance Applicative Parser where
107+instance (Monad m) => Applicative (ZeptoT m) where
92108 pure = return
93109 {-# INLINE pure #-}
94110 (<*>) = ap
95111 {-# INLINE (<*>) #-}
96112
97−gets :: (S -> a) -> Parser a
98−gets f = Parser $ \s -> (# OK (f s), s #)
113+gets :: Monad m => (S -> a) -> ZeptoT m a
114+gets f = Parser $ \s -> return (OK (f s) s)
99115{-# INLINE gets #-}
100116
101−put :: S -> Parser ()
102−put s = Parser $ \_ -> (# OK (), s #)
117+put :: Monad m => S -> ZeptoT m ()
118+put s = Parser $ \_ -> return (OK () s)
103119{-# INLINE put #-}
104120
105121-- | Run a parser.
106122parse :: Parser a -> ByteString -> Either String a
107−parse p bs = case runParser p (S bs) of
108− (# OK a, _ #) -> Right a
109− (# Fail err, _ #) -> Left err
110−
111−instance Monoid (Parser a) where
123+parse p bs = case runIdentity (runParser p (S bs)) of
124+ (OK a _) -> Right a
125+ (Fail err) -> Left err
126+{-# INLINE parse #-}
127+
128+-- | Run a parser on top of the given base monad.
129+parseT :: Monad m => ZeptoT m a -> ByteString -> m (Either String a)
130+parseT p bs = do
131+ result <- runParser p (S bs)
132+ case result of
133+ OK a _ -> return (Right a)
134+ Fail err -> return (Left err)
135+{-# INLINE parseT #-}
136+
137+instance Monad m => Monoid (ZeptoT m a) where
112138 mempty = fail "mempty"
113139 {-# INLINE mempty #-}
114140 mappend = mplus
115141 {-# INLINE mappend #-}
116142
117−instance Alternative Parser where
143+instance Monad m => Alternative (ZeptoT m) where
118144 empty = fail "empty"
119145 {-# INLINE empty #-}
120146 (<|>) = mplus
121147 {-# INLINE (<|>) #-}
122148
123149-- | Consume input while the predicate returns 'True'.
124−takeWhile :: (Word8 -> Bool) -> Parser ByteString
150+takeWhile :: Monad m => (Word8 -> Bool) -> ZeptoT m ByteString
125151takeWhile p = do
126152 (h,t) <- gets (B.span p . input)
127153 put (S t)
@@ -129,7 +155,7 @@ takeWhile p = do
129155{-# INLINE takeWhile #-}
130156
131157-- | Consume @n@ bytes of input.
132−take :: Int -> Parser ByteString
158+take :: Monad m => Int -> ZeptoT m ByteString
133159take !n = do
134160 s <- gets input
135161 if B.length s >= n
@@ -138,7 +164,7 @@ take !n = do
138164{-# INLINE take #-}
139165
140166-- | Match a string exactly.
141−string :: ByteString -> Parser ()
167+string :: Monad m => ByteString -> ZeptoT m ()
142168string s = do
143169 i <- gets input
144170 if s `B.isPrefixOf` i
@@ -147,7 +173,7 @@ string s = do
147173{-# INLINE string #-}
148174
149175-- | Indicate whether the end of the input has been reached.
150−atEnd :: Parser Bool
176+atEnd :: Monad m => ZeptoT m Bool
151177atEnd = do
152178 i <- gets input
153179 return $! B.null i