{-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__ >= 702
{-# LANGUAGE Trustworthy #-} -- Data.ByteString.Unsafe
#endif
{-# LANGUAGE BangPatterns #-}

-- |
-- Module      :  Data.Attoparsec.Zepto
-- Copyright   :  Bryan O'Sullivan 2007-2015
-- License     :  BSD3
--
-- Maintainer  :  bos@serpentine.com
-- Stability   :  experimental
-- Portability :  unknown
--
-- A tiny, highly specialized combinator parser for 'B.ByteString'
-- strings.
--
-- While the main attoparsec module generally performs well, this
-- module is particularly fast for simple non-recursive loops that
-- should not normally result in failed parses.
--
-- /Warning/: on more complex inputs involving recursion or failure,
-- parsers based on this module may be as much as /ten times slower/
-- than regular attoparsec! You should /only/ use this module when you
-- have benchmarks that prove that its use speeds your code up.
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

-- | 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 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 #-}

-- | Run a parser.
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 #-}

-- | Run a parser on top of the given base monad.
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 (<|>) #-}

-- | Consume input while the predicate returns 'True'.
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 #-}

-- | Consume @n@ bytes of input.
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 #-}

-- | Match a string exactly.
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 #-}

-- | Indicate whether the end of the input has been reached.
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 #-}