Permalink
Browse files

Turn the Zepto parser into a monad transformer

  • Loading branch information...
bos committed May 11, 2015
1 parent 10b2e31 commit 4f56f0d6508acfdb60b09d9f945645242211cbca
Showing with 69 additions and 41 deletions.
  1. +67 −41 Data/Attoparsec/Zepto.hs
  2. +2 −0 attoparsec.cabal
View
@@ -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
View
@@ -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

0 comments on commit 4f56f0d

Please sign in to comment.