{-# 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
, parseBytesEither
, parseBytesMaybe
, any
, take
, takeWhile
, takeTrailedBy
, skipWhile
, skipTrailedBy
, skipTrailedBy2
, skipTrailedBy2#
, skipTrailedBy3#
, byteArray
, bytes
, satisfy
, satisfyWith
, cstring
, endOfInput
, isEndOfInput
, remaining
, peekRemaining
, scan
, peek
, peek'
, fail
, orElse
, annotate
, (<?>)
, replicate
, delimit
, measure
, measure_
, 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#,uneffectfulInt#)
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 Foreign.C.String (CString)
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
import qualified GHC.Exts as Exts
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
parseBytesMaybe :: forall e a. (forall s. Parser e s a) -> Bytes -> Maybe a
parseBytesMaybe p !b = runMaybeST action
where
action :: forall s. ST# s (Result# e a)
action s0 = case p @s of
Parser f -> f (unboxBytes b) s0
parseBytesEither :: forall e a. (forall s. Parser e s a) -> Bytes -> Either e a
parseBytesEither p !b = runEitherST action
where
action :: forall s. ST# s (Result# e a)
action s0 = case p @s of
Parser f -> f (unboxBytes b) s0
runMaybeST :: (forall s. ST# s (Result# e x)) -> Maybe x
runMaybeST f = case (runRW# (\s0 -> case f s0 of { (# _, r #) -> r })) of
(# _ | #) -> Nothing
(# | (# x, _, _ #) #) -> Just x
runEitherST :: (forall s. ST# s (Result# e x)) -> Either e x
runEitherST f = case (runRW# (\s0 -> case f s0 of { (# _, r #) -> r })) of
(# e | #) -> Left e
(# | (# x, _, _ #) #) -> Right x
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 #)
)
cstring :: e -> CString -> Parser e s ()
cstring e (Exts.Ptr ptr0) = Parser
( \(# arr, off0, len0 #) s ->
let go !ptr !off !len = case Exts.indexWord8OffAddr# ptr 0# of
0## -> (# s, (# | (# (), off, len #) #) #)
c -> case len of
0# -> (# s, (# e | #) #)
_ -> case Exts.eqWord# c (Exts.indexWord8Array# arr off) of
1# -> go (Exts.plusAddr# ptr 1# ) (off +# 1# ) (len -# 1# )
_ -> (# s, (# e | #) #)
in go ptr0 off0 len0
)
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
peek :: Parser e s (Maybe Word8)
peek = uneffectful $ \chunk ->
let v = if length chunk > 0
then Just (B.unsafeIndex chunk 1)
else Nothing
in InternalSuccess v (offset chunk) (length chunk)
peek' :: e -> Parser e s Word8
peek' e = uneffectful $ \chunk -> if length chunk > 0
then InternalSuccess (B.unsafeIndex chunk 1) (offset chunk) (length chunk)
else InternalFailure e
scan :: state -> (state -> Word8 -> Maybe state) -> Parser e s state
scan s0 t = do
let go s = do
mw <- peek
case mw of
Nothing -> pure s
Just w -> case t s w of
Just s' -> go s'
Nothing -> pure s
go s0
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 + 1)))
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 | #)
skipTrailedBy2 ::
e
-> Word8
-> Word8
-> Parser e s Bool
skipTrailedBy2 e !wa !wb = boxBool (skipTrailedBy2# e wa wb)
skipTrailedBy2# ::
e
-> Word8
-> Word8
-> Parser e s Int#
skipTrailedBy2# e !wa !wb =
uneffectfulInt# (\c -> skipUntilConsumeByteEitherLoop e wa wb c)
skipTrailedBy3# ::
e
-> Word8
-> Word8
-> Word8
-> Parser e s Int#
skipTrailedBy3# e !wa !wb !wc =
uneffectfulInt# (\c -> skipUntilConsumeByte3Loop e wa wb wc c)
skipUntilConsumeByteEitherLoop ::
e
-> Word8
-> Word8
-> Bytes
-> Result# e Int#
skipUntilConsumeByteEitherLoop e !wa !wb !c = if length c > 0
then let byte = PM.indexByteArray (array c) (offset c) in
if | byte == wa -> (# | (# 0#, unI (offset c + 1), unI (length c - 1) #) #)
| byte == wb -> (# | (# 1#, unI (offset c + 1), unI (length c - 1) #) #)
| otherwise -> skipUntilConsumeByteEitherLoop e wa wb (B.unsafeDrop 1 c)
else (# e | #)
skipUntilConsumeByte3Loop ::
e
-> Word8
-> Word8
-> Word8
-> Bytes
-> Result# e Int#
skipUntilConsumeByte3Loop e !wa !wb !wc !c = if length c > 0
then let byte = PM.indexByteArray (array c) (offset c) in
if | byte == wa -> (# | (# 0#, unI (offset c + 1), unI (length c - 1) #) #)
| byte == wb -> (# | (# 1#, unI (offset c + 1), unI (length c - 1) #) #)
| byte == wc -> (# | (# 2#, unI (offset c + 1), unI (length c - 1) #) #)
| otherwise -> skipUntilConsumeByte3Loop e wa wb wc (B.unsafeDrop 1 c)
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
peekRemaining :: Parser e s Bytes
{-# inline peekRemaining #-}
peekRemaining = uneffectful $ \b@(Bytes _ off len) ->
InternalSuccess b off len
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
satisfy :: e -> (Word8 -> Bool) -> Parser e s Word8
satisfy e p = satisfyWith e id p
{-# inline satisfy #-}
satisfyWith :: e -> (Word8 -> a) -> (a -> Bool) -> Parser e s a
satisfyWith e f p = uneffectful $ \chunk -> if length chunk > 1
then case B.unsafeIndex chunk 1 of
w ->
let v = f w
in if p v
then InternalSuccess v (offset chunk + 1) (length chunk - 1)
else InternalFailure e
else InternalFailure e
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 #) #) #)
)
boxInt :: Parser e s Int# -> Parser e s Int
{-# inline boxInt #-}
boxInt (Parser f) = Parser
(\x s0 -> case f x s0 of
(# s1, r #) -> case r of
(# e | #) -> (# s1, (# e | #) #)
(# | (# y, b, c #) #) -> (# s1, (# | (# I# y, b, c #) #) #)
)
boxBool :: Parser e s Int# -> Parser e s Bool
{-# inline boxBool #-}
boxBool (Parser f) = Parser
(\x s0 -> case f x s0 of
(# s1, r #) -> case r of
(# e | #) -> (# s1, (# e | #) #)
(# | (# y, b, c #) #) -> (# s1, (# | (# case y of {1# -> True; _ -> False}, 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 #) #) #)
)
measure_ :: Parser e s a -> Parser e s Int
{-# inline measure_ #-}
measure_ p = boxInt (measure_# p)
measure_# :: Parser e s a -> Parser e s Int#
{-# inline measure_# #-}
measure_# (Parser f) = Parser
(\x@(# _, pre, _ #) s0 -> case f x s0 of
(# s1, r #) -> case r of
(# e | #) -> (# s1, (# e | #) #)
(# | (# _, post, c #) #) -> (# s1, (# | (# post -# pre,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