{-# 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  :  [email protected]
-- 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 {
      forall (m :: * -> *) a. 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 :: forall a b. (a -> b) -> ZeptoT m a -> ZeptoT m b
fmap a -> b
f ZeptoT m a
m = forall (m :: * -> *) a. (S -> m (Result a)) -> ZeptoT m a
Parser forall a b. (a -> b) -> a -> b
$ \S
s -> do
      Result a
result <- 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'  -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> S -> Result a
OK (a -> b
f a
a) S
s')
        Fail String
err -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. String -> Result a
Fail String
err)
    {-# INLINE fmap #-}

instance MonadIO m => MonadIO (ZeptoT m) where
  liftIO :: forall a. IO a -> ZeptoT m a
liftIO IO a
act = forall (m :: * -> *) a. (S -> m (Result a)) -> ZeptoT m a
Parser forall a b. (a -> b) -> a -> b
$ \S
s -> do
    a
result <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO a
act
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> S -> Result a
OK a
result S
s)
  {-# INLINE liftIO #-}

instance Monad m => Monad (ZeptoT m) where
    return :: forall a. a -> ZeptoT m a
return = forall (f :: * -> *) a. Applicative f => a -> f a
pure
    {-# INLINE return #-}

    ZeptoT m a
m >>= :: forall a b. ZeptoT m a -> (a -> ZeptoT m b) -> ZeptoT m b
>>= a -> ZeptoT m b
k   = forall (m :: * -> *) a. (S -> m (Result a)) -> ZeptoT m a
Parser forall a b. (a -> b) -> a -> b
$ \S
s -> do
      Result a
result <- 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'  -> forall (m :: * -> *) a. ZeptoT m a -> S -> m (Result a)
runParser (a -> ZeptoT m b
k a
a) S
s'
        Fail String
err -> forall (m :: * -> *) a. Monad m => a -> m a
return (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 :: forall a. String -> ZeptoT m a
fail String
msg = forall (m :: * -> *) a. (S -> m (Result a)) -> ZeptoT m a
Parser forall a b. (a -> b) -> a -> b
$ \S
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. String -> Result a
Fail String
msg)
    {-# INLINE fail #-}

instance Monad m => MonadPlus (ZeptoT m) where
    mzero :: forall a. ZeptoT m a
mzero = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"mzero"
    {-# INLINE mzero #-}

    mplus :: forall a. ZeptoT m a -> ZeptoT m a -> ZeptoT m a
mplus ZeptoT m a
a ZeptoT m a
b = forall (m :: * -> *) a. (S -> m (Result a)) -> ZeptoT m a
Parser forall a b. (a -> b) -> a -> b
$ \S
s -> do
      Result a
result <- 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
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return Result a
ok
        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 :: forall a. a -> ZeptoT m a
pure a
a = forall (m :: * -> *) a. (S -> m (Result a)) -> ZeptoT m a
Parser forall a b. (a -> b) -> a -> b
$ \S
s -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> S -> Result a
OK a
a S
s)
    {-# INLINE pure #-}
    <*> :: forall a 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 :: forall (m :: * -> *) a. Monad m => (S -> a) -> ZeptoT m a
gets S -> a
f = forall (m :: * -> *) a. (S -> m (Result a)) -> ZeptoT m a
Parser forall a b. (a -> b) -> a -> b
$ \S
s -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> S -> Result a
OK (S -> a
f S
s) S
s)
{-# INLINE gets #-}

put :: Monad m => S -> ZeptoT m ()
put :: forall (m :: * -> *). Monad m => S -> ZeptoT m ()
put S
s = forall (m :: * -> *) a. (S -> m (Result a)) -> ZeptoT m a
Parser forall a b. (a -> b) -> a -> b
$ \S
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> S -> Result a
OK () S
s)
{-# INLINE put #-}

-- | Run a parser.
parse :: Parser a -> ByteString -> Either String a
parse :: forall a. Parser a -> ByteString -> Either String a
parse Parser a
p ByteString
bs = case forall a. Identity a -> a
runIdentity (forall (m :: * -> *) a. ZeptoT m a -> S -> m (Result a)
runParser Parser a
p (ByteString -> S
S ByteString
bs)) of
               (OK a
a S
_)   -> forall a b. b -> Either a b
Right a
a
               (Fail String
err) -> 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 :: forall (m :: * -> *) a.
Monad m =>
ZeptoT m a -> ByteString -> m (Either String a)
parseT ZeptoT m a
p ByteString
bs = do
  Result a
result <- 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
_   -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right a
a)
    Fail String
err -> forall (m :: * -> *) a. Monad m => a -> m a
return (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
(<>) = 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  = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"mempty"
    {-# INLINE mempty #-}
    mappend :: ZeptoT m a -> ZeptoT m a -> ZeptoT m a
mappend = forall a. Semigroup a => a -> a -> a
(<>)
    {-# INLINE mappend #-}

instance Monad m => Alternative (ZeptoT m) where
    empty :: forall a. ZeptoT m a
empty = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"empty"
    {-# INLINE empty #-}
    <|> :: forall 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 :: forall (m :: * -> *).
Monad m =>
(Word8 -> Bool) -> ZeptoT m ByteString
takeWhile Word8 -> Bool
p = do
  (ByteString
h,ByteString
t) <- forall (m :: * -> *) a. Monad m => (S -> a) -> ZeptoT m a
gets ((Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
B.span Word8 -> Bool
p forall b c a. (b -> c) -> (a -> b) -> a -> c
. S -> ByteString
input)
  forall (m :: * -> *). Monad m => S -> ZeptoT m ()
put (ByteString -> S
S ByteString
t)
  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 :: forall (m :: * -> *). Monad m => Int -> ZeptoT m ByteString
take !Int
n = do
  ByteString
s <- forall (m :: * -> *) a. Monad m => (S -> a) -> ZeptoT m a
gets S -> ByteString
input
  if ByteString -> Int
B.length ByteString
s forall a. Ord a => a -> a -> Bool
>= Int
n
    then forall (m :: * -> *). Monad m => S -> ZeptoT m ()
put (ByteString -> S
S (Int -> ByteString -> ByteString
B.unsafeDrop Int
n ByteString
s)) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> ByteString -> ByteString
B.unsafeTake Int
n ByteString
s)
    else 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 :: forall (m :: * -> *). Monad m => ByteString -> ZeptoT m ()
string ByteString
s = do
  ByteString
i <- 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 forall (m :: * -> *). Monad m => S -> ZeptoT m ()
put (ByteString -> S
S (Int -> ByteString -> ByteString
B.unsafeDrop (ByteString -> Int
B.length ByteString
s) ByteString
i)) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    else 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 :: forall (m :: * -> *). Monad m => ZeptoT m Bool
atEnd = do
  ByteString
i <- forall (m :: * -> *) a. Monad m => (S -> a) -> ZeptoT m a
gets S -> ByteString
input
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! ByteString -> Bool
B.null ByteString
i
{-# INLINE atEnd #-}