@@ -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,139 @@
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 qualified Control.Monad.Fail as Fail
42+import Control.Monad.IO.Class (MonadIO(..))
4343import Data.ByteString (ByteString)
44+import Data.Functor.Identity (Identity(runIdentity))
45+import Data.Monoid as Mon (Monoid(..))
46+import Data.Semigroup (Semigroup(..))
47+import Data.Word (Word8)
4448import Prelude hiding (take, takeWhile)
49+import qualified Data.ByteString as B
50+import qualified Data.ByteString.Unsafe as B
4551
4652newtype S = S {
4753 input :: ByteString
4854 }
4955
5056data Result a = Fail String
51− | OK !a
57+ | OK !a S
5258
5359-- | A simple parser.
5460--
5561-- This monad is strict in its state, and the monadic bind operator
5662-- ('>>=') evaluates each result to weak head normal form before
5763-- passing it along.
58−newtype Parser a = Parser {
59− runParser :: S -> (# Result a, S #)
64+newtype ZeptoT m a = Parser {
65+ runParser :: S -> m (Result a)
6066 }
6167
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' #)
68+type Parser a = ZeptoT Identity a
69+
70+instance Monad m => Functor (ZeptoT m) where
71+ fmap f m = Parser $ \s -> do
72+ result <- runParser m s
73+ case result of
74+ OK a s' -> return (OK (f a) s')
75+ Fail err -> return (Fail err)
6676 {-# INLINE fmap #-}
6777
68−instance Monad Parser where
69− return a = Parser $ \s -> (# OK a, s #)
78+instance MonadIO m => MonadIO (ZeptoT m) where
79+ liftIO act = Parser $ \s -> do
80+ result <- liftIO act
81+ return (OK result s)
82+ {-# INLINE liftIO #-}
83+
84+instance Monad m => Monad (ZeptoT m) where
85+ return = pure
7086 {-# INLINE return #-}
7187
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' #)
88+ m >>= k = Parser $ \s -> do
89+ result <- runParser m s
90+ case result of
91+ OK a s' -> runParser (k a) s'
92+ Fail err -> return (Fail err)
7593 {-# INLINE (>>=) #-}
7694
77− fail msg = Parser $ \s -> (# Fail msg, s #)
95+#if !(MIN_VERSION_base(4,13,0))
96+ fail = Fail.fail
97+ {-# INLINE fail #-}
98+#endif
7899
79−instance MonadPlus Parser where
100+instance Monad m => Fail.MonadFail (ZeptoT m) where
101+ fail msg = Parser $ \_ -> return (Fail msg)
102+ {-# INLINE fail #-}
103+
104+instance Monad m => MonadPlus (ZeptoT m) where
80105 mzero = fail "mzero"
81106 {-# INLINE mzero #-}
82107
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'' #)
108+ mplus a b = Parser $ \s -> do
109+ result <- runParser a s
110+ case result of
111+ ok@(OK _ _) -> return ok
112+ _ -> runParser b s
89113 {-# INLINE mplus #-}
90114
91−instance Applicative Parser where
92− pure = return
115+instance (Monad m) => Applicative (ZeptoT m) where
116+ pure a = Parser $ \s -> return (OK a s)
93117 {-# INLINE pure #-}
94118 (<*>) = ap
95119 {-# INLINE (<*>) #-}
96120
97−gets :: (S -> a) -> Parser a
98−gets f = Parser $ \s -> (# OK (f s), s #)
121+gets :: Monad m => (S -> a) -> ZeptoT m a
122+gets f = Parser $ \s -> return (OK (f s) s)
99123{-# INLINE gets #-}
100124
101−put :: S -> Parser ()
102−put s = Parser $ \_ -> (# OK (), s #)
125+put :: Monad m => S -> ZeptoT m ()
126+put s = Parser $ \_ -> return (OK () s)
103127{-# INLINE put #-}
104128
105129-- | Run a parser.
106130parse :: 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
131+parse p bs = case runIdentity (runParser p (S bs)) of
132+ (OK a _) -> Right a
133+ (Fail err) -> Left err
134+{-# INLINE parse #-}
135+
136+-- | Run a parser on top of the given base monad.
137+parseT :: Monad m => ZeptoT m a -> ByteString -> m (Either String a)
138+parseT p bs = do
139+ result <- runParser p (S bs)
140+ case result of
141+ OK a _ -> return (Right a)
142+ Fail err -> return (Left err)
143+{-# INLINE parseT #-}
144+
145+instance Monad m => Semigroup (ZeptoT m a) where
146+ (<>) = mplus
147+ {-# INLINE (<>) #-}
148+
149+instance Monad m => Mon.Monoid (ZeptoT m a) where
112150 mempty = fail "mempty"
113151 {-# INLINE mempty #-}
114− mappend = mplus
152+ mappend = (<>)
115153 {-# INLINE mappend #-}
116154
117−instance Alternative Parser where
155+instance Monad m => Alternative (ZeptoT m) where
118156 empty = fail "empty"
119157 {-# INLINE empty #-}
120158 (<|>) = mplus
121159 {-# INLINE (<|>) #-}
122160
123161-- | Consume input while the predicate returns 'True'.
124−takeWhile :: (Word8 -> Bool) -> Parser ByteString
162+takeWhile :: Monad m => (Word8 -> Bool) -> ZeptoT m ByteString
125163takeWhile p = do
126164 (h,t) <- gets (B.span p . input)
127165 put (S t)
@@ -129,7 +167,7 @@ takeWhile p = do
129167{-# INLINE takeWhile #-}
130168
131169-- | Consume @n@ bytes of input.
132−take :: Int -> Parser ByteString
170+take :: Monad m => Int -> ZeptoT m ByteString
133171take !n = do
134172 s <- gets input
135173 if B.length s >= n
@@ -138,7 +176,7 @@ take !n = do
138176{-# INLINE take #-}
139177
140178-- | Match a string exactly.
141−string :: ByteString -> Parser ()
179+string :: Monad m => ByteString -> ZeptoT m ()
142180string s = do
143181 i <- gets input
144182 if s `B.isPrefixOf` i
@@ -147,7 +185,7 @@ string s = do
147185{-# INLINE string #-}
148186
149187-- | Indicate whether the end of the input has been reached.
150−atEnd :: Parser Bool
188+atEnd :: Monad m => ZeptoT m Bool
151189atEnd = do
152190 i <- gets input
153191 return $! B.null i