git.iko.soy/binary-bits
on master help sign in
Implement joinGet and joinPut

Allows to run the regular binary monads within the bitlevel monads.

commit4d12f0ba1b63567be242f2a642a4d7ad5832c44c authorLennart Kolmodin <kolmodin@gentoo.org> dateFri 27 Aug 2010, 17:04 (16 years ago) parent554c906
2 files changed+30−3
compare with master
unifiedsplit
BitsGet.hs+14 BitsPut.hs+16−3
BitsGet.hs+14
@@ -5,6 +5,8 @@ module BitsGet
55 , runBitGet
66 , runBitGetSimple
77 , BitGet
8+ , joinGet
9+
810 , getBool
911 , getWord8
1012 , getWord16be
@@ -65,6 +67,18 @@ incS (S bs n) o =
6567 let (d,n') = divMod (n+o) 8
6668 in S (unsafeDrop d bs) n'
6769
70+joinGet :: Get a -> BitGet a
71+joinGet m = C $ \s@(S bs o) kf ks -> do
72+ -- put back the rest of the current chunk
73+ case o of
74+ 0 -> putS bs
75+ _ -> putS (unsafeTail bs)
76+ -- run the get function
77+ a <- m
78+ -- whatever is left, get it and us it as our state
79+ bs' <- getS
80+ let s' = S bs' 0
81+ ks s' a
6882
6983readByteString :: S -> Int -> T ByteString S
7084readByteString s@(S bs o) n
BitsPut.hs+16−3
@@ -1,6 +1,7 @@
11module BitsPut
22 ( BitPut
33 , runBitPut
4+ , joinPut
45
56 , putBool
67 , putWord8
@@ -12,6 +13,8 @@ module BitsPut
1213import qualified Data.Binary.Builder as B
1314import Data.Binary.Builder ( Builder )
1415import qualified Data.Binary.Put as Put
16+import Data.Binary.Put ( Put )
17+
1518import Data.ByteString
1619
1720import Data.Bits
@@ -74,18 +77,28 @@ putWord64be :: Int -> Word64 -> BitPut ()
7477putWord64be n w
7578 | n <= 16 = putWord16be n (fromIntegral w)
7679
80+joinPut :: Put -> BitPut ()
81+joinPut m = BitPut $ \s0 -> PairS () $
82+ let (S b0 _ _) = flushIncomplete s0
83+ b = Put.execPut m
84+ in (S (b0`mappend`b) 0 0)
85+
7786flush :: S -> S
7887flush s@(S b w o)
7988 | o > 8 = error "flush: offset > 8"
8089 | o == 8 = S (b `mappend` B.singleton w) 0 0
8190 | otherwise = s
8291
92+flushIncomplete :: S -> S
93+flushIncomplete s@(S b w o)
94+ | o == 0 = s
95+ | otherwise = (S (b `mappend` B.singleton w) 0 0)
96+
8397runBitPut :: BitPut () -> Put.Put
8498runBitPut m = Put.putBuilder b'
8599 where
86− PairS _ (S b t o) = run m (S mempty 0 0)
87− b' | o == 0 = b
88− | otherwise = b `mappend` B.singleton t
100+ PairS _ s@(S b t o) = run m (S mempty 0 0)
101+ (S b' _ _) = flushIncomplete s
89102
90103instance Monad BitPut where
91104 m >>= k = BitPut $ \s ->