packages feed

binary-strict 0.2.4 → 0.3.0

raw patch · 5 files changed

+385/−17 lines, 5 files

Files

binary-strict.cabal view
@@ -1,5 +1,5 @@ name:            binary-strict-version:         0.2.4+version:         0.3.0 license:         BSD3 license-file:    LICENSE author:          Lennart Kolmodin <kolmodin@dtek.chalmers.se>@@ -19,6 +19,8 @@                  Data.Binary.Strict.IncrementalGet,                  Data.Binary.Strict.BitGet,                  Data.Binary.Strict.Util+                 Data.Binary.Strict.ByteSet+                 Data.Binary.Strict.Class extensions:      CPP, FlexibleContexts hs-source-dirs:  src extra-source-files: tests/BitGetTest.hs, src/Data/Binary/Strict/Common.h
+ src/Data/Binary/Strict/ByteSet.hs view
@@ -0,0 +1,98 @@+-- | A ByteSet is a fast Set object for Word8's. The construction of these+--   objects isn't terribly quick, but the member function should be about+--   as good as you can get. Thus, you should use this when @member@ is the+--   most common operation+--+--   This object is designed to be imported qualified:+--+--   > import qualified Data.Binary.Strict.ByteSet as BSet+module Data.Binary.Strict.ByteSet+  ( ByteSet+  -- * Construction+  , empty+  , full+  , singleton+  , fromList+  , range++  -- * Combination+  , union+  , intersection+  , difference++  -- * Uniary functions+  , complement+  , toList+  , member++  ) where++import Data.List (foldl')+import Data.Word (Word8, Word64)+import Data.Array.Base (unsafeAt)+import Data.Array.Unboxed hiding ((!), range)+import Data.Bits ((.&.), (.|.), shiftL, shiftR)+import qualified Data.Bits as Bits++data ByteSet = ByteSet !(UArray Word8 Word64)++-- | We don't import the usual array indexing function from the array+--   modules. Instead, we implement it ourselves and remove the bounds+--   checking+(!) :: UArray Word8 Word64 -> Word8 -> Word64+(!) arr = unsafeAt arr . fromIntegral++instance Show ByteSet where+  show = ((++) "ByteSet ") . show . toList++-- | An empty set+empty :: ByteSet+empty = ByteSet $ listArray (0, 3) $ replicate 4 0++-- | The set contained all elements+full :: ByteSet+full = ByteSet $ listArray (0, 3) $ replicate 4 0xffffffffffffffff++-- | A set with a single element+singleton :: Word8 -> ByteSet+singleton n+  | n < 64 = ByteSet $ listArray (0, 3) $ [wordsArray ! n, 0, 0, 0]+  | n < 128 = ByteSet $ listArray (0, 3) $ [0, wordsArray ! (n - 64), 0, 0]+  | n < 196 = ByteSet $ listArray (0, 3) $ [0, 0, wordsArray ! (n - 128), 0]+  | otherwise = ByteSet $ listArray (0, 3) $ [0, 0, 0, wordsArray ! (n - 196)]++wordsArray :: UArray Word8 Word64+wordsArray = listArray (0, 63) $ map (\x -> (1 :: Word64) `shiftL` x) [0..63]++-- | A generic binary function+binary :: (Word64 -> Word64 -> Word64) -> ByteSet -> ByteSet -> ByteSet+binary f (ByteSet a) (ByteSet b) =+  ByteSet $ listArray (0, 3) [f (a ! 0) (b ! 0), f (a ! 1) (b ! 1), f (a ! 2) (b ! 2), f (a ! 3) (b ! 3)]++union :: ByteSet -> ByteSet -> ByteSet+union = binary (.|.)+intersection :: ByteSet -> ByteSet -> ByteSet+intersection = binary (.&.)+difference :: ByteSet -> ByteSet -> ByteSet+difference = binary (\a b -> a .&. Bits.complement b)++complement :: ByteSet -> ByteSet+complement (ByteSet a) =+  ByteSet $ amap Bits.complement a++word64ToList :: Word64 -> [Word8]+word64ToList x = filter (\n -> (x .&. ((1 :: Word64) `shiftL` (fromIntegral n))) /= 0) [0..63]++toList :: ByteSet -> [Word8]+toList (ByteSet a) =+  word64ToList (a ! 0) ++ map (+ 64) (word64ToList (a ! 1)) ++ map (+ 128) (word64ToList (a ! 2)) ++ map (+ 196) (word64ToList (a ! 3))++fromList :: [Word8] -> ByteSet+fromList = foldl' union empty . map singleton++-- | Construct a ByteSet containing all the elements from a to b, inclusive.+range :: Word8 -> Word8 -> ByteSet+range a b = fromList [a..b]++member :: ByteSet -> Word8 -> Bool+member (ByteSet a) n = (a ! (n `shiftR` 6)) .&. (wordsArray ! (n .&. 63)) /= 0
+ src/Data/Binary/Strict/Class.hs view
@@ -0,0 +1,82 @@+-- | This module contains a single class which abstracts over Get and+--   IncrementalGet, so that one can write parsers which work in both.+--   If you are using this module, you may find that+--   -fno-monomorphism-restriction is very useful.+module Data.Binary.Strict.Class where++import Control.Applicative(Alternative(..))++import qualified Data.ByteString as B+import Data.Word++-- | This is the generic class for the set of binary parsers. This lets you+--   write parser functions which are agnostic about the pattern of parsing+--   in which they get used (incremental, strict, bitwise etc)+class (Monad m, Alternative m) => BinaryParser m where+  skip :: Int -> m ()+  bytesRead :: m Int+  remaining :: m Int+  isEmpty :: m Bool+  spanOf :: (Word8 -> Bool) -> m B.ByteString+  spanOf1 :: (Word8 -> Bool) -> m B.ByteString+  spanOf1 p = do+    result <- spanOf p+    if B.null result+       then fail ""+       else return result++  string :: B.ByteString -> m ()+  string s = do+    s' <- getByteString $ B.length s+    if s == s'+       then return ()+       else fail $ "expecting:" ++ show s++  word8 :: Word8 -> m ()+  word8 w = do+    w' <- getWord8+    if w == w'+       then return ()+       else fail ""++  oneOf :: (Word8 -> Bool) -> m Word8+  oneOf p = do+    w <- getWord8+    if p w+       then return w+       else fail ""++  many :: m a -> m [a]+  many p = do+    v <- (p >>= return . Just) <|> (return Nothing)+    case v of+         Just x -> do+           rest <- many p+           return $ x : rest+         Nothing -> return []++  many1 :: m a -> m [a]+  many1 p = do+    result <- many p+    case result of+         [] -> fail ""+         x -> return x++  optional :: m a -> m (Maybe a)+  optional p = (p >>= return . Just) <|> return Nothing++  getWord8 :: m Word8+  getByteString :: Int -> m B.ByteString++  getWord16be :: m Word16+  getWord32be :: m Word32+  getWord64be :: m Word64++  getWord16le :: m Word16+  getWord32le :: m Word32+  getWord64le :: m Word64++  getWordhost :: m Word+  getWord16host :: m Word16+  getWord32host :: m Word32+  getWord64host :: m Word64
src/Data/Binary/Strict/Get.hs view
@@ -44,6 +44,9 @@     , lookAhead     , lookAheadM     , lookAheadE+    , zero+    , plus+    , spanOf      -- * Utility     , skip@@ -78,6 +81,9 @@     , getFloat64host ) where +import Control.Applicative(Alternative(..), Applicative(..))+import Control.Monad (MonadPlus(..), ap)+ import Control.Monad (when) import Data.Maybe (isNothing) @@ -87,6 +93,8 @@ import Foreign import Foreign.C.Types +import qualified Data.Binary.Strict.Class as Class+ #if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) import GHC.Base import GHC.Word@@ -121,6 +129,58 @@ initState :: B.ByteString -> S initState input = S input 0 {-# INLINE initState #-}++plus :: Get a -> Get a -> Get a+plus p1 p2 =+  Get $ \s ->+    case unGet p1 s of+         (Left _, _) -> unGet p2 s+         v@(Right _, _) -> v++zero :: Get a+zero = Get $ \s -> (Left "", s)++instance MonadPlus Get where+  mzero = zero+  mplus = plus++instance Applicative Get where+  pure = return+  (<*>) = ap++instance Alternative Get where+  empty = zero+  (<|>) = plus++instance Class.BinaryParser Get where+  skip = skip+  bytesRead = bytesRead+  remaining = remaining+  isEmpty = isEmpty+  spanOf = spanOf+  getWord8 = getWord8+  getByteString = getByteString++  getWord16be = getWord16be+  getWord32be = getWord32be+  getWord64be = getWord64be++  getWord16le = getWord16le+  getWord32le = getWord32le+  getWord64le = getWord64le++  getWordhost = getWordhost+  getWord16host = getWord16host+  getWord32host = getWord32host+  getWord64host = getWord64host++spanOf :: (Word8 -> Bool) -> Get B.ByteString+spanOf p =+  Get $ \(S s i) ->+    let+      (left, rest) = B.span p s+    in+      (Right left, S rest (i + B.length left))  -- | Run a parser on the given input and return the result (either an error --   string from a call to @fail@, or the parsing result) and the remainder of
src/Data/Binary/Strict/IncrementalGet.hs view
@@ -55,6 +55,10 @@     , bytesRead     , remaining     , isEmpty+    , plus+    , zero+    , spanOf+    , suspend      -- * Parsing particular types     , getWord8@@ -79,8 +83,13 @@     , getWord64host ) where +import Control.Applicative(Alternative(..), Applicative(..))+import Control.Monad (MonadPlus(..), ap)+ import qualified Data.ByteString as B import qualified Data.ByteString.Internal as B+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Lazy.Internal as BL  import Foreign @@ -89,10 +98,14 @@ import GHC.Word #endif +import qualified Data.Binary.Strict.Class as Class+ #ifndef __HADDOCK__ -- | The parse state-data S = S {-# UNPACK #-} !B.ByteString  -- ^ input+data S = S {-# UNPACK #-} !BL.ByteString  -- ^ input            {-# UNPACK #-} !Int  -- ^ bytes read+           {-# UNPACK #-} ![B.ByteString]+           {-# UNPACK #-} !Int  -- ^ the failure depth #endif  -- | The result of a partial parse@@ -106,12 +119,25 @@                 --   the given list of results before doing so. To continue the                 --   parse pass more data to the given continuation +-- | This is the internal version of the above. This is the type which is+--   actually used by the code, as it has the extra information needed+--   for backtracking. This is converted to an external friendly @Result@+--   type just before giving it to the outside world.+data IResult a = IFailed S String+               | IFinished S a+               | IPartial (B.ByteString -> IResult a)++instance Show (IResult a) where+  show (IFailed _ err) = "IFailed " ++ err+  show (IFinished _ _) = "IFinished"+  show (IPartial _) = "IPartial"+ instance (Show a) => Show (Result a) where   show (Failed err) = "Failed " ++ err-  show (Finished _ rs) = "Finished " ++ show rs+  show (Finished rest rs) = "Finished " ++ show rest ++ " " ++ show rs   show (Partial _) = "Partial" -newtype Get r a = Get { unGet :: S -> (a -> S -> Result r) -> Result r }+newtype Get r a = Get { unGet :: S -> (a -> S -> IResult r) -> IResult r }  instance Functor (Get r) where     fmap f m = Get (\s -> \cont -> unGet m s (cont . f))@@ -119,20 +145,105 @@ instance Monad (Get r) where   return a = Get (\s -> \k -> k a s)   m >>= k = Get (\s -> \cont -> unGet m s (\a -> \s' -> unGet (k a) s' cont))-  fail err = Get (const $ const $ Failed err)+  fail err = Get (\s -> const $ IFailed s err)  get :: Get r S get = Get (\s -> \k -> k s s) +strictToLazy :: B.ByteString -> BL.ByteString+strictToLazy x+  | B.null x = BL.Empty+  | otherwise = BL.Chunk x BL.Empty++lazyToStrict :: BL.ByteString -> B.ByteString+lazyToStrict = B.concat . BL.toChunks+ initState :: B.ByteString -> S-initState input = S input 0+initState input = S (strictToLazy input) 0 [] 0 {-# INLINE initState #-} +-- | This turns an internal Result into one safe for the outside world+toplevelTranslate :: IResult a -> Result a+toplevelTranslate (IFailed _ err) = Failed err+toplevelTranslate (IFinished (S rest _ _ _) value) = Finished (lazyToStrict rest) value+toplevelTranslate (IPartial k) = Partial $ toplevelTranslate . k++-- | This is the final continuation that turns a passed value into an IFinished+terminalContinuation :: a -> S -> IResult a+terminalContinuation v s = IFinished s v+ -- | Start a parser and return the first Result. runGet :: Get r r -> B.ByteString -> Result r runGet m input =-  unGet m (initState input) (\v -> (\(S s _) -> Finished s v))+  toplevelTranslate $ unGet m (initState input) terminalContinuation +-- | I'm not sure if this is a huge bodge or not. It probably is.+--+--   When performing a choice (in @plus@), the failure depth in the current+--   state is incremented. If a failure is generated inside the attempted path,+--   the state carried in the IFailure will have this incremented failure+--   depth. However, we don't want to backtrack after the attempted path has+--   completed. Thus we insert this cut continuation, which decrements the failure+--   count of any failure passing though, thus it would be caught in @plus@ and+--   doesn't trigger a backtrack.+cutContinuation :: (a -> S -> IResult r) -> a -> S -> IResult r+cutContinuation k v s =+  case k v s of+       IFailed (S lb i adds failDepth) err -> IFailed (S lb i adds (failDepth - 1)) err+       x -> x++-- | This is the choice operator. If the first option fails, the second is+--   tried. The failure of the first option must happen within this function+--   otherwise rollback is not attempted.+plus :: Get r a -> Get r a -> Get r a+plus p1 p2 =+  Get $ \(S lb i adds failDepth) k ->+    let+      filter f@(IFailed (S _ _ adds' failDepth') _)+        | failDepth' == failDepth + 1 = unGet p2 (S (lb `BL.append` (BL.fromChunks $ reverse adds')) i (adds' ++ adds) failDepth) k+        | otherwise = f+      filter (IPartial cont) = IPartial (filter . cont)+      filter v@(IFinished _ _) = v+    in+      filter $ unGet p1 (S lb i [] (failDepth + 1)) (cutContinuation k)++zero :: Get r a+zero = fail ""++instance MonadPlus (Get r) where+    mzero = zero+    mplus = plus++instance Applicative (Get r) where+    pure = return+    (<*>) = ap++instance Alternative (Get r) where+    empty = zero+    (<|>) = plus++instance Class.BinaryParser (Get r) where+  skip = skip+  bytesRead = bytesRead+  remaining = remaining+  isEmpty = isEmpty+  spanOf = spanOf+  getWord8 = getWord8+  getByteString = getByteString++  getWord16be = getWord16be+  getWord32be = getWord32be+  getWord64be = getWord64be++  getWord16le = getWord16le+  getWord32le = getWord32le+  getWord64le = getWord64le++  getWordhost = getWordhost+  getWord16host = getWord16host+  getWord32host = getWord32host+  getWord64host = getWord64host+ -- | Skip ahead @n@ bytes. Fails if fewer than @n@ bytes are available. skip :: Int -> Get r () skip n = readN (fromIntegral n) (const ())@@ -140,22 +251,22 @@ -- | Get the total number of bytes read to this point. bytesRead :: Get r Int bytesRead = do-  S _ b <- get+  S _ b _ _ <- get   return b  -- | Get the number of remaining unparsed bytes. -- Useful for checking whether all input has been consumed. remaining :: Get r Int remaining = do-  S s _ <- get-  return (fromIntegral (B.length s))+  S s _ _ _<- get+  return (fromIntegral (BL.length s))  -- | Test whether all input has been consumed, -- i.e. there are no remaining unparsed bytes. isEmpty :: Get r Bool isEmpty = do-  S s _ <- get-  return $ B.null s+  S s _ _ _ <- get+  return $ BL.null s  ------------------------------------------------------------------------ -- Utility with ByteStrings@@ -166,13 +277,18 @@ getByteString n = readN n id {-# INLINE getByteString #-} +-- | Yield a partial and get more data+suspend :: Get r ()+suspend = Get $ \(S lb i adds failDepth) k ->+  IPartial (\s -> k () (S (BL.append lb $ strictToLazy s) i (s : adds) failDepth))+ -- | Pull @n@ bytes from the input, as a strict ByteString. getBytes :: Int -> Get r B.ByteString-getBytes n = Get $ \(S s offset) -> \cont ->-  if n <= B.length s-     then let (consume, rest) = B.splitAt n s-           in cont consume $ S rest (offset + fromIntegral n)-     else Partial (\s' -> unGet (getBytes n) (S (B.append s s') offset) cont)+getBytes n = Get $ \(S s offset adds failDepth) -> \cont ->+  if fromIntegral n <= BL.length s+     then let (consume, rest) = BL.splitAt (fromIntegral n) s+           in cont (lazyToStrict consume) $ S rest (offset + fromIntegral n) adds failDepth+     else IPartial (\s' -> unGet (getBytes n) (S (BL.append s $ strictToLazy s') offset (s' : adds) failDepth) cont) {-# INLINE getBytes #-}  -- Pull n bytes from the input, and apply a parser to those bytes,@@ -190,6 +306,16 @@  GETWORDS(Get r, getBytes) GETHOSTWORDS(Get r)++spanOf :: (Word8 -> Bool) -> Get r B.ByteString+spanOf p =+  Get $ \(S lb i adds failDepth) k ->+    let+      (left, rest) = BL.span p lb+    in+      if BL.null rest+         then IPartial (\s -> unGet (spanOf p) (S (strictToLazy s) (i + (fromIntegral $ BL.length lb)) (s : adds) failDepth) (\a -> k $ B.append (lazyToStrict left) a))+         else k (lazyToStrict left) (S rest (i + (fromIntegral $ BL.length left)) adds failDepth)  shiftl_w16 :: Word16 -> Int -> Word16 shiftl_w32 :: Word32 -> Int -> Word32