mirror of
https://github.com/ilyakooo0/binary-bits.git
synced 2024-09-11 06:35:26 +03:00
Comment out the R structure, only monads left
This commit is contained in:
parent
4556008a65
commit
1467419c82
170
BitsGet.hs
170
BitsGet.hs
@ -1,10 +1,10 @@
|
||||
{-# LANGUAGE GADTs, RankNTypes, MagicHash, CPP #-}
|
||||
|
||||
module BitsGet
|
||||
( R(..)
|
||||
, T(..)
|
||||
, get
|
||||
, getR
|
||||
( -- R(..),
|
||||
T(..)
|
||||
-- , get
|
||||
-- , getR
|
||||
, readBool
|
||||
, readWord8
|
||||
, readWord16be
|
||||
@ -37,91 +37,12 @@ import GHC.Word
|
||||
import GHC.Int
|
||||
#endif
|
||||
|
||||
data R a where
|
||||
RBool :: R Bool
|
||||
RWord8 :: Int -> R Word8
|
||||
RWord16be :: Int -> R Word16
|
||||
RWord32be :: Int -> R Word32
|
||||
RByteString :: Int -> R ByteString
|
||||
RThis :: a -> R a
|
||||
RNextTo :: R a -> R b -> R (T a b)
|
||||
RMap :: R b -> (b -> R a) -> R a
|
||||
RMapPure :: R a -> (a -> b) -> R b
|
||||
RList :: Int -> R a -> R [a]
|
||||
RCheck :: R a -> (a -> Bool) -> String -> R a
|
||||
|
||||
data T a b = !a :*: !b deriving (Show)
|
||||
|
||||
instance Functor R where
|
||||
fmap f m = RMapPure m f
|
||||
|
||||
instance Show (R a) where
|
||||
show r = case r of
|
||||
RBool -> "Bool"
|
||||
|
||||
size_in_bits :: forall a. R a -- ^ The record
|
||||
-> Int -- ^ Number of bits
|
||||
size_in_bits r = case r of
|
||||
RBool -> 1
|
||||
RWord8 n -> min n 8
|
||||
RWord16be n -> min n 16
|
||||
RWord32be n -> min n 16
|
||||
RByteString n -> 8 * n
|
||||
RThis _ -> 0
|
||||
RList n r -> n * size_in_bits r
|
||||
RMap r _ -> size_in_bits r
|
||||
RMapPure r _ -> size_in_bits r
|
||||
RCheck r _ _ -> size_in_bits r
|
||||
RNextTo a b -> size_in_bits a + size_in_bits b
|
||||
|
||||
data S = S !ByteString -- ^ Input
|
||||
!Int -- ^ Bit offset (0-7)
|
||||
deriving (Show)
|
||||
|
||||
size_in_bytes :: forall a. R a
|
||||
-> Int
|
||||
size_in_bytes r = byte_offset (size_in_bits r + 7)
|
||||
|
||||
get :: R a -> Get a
|
||||
get r = do
|
||||
bs <- getByteString (size_in_bytes r)
|
||||
a :*: s <- getR (S bs 0) r
|
||||
return a
|
||||
|
||||
getR :: S -> R a -> Get (T a S)
|
||||
getR s0 r = do
|
||||
case r of
|
||||
RBool -> return (readBool s0)
|
||||
RWord8 n -> return (readWord8 s0 n)
|
||||
RWord16be n -> return (readWord16be s0 n)
|
||||
RWord32be n -> return (readWord32be s0 n)
|
||||
RByteString n -> return (readByteString s0 n)
|
||||
RThis x -> return (x :*: s0)
|
||||
RNextTo a b -> do
|
||||
t :*: s <- getR s0 a
|
||||
u :*: s' <- getR s b
|
||||
return (t:*:u:*:s')
|
||||
RMap r p -> do
|
||||
a :*: s@(S bs o) <- getR s0 r
|
||||
let codepath = p a
|
||||
required_bytes = byte_offset (size_in_bits r - o)
|
||||
bs' <- getByteString required_bytes
|
||||
getR (S (bs `append` bs') o) codepath
|
||||
RMapPure r f -> do
|
||||
a :*: s <- getR s0 r
|
||||
return (f a :*: s)
|
||||
RList n r ->
|
||||
let loop 0 s acc = return (List.reverse acc :*: s)
|
||||
loop m s acc = do
|
||||
a :*: s' <- getR s r
|
||||
loop (m-1) s' (a:acc)
|
||||
in loop n s0 []
|
||||
RCheck r c m -> do
|
||||
a :*: s <- getR s0 r
|
||||
if c a
|
||||
then return (a :*: s)
|
||||
else fail m
|
||||
|
||||
-- make_mask 3 = 00000111
|
||||
make_mask :: Bits a => Int -> a
|
||||
make_mask n = (1 `shiftL` fromIntegral n) - 1
|
||||
@ -388,3 +309,86 @@ shiftr_w16 = shiftR
|
||||
shiftr_w32 = shiftR
|
||||
shiftr_w64 = shiftR
|
||||
#endif
|
||||
|
||||
{-
|
||||
data R a where
|
||||
RBool :: R Bool
|
||||
RWord8 :: Int -> R Word8
|
||||
RWord16be :: Int -> R Word16
|
||||
RWord32be :: Int -> R Word32
|
||||
RByteString :: Int -> R ByteString
|
||||
RThis :: a -> R a
|
||||
RNextTo :: R a -> R b -> R (T a b)
|
||||
RMap :: R b -> (b -> R a) -> R a
|
||||
RMapPure :: R a -> (a -> b) -> R b
|
||||
RList :: Int -> R a -> R [a]
|
||||
RCheck :: R a -> (a -> Bool) -> String -> R a
|
||||
|
||||
instance Functor R where
|
||||
fmap f m = RMapPure m f
|
||||
|
||||
instance Show (R a) where
|
||||
show r = case r of
|
||||
RBool -> "Bool"
|
||||
|
||||
size_in_bits :: forall a. R a -- ^ The record
|
||||
-> Int -- ^ Number of bits
|
||||
size_in_bits r = case r of
|
||||
RBool -> 1
|
||||
RWord8 n -> min n 8
|
||||
RWord16be n -> min n 16
|
||||
RWord32be n -> min n 16
|
||||
RByteString n -> 8 * n
|
||||
RThis _ -> 0
|
||||
RList n r -> n * size_in_bits r
|
||||
RMap r _ -> size_in_bits r
|
||||
RMapPure r _ -> size_in_bits r
|
||||
RCheck r _ _ -> size_in_bits r
|
||||
RNextTo a b -> size_in_bits a + size_in_bits b
|
||||
|
||||
size_in_bytes :: forall a. R a
|
||||
-> Int
|
||||
size_in_bytes r = byte_offset (size_in_bits r + 7)
|
||||
|
||||
get :: R a -> Get a
|
||||
get r = do
|
||||
bs <- getByteString (size_in_bytes r)
|
||||
a :*: s <- getR (S bs 0) r
|
||||
return a
|
||||
|
||||
getR :: S -> R a -> Get (T a S)
|
||||
getR s0 r = do
|
||||
case r of
|
||||
RBool -> return (readBool s0)
|
||||
RWord8 n -> return (readWord8 s0 n)
|
||||
RWord16be n -> return (readWord16be s0 n)
|
||||
RWord32be n -> return (readWord32be s0 n)
|
||||
RByteString n -> return (readByteString s0 n)
|
||||
RThis x -> return (x :*: s0)
|
||||
RNextTo a b -> do
|
||||
t :*: s <- getR s0 a
|
||||
u :*: s' <- getR s b
|
||||
return (t:*:u:*:s')
|
||||
RMap r p -> do
|
||||
a :*: s@(S bs o) <- getR s0 r
|
||||
let codepath = p a
|
||||
required_bytes = byte_offset (size_in_bits r - o)
|
||||
bs' <- getByteString required_bytes
|
||||
getR (S (bs `append` bs') o) codepath
|
||||
RMapPure r f -> do
|
||||
a :*: s <- getR s0 r
|
||||
return (f a :*: s)
|
||||
RList n r ->
|
||||
let loop 0 s acc = return (List.reverse acc :*: s)
|
||||
loop m s acc = do
|
||||
a :*: s' <- getR s r
|
||||
loop (m-1) s' (a:acc)
|
||||
in loop n s0 []
|
||||
RCheck r c m -> do
|
||||
a :*: s <- getR s0 r
|
||||
if c a
|
||||
then return (a :*: s)
|
||||
else fail m
|
||||
-}
|
||||
|
||||
|
||||
|
@ -8,7 +8,7 @@ module BitsPut
|
||||
import qualified Data.Binary.Builder as B
|
||||
import Data.Binary.Builder ( Builder )
|
||||
import qualified Data.Binary.Put as Put
|
||||
import Data.ByteString
|
||||
import Data.ByteString
|
||||
|
||||
import Data.Bits
|
||||
import Data.Monoid
|
||||
@ -63,4 +63,4 @@ instance Monad BitPut where
|
||||
let PairS a s' = run m s
|
||||
PairS b s'' = run (k a) s'
|
||||
in PairS b s''
|
||||
return x = BitPut $ \s -> PairS x s
|
||||
return x = BitPut $ \s -> PairS x s
|
||||
|
40
BitsQC.hs
40
BitsQC.hs
@ -14,26 +14,17 @@ import qualified BitsPut as BP
|
||||
import Test.QuickCheck
|
||||
|
||||
main = do
|
||||
quickCheck prop_Word16be_with_offset
|
||||
quickCheck prop_Word16be_list
|
||||
quickCheck prop_SimpleCase
|
||||
quickCheck prop_Word32_from_2_Word16
|
||||
quickCheck prop_Word32_from_Word8_and_Word16
|
||||
quickCheck prop_Bools
|
||||
quickCheck prop_Word8_putget
|
||||
|
||||
prop_SimpleCase :: Word16 -> Property
|
||||
prop_SimpleCase w = w < 0x8000 ==>
|
||||
let p = RMap RBool $ \v -> case v of
|
||||
True -> RWord16be 15
|
||||
False -> RMapPure
|
||||
(RWord8 7 `RNextTo` RWord8 8)
|
||||
(\(msb:*:lsb)-> (fromIntegral msb `shiftL` 8) .|. fromIntegral lsb)
|
||||
w' = runGet (get p) lbs
|
||||
in w == w'
|
||||
where
|
||||
lbs = runPut (putWord16be w)
|
||||
|
||||
-- these tests use the R structure
|
||||
--
|
||||
-- quickCheck prop_Word16be_with_offset
|
||||
-- quickCheck prop_Word16be_list
|
||||
-- quickCheck prop_SimpleCase
|
||||
-- quickCheck prop_Word32_from_2_Word16
|
||||
-- quickCheck prop_Word32_from_Word8_and_Word16
|
||||
|
||||
prop_Word8_putget :: [Word8] -> Property
|
||||
prop_Word8_putget ws = length ws <= fromIntegral (maxBound :: Word8) ==>
|
||||
-- write all word8s with as many bits as it's required
|
||||
@ -56,6 +47,20 @@ prop_Bools bs = property $
|
||||
in bs == bs'
|
||||
where lbs = runPut $ BP.runBitPut (mapM_ BP.putBool bs)
|
||||
|
||||
|
||||
{-
|
||||
prop_SimpleCase :: Word16 -> Property
|
||||
prop_SimpleCase w = w < 0x8000 ==>
|
||||
let p = RMap RBool $ \v -> case v of
|
||||
True -> RWord16be 15
|
||||
False -> RMapPure
|
||||
(RWord8 7 `RNextTo` RWord8 8)
|
||||
(\(msb:*:lsb)-> (fromIntegral msb `shiftL` 8) .|. fromIntegral lsb)
|
||||
w' = runGet (get p) lbs
|
||||
in w == w'
|
||||
where
|
||||
lbs = runPut (putWord16be w)
|
||||
|
||||
prop_Word16be_with_offset :: Word16 -> Property
|
||||
prop_Word16be_with_offset w = w < 0x8000 ==>
|
||||
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 $
|
||||
where
|
||||
lbs = encode w0
|
||||
w0 = ((fromIntegral w1) `shiftL` 16) .|. fromIntegral w2
|
||||
-}
|
||||
|
||||
instance Arbitrary Word8 where
|
||||
arbitrary = choose (minBound, maxBound)
|
||||
|
Loading…
Reference in New Issue
Block a user