{-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__ >= 702
{-# LANGUAGE Trustworthy #-}
#endif
{-# LANGUAGE BangPatterns #-}
module Data.Attoparsec.Zepto
(
Parser
, ZeptoT
, parse
, parseT
, atEnd
, string
, take
, takeWhile
) where
import Control.Applicative
import Control.Monad (MonadPlus(..), ap)
import qualified Control.Monad.Fail as Fail
import Control.Monad.IO.Class (MonadIO(..))
import Data.ByteString (ByteString)
import Data.Functor.Identity (Identity(runIdentity))
import Data.Monoid as Mon (Monoid(..))
import Data.Semigroup (Semigroup(..))
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 {
S -> ByteString
input :: ByteString
}
data Result a = Fail String
| OK !a S
newtype ZeptoT m a = Parser {
ZeptoT m a -> S -> m (Result a)
runParser :: S -> m (Result a)
}
type Parser a = ZeptoT Identity a
instance Monad m => Functor (ZeptoT m) where
fmap :: (a -> b) -> ZeptoT m a -> ZeptoT m b
fmap a -> b
f ZeptoT m a
m = (S -> m (Result b)) -> ZeptoT m b
forall (m :: * -> *) a. (S -> m (Result a)) -> ZeptoT m a
Parser ((S -> m (Result b)) -> ZeptoT m b)
-> (S -> m (Result b)) -> ZeptoT m b
forall a b. (a -> b) -> a -> b
$ \S
s -> do
Result a
result <- ZeptoT m a -> S -> m (Result a)
forall (m :: * -> *) a. ZeptoT m a -> S -> m (Result a)
runParser ZeptoT m a
m S
s
case Result a
result of
OK a
a S
s' -> Result b -> m (Result b)
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> S -> Result b
forall a. a -> S -> Result a
OK (a -> b
f a
a) S
s')
Fail String
err -> Result b -> m (Result b)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Result b
forall a. String -> Result a
Fail String
err)
{-# INLINE fmap #-}
instance MonadIO m => MonadIO (ZeptoT m) where
liftIO :: IO a -> ZeptoT m a
liftIO IO a
act = (S -> m (Result a)) -> ZeptoT m a
forall (m :: * -> *) a. (S -> m (Result a)) -> ZeptoT m a
Parser ((S -> m (Result a)) -> ZeptoT m a)
-> (S -> m (Result a)) -> ZeptoT m a
forall a b. (a -> b) -> a -> b
$ \S
s -> do
a
result <- IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO a
act
Result a -> m (Result a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> S -> Result a
forall a. a -> S -> Result a
OK a
result S
s)
{-# INLINE liftIO #-}
instance Monad m => Monad (ZeptoT m) where
return :: a -> ZeptoT m a
return = a -> ZeptoT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
{-# INLINE return #-}
ZeptoT m a
m >>= :: ZeptoT m a -> (a -> ZeptoT m b) -> ZeptoT m b
>>= a -> ZeptoT m b
k = (S -> m (Result b)) -> ZeptoT m b
forall (m :: * -> *) a. (S -> m (Result a)) -> ZeptoT m a
Parser ((S -> m (Result b)) -> ZeptoT m b)
-> (S -> m (Result b)) -> ZeptoT m b
forall a b. (a -> b) -> a -> b
$ \S
s -> do
Result a
result <- ZeptoT m a -> S -> m (Result a)
forall (m :: * -> *) a. ZeptoT m a -> S -> m (Result a)
runParser ZeptoT m a
m S
s
case Result a
result of
OK a
a S
s' -> ZeptoT m b -> S -> m (Result b)
forall (m :: * -> *) a. ZeptoT m a -> S -> m (Result a)
runParser (a -> ZeptoT m b
k a
a) S
s'
Fail String
err -> Result b -> m (Result b)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Result b
forall a. String -> Result a
Fail String
err)
{-# INLINE (>>=) #-}
#if !(MIN_VERSION_base(4,13,0))
fail = Fail.fail
{-# INLINE fail #-}
#endif
instance Monad m => Fail.MonadFail (ZeptoT m) where
fail :: String -> ZeptoT m a
fail String
msg = (S -> m (Result a)) -> ZeptoT m a
forall (m :: * -> *) a. (S -> m (Result a)) -> ZeptoT m a
Parser ((S -> m (Result a)) -> ZeptoT m a)
-> (S -> m (Result a)) -> ZeptoT m a
forall a b. (a -> b) -> a -> b
$ \S
_ -> Result a -> m (Result a)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Result a
forall a. String -> Result a
Fail String
msg)
{-# INLINE fail #-}
instance Monad m => MonadPlus (ZeptoT m) where
mzero :: ZeptoT m a
mzero = String -> ZeptoT m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"mzero"
{-# INLINE mzero #-}
mplus :: ZeptoT m a -> ZeptoT m a -> ZeptoT m a
mplus ZeptoT m a
a ZeptoT m a
b = (S -> m (Result a)) -> ZeptoT m a
forall (m :: * -> *) a. (S -> m (Result a)) -> ZeptoT m a
Parser ((S -> m (Result a)) -> ZeptoT m a)
-> (S -> m (Result a)) -> ZeptoT m a
forall a b. (a -> b) -> a -> b
$ \S
s -> do
Result a
result <- ZeptoT m a -> S -> m (Result a)
forall (m :: * -> *) a. ZeptoT m a -> S -> m (Result a)
runParser ZeptoT m a
a S
s
case Result a
result of
ok :: Result a
ok@(OK a
_ S
_) -> Result a -> m (Result a)
forall (m :: * -> *) a. Monad m => a -> m a
return Result a
ok
Result a
_ -> ZeptoT m a -> S -> m (Result a)
forall (m :: * -> *) a. ZeptoT m a -> S -> m (Result a)
runParser ZeptoT m a
b S
s
{-# INLINE mplus #-}
instance (Monad m) => Applicative (ZeptoT m) where
pure :: a -> ZeptoT m a
pure a
a = (S -> m (Result a)) -> ZeptoT m a
forall (m :: * -> *) a. (S -> m (Result a)) -> ZeptoT m a
Parser ((S -> m (Result a)) -> ZeptoT m a)
-> (S -> m (Result a)) -> ZeptoT m a
forall a b. (a -> b) -> a -> b
$ \S
s -> Result a -> m (Result a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> S -> Result a
forall a. a -> S -> Result a
OK a
a S
s)
{-# INLINE pure #-}
<*> :: ZeptoT m (a -> b) -> ZeptoT m a -> ZeptoT m b
(<*>) = ZeptoT m (a -> b) -> ZeptoT m a -> ZeptoT m b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
{-# INLINE (<*>) #-}
gets :: Monad m => (S -> a) -> ZeptoT m a
gets :: (S -> a) -> ZeptoT m a
gets S -> a
f = (S -> m (Result a)) -> ZeptoT m a
forall (m :: * -> *) a. (S -> m (Result a)) -> ZeptoT m a
Parser ((S -> m (Result a)) -> ZeptoT m a)
-> (S -> m (Result a)) -> ZeptoT m a
forall a b. (a -> b) -> a -> b
$ \S
s -> Result a -> m (Result a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> S -> Result a
forall a. a -> S -> Result a
OK (S -> a
f S
s) S
s)
{-# INLINE gets #-}
put :: Monad m => S -> ZeptoT m ()
put :: S -> ZeptoT m ()
put S
s = (S -> m (Result ())) -> ZeptoT m ()
forall (m :: * -> *) a. (S -> m (Result a)) -> ZeptoT m a
Parser ((S -> m (Result ())) -> ZeptoT m ())
-> (S -> m (Result ())) -> ZeptoT m ()
forall a b. (a -> b) -> a -> b
$ \S
_ -> Result () -> m (Result ())
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> S -> Result ()
forall a. a -> S -> Result a
OK () S
s)
{-# INLINE put #-}
parse :: Parser a -> ByteString -> Either String a
parse :: Parser a -> ByteString -> Either String a
parse Parser a
p ByteString
bs = case Identity (Result a) -> Result a
forall a. Identity a -> a
runIdentity (Parser a -> S -> Identity (Result a)
forall (m :: * -> *) a. ZeptoT m a -> S -> m (Result a)
runParser Parser a
p (ByteString -> S
S ByteString
bs)) of
(OK a
a S
_) -> a -> Either String a
forall a b. b -> Either a b
Right a
a
(Fail String
err) -> String -> Either String a
forall a b. a -> Either a b
Left String
err
{-# INLINE parse #-}
parseT :: Monad m => ZeptoT m a -> ByteString -> m (Either String a)
parseT :: ZeptoT m a -> ByteString -> m (Either String a)
parseT ZeptoT m a
p ByteString
bs = do
Result a
result <- ZeptoT m a -> S -> m (Result a)
forall (m :: * -> *) a. ZeptoT m a -> S -> m (Result a)
runParser ZeptoT m a
p (ByteString -> S
S ByteString
bs)
case Result a
result of
OK a
a S
_ -> Either String a -> m (Either String a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Either String a
forall a b. b -> Either a b
Right a
a)
Fail String
err -> Either String a -> m (Either String a)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Either String a
forall a b. a -> Either a b
Left String
err)
{-# INLINE parseT #-}
instance Monad m => Semigroup (ZeptoT m a) where
<> :: ZeptoT m a -> ZeptoT m a -> ZeptoT m a
(<>) = ZeptoT m a -> ZeptoT m a -> ZeptoT m a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus
{-# INLINE (<>) #-}
instance Monad m => Mon.Monoid (ZeptoT m a) where
mempty :: ZeptoT m a
mempty = String -> ZeptoT m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"mempty"
{-# INLINE mempty #-}
mappend :: ZeptoT m a -> ZeptoT m a -> ZeptoT m a
mappend = ZeptoT m a -> ZeptoT m a -> ZeptoT m a
forall a. Semigroup a => a -> a -> a
(<>)
{-# INLINE mappend #-}
instance Monad m => Alternative (ZeptoT m) where
empty :: ZeptoT m a
empty = String -> ZeptoT m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"empty"
{-# INLINE empty #-}
<|> :: ZeptoT m a -> ZeptoT m a -> ZeptoT m a
(<|>) = ZeptoT m a -> ZeptoT m a -> ZeptoT m a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus
{-# INLINE (<|>) #-}
takeWhile :: Monad m => (Word8 -> Bool) -> ZeptoT m ByteString
takeWhile :: (Word8 -> Bool) -> ZeptoT m ByteString
takeWhile Word8 -> Bool
p = do
(ByteString
h,ByteString
t) <- (S -> (ByteString, ByteString))
-> ZeptoT m (ByteString, ByteString)
forall (m :: * -> *) a. Monad m => (S -> a) -> ZeptoT m a
gets ((Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
B.span Word8 -> Bool
p (ByteString -> (ByteString, ByteString))
-> (S -> ByteString) -> S -> (ByteString, ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. S -> ByteString
input)
S -> ZeptoT m ()
forall (m :: * -> *). Monad m => S -> ZeptoT m ()
put (ByteString -> S
S ByteString
t)
ByteString -> ZeptoT m ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
h
{-# INLINE takeWhile #-}
take :: Monad m => Int -> ZeptoT m ByteString
take :: Int -> ZeptoT m ByteString
take !Int
n = do
ByteString
s <- (S -> ByteString) -> ZeptoT m ByteString
forall (m :: * -> *) a. Monad m => (S -> a) -> ZeptoT m a
gets S -> ByteString
input
if ByteString -> Int
B.length ByteString
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n
then S -> ZeptoT m ()
forall (m :: * -> *). Monad m => S -> ZeptoT m ()
put (ByteString -> S
S (Int -> ByteString -> ByteString
B.unsafeDrop Int
n ByteString
s)) ZeptoT m () -> ZeptoT m ByteString -> ZeptoT m ByteString
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ByteString -> ZeptoT m ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> ByteString -> ByteString
B.unsafeTake Int
n ByteString
s)
else String -> ZeptoT m ByteString
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"insufficient input"
{-# INLINE take #-}
string :: Monad m => ByteString -> ZeptoT m ()
string :: ByteString -> ZeptoT m ()
string ByteString
s = do
ByteString
i <- (S -> ByteString) -> ZeptoT m ByteString
forall (m :: * -> *) a. Monad m => (S -> a) -> ZeptoT m a
gets S -> ByteString
input
if ByteString
s ByteString -> ByteString -> Bool
`B.isPrefixOf` ByteString
i
then S -> ZeptoT m ()
forall (m :: * -> *). Monad m => S -> ZeptoT m ()
put (ByteString -> S
S (Int -> ByteString -> ByteString
B.unsafeDrop (ByteString -> Int
B.length ByteString
s) ByteString
i)) ZeptoT m () -> ZeptoT m () -> ZeptoT m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> ZeptoT m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
else String -> ZeptoT m ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"string"
{-# INLINE string #-}
atEnd :: Monad m => ZeptoT m Bool
atEnd :: ZeptoT m Bool
atEnd = do
ByteString
i <- (S -> ByteString) -> ZeptoT m ByteString
forall (m :: * -> *) a. Monad m => (S -> a) -> ZeptoT m a
gets S -> ByteString
input
Bool -> ZeptoT m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> ZeptoT m Bool) -> Bool -> ZeptoT m Bool
forall a b. (a -> b) -> a -> b
$! ByteString -> Bool
B.null ByteString
i
{-# INLINE atEnd #-}