module Codec.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 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.Storable (Storable, peek, sizeOf)
import Foreign.Ptr (plusPtr, castPtr)
import Foreign.ForeignPtr (withForeignPtr)
import Control.Monad.ST (runST)
import Control.Monad.ST.Unsafe (unsafeInterleaveST)
import Control.Monad
import Control.Applicative
import Data.STRef
import Data.Word
import Data.Int
import Data.Bits
import Data.Maybe
data S = S {-# UNPACK #-} !B.ByteString
L.ByteString
{-# UNPACK #-} !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 `bsJoin` 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 `bsJoin` 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 `bsJoin` 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 `bsJoin` 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 `bsJoin` 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
bsJoin :: B.ByteString -> L.ByteString -> L.ByteString
bsJoin 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