{-# LANGUAGE CPP #-}

module BinaryParser
  ( BinaryParser,
    run,
    failure,
    byte,
    matchingByte,
    bytesOfSize,
    bytesWhile,
    unitOfSize,
    unitOfBytes,
    unitWhile,
    remainders,
    fold,
    endOfInput,
    sized,

    -- * Extras
    storableOfSize,
    beWord16,
    leWord16,
    beWord32,
    leWord32,
    beWord64,
    leWord64,
    asciiIntegral,
  )
where

import BinaryParser.Prelude hiding (fold)
import qualified BinaryParser.Prelude as B
import qualified Data.ByteString as ByteString
import qualified Data.ByteString.Internal as A
import qualified Data.ByteString.Unsafe as ByteString

-- |
-- A highly-efficient parser specialised for strict 'ByteString's.
--
-- Supports the roll-back and alternative branching
-- on the basis of the 'Alternative' interface.
--
-- Does not generate fancy error-messages,
-- which contributes to its efficiency.
newtype BinaryParser a
  = BinaryParser (ByteString -> Either Text (a, ByteString))
  deriving
    (forall a b. a -> BinaryParser b -> BinaryParser a
forall a b. (a -> b) -> BinaryParser a -> BinaryParser b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> BinaryParser b -> BinaryParser a
$c<$ :: forall a b. a -> BinaryParser b -> BinaryParser a
fmap :: forall a b. (a -> b) -> BinaryParser a -> BinaryParser b
$cfmap :: forall a b. (a -> b) -> BinaryParser a -> BinaryParser b
Functor, Functor BinaryParser
forall a. a -> BinaryParser a
forall a b. BinaryParser a -> BinaryParser b -> BinaryParser a
forall a b. BinaryParser a -> BinaryParser b -> BinaryParser b
forall a b.
BinaryParser (a -> b) -> BinaryParser a -> BinaryParser b
forall a b c.
(a -> b -> c) -> BinaryParser a -> BinaryParser b -> BinaryParser c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. BinaryParser a -> BinaryParser b -> BinaryParser a
$c<* :: forall a b. BinaryParser a -> BinaryParser b -> BinaryParser a
*> :: forall a b. BinaryParser a -> BinaryParser b -> BinaryParser b
$c*> :: forall a b. BinaryParser a -> BinaryParser b -> BinaryParser b
liftA2 :: forall a b c.
(a -> b -> c) -> BinaryParser a -> BinaryParser b -> BinaryParser c
$cliftA2 :: forall a b c.
(a -> b -> c) -> BinaryParser a -> BinaryParser b -> BinaryParser c
<*> :: forall a b.
BinaryParser (a -> b) -> BinaryParser a -> BinaryParser b
$c<*> :: forall a b.
BinaryParser (a -> b) -> BinaryParser a -> BinaryParser b
pure :: forall a. a -> BinaryParser a
$cpure :: forall a. a -> BinaryParser a
Applicative, Applicative BinaryParser
forall a. BinaryParser a
forall a. BinaryParser a -> BinaryParser [a]
forall a. BinaryParser a -> BinaryParser a -> BinaryParser a
forall (f :: * -> *).
Applicative f
-> (forall a. f a)
-> (forall a. f a -> f a -> f a)
-> (forall a. f a -> f [a])
-> (forall a. f a -> f [a])
-> Alternative f
many :: forall a. BinaryParser a -> BinaryParser [a]
$cmany :: forall a. BinaryParser a -> BinaryParser [a]
some :: forall a. BinaryParser a -> BinaryParser [a]
$csome :: forall a. BinaryParser a -> BinaryParser [a]
<|> :: forall a. BinaryParser a -> BinaryParser a -> BinaryParser a
$c<|> :: forall a. BinaryParser a -> BinaryParser a -> BinaryParser a
empty :: forall a. BinaryParser a
$cempty :: forall a. BinaryParser a
Alternative, Applicative BinaryParser
forall a. a -> BinaryParser a
forall a b. BinaryParser a -> BinaryParser b -> BinaryParser b
forall a b.
BinaryParser a -> (a -> BinaryParser b) -> BinaryParser b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> BinaryParser a
$creturn :: forall a. a -> BinaryParser a
>> :: forall a b. BinaryParser a -> BinaryParser b -> BinaryParser b
$c>> :: forall a b. BinaryParser a -> BinaryParser b -> BinaryParser b
>>= :: forall a b.
BinaryParser a -> (a -> BinaryParser b) -> BinaryParser b
$c>>= :: forall a b.
BinaryParser a -> (a -> BinaryParser b) -> BinaryParser b
Monad, Monad BinaryParser
Alternative BinaryParser
forall a. BinaryParser a
forall a. BinaryParser a -> BinaryParser a -> BinaryParser a
forall (m :: * -> *).
Alternative m
-> Monad m
-> (forall a. m a)
-> (forall a. m a -> m a -> m a)
-> MonadPlus m
mplus :: forall a. BinaryParser a -> BinaryParser a -> BinaryParser a
$cmplus :: forall a. BinaryParser a -> BinaryParser a -> BinaryParser a
mzero :: forall a. BinaryParser a
$cmzero :: forall a. BinaryParser a
MonadPlus, MonadError Text)
    via (StateT ByteString (Except Text))

type role BinaryParser representational

instance MonadFail BinaryParser where
  fail :: forall a. String -> BinaryParser a
fail = forall a. Text -> BinaryParser a
failure forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. IsString a => String -> a
fromString

-- |
-- Apply a parser to bytes.
{-# INLINE run #-}
run :: BinaryParser a -> ByteString -> Either Text a
run :: forall a. BinaryParser a -> ByteString -> Either Text a
run (BinaryParser ByteString -> Either Text (a, ByteString)
parser) ByteString
input =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ ByteString -> Either Text (a, ByteString)
parser ByteString
input

-- |
-- Fail with a message.
{-# INLINE failure #-}
failure :: Text -> BinaryParser a
failure :: forall a. Text -> BinaryParser a
failure Text
text =
  forall a.
(ByteString -> Either Text (a, ByteString)) -> BinaryParser a
BinaryParser (forall a b. a -> b -> a
const (forall a b. a -> Either a b
Left Text
text))

-- |
-- Consume a single byte.
{-# INLINE byte #-}
byte :: BinaryParser Word8
byte :: BinaryParser Word8
byte =
  forall a.
(ByteString -> Either Text (a, ByteString)) -> BinaryParser a
BinaryParser forall a b. (a -> b) -> a -> b
$ \ByteString
remainders ->
    if ByteString -> Bool
ByteString.null ByteString
remainders
      then forall a b. a -> Either a b
Left Text
"End of input"
      else forall a b. b -> Either a b
Right (ByteString -> Word8
ByteString.unsafeHead ByteString
remainders, Int -> ByteString -> ByteString
ByteString.unsafeDrop Int
1 ByteString
remainders)

-- |
-- Consume a single byte, which satisfies the predicate.
{-# INLINE satisfyingByte #-}
satisfyingByte :: (Word8 -> Bool) -> BinaryParser Word8
satisfyingByte :: (Word8 -> Bool) -> BinaryParser Word8
satisfyingByte Word8 -> Bool
predicate =
  forall a.
(ByteString -> Either Text (a, ByteString)) -> BinaryParser a
BinaryParser forall a b. (a -> b) -> a -> b
$ \ByteString
remainders ->
    case ByteString -> Maybe (Word8, ByteString)
ByteString.uncons ByteString
remainders of
      Maybe (Word8, ByteString)
Nothing -> forall a b. a -> Either a b
Left Text
"End of input"
      Just (Word8
head, ByteString
tail) ->
        if Word8 -> Bool
predicate Word8
head
          then forall a b. b -> Either a b
Right (Word8
head, ByteString
tail)
          else forall a b. a -> Either a b
Left Text
"Byte doesn't satisfy a predicate"

-- |
-- Consume a single byte, which satisfies the predicate.
{-# INLINE matchingByte #-}
matchingByte :: (Word8 -> Either Text a) -> BinaryParser a
matchingByte :: forall a. (Word8 -> Either Text a) -> BinaryParser a
matchingByte Word8 -> Either Text a
matcher =
  forall a.
(ByteString -> Either Text (a, ByteString)) -> BinaryParser a
BinaryParser forall a b. (a -> b) -> a -> b
$ \ByteString
remainders ->
    case ByteString -> Maybe (Word8, ByteString)
ByteString.uncons ByteString
remainders of
      Maybe (Word8, ByteString)
Nothing -> forall a b. a -> Either a b
Left Text
"End of input"
      Just (Word8
head, ByteString
tail) ->
        case Word8 -> Either Text a
matcher Word8
head of
          Right a
result -> forall a b. b -> Either a b
Right (a
result, ByteString
tail)
          Left Text
error -> forall a b. a -> Either a b
Left Text
error

-- |
-- Consume an amount of bytes.
{-# INLINE bytesOfSize #-}
bytesOfSize :: Int -> BinaryParser ByteString
bytesOfSize :: Int -> BinaryParser ByteString
bytesOfSize Int
size =
  forall a.
(ByteString -> Either Text (a, ByteString)) -> BinaryParser a
BinaryParser forall a b. (a -> b) -> a -> b
$ \ByteString
remainders ->
    if ByteString -> Int
ByteString.length ByteString
remainders forall a. Ord a => a -> a -> Bool
>= Int
size
      then forall a b. b -> Either a b
Right (Int -> ByteString -> ByteString
ByteString.unsafeTake Int
size ByteString
remainders, Int -> ByteString -> ByteString
ByteString.unsafeDrop Int
size ByteString
remainders)
      else forall a b. a -> Either a b
Left Text
"End of input"

-- |
-- Consume multiple bytes, which satisfy the predicate.
{-# INLINE bytesWhile #-}
bytesWhile :: (Word8 -> Bool) -> BinaryParser ByteString
bytesWhile :: (Word8 -> Bool) -> BinaryParser ByteString
bytesWhile Word8 -> Bool
predicate =
  forall a.
(ByteString -> Either Text (a, ByteString)) -> BinaryParser a
BinaryParser forall a b. (a -> b) -> a -> b
$ \ByteString
remainders ->
    forall a b. b -> Either a b
Right ((Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
ByteString.span Word8 -> Bool
predicate ByteString
remainders)

-- |
-- Skip an amount of bytes.
{-# INLINE unitOfSize #-}
unitOfSize :: Int -> BinaryParser ()
unitOfSize :: Int -> BinaryParser ()
unitOfSize Int
size =
  forall a.
(ByteString -> Either Text (a, ByteString)) -> BinaryParser a
BinaryParser forall a b. (a -> b) -> a -> b
$ \ByteString
remainders ->
    if ByteString -> Int
ByteString.length ByteString
remainders forall a. Ord a => a -> a -> Bool
>= Int
size
      then forall a b. b -> Either a b
Right ((), Int -> ByteString -> ByteString
ByteString.unsafeDrop Int
size ByteString
remainders)
      else forall a b. a -> Either a b
Left Text
"End of input"

-- |
-- Skip specific bytes, while failing if they don't match.
{-# INLINE unitOfBytes #-}
unitOfBytes :: ByteString -> BinaryParser ()
unitOfBytes :: ByteString -> BinaryParser ()
unitOfBytes ByteString
bytes =
  forall a.
(ByteString -> Either Text (a, ByteString)) -> BinaryParser a
BinaryParser forall a b. (a -> b) -> a -> b
$ \ByteString
remainders ->
    if ByteString -> ByteString -> Bool
ByteString.isPrefixOf ByteString
bytes ByteString
remainders
      then forall a b. b -> Either a b
Right ((), Int -> ByteString -> ByteString
ByteString.unsafeDrop (ByteString -> Int
ByteString.length ByteString
bytes) ByteString
remainders)
      else forall a b. a -> Either a b
Left Text
"Bytes don't match"

-- |
-- Skip bytes, which satisfy the predicate.
{-# INLINE unitWhile #-}
unitWhile :: (Word8 -> Bool) -> BinaryParser ()
unitWhile :: (Word8 -> Bool) -> BinaryParser ()
unitWhile Word8 -> Bool
predicate =
  forall a.
(ByteString -> Either Text (a, ByteString)) -> BinaryParser a
BinaryParser forall a b. (a -> b) -> a -> b
$ \ByteString
remainders ->
    forall a b. b -> Either a b
Right ((), (Word8 -> Bool) -> ByteString -> ByteString
ByteString.dropWhile Word8 -> Bool
predicate ByteString
remainders)

-- |
-- Consume all the remaining bytes.
{-# INLINE remainders #-}
remainders :: BinaryParser ByteString
remainders :: BinaryParser ByteString
remainders =
  forall a.
(ByteString -> Either Text (a, ByteString)) -> BinaryParser a
BinaryParser forall a b. (a -> b) -> a -> b
$ \ByteString
remainders -> forall a b. b -> Either a b
Right (ByteString
remainders, ByteString
ByteString.empty)

-- |
-- Fail if the input hasn't ended.
{-# INLINE endOfInput #-}
endOfInput :: BinaryParser ()
endOfInput :: BinaryParser ()
endOfInput =
  forall a.
(ByteString -> Either Text (a, ByteString)) -> BinaryParser a
BinaryParser forall a b. (a -> b) -> a -> b
$ \case
    ByteString
"" -> forall a b. b -> Either a b
Right ((), ByteString
ByteString.empty)
    ByteString
_ -> forall a b. a -> Either a b
Left Text
"Not the end of input"

-- |
-- Left-fold the bytes, terminating before the byte,
-- on which the step function returns Nothing.
{-# INLINE fold #-}
fold :: (a -> Word8 -> Maybe a) -> a -> BinaryParser a
fold :: forall a. (a -> Word8 -> Maybe a) -> a -> BinaryParser a
fold a -> Word8 -> Maybe a
step a
init =
  forall a.
(ByteString -> Either Text (a, ByteString)) -> BinaryParser a
BinaryParser forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> ByteString -> (a, ByteString)
loop a
init
  where
    loop :: a -> ByteString -> (a, ByteString)
loop !a
accumulator ByteString
remainders =
      case ByteString -> Maybe (Word8, ByteString)
ByteString.uncons ByteString
remainders of
        Maybe (Word8, ByteString)
Nothing -> (a
accumulator, ByteString
remainders)
        Just (Word8
head, ByteString
tail) ->
          case a -> Word8 -> Maybe a
step a
accumulator Word8
head of
            Just a
newAccumulator ->
              a -> ByteString -> (a, ByteString)
loop a
newAccumulator ByteString
tail
            Maybe a
Nothing -> (a
accumulator, ByteString
remainders)

-- |
-- Run a subparser passing it a chunk of the current input of the specified size.
{-# INLINE sized #-}
sized :: Int -> BinaryParser a -> BinaryParser a
sized :: forall a. Int -> BinaryParser a -> BinaryParser a
sized Int
size (BinaryParser ByteString -> Either Text (a, ByteString)
parser) =
  forall a.
(ByteString -> Either Text (a, ByteString)) -> BinaryParser a
BinaryParser forall a b. (a -> b) -> a -> b
$ \ByteString
remainders ->
    if ByteString -> Int
ByteString.length ByteString
remainders forall a. Ord a => a -> a -> Bool
>= Int
size
      then
        ByteString -> Either Text (a, ByteString)
parser (Int -> ByteString -> ByteString
ByteString.unsafeTake Int
size ByteString
remainders)
          forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(a, ByteString)
result -> (forall a b. (a, b) -> a
fst (a, ByteString)
result, Int -> ByteString -> ByteString
ByteString.unsafeDrop Int
size ByteString
remainders))
      else forall a b. a -> Either a b
Left Text
"End of input"

-- |
-- Storable value of the given amount of bytes.
{-# INLINE storableOfSize #-}
storableOfSize :: Storable a => Int -> BinaryParser a
storableOfSize :: forall a. Storable a => Int -> BinaryParser a
storableOfSize Int
size =
  forall a.
(ByteString -> Either Text (a, ByteString)) -> BinaryParser a
BinaryParser forall a b. (a -> b) -> a -> b
$ \(A.PS ForeignPtr Word8
payloadFP Int
offset Int
length) ->
    if Int
length forall a. Ord a => a -> a -> Bool
>= Int
size
      then
        let result :: a
result =
              forall a. IO a -> a
unsafeDupablePerformIO forall a b. (a -> b) -> a -> b
$ forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
payloadFP forall a b. (a -> b) -> a -> b
$ \Ptr Word8
ptr -> forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff (forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
ptr) Int
offset
            newRemainder :: ByteString
newRemainder =
              ForeignPtr Word8 -> Int -> Int -> ByteString
A.PS ForeignPtr Word8
payloadFP (Int
offset forall a. Num a => a -> a -> a
+ Int
size) (Int
length forall a. Num a => a -> a -> a
- Int
size)
         in forall a b. b -> Either a b
Right (a
result, ByteString
newRemainder)
      else forall a b. a -> Either a b
Left Text
"End of input"

-- | Big-endian word of 2 bytes.
{-# INLINE beWord16 #-}
beWord16 :: BinaryParser Word16
#ifdef WORDS_BIGENDIAN
beWord16 =
  storableOfSize 2
#else
beWord16 :: BinaryParser Word16
beWord16 =
  Word16 -> Word16
byteSwap16 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Storable a => Int -> BinaryParser a
storableOfSize Int
2
#endif

-- | Little-endian word of 2 bytes.
{-# INLINE leWord16 #-}
leWord16 :: BinaryParser Word16
#ifdef WORDS_BIGENDIAN
leWord16 =
  byteSwap16 <$> storableOfSize 2
#else
leWord16 :: BinaryParser Word16
leWord16 =
  forall a. Storable a => Int -> BinaryParser a
storableOfSize Int
2
#endif

-- | Big-endian word of 4 bytes.
{-# INLINE beWord32 #-}
beWord32 :: BinaryParser Word32
#ifdef WORDS_BIGENDIAN
beWord32 =
  storableOfSize 4
#else
beWord32 :: BinaryParser Word32
beWord32 =
  Word32 -> Word32
byteSwap32 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Storable a => Int -> BinaryParser a
storableOfSize Int
4
#endif

-- | Little-endian word of 4 bytes.
{-# INLINE leWord32 #-}
leWord32 :: BinaryParser Word32
#ifdef WORDS_BIGENDIAN
leWord32 =
  byteSwap32 <$> storableOfSize 4
#else
leWord32 :: BinaryParser Word32
leWord32 =
  forall a. Storable a => Int -> BinaryParser a
storableOfSize Int
4
#endif

-- | Big-endian word of 8 bytes.
{-# INLINE beWord64 #-}
beWord64 :: BinaryParser Word64
#ifdef WORDS_BIGENDIAN
beWord64 =
  storableOfSize 8
#else
beWord64 :: BinaryParser Word64
beWord64 =
  Word64 -> Word64
byteSwap64 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Storable a => Int -> BinaryParser a
storableOfSize Int
8
#endif

-- | Little-endian word of 8 bytes.
{-# INLINE leWord64 #-}
leWord64 :: BinaryParser Word64
#ifdef WORDS_BIGENDIAN
leWord64 =
  byteSwap64 <$> storableOfSize 8
#else
leWord64 :: BinaryParser Word64
leWord64 =
  forall a. Storable a => Int -> BinaryParser a
storableOfSize Int
8
#endif

-- |
-- Integral number encoded in ASCII.
{-# INLINE asciiIntegral #-}
asciiIntegral :: Integral a => BinaryParser a
asciiIntegral :: forall a. Integral a => BinaryParser a
asciiIntegral =
  do
    a
firstDigit <- forall a. (Word8 -> Either Text a) -> BinaryParser a
matchingByte forall {a} {b} {a}.
(Integral a, Num b, IsString a) =>
a -> Either a b
byteDigit
    forall a. (a -> Word8 -> Maybe a) -> a -> BinaryParser a
fold forall {a} {a}. (Integral a, Num a) => a -> a -> Maybe a
step a
firstDigit
  where
    byteDigit :: a -> Either a b
byteDigit a
byte =
      case a
byte forall a. Num a => a -> a -> a
- a
48 of
        a
subtracted ->
          if a
subtracted forall a. Ord a => a -> a -> Bool
<= a
9
            then forall a b. b -> Either a b
Right (forall a b. (Integral a, Num b) => a -> b
fromIntegral a
subtracted)
            else forall a b. a -> Either a b
Left a
"Not an ASCII decimal byte"
    step :: a -> a -> Maybe a
step a
state a
byte =
      case forall {a} {b} {a}.
(Integral a, Num b, IsString a) =>
a -> Either a b
byteDigit a
byte of
        Right a
digit -> forall a. a -> Maybe a
Just (a
state forall a. Num a => a -> a -> a
* a
10 forall a. Num a => a -> a -> a
+ a
digit)
        Either String a
_ -> forall a. Maybe a
Nothing