{-# 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 f :: a -> b
f m :: 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
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
a s' :: 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 err :: 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 act :: 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
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 #-}
m :: ZeptoT m a
m >>= :: ZeptoT m a -> (a -> ZeptoT m b) -> ZeptoT m b
>>= k :: 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
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
a s' :: 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 err :: 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 msg :: 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
$ \_ -> 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 "mzero"
{-# INLINE mzero #-}
mplus :: ZeptoT m a -> ZeptoT m a -> ZeptoT m a
mplus a :: ZeptoT m a
a b :: 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
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 _ _) -> Result a -> m (Result a)
forall (m :: * -> *) a. Monad m => a -> m a
return Result a
ok
_ -> 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
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
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 f :: 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
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 = (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
$ \_ -> 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 p :: Parser a
p bs :: 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
a _) -> a -> Either String a
forall a b. b -> Either a b
Right a
a
(Fail err :: 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 p :: ZeptoT m a
p bs :: 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
a _ -> 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 err :: 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 "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 "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 p :: Word8 -> Bool
p = do
(h :: ByteString
h,t :: 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 "insufficient input"
{-# INLINE take #-}
string :: Monad m => ByteString -> ZeptoT m ()
string :: ByteString -> ZeptoT m ()
string s :: 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"
{-# 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 #-}