git.iko.soy/binary-bits
on master help sign in
Add bit order in put
8d44be0Sylvain HENRY
Data/Binary/Bits/Put.hs+33−32
compare with master
unifiedsplit
@@ -36,6 +36,7 @@ import Data.Binary.Builder ( Builder )
36import qualified Data.Binary.Put as Put
36import qualified Data.Binary.Put as Put
37import Data.Binary.Put ( Put )
37import Data.Binary.Put ( Put )
38import Data.Binary.Bits.Internal
38import Data.Binary.Bits.Internal
39+import Data.Binary.Bits.BitOrder
39
40
40import Data.ByteString
41import Data.ByteString
41
42
@@ -48,7 +49,7 @@ data BitPut a = BitPut { run :: (S -> PairS a) }
48
49
49data PairS a = PairS a {-# UNPACK #-} !S
50data PairS a = PairS a {-# UNPACK #-} !S
50
51
51−data S = S !Builder !Word8 !Int
52+data S = S !Builder !Word8 !Int !BitOrder
52
53
53-- | Put a 1 bit 'Bool'.
54-- | Put a 1 bit 'Bool'.
54putBool :: Bool -> BitPut ()
55putBool :: Bool -> BitPut ()
@@ -60,16 +61,16 @@ putWord8 :: Int -> Word8 -> BitPut ()
60putWord8 n w = BitPut $ \s -> PairS () $
61putWord8 n w = BitPut $ \s -> PairS () $
61 let w' = make_mask n .&. w in
62 let w' = make_mask n .&. w in
62 case s of
63 case s of
63− -- a whole word8, no offset
64+ -- a whole word8, no offset
64− (S b t o) | n == 8 && o == 0 -> flush $ S b w n
65+ (S b t o bo) | n == 8 && o == 0 -> flush $ S b w n bo
65− -- less than a word8, will fit in the current word8
66+ -- less than a word8, will fit in the current word8
66− | n <= 8 - o -> flush $ S b (t .|. (w' `shiftL` (8 - n - o))) (o+n)
67+ | n <= 8 - o -> flush $ S b (t .|. (w' `shiftL` (8 - n - o))) (o+n) bo
67− -- will finish this word8, and spill into the next one
68+ -- will finish this word8, and spill into the next one
68− | otherwise -> flush $
69+ | otherwise -> flush $
69− let o' = o + n - 8
70+ let o' = o + n - 8
70− b' = t .|. (w' `shiftR` o')
71+ b' = t .|. (w' `shiftR` o')
71− t' = w `shiftL` (8 - o')
72+ t' = w `shiftL` (8 - o')
72− in S (b `mappend` B.singleton b') t' o'
73+ in S (b `mappend` B.singleton b') t' o' bo
73
74
74-- | Put the @n@ lower bits of a 'Word16'.
75-- | Put the @n@ lower bits of a 'Word16'.
75putWord16be :: Int -> Word16 -> BitPut ()
76putWord16be :: Int -> Word16 -> BitPut ()
@@ -82,18 +83,18 @@ putWord16be n w
82 -- as n>=9, it's too big to fit into one single byte
83 -- as n>=9, it's too big to fit into one single byte
83 -- it'll either use 2 or 3 bytes
84 -- it'll either use 2 or 3 bytes
84 -- it'll fit in 2 bytes
85 -- it'll fit in 2 bytes
85− (S b t o) | o + n <= 16 -> flush $
86+ (S b t o bo) | o + n <= 16 -> flush $
86− let o' = o + n - 8
87+ let o' = o + n - 8
87− b' = t .|. fromIntegral (w' `shiftR` o')
88+ b' = t .|. fromIntegral (w' `shiftR` o')
88− t' = fromIntegral (w `shiftL` (8-o'))
89+ t' = fromIntegral (w `shiftL` (8-o'))
89− in (S (b `mappend` B.singleton b') t' o')
90+ in (S (b `mappend` B.singleton b') t' o' bo)
90− -- 3 bytes required
91+ -- 3 bytes required
91− | otherwise -> flush $
92+ | otherwise -> flush $
92− let o' = o + n - 16
93+ let o' = o + n - 16
93− b' = t .|. fromIntegral (w' `shiftR` (o' + 8))
94+ b' = t .|. fromIntegral (w' `shiftR` (o' + 8))
94− b'' = fromIntegral ((w `shiftR` o') .&. 0xff)
95+ b'' = fromIntegral ((w `shiftR` o') .&. 0xff)
95− t' = fromIntegral (w `shiftL` (8-o'))
96+ t' = fromIntegral (w `shiftL` (8-o'))
96− in (S (b `mappend` B.singleton b' `mappend` B.singleton b'') t' o')
97+ in (S (b `mappend` B.singleton b' `mappend` B.singleton b'') t' o' bo)
97
98
98-- | Put the @n@ lower bits of a 'Word32'.
99-- | Put the @n@ lower bits of a 'Word32'.
99putWord32be :: Int -> Word32 -> BitPut ()
100putWord32be :: Int -> Word32 -> BitPut ()
@@ -119,33 +120,33 @@ putByteString bs = do
119 then mapM_ (putWord8 8) (unpack bs) -- naive
120 then mapM_ (putWord8 8) (unpack bs) -- naive
120 else joinPut (Put.putByteString bs)
121 else joinPut (Put.putByteString bs)
121 where
122 where
122− hasOffset = BitPut $ \ s@(S _ _ o) -> PairS (o /= 0) s
123+ hasOffset = BitPut $ \ s@(S _ _ o _) -> PairS (o /= 0) s
123
124
124-- | Run a 'Put' inside 'BitPut'. Any partially written bytes will be flushed
125-- | Run a 'Put' inside 'BitPut'. Any partially written bytes will be flushed
125-- before 'Put' executes to ensure byte alignment.
126-- before 'Put' executes to ensure byte alignment.
126joinPut :: Put -> BitPut ()
127joinPut :: Put -> BitPut ()
127joinPut m = BitPut $ \s0 -> PairS () $
128joinPut m = BitPut $ \s0 -> PairS () $
128− let (S b0 _ _) = flushIncomplete s0
129+ let (S b0 _ _ bo) = flushIncomplete s0
129 b = Put.execPut m
130 b = Put.execPut m
130− in (S (b0`mappend`b) 0 0)
131+ in (S (b0`mappend`b) 0 0 bo)
131
132
132flush :: S -> S
133flush :: S -> S
133−flush s@(S b w o)
134+flush s@(S b w o bo)
134 | o > 8 = error "flush: offset > 8"
135 | o > 8 = error "flush: offset > 8"
135− | o == 8 = S (b `mappend` B.singleton w) 0 0
136+ | o == 8 = S (b `mappend` B.singleton w) 0 0 bo
136 | otherwise = s
137 | otherwise = s
137
138
138flushIncomplete :: S -> S
139flushIncomplete :: S -> S
139−flushIncomplete s@(S b w o)
140+flushIncomplete s@(S b w o bo)
140 | o == 0 = s
141 | o == 0 = s
141− | otherwise = (S (b `mappend` B.singleton w) 0 0)
142+ | otherwise = (S (b `mappend` B.singleton w) 0 0 bo)
142
143
143-- | Run the 'BitPut' monad inside 'Put'.
144-- | Run the 'BitPut' monad inside 'Put'.
144runBitPut :: BitPut () -> Put.Put
145runBitPut :: BitPut () -> Put.Put
145runBitPut m = Put.putBuilder b
146runBitPut m = Put.putBuilder b
146 where
147 where
147− PairS _ s = run m (S mempty 0 0)
148+ PairS _ s = run m (S mempty 0 0 BB)
148− (S b _ _) = flushIncomplete s
149+ (S b _ _ _) = flushIncomplete s
149
150
150instance Functor BitPut where
151instance Functor BitPut where
151 fmap f (BitPut k) = BitPut $ \s ->
152 fmap f (BitPut k) = BitPut $ \s ->