{-# language BangPatterns #-}
{-# language BinaryLiterals #-}
{-# language DataKinds #-}
{-# language DeriveFunctor #-}
{-# language DerivingStrategies #-}
{-# language GADTSyntax #-}
{-# language KindSignatures #-}
{-# language LambdaCase #-}
{-# language MagicHash #-}
{-# language MultiWayIf #-}
{-# language PolyKinds #-}
{-# language RankNTypes #-}
{-# language ScopedTypeVariables #-}
{-# language StandaloneDeriving #-}
{-# language TypeApplications #-}
{-# language UnboxedSums #-}
{-# language UnboxedTuples #-}
module Data.Bytes.Parser
(
Parser
, Result(..)
, Slice(..)
, parseByteArray
, parseBytes
, parseBytesEffectfully
, any
, take
, takeWhile
, takeTrailedBy
, skipWhile
, skipTrailedBy
, byteArray
, bytes
, endOfInput
, isEndOfInput
, remaining
, fail
, orElse
, annotate
, (<?>)
, replicate
, delimit
, measure
, effect
, boxWord32
, boxIntPair
, unboxWord32
, unboxIntPair
, bindFromCharToLifted
, bindFromLiftedToIntPair
, bindFromLiftedToInt
, bindFromIntToIntPair
, bindFromCharToIntPair
, bindFromMaybeCharToIntPair
, bindFromMaybeCharToLifted
, pureIntPair
, failIntPair
) where
import Prelude hiding (length,any,fail,takeWhile,take,replicate)
import Data.Bytes.Parser.Internal (InternalResult(..),Parser(..),ST#,unboxBytes)
import Data.Bytes.Parser.Internal (boxBytes,Result#,uneffectful,fail)
import Data.Bytes.Parser.Internal (uneffectful#)
import Data.Bytes.Parser.Types (Result(Failure,Success),Slice(Slice))
import Data.Bytes.Parser.Unsafe (unconsume,expose,cursor)
import Data.Bytes.Types (Bytes(..))
import Data.Primitive (ByteArray(..))
import GHC.Exts (Int(I#),Word#,Int#,Char#,runRW#,(+#),(-#),(>=#))
import GHC.ST (ST(..))
import GHC.Word (Word32(W32#),Word8)
import Data.Primitive.Contiguous (Contiguous,Element)
import qualified Data.Bytes as B
import qualified Data.Primitive as PM
import qualified Data.Primitive.Contiguous as C
parseBytes :: forall e a. (forall s. Parser e s a) -> Bytes -> Result e a
parseBytes p !b = runResultST action
where
action :: forall s. ST# s (Result# e a)
action s0 = case p @s of
Parser f -> f (unboxBytes b) s0
runResultST :: (forall s. ST# s (Result# e x)) -> Result e x
runResultST f = case (runRW# (\s0 -> case f s0 of { (# _, r #) -> r })) of
(# e | #) -> Failure e
(# | (# x, off, len #) #) -> Success (Slice (I# off) (I# len) x)
parseByteArray :: (forall s. Parser e s a) -> ByteArray -> Result e a
parseByteArray p b =
parseBytes p (Bytes b 0 (PM.sizeofByteArray b))
parseBytesEffectfully :: Parser e s a -> Bytes -> ST s (Result e a)
parseBytesEffectfully (Parser f) !b = ST
(\s0 -> case f (unboxBytes b) s0 of
(# s1, r #) -> (# s1, boxPublicResult r #)
)
effect :: ST s a -> Parser e s a
effect (ST f) = Parser
( \(# _, off, len #) s0 -> case f s0 of
(# s1, a #) -> (# s1, (# | (# a, off, len #) #) #)
)
byteArray :: e -> ByteArray -> Parser e s ()
byteArray e !expected = bytes e (B.fromByteArray expected)
bytes :: e -> Bytes -> Parser e s ()
bytes e !expected = Parser
( \actual@(# _, off, len #) s ->
let r = if B.isPrefixOf expected (boxBytes actual)
then let !(I# movement) = length expected in
(# | (# (), off +# movement, len -# movement #) #)
else (# e | #)
in (# s, r #)
)
infix 0 <?>
(<?>) :: Parser x s a -> e -> Parser e s a
(<?>) = annotate
annotate :: Parser x s a -> e -> Parser e s a
annotate p e = p `orElse` fail e
any :: e -> Parser e s Word8
{-# inline any #-}
any e = uneffectful $ \chunk -> if length chunk > 0
then
let w = PM.indexByteArray (array chunk) (offset chunk) :: Word8
in InternalSuccess w (offset chunk + 1) (length chunk - 1)
else InternalFailure e
anyUnsafe :: Parser e s Word8
{-# inline anyUnsafe #-}
anyUnsafe = uneffectful $ \chunk ->
let w = PM.indexByteArray (array chunk) (offset chunk) :: Word8
in InternalSuccess w (offset chunk + 1) (length chunk - 1)
takeWhile :: (Word8 -> Bool) -> Parser e s Bytes
{-# inline takeWhile #-}
takeWhile f = uneffectful $ \chunk -> case B.takeWhile f chunk of
bs -> InternalSuccess bs (offset chunk + length bs) (length chunk - length bs)
takeTrailedBy :: e -> Word8 -> Parser e s Bytes
takeTrailedBy e !w = do
!start <- cursor
skipTrailedBy e w
!end <- cursor
!arr <- expose
pure (Bytes arr start (end - start))
skipTrailedBy :: e -> Word8 -> Parser e s ()
skipTrailedBy e !w = uneffectful# (\c -> skipUntilConsumeByteLoop e w c)
skipUntilConsumeByteLoop ::
e
-> Word8
-> Bytes
-> Result# e ()
skipUntilConsumeByteLoop e !w !c = if length c > 0
then if PM.indexByteArray (array c) (offset c) /= (w :: Word8)
then skipUntilConsumeByteLoop e w (B.unsafeDrop 1 c)
else (# | (# (), unI (offset c + 1), unI (length c - 1) #) #)
else (# e | #)
take :: e -> Int -> Parser e s Bytes
{-# inline take #-}
take e n = uneffectful $ \chunk -> if n <= B.length chunk
then case B.unsafeTake n chunk of
bs -> InternalSuccess bs (offset chunk + n) (length chunk - n)
else InternalFailure e
remaining :: Parser e s Bytes
{-# inline remaining #-}
remaining = uneffectful $ \chunk ->
InternalSuccess chunk (offset chunk + length chunk) 0
skipWhile :: (Word8 -> Bool) -> Parser e s ()
{-# inline skipWhile #-}
skipWhile f = go where
go = isEndOfInput >>= \case
True -> pure ()
False -> do
w <- anyUnsafe
if f w
then go
else unconsume 1
endOfInput :: e -> Parser e s ()
endOfInput e = uneffectful $ \chunk -> if length chunk == 0
then InternalSuccess () (offset chunk) 0
else InternalFailure e
isEndOfInput :: Parser e s Bool
isEndOfInput = uneffectful $ \chunk ->
InternalSuccess (length chunk == 0) (offset chunk) (length chunk)
boxPublicResult :: Result# e a -> Result e a
boxPublicResult (# | (# a, b, c #) #) = Success (Slice (I# b) (I# c) a)
boxPublicResult (# e | #) = Failure e
unboxWord32 :: Parser e s Word32 -> Parser e s Word#
unboxWord32 (Parser f) = Parser
(\x s0 -> case f x s0 of
(# s1, r #) -> case r of
(# e | #) -> (# s1, (# e | #) #)
(# | (# W32# a, b, c #) #) -> (# s1, (# | (# a, b, c #) #) #)
)
unboxIntPair :: Parser e s (Int,Int) -> Parser e s (# Int#, Int# #)
unboxIntPair (Parser f) = Parser
(\x s0 -> case f x s0 of
(# s1, r #) -> case r of
(# e | #) -> (# s1, (# e | #) #)
(# | (# (I# y, I# z), b, c #) #) -> (# s1, (# | (# (# y, z #), b, c #) #) #)
)
boxWord32 :: Parser e s Word# -> Parser e s Word32
boxWord32 (Parser f) = Parser
(\x s0 -> case f x s0 of
(# s1, r #) -> case r of
(# e | #) -> (# s1, (# e | #) #)
(# | (# a, b, c #) #) -> (# s1, (# | (# W32# a, b, c #) #) #)
)
boxIntPair :: Parser e s (# Int#, Int# #) -> Parser e s (Int,Int)
boxIntPair (Parser f) = Parser
(\x s0 -> case f x s0 of
(# s1, r #) -> case r of
(# e | #) -> (# s1, (# e | #) #)
(# | (# (# y, z #), b, c #) #) -> (# s1, (# | (# (I# y, I# z), b, c #) #) #)
)
infixl 3 `orElse`
orElse :: Parser x s a -> Parser e s a -> Parser e s a
{-# inline orElse #-}
orElse (Parser f) (Parser g) = Parser
(\x s0 -> case f x s0 of
(# s1, r0 #) -> case r0 of
(# _ | #) -> g x s1
(# | r #) -> (# s1, (# | r #) #)
)
bindFromCharToLifted :: Parser s e Char# -> (Char# -> Parser s e a) -> Parser s e a
{-# inline bindFromCharToLifted #-}
bindFromCharToLifted (Parser f) g = Parser
(\x@(# arr, _, _ #) s0 -> case f x s0 of
(# s1, r0 #) -> case r0 of
(# e | #) -> (# s1, (# e | #) #)
(# | (# y, b, c #) #) ->
runParser (g y) (# arr, b, c #) s1
)
bindFromCharToIntPair :: Parser s e Char# -> (Char# -> Parser s e (# Int#, Int# #)) -> Parser s e (# Int#, Int# #)
{-# inline bindFromCharToIntPair #-}
bindFromCharToIntPair (Parser f) g = Parser
(\x@(# arr, _, _ #) s0 -> case f x s0 of
(# s1, r0 #) -> case r0 of
(# e | #) -> (# s1, (# e | #) #)
(# | (# y, b, c #) #) ->
runParser (g y) (# arr, b, c #) s1
)
bindFromLiftedToInt :: Parser s e a -> (a -> Parser s e Int#) -> Parser s e Int#
{-# inline bindFromLiftedToInt #-}
bindFromLiftedToInt (Parser f) g = Parser
(\x@(# arr, _, _ #) s0 -> case f x s0 of
(# s1, r0 #) -> case r0 of
(# e | #) -> (# s1, (# e | #) #)
(# | (# y, b, c #) #) ->
runParser (g y) (# arr, b, c #) s1
)
bindFromLiftedToIntPair :: Parser s e a -> (a -> Parser s e (# Int#, Int# #)) -> Parser s e (# Int#, Int# #)
{-# inline bindFromLiftedToIntPair #-}
bindFromLiftedToIntPair (Parser f) g = Parser
(\x@(# arr, _, _ #) s0 -> case f x s0 of
(# s1, r0 #) -> case r0 of
(# e | #) -> (# s1, (# e | #) #)
(# | (# y, b, c #) #) ->
runParser (g y) (# arr, b, c #) s1
)
bindFromIntToIntPair :: Parser s e Int# -> (Int# -> Parser s e (# Int#, Int# #)) -> Parser s e (# Int#, Int# #)
{-# inline bindFromIntToIntPair #-}
bindFromIntToIntPair (Parser f) g = Parser
(\x@(# arr, _, _ #) s0 -> case f x s0 of
(# s1, r0 #) -> case r0 of
(# e | #) -> (# s1, (# e | #) #)
(# | (# y, b, c #) #) ->
runParser (g y) (# arr, b, c #) s1
)
bindFromMaybeCharToIntPair ::
Parser s e (# (# #) | Char# #)
-> ((# (# #) | Char# #) -> Parser s e (# Int#, Int# #))
-> Parser s e (# Int#, Int# #)
{-# inline bindFromMaybeCharToIntPair #-}
bindFromMaybeCharToIntPair (Parser f) g = Parser
(\x@(# arr, _, _ #) s0 -> case f x s0 of
(# s1, r0 #) -> case r0 of
(# e | #) -> (# s1, (# e | #) #)
(# | (# y, b, c #) #) ->
runParser (g y) (# arr, b, c #) s1
)
bindFromMaybeCharToLifted ::
Parser s e (# (# #) | Char# #)
-> ((# (# #) | Char# #) -> Parser s e a)
-> Parser s e a
{-# inline bindFromMaybeCharToLifted #-}
bindFromMaybeCharToLifted (Parser f) g = Parser
(\x@(# arr, _, _ #) s0 -> case f x s0 of
(# s1, r0 #) -> case r0 of
(# e | #) -> (# s1, (# e | #) #)
(# | (# y, b, c #) #) ->
runParser (g y) (# arr, b, c #) s1
)
pureIntPair ::
(# Int#, Int# #)
-> Parser s e (# Int#, Int# #)
{-# inline pureIntPair #-}
pureIntPair a = Parser
(\(# _, b, c #) s -> (# s, (# | (# a, b, c #) #) #))
failIntPair :: e -> Parser e s (# Int#, Int# #)
{-# inline failIntPair #-}
failIntPair e = Parser
(\(# _, _, _ #) s -> (# s, (# e | #) #))
measure :: Parser e s a -> Parser e s (Int,a)
{-# inline measure #-}
measure (Parser f) = Parser
(\x@(# _, pre, _ #) s0 -> case f x s0 of
(# s1, r #) -> case r of
(# e | #) -> (# s1, (# e | #) #)
(# | (# y, post, c #) #) -> (# s1, (# | (# (I# (post -# pre), y),post,c #) #) #)
)
delimit ::
e
-> e
-> Int
-> Parser e s a
-> Parser e s a
delimit esz eleftovers (I# n) (Parser f) = Parser
( \(# arr, off, len #) s0 -> case len >=# n of
1# -> case f (# arr, off, n #) s0 of
(# s1, r #) -> case r of
(# e | #) -> (# s1, (# e | #) #)
(# | (# a, newOff, leftovers #) #) -> case leftovers of
0# -> (# s1, (# | (# a, newOff, len -# n #) #) #)
_ -> (# s1, (# eleftovers | #) #)
_ -> (# s0, (# esz | #) #)
)
replicate :: forall arr e s a. (Contiguous arr, Element arr a)
=> Int
-> Parser e s a
-> Parser e s (arr a)
{-# inline replicate #-}
replicate !len p = do
marr <- effect (C.new len)
let go :: Int -> Parser e s (arr a)
go !ix = if ix < len
then do
a <- p
effect (C.write marr ix a)
go (ix + 1)
else effect (C.unsafeFreeze marr)
go 0
unI :: Int -> Int#
unI (I# w) = w