module Data.ByteString.Parser (
Parser
, runParser
, runParserState
, choice
, expect
, skip
, lookAhead
, lookAheadM
, lookAheadE
, bytesRead
, getBytes
, remaining
, isEmpty
, satisfy
, getString
, getStringNul
, string
, getWord8
, getInt8
, word8
, int8
, getByteString
, getLazyByteString
, getLazyByteStringNul
, getRemainingLazyByteString
, getWord16be
, word16be
, getWord24be
, word24be
, getWord32be
, word32be
, getWord64be
, word64be
, getInt16be
, int16be
, getInt32be
, int32be
, getInt64be
, int64be
, getWord16le
, word16le
, getWord24le
, word24le
, getWord32le
, word32le
, getWord64le
, word64le
, getInt16le
, int16le
, getInt32le
, int32le
, getInt64le
, int64le
, getWordHost
, wordHost
, getWord16host
, word16host
, getWord32host
, word32host
, getWord64host
, word64host
, getVarLenBe
, varLenBe
, getVarLenLe
, varLenLe
) where
import Control.Monad hiding (join)
import Control.Applicative
import Data.Maybe (isNothing)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Internal as B
import qualified Data.ByteString.Lazy.Internal as L
import Foreign hiding (unsafePerformIO)
#if MIN_VERSION_base(4,4,0)
import Control.Monad.ST.Unsafe (unsafeInterleaveST)
#else
import Control.Monad.ST (unsafeInterleaveST)
#endif
import Control.Monad.ST hiding (unsafeInterleaveST)
import Data.STRef
data S = S !B.ByteString
L.ByteString
!Int64
newtype Parser a = Parser { unParser :: S -> Either String (a, S) }
instance Functor Parser where
fmap f m = Parser $ \s -> case unParser m s of
Left e -> Left e
Right (a, s') -> Right (f a, s')
instance Monad Parser where
return a = Parser (\s -> Right (a, s))
m >>= k = Parser $ \s -> case (unParser m) s of
Left e -> Left e
Right (a, s') -> (unParser (k a)) s'
fail err = Parser $ \(S _ _ bytes) ->
Left (err ++ ". Failed reading at byte position " ++ show bytes)
instance MonadPlus Parser where
mzero = Parser $ \_ -> Left []
mplus p1 p2 = Parser $ \s -> case (unParser p1 s) of
Left e1 -> case (unParser p2 s) of
Left e2 -> Left (e1 ++ "\n" ++ e2)
ok -> ok
ok -> ok
instance Applicative Parser where
pure = return
(<*>) = ap
instance Alternative Parser where
empty = mzero
(<|>) = mplus
get :: Parser S
get = Parser $ \s -> Right (s, s)
put :: S -> Parser ()
put s = Parser $ \_ -> Right ((), s)
initState :: L.ByteString -> S
initState xs = mkState xs 0
mkState :: L.ByteString -> Int64 -> S
mkState l = case l of
L.Empty -> S B.empty L.empty
L.Chunk x xs -> S x xs
runParser :: Parser a -> L.ByteString -> Either String a
runParser m str = case unParser m (initState str) of
Left e -> Left e
Right (a, _) -> Right a
runParserState :: Parser a -> L.ByteString -> Int64 -> Either String (a, L.ByteString, Int64)
runParserState m str off =
case unParser m (mkState str off) of
Left e -> Left e
Right (a, ~(S s ss newOff)) -> Right (a, s `join` ss, newOff)
choice :: [Parser a] -> Parser a
choice = foldl (<|>) mzero
skip :: Word64 -> Parser ()
skip n = readN (fromIntegral n) (const ())
lookAhead :: Parser a -> Parser a
lookAhead ga = do
s <- get
a <- ga
put s
return a
lookAheadM :: Parser (Maybe a) -> Parser (Maybe a)
lookAheadM gma = do
s <- get
ma <- gma
when (isNothing ma) $ put s
return ma
lookAheadE :: Parser (Either a b) -> Parser (Either a b)
lookAheadE gea = do
s <- get
ea <- gea
case ea of
Left _ -> put s
_ -> return ()
return ea
expect :: (Show a, Eq a) => (a -> Bool) -> Parser a -> Parser a
expect f p = do
v <- p
when (not $ f v) $ fail $ show v ++ " was not expected."
return v
getString :: Int -> Parser String
getString l = do
bs <- getLazyByteString (fromIntegral l)
return $! map B.w2c (L.unpack bs)
getStringNul :: Parser String
getStringNul = do
bs <- getLazyByteStringNul
return $! map B.w2c (L.unpack bs)
string :: String -> Parser String
string s = expect (s ==) (getString $ length s)
bytesRead :: Parser Int64
bytesRead = do
S _ _ b <- get
return b
remaining :: Parser Int64
remaining = do
S s ss _ <- get
return $! (fromIntegral (B.length s) + L.length ss)
isEmpty :: Parser Bool
isEmpty = do
S s ss _ <- get
return $! (B.null s && L.null ss)
getByteString :: Int -> Parser B.ByteString
getByteString n = readN n id
getLazyByteString :: Int64 -> Parser L.ByteString
getLazyByteString n = do
S s ss bytes <- get
let big = s `join` ss
case splitAtST n big of
(consume, rest) -> do put $ mkState rest (bytes + n)
return consume
getLazyByteStringNul :: Parser L.ByteString
getLazyByteStringNul = do
S s ss bytes <- get
let big = s `join` ss
(consume, t) = L.break (== 0) big
(h, rest) = L.splitAt 1 t
when (L.null h) $ fail "too few bytes"
put $ mkState rest (bytes + L.length consume + 1)
return consume
getRemainingLazyByteString :: Parser L.ByteString
getRemainingLazyByteString = do
S s ss _ <- get
return $! (s `join` ss)
getBytes :: Int -> Parser B.ByteString
getBytes n = do
S s ss bytes <- get
if n <= B.length s
then do let (consume,rest) = B.splitAt n s
put $! S rest ss (bytes + fromIntegral n)
return $! consume
else
case L.splitAt (fromIntegral n) (s `join` ss) of
(consuming, rest) ->
do let now = B.concat . L.toChunks $ consuming
put $! mkState rest (bytes + fromIntegral n)
when (B.length now < n) $ fail "too few bytes"
return now
join :: B.ByteString -> L.ByteString -> L.ByteString
join bb lb
| B.null bb = lb
| otherwise = L.Chunk bb lb
splitAtST :: Int64 -> L.ByteString -> (L.ByteString, L.ByteString)
splitAtST i ps | i <= 0 = (L.empty, ps)
splitAtST i ps = runST (
do r <- newSTRef undefined
xs <- first r i ps
ys <- unsafeInterleaveST (readSTRef r)
return (xs, ys))
where
first r 0 xs@(L.Chunk _ _) = writeSTRef r xs >> return L.Empty
first r _ L.Empty = writeSTRef r L.Empty >> return L.Empty
first r n (L.Chunk x xs)
| n < l = do writeSTRef r (L.Chunk (B.drop (fromIntegral n) x) xs)
return $! L.Chunk (B.take (fromIntegral n) x) L.Empty
| otherwise = do writeSTRef r (L.drop (n l) xs)
liftM (L.Chunk x) $ unsafeInterleaveST (first r (n l) xs)
where l = fromIntegral (B.length x)
readN :: Int -> (B.ByteString -> a) -> Parser a
readN n f = fmap f $ getBytes n
getPtr :: Storable a => Int -> Parser a
getPtr n = do
(fp,o,_) <- readN n B.toForeignPtr
return . B.inlinePerformIO $ withForeignPtr fp $ \p -> peek (castPtr $ p `plusPtr` o)
satisfy :: (Word8 -> Bool) -> Parser Word8
satisfy f = do
w <- getWord8
guard (f w)
return w
getWord8 :: Parser Word8
getWord8 = getPtr (sizeOf (undefined :: Word8))
word8 :: Word8 -> Parser Word8
word8 w = expect (w ==) getWord8
getWord16be :: Parser Word16
getWord16be = do
s <- readN 2 id
return $! (fromIntegral (s `B.index` 0) `shiftL` 8) .|.
(fromIntegral (s `B.index` 1))
word16be :: Word16 -> Parser Word16
word16be w = expect (w ==) getWord16be
getWord16le :: Parser Word16
getWord16le = do
s <- readN 2 id
return $! (fromIntegral (s `B.index` 1) `shiftL` 8) .|.
(fromIntegral (s `B.index` 0) )
word16le :: Word16 -> Parser Word16
word16le w = expect (w ==) getWord16le
getWord24be :: Parser Word32
getWord24be = do
s <- readN 3 id
return $! (fromIntegral (s `B.index` 0) `shiftL` 16) .|.
(fromIntegral (s `B.index` 1) `shiftL` 8) .|.
(fromIntegral (s `B.index` 2) )
word24be :: Word32 -> Parser Word32
word24be w = expect (w ==) getWord24be
getWord24le :: Parser Word32
getWord24le = do
s <- readN 3 id
return $! (fromIntegral (s `B.index` 2) `shiftL` 16) .|.
(fromIntegral (s `B.index` 1) `shiftL` 8) .|.
(fromIntegral (s `B.index` 0) )
word24le :: Word32 -> Parser Word32
word24le w = expect (w ==) getWord24le
getWord32be :: Parser Word32
getWord32be = do
s <- readN 4 id
return $! (fromIntegral (s `B.index` 0) `shiftL` 24) .|.
(fromIntegral (s `B.index` 1) `shiftL` 16) .|.
(fromIntegral (s `B.index` 2) `shiftL` 8) .|.
(fromIntegral (s `B.index` 3) )
word32be :: Word32 -> Parser Word32
word32be w = expect (w ==) getWord32be
getWord32le :: Parser Word32
getWord32le = do
s <- readN 4 id
return $! (fromIntegral (s `B.index` 3) `shiftL` 24) .|.
(fromIntegral (s `B.index` 2) `shiftL` 16) .|.
(fromIntegral (s `B.index` 1) `shiftL` 8) .|.
(fromIntegral (s `B.index` 0) )
word32le :: Word32 -> Parser Word32
word32le w = expect (w ==) getWord32le
getWord64be :: Parser Word64
getWord64be = do
s <- readN 8 id
return $! (fromIntegral (s `B.index` 0) `shiftL` 56) .|.
(fromIntegral (s `B.index` 1) `shiftL` 48) .|.
(fromIntegral (s `B.index` 2) `shiftL` 40) .|.
(fromIntegral (s `B.index` 3) `shiftL` 32) .|.
(fromIntegral (s `B.index` 4) `shiftL` 24) .|.
(fromIntegral (s `B.index` 5) `shiftL` 16) .|.
(fromIntegral (s `B.index` 6) `shiftL` 8) .|.
(fromIntegral (s `B.index` 7) )
word64be :: Word64 -> Parser Word64
word64be w = expect (w ==) getWord64be
getWord64le :: Parser Word64
getWord64le = do
s <- readN 8 id
return $! (fromIntegral (s `B.index` 7) `shiftL` 56) .|.
(fromIntegral (s `B.index` 6) `shiftL` 48) .|.
(fromIntegral (s `B.index` 5) `shiftL` 40) .|.
(fromIntegral (s `B.index` 4) `shiftL` 32) .|.
(fromIntegral (s `B.index` 3) `shiftL` 24) .|.
(fromIntegral (s `B.index` 2) `shiftL` 16) .|.
(fromIntegral (s `B.index` 1) `shiftL` 8) .|.
(fromIntegral (s `B.index` 0) )
word64le :: Word64 -> Parser Word64
word64le w = expect (w ==) getWord64le
getInt8 :: Parser Int8
getInt8 = getWord8 >>= return . fromIntegral
int8 :: Int8 -> Parser Int8
int8 i = expect (i ==) getInt8
getInt16le :: Parser Int16
getInt16le = getWord16le >>= return . fromIntegral
int16le :: Int16 -> Parser Int16
int16le i = expect (i ==) getInt16le
getInt16be :: Parser Int16
getInt16be = getWord16be >>= return . fromIntegral
int16be :: Int16 -> Parser Int16
int16be i = expect (i ==) getInt16be
getInt32le :: Parser Int32
getInt32le = getWord32le >>= return . fromIntegral
int32le :: Int32 -> Parser Int32
int32le i = expect (i ==) getInt32le
getInt32be :: Parser Int32
getInt32be = getWord32be >>= return . fromIntegral
int32be :: Int32 -> Parser Int32
int32be i = expect (i ==) getInt32be
getInt64le :: Parser Int64
getInt64le = getWord64le >>= return . fromIntegral
int64le :: Int64 -> Parser Int64
int64le i = expect (i ==) getInt64le
getInt64be :: Parser Int64
getInt64be = getWord64be >>= return . fromIntegral
int64be :: Int64 -> Parser Int64
int64be i = expect (i ==) getInt64be
getWordHost :: Parser Word
getWordHost = getPtr (sizeOf (undefined :: Word))
wordHost :: Word -> Parser Word
wordHost w = expect (w ==) getWordHost
getWord16host :: Parser Word16
getWord16host = getPtr (sizeOf (undefined :: Word16))
word16host :: Word16 -> Parser Word16
word16host w = expect (w ==) getWord16host
getWord32host :: Parser Word32
getWord32host = getPtr (sizeOf (undefined :: Word32))
word32host :: Word32 -> Parser Word32
word32host w = expect (w ==) getWord32host
getWord64host :: Parser Word64
getWord64host = getPtr (sizeOf (undefined :: Word64))
word64host :: Word64 -> Parser Word64
word64host w = expect (w ==) getWord64host
getVarLenBe :: Parser Word64
getVarLenBe = f 0
where
f :: Word64 -> Parser Word64
f acc = do
w <- getWord8 >>= return . fromIntegral
if testBit w 7
then f $! (shiftL acc 7) .|. (clearBit w 7)
else return $! (shiftL acc 7) .|. w
varLenBe :: Word64 -> Parser Word64
varLenBe a = expect (a ==) getVarLenBe
getVarLenLe :: Parser Word64
getVarLenLe = do
w <- getWord8 >>= return . fromIntegral
if testBit w 7
then do
w' <- getVarLenLe
return $! (clearBit w 7) .|. (shiftL w' 7)
else return $! w
varLenLe :: Word64 -> Parser Word64
varLenLe a = expect (a ==) getVarLenLe