git.iko.soy/binary-bits
on master help sign in
Comment out the R structure, only monads left
1467419Lennart Kolmodin
BitsGet.hs+87−83
compare with master
unifiedsplit
@@ -1,10 +1,10 @@
1{-# LANGUAGE GADTs, RankNTypes, MagicHash, CPP #-}
1{-# LANGUAGE GADTs, RankNTypes, MagicHash, CPP #-}
2
2
3module BitsGet
3module BitsGet
4− ( R(..)
4+ ( -- R(..),
5− , T(..)
5+ T(..)
6− , get
6+ -- , get
7− , getR
7+ -- , getR
8 , readBool
8 , readBool
9 , readWord8
9 , readWord8
10 , readWord16be
10 , readWord16be
@@ -37,91 +37,12 @@ import GHC.Word
37import GHC.Int
37import GHC.Int
38#endif
38#endif
39
39
40−data R a where
41− RBool :: R Bool
42− RWord8 :: Int -> R Word8
43− RWord16be :: Int -> R Word16
44− RWord32be :: Int -> R Word32
45− RByteString :: Int -> R ByteString
46− RThis :: a -> R a
47− RNextTo :: R a -> R b -> R (T a b)
48− RMap :: R b -> (b -> R a) -> R a
49− RMapPure :: R a -> (a -> b) -> R b
50− RList :: Int -> R a -> R [a]
51− RCheck :: R a -> (a -> Bool) -> String -> R a
52−
53data T a b = !a :*: !b deriving (Show)
40data T a b = !a :*: !b deriving (Show)
54
41
55−instance Functor R where
56− fmap f m = RMapPure m f
57−
58−instance Show (R a) where
59− show r = case r of
60− RBool -> "Bool"
61−
62−size_in_bits :: forall a. R a -- ^ The record
63− -> Int -- ^ Number of bits
64−size_in_bits r = case r of
65− RBool -> 1
66− RWord8 n -> min n 8
67− RWord16be n -> min n 16
68− RWord32be n -> min n 16
69− RByteString n -> 8 * n
70− RThis _ -> 0
71− RList n r -> n * size_in_bits r
72− RMap r _ -> size_in_bits r
73− RMapPure r _ -> size_in_bits r
74− RCheck r _ _ -> size_in_bits r
75− RNextTo a b -> size_in_bits a + size_in_bits b
76−
77data S = S !ByteString -- ^ Input
42data S = S !ByteString -- ^ Input
78 !Int -- ^ Bit offset (0-7)
43 !Int -- ^ Bit offset (0-7)
79 deriving (Show)
44 deriving (Show)
80
45
81−size_in_bytes :: forall a. R a
82− -> Int
83−size_in_bytes r = byte_offset (size_in_bits r + 7)
84−
85−get :: R a -> Get a
86−get r = do
87− bs <- getByteString (size_in_bytes r)
88− a :*: s <- getR (S bs 0) r
89− return a
90−
91−getR :: S -> R a -> Get (T a S)
92−getR s0 r = do
93− case r of
94− RBool -> return (readBool s0)
95− RWord8 n -> return (readWord8 s0 n)
96− RWord16be n -> return (readWord16be s0 n)
97− RWord32be n -> return (readWord32be s0 n)
98− RByteString n -> return (readByteString s0 n)
99− RThis x -> return (x :*: s0)
100− RNextTo a b -> do
101− t :*: s <- getR s0 a
102− u :*: s' <- getR s b
103− return (t:*:u:*:s')
104− RMap r p -> do
105− a :*: s@(S bs o) <- getR s0 r
106− let codepath = p a
107− required_bytes = byte_offset (size_in_bits r - o)
108− bs' <- getByteString required_bytes
109− getR (S (bs `append` bs') o) codepath
110− RMapPure r f -> do
111− a :*: s <- getR s0 r
112− return (f a :*: s)
113− RList n r ->
114− let loop 0 s acc = return (List.reverse acc :*: s)
115− loop m s acc = do
116− a :*: s' <- getR s r
117− loop (m-1) s' (a:acc)
118− in loop n s0 []
119− RCheck r c m -> do
120− a :*: s <- getR s0 r
121− if c a
122− then return (a :*: s)
123− else fail m
124−
125-- make_mask 3 = 00000111
46-- make_mask 3 = 00000111
126make_mask :: Bits a => Int -> a
47make_mask :: Bits a => Int -> a
127make_mask n = (1 `shiftL` fromIntegral n) - 1
48make_mask n = (1 `shiftL` fromIntegral n) - 1
@@ -388,3 +309,86 @@ shiftr_w16 = shiftR
388shiftr_w32 = shiftR
309shiftr_w32 = shiftR
389shiftr_w64 = shiftR
310shiftr_w64 = shiftR
390#endif
311#endif
312+
313+{-
314+data R a where
315+ RBool :: R Bool
316+ RWord8 :: Int -> R Word8
317+ RWord16be :: Int -> R Word16
318+ RWord32be :: Int -> R Word32
319+ RByteString :: Int -> R ByteString
320+ RThis :: a -> R a
321+ RNextTo :: R a -> R b -> R (T a b)
322+ RMap :: R b -> (b -> R a) -> R a
323+ RMapPure :: R a -> (a -> b) -> R b
324+ RList :: Int -> R a -> R [a]
325+ RCheck :: R a -> (a -> Bool) -> String -> R a
326+
327+instance Functor R where
328+ fmap f m = RMapPure m f
329+
330+instance Show (R a) where
331+ show r = case r of
332+ RBool -> "Bool"
333+
334+size_in_bits :: forall a. R a -- ^ The record
335+ -> Int -- ^ Number of bits
336+size_in_bits r = case r of
337+ RBool -> 1
338+ RWord8 n -> min n 8
339+ RWord16be n -> min n 16
340+ RWord32be n -> min n 16
341+ RByteString n -> 8 * n
342+ RThis _ -> 0
343+ RList n r -> n * size_in_bits r
344+ RMap r _ -> size_in_bits r
345+ RMapPure r _ -> size_in_bits r
346+ RCheck r _ _ -> size_in_bits r
347+ RNextTo a b -> size_in_bits a + size_in_bits b
348+
349+size_in_bytes :: forall a. R a
350+ -> Int
351+size_in_bytes r = byte_offset (size_in_bits r + 7)
352+
353+get :: R a -> Get a
354+get r = do
355+ bs <- getByteString (size_in_bytes r)
356+ a :*: s <- getR (S bs 0) r
357+ return a
358+
359+getR :: S -> R a -> Get (T a S)
360+getR s0 r = do
361+ case r of
362+ RBool -> return (readBool s0)
363+ RWord8 n -> return (readWord8 s0 n)
364+ RWord16be n -> return (readWord16be s0 n)
365+ RWord32be n -> return (readWord32be s0 n)
366+ RByteString n -> return (readByteString s0 n)
367+ RThis x -> return (x :*: s0)
368+ RNextTo a b -> do
369+ t :*: s <- getR s0 a
370+ u :*: s' <- getR s b
371+ return (t:*:u:*:s')
372+ RMap r p -> do
373+ a :*: s@(S bs o) <- getR s0 r
374+ let codepath = p a
375+ required_bytes = byte_offset (size_in_bits r - o)
376+ bs' <- getByteString required_bytes
377+ getR (S (bs `append` bs') o) codepath
378+ RMapPure r f -> do
379+ a :*: s <- getR s0 r
380+ return (f a :*: s)
381+ RList n r ->
382+ let loop 0 s acc = return (List.reverse acc :*: s)
383+ loop m s acc = do
384+ a :*: s' <- getR s r
385+ loop (m-1) s' (a:acc)
386+ in loop n s0 []
387+ RCheck r c m -> do
388+ a :*: s <- getR s0 r
389+ if c a
390+ then return (a :*: s)
391+ else fail m
392+-}
393+
394+
BitsPut.hs+2−2
@@ -8,7 +8,7 @@ module BitsPut
8import qualified Data.Binary.Builder as B
8import qualified Data.Binary.Builder as B
9import Data.Binary.Builder ( Builder )
9import Data.Binary.Builder ( Builder )
10import qualified Data.Binary.Put as Put
10import qualified Data.Binary.Put as Put
11−import Data.ByteString
11+import Data.ByteString
12
12
13import Data.Bits
13import Data.Bits
14import Data.Monoid
14import Data.Monoid
@@ -63,4 +63,4 @@ instance Monad BitPut where
63 let PairS a s' = run m s
63 let PairS a s' = run m s
64 PairS b s'' = run (k a) s'
64 PairS b s'' = run (k a) s'
65 in PairS b s''
65 in PairS b s''
66− return x = BitPut $ \s -> PairS x s
66+ return x = BitPut $ \s -> PairS x s
BitsQC.hs+23−17
@@ -14,26 +14,17 @@ import qualified BitsPut as BP
14import Test.QuickCheck
14import Test.QuickCheck
15
15
16main = do
16main = do
17− quickCheck prop_Word16be_with_offset
18− quickCheck prop_Word16be_list
19− quickCheck prop_SimpleCase
20− quickCheck prop_Word32_from_2_Word16
21− quickCheck prop_Word32_from_Word8_and_Word16
22 quickCheck prop_Bools
17 quickCheck prop_Bools
23 quickCheck prop_Word8_putget
18 quickCheck prop_Word8_putget
24
19
25−prop_SimpleCase :: Word16 -> Property
20+ -- these tests use the R structure
26−prop_SimpleCase w = w < 0x8000 ==>
21+ --
27− let p = RMap RBool $ \v -> case v of
22+ -- quickCheck prop_Word16be_with_offset
28− True -> RWord16be 15
23+ -- quickCheck prop_Word16be_list
29− False -> RMapPure
24+ -- quickCheck prop_SimpleCase
30− (RWord8 7 `RNextTo` RWord8 8)
25+ -- quickCheck prop_Word32_from_2_Word16
31− (\(msb:*:lsb)-> (fromIntegral msb `shiftL` 8) .|. fromIntegral lsb)
26+ -- quickCheck prop_Word32_from_Word8_and_Word16
32− w' = runGet (get p) lbs
27+
33− in w == w'
34− where
35− lbs = runPut (putWord16be w)
36−
37prop_Word8_putget :: [Word8] -> Property
28prop_Word8_putget :: [Word8] -> Property
38prop_Word8_putget ws = length ws <= fromIntegral (maxBound :: Word8) ==>
29prop_Word8_putget ws = length ws <= fromIntegral (maxBound :: Word8) ==>
39 -- write all word8s with as many bits as it's required
30 -- write all word8s with as many bits as it's required
@@ -56,6 +47,20 @@ prop_Bools bs = property $
56 in bs == bs'
47 in bs == bs'
57 where lbs = runPut $ BP.runBitPut (mapM_ BP.putBool bs)
48 where lbs = runPut $ BP.runBitPut (mapM_ BP.putBool bs)
58
49
50+
51+{-
52+prop_SimpleCase :: Word16 -> Property
53+prop_SimpleCase w = w < 0x8000 ==>
54+ let p = RMap RBool $ \v -> case v of
55+ True -> RWord16be 15
56+ False -> RMapPure
57+ (RWord8 7 `RNextTo` RWord8 8)
58+ (\(msb:*:lsb)-> (fromIntegral msb `shiftL` 8) .|. fromIntegral lsb)
59+ w' = runGet (get p) lbs
60+ in w == w'
61+ where
62+ lbs = runPut (putWord16be w)
63+
59prop_Word16be_with_offset :: Word16 -> Property
64prop_Word16be_with_offset :: Word16 -> Property
60prop_Word16be_with_offset w = w < 0x8000 ==>
65prop_Word16be_with_offset w = w < 0x8000 ==>
61 let b :*: w' :*: w'' = runGet (get (RCheck RBool not "fail" `RNextTo` RWord16be 15 `RNextTo` RWord16be 16)) lbs
66 let b :*: w' :*: w'' = runGet (get (RCheck RBool not "fail" `RNextTo` RWord16be 15 `RNextTo` RWord16be 16)) lbs
@@ -88,6 +93,7 @@ prop_Word32_from_2_Word16 w1 w2 = property $
88 where
93 where
89 lbs = encode w0
94 lbs = encode w0
90 w0 = ((fromIntegral w1) `shiftL` 16) .|. fromIntegral w2
95 w0 = ((fromIntegral w1) `shiftL` 16) .|. fromIntegral w2
96+-}
91
97
92instance Arbitrary Word8 where
98instance Arbitrary Word8 where
93 arbitrary = choose (minBound, maxBound)
99 arbitrary = choose (minBound, maxBound)