binary-strict 0.4.6 → 0.4.7

raw patch · 3 files changed

+62/−14 lines, 3 files

Files

• binary-strict.cabal +1/−1
• src/Data/Binary/BitPut.hs +60/−12
• src/Data/Binary/Strict/Class.hs +1/−1

@@ -1,5 +1,5 @@ name:            binary-strict-version:         0.4.6+version:         0.4.7 license:         BSD3 license-file:    LICENSE author:          Lennart Kolmodin <kolmodin@dtek.chalmers.se>

@@ -1,3 +1,4 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module      : Data.Binary.BitPut@@ -19,9 +20,15 @@ ----------------------------------------------------------------------------- module Data.Binary.BitPut   ( BitPut+  , BitPutM+  , BitPutT   , runBitPut+  , runBitPutM+  , runBitPutT   , putBit+  , putBitT   , putNBits+  , putNBitsT   , putBits   , putByteString   , putLeftByteString@@ -29,37 +36,41 @@  import Data.Bits (bitSize, Bits) import Control.Monad+import Control.Monad.Trans+import Control.Monad.Error import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import qualified Data.Binary.BitBuilder as BB -newtype BitPut' a = BitPut' { unPut :: (a, BB.BitBuilder) }+newtype BitPutM a = BitPutM { unPut :: (a, BB.BitBuilder) } -type BitPut = BitPut' ()+type BitPut = BitPutM () -instance Functor BitPut' where-   fmap f m = BitPut' (let (a, w) = unPut m in (f a, w))+instance Functor BitPutM where+   fmap f m = BitPutM (let (a, w) = unPut m in (f a, w)) -instance Monad BitPut' where-   return a = BitPut' (a,BB.empty)-   m >>= k = BitPut' (let (a, w) = unPut m+instance Monad BitPutM where+   return a = BitPutM (a,BB.empty)+   m >>= k = BitPutM (let (a, w) = unPut m                           (b, w') = unPut (k a)                        in (b, w `BB.append` w')) -   m >> k = BitPut' (let (_, w) = unPut m+   m >> k = BitPutM (let (_, w) = unPut m                          (b, w') = unPut k                       in (b, w `BB.append` w'))    {-# INLINE (>>) #-} +newtype BitPutT m a = BitPutT { unPutT :: m (a, BB.BitBuilder) }+ -- | Append a single bit putBit :: Bool -> BitPut-putBit bit = BitPut' ((), BB.singleton bit)+putBit bit = BitPutM ((), BB.singleton bit)  -- | Append the bottom n bits of the given bits value. In the case that more --   bits are requested than the value provides, this acts as if the value --   has as unlimited number of leading 0 bits. putNBits :: (Integral a, Bits a) => Int -> a -> BitPut-putNBits n v = BitPut' ((), BB.fromBits n v)+putNBits n v = BitPutM ((), BB.fromBits n v)  -- | Append a value. Note that this function is undefined for instances of Bits --   which have no fixed bitsize (like Integer)@@ -68,15 +79,52 @@  -- | Append a ByteString putByteString :: B.ByteString -> BitPut-putByteString bs = BitPut' ((), BB.fromByteString (bs, 0))+putByteString bs = BitPutM ((), BB.fromByteString (bs, 0))  -- | Append a left aligned ByteString where ByteString has a partial byte --   with the given number of valid bits, from the MSB downwards. The number --   of such bits must be 0..7. (A normal ByteString, which all bytes full --   would use 0) putLeftByteString :: (B.ByteString, Int) -> BitPut-putLeftByteString bs = BitPut' ((), BB.fromByteString bs)+putLeftByteString bs = BitPutM ((), BB.fromByteString bs)  runBitPut :: BitPut -> BL.ByteString runBitPut m = let (_, w) = unPut m                in BB.toLazyByteString w++runBitPutM :: BitPutM a -> (a, BL.ByteString)+runBitPutM m = let (x, w) = unPut m+               in (x, BB.toLazyByteString w)++instance Monad m => Functor (BitPutT m) where+   fmap f m = BitPutT $ do+      ~(x, w) <- unPutT m+      return (f x, w)++instance Monad m => Monad (BitPutT m) where+   return a = BitPutT $ return (a, BB.empty)+   m >>= k = BitPutT $ do+      ~(a, w) <- unPutT m+      ~(b, w') <- unPutT (k a)+      return (b, w `BB.append` w')++runBitPutT :: Monad m => BitPutT m a -> m (a, BL.ByteString)+runBitPutT m = do+  ~(x, w) <- unPutT m+  return (x, BB.toLazyByteString w)++putBitT :: (Monad m) => Bool -> BitPutT m ()+putBitT bit = BitPutT $ return ((), BB.singleton bit)++putNBitsT :: (Monad m, Integral a, Bits a) => Int -> a -> BitPutT m ()+putNBitsT n v = BitPutT $ return ((), BB.fromBits n v)++instance MonadTrans BitPutT where+   lift m = BitPutT $ do+      a <- m+      return (a, BB.empty)++instance MonadError e m => MonadError e (BitPutT m) where+   throwError = lift . throwError+   m `catchError` h = BitPutT $ do+      unPutT m `catchError` \e -> unPutT (h e)

@@ -4,7 +4,7 @@ --   -fno-monomorphism-restriction is very useful. module Data.Binary.Strict.Class where -import Control.Applicative(Alternative(..))+import Control.Applicative (Alternative, (<|>))  import qualified Data.ByteString as B import Data.Word