-- | This module contains fuctions and templates for building up and breaking
--   down packed bit structures. It's something like Erlang's bit-syntax (or,
--   actually, more like Python's struct module).
--
--   This code uses Data.ByteString which is included in GHC 6.5 and you can
--   get it for 6.4 at <http://www.cse.unsw.edu.au/~dons/fps.html>
module Data.BitSyntax (
  -- * Building bit structures
  -- | The core function here is makeBits, which is a perfectly normal function.
  --   Here's an example which makes a SOCKS4a request header:
  -- @
  --   makeBits [U8 4, U8 1, U16 80, U32 10, NullTerminated \"username\",
  --             NullTerminated \"www.haskell.org\"]
  -- @
  BitBlock(..),
  makeBits,
  -- * Breaking up bit structures
  -- | The main function for this is bitSyn, which is a template function and
  --   so you'll need to run with @-fth@ to enable template haskell
  --   <http://www.haskell.org/th/>.
  --
  --   To expand the function you use the splice command:
  -- @
  --   $(bitSyn [...])
  -- @
  --
  -- The expanded function has type @ByteString -> (...)@ where the elements of
  -- the tuple depend of the argument to bitSyn (that's why it has to be a template
  -- function).
  --
  -- Heres an example, translated from the Erlang manual, which parses an IP header:
  --
  -- @
  -- decodeOptions bs ([_, hlen], _, _, _, _, _, _, _, _, _)
  --   | hlen > 5  = return $ BS.splitAt (fromIntegral ((hlen - 5) * 4)) bs
  --   | otherwise = return (BS.empty, bs)
  -- @
  --
  -- @
  -- ipDecode = $(bitSyn [PackedBits [4, 4], Unsigned 1, Unsigned 2, Unsigned 2,
  --                      PackedBits [3, 13], Unsigned 1, Unsigned 1, Unsigned 2,
  --                      Fixed 4, Fixed 4, Context \'decodeOptions, Rest])
  -- @
  --
  -- @
  -- ipPacket = BS.pack [0x45, 0, 0, 0x34, 0xd8, 0xd2, 0x40, 0, 0x40, 0x06,
  --                     0xa0, 0xca, 0xac, 0x12, 0x68, 0x4d, 0xac, 0x18,
  --                     0x00, 0xaf]
  -- @
  --
  -- This function has several weaknesses compared to the Erlang version: The
  -- elements of the bit structure are not named in place, instead you have to
  -- do a pattern match on the resulting tuple and match up the indexes. The
  -- type system helps in this, but it's still not quite as nice.

  ReadType(..), bitSyn,

  -- I get errors if these aren't exported (Can't find interface-file
  -- declaration for Data.BitSyntax.decodeU16)
  decodeU8, decodeU16, decodeU32, decodeU16LE, decodeU32LE) where

import Language.Haskell.TH.Lib
import Language.Haskell.TH.Syntax

import qualified Data.ByteString as BS
import Data.Char (ord)
import Control.Monad
import Test.QuickCheck (Arbitrary(), arbitrary, Gen())

import Foreign

foreign import ccall unsafe "htonl" htonl :: Word32 -> Word32
foreign import ccall unsafe "htons" htons :: Word16 -> Word16

-- There's no good way to convert to little-endian. The htons functions only
-- convert to big endian and they don't have any little endian friends. So we
-- need to detect which kind of system we are on and act accordingly. We can
-- detect the type of system by seeing if htonl actaully doesn't anything (it's
-- the identity function on big-endian systems, of course). If it doesn't we're
-- on a big-endian system and so need to do the byte-swapping in Haskell because
-- the C functions are no-ops

-- | A native Haskell version of htonl for the case where we need to convert
--   to little-endian on a big-endian system
endianSwitch32 :: Word32 -> Word32
endianSwitch32 :: Word32 -> Word32
endianSwitch32 Word32
a = ((Word32
a Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0xff) Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftL` Int
24) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|.
                   ((Word32
a Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0xff00) Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftL` Int
8) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|.
                   ((Word32
a Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0xff0000) Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftR` Int
8) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|.
                   (Word32
a Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftR` Int
24)

-- | A native Haskell version of htons for the case where we need to convert
--   to little-endian on a big-endian system
endianSwitch16 :: Word16 -> Word16
endianSwitch16 :: Word16 -> Word16
endianSwitch16 Word16
a = ((Word16
a Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.&. Word16
0xff) Word16 -> Int -> Word16
forall a. Bits a => a -> Int -> a
`shiftL` Int
8) Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.|.
                   (Word16
a Word16 -> Int -> Word16
forall a. Bits a => a -> Int -> a
`shiftR` Int
8)

littleEndian32 :: Word32 -> Word32
littleEndian32 :: Word32 -> Word32
littleEndian32 Word32
a = if Word32 -> Word32
htonl Word32
1 Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
1
                     then Word32 -> Word32
endianSwitch32 Word32
a
                     else Word32
a

littleEndian16 :: Word16 -> Word16
littleEndian16 :: Word16 -> Word16
littleEndian16 Word16
a = if Word32 -> Word32
htonl Word32
1 Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
1
                     then Word16 -> Word16
endianSwitch16 Word16
a
                     else Word16
a

data BitBlock = -- | Unsigned 8-bit int
                U8 Int |
                -- | Unsigned 16-bit int
                U16 Int |
                -- | Unsigned 32-bit int
                U32 Int |
                -- | Little-endian, unsigned 16-bit int
                U16LE Int |
                -- | Little-endian, unsigned 32-bit int
                U32LE Int |
                -- | Appends the string with a trailing NUL byte
                NullTerminated String |
                -- | Appends the string without any terminator
                RawString String |
                -- | Appends a ByteString
                RawByteString BS.ByteString |
                -- | Packs a series of bit fields together. The argument is
                --   a list of pairs where the first element is the size
                --   (in bits) and the second is the value. The sum of the
                --   sizes for a given PackBits must be a multiple of 8
                PackBits [(Int, Int)]
                deriving (Int -> BitBlock -> ShowS
[BitBlock] -> ShowS
BitBlock -> String
(Int -> BitBlock -> ShowS)
-> (BitBlock -> String) -> ([BitBlock] -> ShowS) -> Show BitBlock
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BitBlock] -> ShowS
$cshowList :: [BitBlock] -> ShowS
show :: BitBlock -> String
$cshow :: BitBlock -> String
showsPrec :: Int -> BitBlock -> ShowS
$cshowsPrec :: Int -> BitBlock -> ShowS
Show)

-- Encodes a member of the Bits class as a series of bytes and returns the
-- ByteString of those bytes.
getBytes :: (Integral a, Bounded a, Bits a) => a -> BS.ByteString
getBytes :: a -> ByteString
getBytes a
input =
    let getByte :: t -> t -> [a]
getByte t
_ t
0 = []
        getByte t
x t
remaining = (t -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (t -> a) -> t -> a
forall a b. (a -> b) -> a -> b
$ (t
x t -> t -> t
forall a. Bits a => a -> a -> a
.&. t
0xff)) a -> [a] -> [a]
forall a. a -> [a] -> [a]
:
                              t -> t -> [a]
getByte (t -> Int -> t
forall a. Bits a => a -> Int -> a
shiftR t
x Int
8) (t
remaining t -> t -> t
forall a. Num a => a -> a -> a
- t
1)
        in
        if (a -> Int
forall a. Bits a => a -> Int
bitSize a
input Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
8) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0
           then String -> ByteString
forall a. HasCallStack => String -> a
error String
"Input data bit size must be a multiple of 8"
           else [Word8] -> ByteString
BS.pack ([Word8] -> ByteString) -> [Word8] -> ByteString
forall a b. (a -> b) -> a -> b
$ a -> Int -> [Word8]
forall t t a.
(Integral t, Bits t, Num t, Num a, Eq t) =>
t -> t -> [a]
getByte a
input (a -> Int
forall a. Bits a => a -> Int
bitSize a
input Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
8)

-- Performs the work behind PackBits
packBits :: (Word8, Int, [Word8])  -- ^ The current byte, the number of bits
                                   --   used in that byte and the (reverse)
                                   --   list of produced bytes
         -> (Int, Int)  -- ^ The size (in bits) of the value, and the value
         -> (Word8, Int, [Word8])  -- See first argument
packBits :: (Word8, Int, [Word8]) -> (Int, Int) -> (Word8, Int, [Word8])
packBits (Word8
current, Int
used, [Word8]
bytes) (Int
size, Int
value) =
  if Int
bitsWritten Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
size
    then (Word8, Int, [Word8]) -> (Int, Int) -> (Word8, Int, [Word8])
packBits (Word8
0, Int
0, Word8
current' Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: [Word8]
bytes) (Int
size Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
bitsWritten, Int
value)
    else if Int
used' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
8
           then (Word8
0, Int
0, Word8
current' Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: [Word8]
bytes)
           else (Word8
current', Int
used', [Word8]
bytes)
  where
    top :: Int
top = Int
size Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
    topOfByte :: Int
topOfByte = Int
7 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
used
    aligned :: Int
aligned = Int
value Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shift` (Int
topOfByte Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
top)
    newBits :: Word8
newBits = (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
aligned) :: Word8
    current' :: Word8
current' = Word8
current Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8
newBits
    bitsWritten :: Int
bitsWritten = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
used) Int
size
    used' :: Int
used' = Int
used Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
bitsWritten

bits :: BitBlock -> BS.ByteString
bits :: BitBlock -> ByteString
bits (U8 Int
v) = [Word8] -> ByteString
BS.pack [((Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
v) :: Word8)]
bits (U16 Int
v) = Word16 -> ByteString
forall a. (Integral a, Bounded a, Bits a) => a -> ByteString
getBytes ((Word16 -> Word16
htons (Word16 -> Word16) -> Word16 -> Word16
forall a b. (a -> b) -> a -> b
$ Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
v) :: Word16)
bits (U32 Int
v) = Word32 -> ByteString
forall a. (Integral a, Bounded a, Bits a) => a -> ByteString
getBytes ((Word32 -> Word32
htonl (Word32 -> Word32) -> Word32 -> Word32
forall a b. (a -> b) -> a -> b
$ Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
v) :: Word32)
bits (U16LE Int
v) = Word16 -> ByteString
forall a. (Integral a, Bounded a, Bits a) => a -> ByteString
getBytes (Word16 -> Word16
littleEndian16 (Word16 -> Word16) -> Word16 -> Word16
forall a b. (a -> b) -> a -> b
$ Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
v)
bits (U32LE Int
v) = Word32 -> ByteString
forall a. (Integral a, Bounded a, Bits a) => a -> ByteString
getBytes (Word32 -> Word32
littleEndian32 (Word32 -> Word32) -> Word32 -> Word32
forall a b. (a -> b) -> a -> b
$ Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
v)
bits (NullTerminated String
str) = [Word8] -> ByteString
BS.pack ([Word8] -> ByteString) -> [Word8] -> ByteString
forall a b. (a -> b) -> a -> b
$ ((Char -> Word8) -> String -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> (Char -> Int) -> Char -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord) String
str) [Word8] -> [Word8] -> [Word8]
forall a. [a] -> [a] -> [a]
++ [Word8
0]
bits (RawString String
str) = [Word8] -> ByteString
BS.pack ([Word8] -> ByteString) -> [Word8] -> ByteString
forall a b. (a -> b) -> a -> b
$ (Char -> Word8) -> String -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> (Char -> Int) -> Char -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord) String
str
bits (RawByteString ByteString
bs) = ByteString
bs
bits (PackBits [(Int, Int)]
bitspec) =
  if ([Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ ((Int, Int) -> Int) -> [(Int, Int)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Int) -> Int
forall a b. (a, b) -> a
fst [(Int, Int)]
bitspec) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
8 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0
    then String -> ByteString
forall a. HasCallStack => String -> a
error String
"Sum of sizes of a bit spec must == 0 mod 8"
    else (\(Word8
_, Int
_, [Word8]
a) -> [Word8] -> ByteString
BS.pack ([Word8] -> ByteString) -> [Word8] -> ByteString
forall a b. (a -> b) -> a -> b
$ [Word8] -> [Word8]
forall a. [a] -> [a]
reverse [Word8]
a) ((Word8, Int, [Word8]) -> ByteString)
-> (Word8, Int, [Word8]) -> ByteString
forall a b. (a -> b) -> a -> b
$ ((Word8, Int, [Word8]) -> (Int, Int) -> (Word8, Int, [Word8]))
-> (Word8, Int, [Word8]) -> [(Int, Int)] -> (Word8, Int, [Word8])
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (Word8, Int, [Word8]) -> (Int, Int) -> (Word8, Int, [Word8])
packBits (Word8
0, Int
0, []) [(Int, Int)]
bitspec

-- | Make a binary string from the list of elements given
makeBits :: [BitBlock] -> BS.ByteString
makeBits :: [BitBlock] -> ByteString
makeBits = [ByteString] -> ByteString
BS.concat ([ByteString] -> ByteString)
-> ([BitBlock] -> [ByteString]) -> [BitBlock] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((BitBlock -> ByteString) -> [BitBlock] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map BitBlock -> ByteString
bits)

data ReadType = -- | An unsigned number of some number of bytes. Valid
                --   arguments are 1, 2 and 4
                Unsigned Integer |
                -- | An unsigned, little-endian integer of some number of
                --   bytes. Valid arguments are 2 and 4
                UnsignedLE Integer |
                -- | A variable length element to be decoded by a custom
                --   function. The function's name is given as the single
                --   argument and should have type
                --   @Monad m => ByteString -> m (v, ByteString)@
                Variable Name |
                -- | Skip some number of bytes
                Skip Integer |
                -- | A fixed size field, the result of which is a ByteString
                --   of that length.
                Fixed Integer |
                -- | Decode a value and ignore it (the result will not be part
                --   of the returned tuple)
                Ignore ReadType |
                -- | Like variable, but the decoding function is passed the
                --   entire result tuple so far. Thus the function whose name
                --   passed has type
                --   @Monad m => ByteString -> (...) -> m (v, ByteString)@
                Context Name |
                -- | Takes the most recent element of the result tuple and
                --   interprets it as the length of this field. Results in
                --   a ByteString
                LengthPrefixed |
                -- | Decode a series of bit fields, results in a list of
                --   Integers. Each element of the argument is the length of
                --   the bit field. The sums of the lengths must be a multiple
                --   of 8
                PackedBits [Integer] |
                -- | Results in a ByteString containing the undecoded bytes so
                --   far. Generally used at the end to return the trailing body
                --   of a structure, it can actually be used at any point in the
                --   decoding to return the trailing part at that point.
                Rest

fromBytes :: (Num a, Bits a) => [a] -> a
fromBytes :: [a] -> a
fromBytes [a]
input =
    let dofb :: t -> [t] -> t
dofb t
accum [] = t
accum
        dofb t
accum (t
x:[t]
xs) = t -> [t] -> t
dofb ((t -> Int -> t
forall a. Bits a => a -> Int -> a
shiftL t
accum Int
8) t -> t -> t
forall a. Bits a => a -> a -> a
.|. t
x) [t]
xs
        in
        a -> [a] -> a
forall t. Bits t => t -> [t] -> t
dofb a
0 ([a] -> a) -> [a] -> a
forall a b. (a -> b) -> a -> b
$ [a] -> [a]
forall a. [a] -> [a]
reverse [a]
input


-- | First byte of a 'BS.ByteString'.
decodeU8 :: BS.ByteString -> Word8
decodeU8 :: ByteString -> Word8
decodeU8 = Word8 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Word8) -> (ByteString -> Word8) -> ByteString -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> Word8
forall a. [a] -> a
head ([Word8] -> Word8)
-> (ByteString -> [Word8]) -> ByteString -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Word8]
BS.unpack
-- | Convert little-endian 'BS.ByteString' to big-endian 'Word16'.
decodeU16 :: BS.ByteString -> Word16
decodeU16 :: ByteString -> Word16
decodeU16 = Word16 -> Word16
htons (Word16 -> Word16)
-> (ByteString -> Word16) -> ByteString -> Word16
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word16] -> Word16
forall a. (Num a, Bits a) => [a] -> a
fromBytes ([Word16] -> Word16)
-> (ByteString -> [Word16]) -> ByteString -> Word16
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> Word16) -> [Word8] -> [Word16]
forall a b. (a -> b) -> [a] -> [b]
map Word8 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Word8] -> [Word16])
-> (ByteString -> [Word8]) -> ByteString -> [Word16]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Word8]
BS.unpack
-- | Convert little-endian 'BS.ByteString' to big-endian 'Word32'.
decodeU32 :: BS.ByteString -> Word32
decodeU32 :: ByteString -> Word32
decodeU32 = Word32 -> Word32
htonl (Word32 -> Word32)
-> (ByteString -> Word32) -> ByteString -> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word32] -> Word32
forall a. (Num a, Bits a) => [a] -> a
fromBytes ([Word32] -> Word32)
-> (ByteString -> [Word32]) -> ByteString -> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> Word32) -> [Word8] -> [Word32]
forall a b. (a -> b) -> [a] -> [b]
map Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Word8] -> [Word32])
-> (ByteString -> [Word8]) -> ByteString -> [Word32]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Word8]
BS.unpack
-- | Convert little-endian 'BS.ByteString' to little-endian 'Word16'.
decodeU16LE :: BS.ByteString -> Word16
decodeU16LE :: ByteString -> Word16
decodeU16LE = Word16 -> Word16
littleEndian16 (Word16 -> Word16)
-> (ByteString -> Word16) -> ByteString -> Word16
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word16] -> Word16
forall a. (Num a, Bits a) => [a] -> a
fromBytes ([Word16] -> Word16)
-> (ByteString -> [Word16]) -> ByteString -> Word16
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> Word16) -> [Word8] -> [Word16]
forall a b. (a -> b) -> [a] -> [b]
map Word8 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Word8] -> [Word16])
-> (ByteString -> [Word8]) -> ByteString -> [Word16]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Word8]
BS.unpack
-- | Convert little-endian 'BS.ByteString' to little-endian 'Word32'.
decodeU32LE :: BS.ByteString -> Word32
decodeU32LE :: ByteString -> Word32
decodeU32LE = Word32 -> Word32
littleEndian32 (Word32 -> Word32)
-> (ByteString -> Word32) -> ByteString -> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word32] -> Word32
forall a. (Num a, Bits a) => [a] -> a
fromBytes ([Word32] -> Word32)
-> (ByteString -> [Word32]) -> ByteString -> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> Word32) -> [Word8] -> [Word32]
forall a b. (a -> b) -> [a] -> [b]
map Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Word8] -> [Word32])
-> (ByteString -> [Word8]) -> ByteString -> [Word32]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Word8]
BS.unpack

decodeBits :: [Integer] -> BS.ByteString -> [Integer]
decodeBits :: [Integer] -> ByteString -> [Integer]
decodeBits [Integer]
sizes ByteString
bs =
  [Integer] -> [Integer]
forall a. [a] -> [a]
reverse [Integer]
values
  where
    ([Integer]
values, Integer
_, [Word8]
_) = (([Integer], Integer, [Word8])
 -> Integer -> ([Integer], Integer, [Word8]))
-> ([Integer], Integer, [Word8])
-> [Integer]
-> ([Integer], Integer, [Word8])
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ([Integer], Integer, [Word8])
-> Integer -> ([Integer], Integer, [Word8])
unpackBits ([], Integer
0, ByteString -> [Word8]
BS.unpack ByteString
bitdata) [Integer]
sizes
    bytesize :: Integer
bytesize = ([Integer] -> Integer
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Integer]
sizes) Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftR` Int
3
    (ByteString
bitdata, ByteString
_) = Int -> ByteString -> (ByteString, ByteString)
BS.splitAt (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
bytesize) ByteString
bs

unpackBits :: ([Integer], Integer, [Word8]) -> Integer -> ([Integer], Integer, [Word8])
unpackBits :: ([Integer], Integer, [Word8])
-> Integer -> ([Integer], Integer, [Word8])
unpackBits ([Integer], Integer, [Word8])
state Integer
size = Integer
-> ([Integer], Integer, [Word8])
-> Integer
-> ([Integer], Integer, [Word8])
unpackBitsInner Integer
0 ([Integer], Integer, [Word8])
state Integer
size

unpackBitsInner :: Integer ->
                   ([Integer], Integer, [Word8]) ->
                   Integer ->
                   ([Integer], Integer, [Word8])
unpackBitsInner :: Integer
-> ([Integer], Integer, [Word8])
-> Integer
-> ([Integer], Integer, [Word8])
unpackBitsInner Integer
_ ([Integer]
output, Integer
used, []) Integer
_ = ([Integer]
output, Integer
used, [])
unpackBitsInner Integer
val ([Integer]
output, Integer
used, Word8
current : [Word8]
input) Integer
bitsToGet =
  if Integer
bitsToGet' Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0
    then Integer
-> ([Integer], Integer, [Word8])
-> Integer
-> ([Integer], Integer, [Word8])
unpackBitsInner Integer
val'' ([Integer]
output, Integer
0, [Word8]
input) Integer
bitsToGet'
    else if Integer
used' Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
8
           then (Integer
val'' Integer -> [Integer] -> [Integer]
forall a. a -> [a] -> [a]
: [Integer]
output, Integer
used', Word8
current'' Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: [Word8]
input)
           else (Integer
val'' Integer -> [Integer] -> [Integer]
forall a. a -> [a] -> [a]
: [Integer]
output, Integer
0, [Word8]
input)
  where
    bitsAv :: Integer
bitsAv = Integer
8 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
used
    bitsTaken :: Integer
bitsTaken = Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
min Integer
bitsAv Integer
bitsToGet
    val' :: Integer
val' = Integer
val Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shift` (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
bitsTaken)
    current' :: Word8
current' = Word8
current Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`shiftR` (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer
8 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
bitsTaken))
    current'' :: Word8
current'' = Word8
current Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`shiftL` (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
bitsTaken)
    val'' :: Integer
val'' = Integer
val' Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
.|. (Word8 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
current')
    bitsToGet' :: Integer
bitsToGet' = Integer
bitsToGet Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
bitsTaken
    used' :: Integer
used' = Integer
used Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
bitsTaken

readElement :: ([Stmt], Name, [Name]) -> ReadType -> Q ([Stmt], Name, [Name])

readElement :: ([Stmt], Name, [Name]) -> ReadType -> Q ([Stmt], Name, [Name])
readElement ([Stmt]
stmts, Name
inputname, [Name]
tuplenames) (Context Name
funcname) = do
  Name
valname <- String -> Q Name
newName String
"val"
  Name
restname <- String -> Q Name
newName String
"rest"

  let stmt :: Stmt
stmt = Pat -> Exp -> Stmt
BindS ([Pat] -> Pat
TupP [Name -> Pat
VarP Name
valname, Name -> Pat
VarP Name
restname])
                   (Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE Name
funcname)
                               (Name -> Exp
VarE Name
inputname))
#if MIN_VERSION_template_haskell(2,16,0)
                         ([Maybe Exp] -> Exp
TupE ([Maybe Exp] -> Exp) -> [Maybe Exp] -> Exp
forall a b. (a -> b) -> a -> b
$ (Name -> Maybe Exp) -> [Name] -> [Maybe Exp]
forall a b. (a -> b) -> [a] -> [b]
map (Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Maybe Exp) -> (Name -> Exp) -> Name -> Maybe Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Exp
VarE) ([Name] -> [Maybe Exp]) -> [Name] -> [Maybe Exp]
forall a b. (a -> b) -> a -> b
$ [Name] -> [Name]
forall a. [a] -> [a]
reverse [Name]
tuplenames))
#else
                         (TupE $ map VarE $ reverse tuplenames))
#endif
  ([Stmt], Name, [Name]) -> Q ([Stmt], Name, [Name])
forall (m :: * -> *) a. Monad m => a -> m a
return (Stmt
stmt Stmt -> [Stmt] -> [Stmt]
forall a. a -> [a] -> [a]
: [Stmt]
stmts, Name
restname, Name
valname Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: [Name]
tuplenames)

readElement ([Stmt]
stmts, Name
inputname, [Name]
tuplenames) (Fixed Integer
n) = do
  Name
valname <- String -> Q Name
newName String
"val"
  Name
restname <- String -> Q Name
newName String
"rest"
  let dec1 :: Dec
dec1 = Pat -> Body -> [Dec] -> Dec
ValD ([Pat] -> Pat
TupP [Name -> Pat
VarP Name
valname, Name -> Pat
VarP Name
restname])
                  (Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'BS.splitAt)
                                        (Lit -> Exp
LitE (Integer -> Lit
IntegerL Integer
n)))
                                  (Name -> Exp
VarE Name
inputname))
                  []

  ([Stmt], Name, [Name]) -> Q ([Stmt], Name, [Name])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Stmt
LetS [Dec
dec1] Stmt -> [Stmt] -> [Stmt]
forall a. a -> [a] -> [a]
: [Stmt]
stmts, Name
restname, Name
valname Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: [Name]
tuplenames)

readElement state :: ([Stmt], Name, [Name])
state@([Stmt]
_, Name
_, [Name]
tuplenames) (Ignore ReadType
n) = do
  ([Stmt]
a, Name
b, [Name]
_) <- ([Stmt], Name, [Name]) -> ReadType -> Q ([Stmt], Name, [Name])
readElement ([Stmt], Name, [Name])
state ReadType
n
  ([Stmt], Name, [Name]) -> Q ([Stmt], Name, [Name])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Stmt]
a, Name
b, [Name]
tuplenames)

readElement ([Stmt]
stmts, Name
inputname, [Name]
tuplenames) ReadType
LengthPrefixed = do
  Name
valname <- String -> Q Name
newName String
"val"
  Name
restname <- String -> Q Name
newName String
"rest"

  let sourcename :: Name
sourcename = [Name] -> Name
forall a. [a] -> a
head [Name]
tuplenames
      dec :: Dec
dec = Pat -> Body -> [Dec] -> Dec
ValD ([Pat] -> Pat
TupP [Name -> Pat
VarP Name
valname, Name -> Pat
VarP Name
restname])
                 (Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'BS.splitAt)
                                       (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'fromIntegral)
                                             (Name -> Exp
VarE Name
sourcename)))
                                 (Name -> Exp
VarE Name
inputname))
                 []

  ([Stmt], Name, [Name]) -> Q ([Stmt], Name, [Name])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Stmt
LetS [Dec
dec] Stmt -> [Stmt] -> [Stmt]
forall a. a -> [a] -> [a]
: [Stmt]
stmts, Name
restname, Name
valname Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: [Name]
tuplenames)

readElement ([Stmt]
stmts, Name
inputname, [Name]
tuplenames) (Variable Name
funcname) = do
  Name
valname <- String -> Q Name
newName String
"val"
  Name
restname <- String -> Q Name
newName String
"rest"

  let stmt :: Stmt
stmt = Pat -> Exp -> Stmt
BindS ([Pat] -> Pat
TupP [Name -> Pat
VarP Name
valname, Name -> Pat
VarP Name
restname])
                   (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE Name
funcname) (Name -> Exp
VarE Name
inputname))

  ([Stmt], Name, [Name]) -> Q ([Stmt], Name, [Name])
forall (m :: * -> *) a. Monad m => a -> m a
return (Stmt
stmt Stmt -> [Stmt] -> [Stmt]
forall a. a -> [a] -> [a]
: [Stmt]
stmts, Name
restname, Name
valname Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: [Name]
tuplenames)

readElement ([Stmt]
stmts, Name
inputname, [Name]
tuplenames) ReadType
Rest = do
  Name
restname <- String -> Q Name
newName String
"rest"
  let dec :: Dec
dec = Pat -> Body -> [Dec] -> Dec
ValD (Name -> Pat
VarP Name
restname)
                 (Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
inputname)
                 []
  ([Stmt], Name, [Name]) -> Q ([Stmt], Name, [Name])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Stmt
LetS [Dec
dec] Stmt -> [Stmt] -> [Stmt]
forall a. a -> [a] -> [a]
: [Stmt]
stmts, Name
inputname, Name
restname Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: [Name]
tuplenames)

readElement ([Stmt]
stmts, Name
inputname, [Name]
tuplenames) (Skip Integer
n) = do
  -- Expands to something like:
  --   rest = Data.ByteString.drop n input
  Name
restname <- String -> Q Name
newName String
"rest"
  let dec :: Dec
dec = Pat -> Body -> [Dec] -> Dec
ValD (Name -> Pat
VarP Name
restname)
                 (Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'BS.drop)
                                       (Lit -> Exp
LitE (Integer -> Lit
IntegerL Integer
n)))
                                 (Name -> Exp
VarE Name
inputname))
                 []
  ([Stmt], Name, [Name]) -> Q ([Stmt], Name, [Name])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Stmt
LetS [Dec
dec] Stmt -> [Stmt] -> [Stmt]
forall a. a -> [a] -> [a]
: [Stmt]
stmts, Name
restname, [Name]
tuplenames)

readElement ([Stmt], Name, [Name])
state (Unsigned Integer
size) = do
  -- Expands to something like:
  --    (aval, arest) = Data.ByteString.splitAt 1 input
  --    a = BitSyntax.decodeU8 aval
  let decodefunc :: Name
decodefunc = case Integer
size of
                     Integer
1 -> 'decodeU8
                     Integer
2 -> 'decodeU16
                     Integer
_ -> 'decodeU32 -- Default to 32
  ([Stmt], Name, [Name])
-> Exp -> Integer -> Q ([Stmt], Name, [Name])
decodeHelper ([Stmt], Name, [Name])
state (Name -> Exp
VarE Name
decodefunc) Integer
size

readElement ([Stmt], Name, [Name])
state (UnsignedLE Integer
size) = do
  -- Expands to something like:
  --    (aval, arest) = Data.ByteString.splitAt 1 input
  --    a = BitSyntax.decodeU8LE aval
  let decodefunc :: Name
decodefunc = case Integer
size of
                     Integer
2 -> 'decodeU16LE
                     Integer
_ -> 'decodeU32LE -- Default to 4
  ([Stmt], Name, [Name])
-> Exp -> Integer -> Q ([Stmt], Name, [Name])
decodeHelper ([Stmt], Name, [Name])
state (Name -> Exp
VarE Name
decodefunc) Integer
size

readElement ([Stmt], Name, [Name])
state (PackedBits [Integer]
sizes) =
  if [Integer] -> Integer
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Integer]
sizes Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`mod` Integer
8 Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
0
    then String -> Q ([Stmt], Name, [Name])
forall a. HasCallStack => String -> a
error String
"Sizes of packed bits must == 0 mod 8"
    else ([Stmt], Name, [Name])
-> Exp -> Integer -> Q ([Stmt], Name, [Name])
decodeHelper ([Stmt], Name, [Name])
state
                      (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'decodeBits)
                            ([Exp] -> Exp
ListE ([Exp] -> Exp) -> [Exp] -> Exp
forall a b. (a -> b) -> a -> b
$ (Integer -> Exp) -> [Integer] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map (Lit -> Exp
LitE (Lit -> Exp) -> (Integer -> Lit) -> Integer -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Lit
IntegerL) [Integer]
sizes))
                      (([Integer] -> Integer
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Integer]
sizes) Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftR` Int
3)

decodeHelper :: ([Stmt], Name, [Name])      -> Exp
                                            -> Integer
                                            -> Q ([Stmt], Name, [Name])
decodeHelper :: ([Stmt], Name, [Name])
-> Exp -> Integer -> Q ([Stmt], Name, [Name])
decodeHelper ([Stmt]
stmts, Name
inputname, [Name]
tuplenames) Exp
decodefunc Integer
size = do
  Name
valname <- String -> Q Name
newName String
"val"
  Name
restname <- String -> Q Name
newName String
"rest"
  Name
tuplename <- String -> Q Name
newName String
"tup"
  let dec1 :: Dec
dec1 = Pat -> Body -> [Dec] -> Dec
ValD ([Pat] -> Pat
TupP [Name -> Pat
VarP Name
valname, Name -> Pat
VarP Name
restname])
                  (Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'BS.splitAt)
                                        (Lit -> Exp
LitE (Integer -> Lit
IntegerL Integer
size)))
                                  (Name -> Exp
VarE Name
inputname))
                  []
  let dec2 :: Dec
dec2 = Pat -> Body -> [Dec] -> Dec
ValD (Name -> Pat
VarP Name
tuplename)
                  (Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE Exp
decodefunc (Name -> Exp
VarE Name
valname))
                  []

  ([Stmt], Name, [Name]) -> Q ([Stmt], Name, [Name])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Stmt
LetS [Dec
dec1, Dec
dec2] Stmt -> [Stmt] -> [Stmt]
forall a. a -> [a] -> [a]
: [Stmt]
stmts, Name
restname, Name
tuplename Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: [Name]
tuplenames)

decGetName :: Dec -> Name
decGetName :: Dec -> Name
decGetName (ValD (VarP Name
name) Body
_ [Dec]
_) = Name
name
decGetName Dec
_                      = Name
forall a. HasCallStack => a
undefined -- Error!

-- | Example usage:
--
-- > parsePascalString :: Monad m => ByteString -> m (Word16, ByteString)
-- > parsePascalString bs = $( bitSyn [UnsignedLE 2, LengthPrefixed] ) bs
bitSyn :: [ReadType] -> Q Exp
bitSyn :: [ReadType] -> Q Exp
bitSyn [ReadType]
elements = do
    Name
inputname <- String -> Q Name
newName String
"input"
    ([Stmt]
stmts, Name
restname, [Name]
tuplenames) <- (([Stmt], Name, [Name]) -> ReadType -> Q ([Stmt], Name, [Name]))
-> ([Stmt], Name, [Name]) -> [ReadType] -> Q ([Stmt], Name, [Name])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ([Stmt], Name, [Name]) -> ReadType -> Q ([Stmt], Name, [Name])
readElement ([], Name
inputname, []) [ReadType]
elements
    Stmt
returnS <- Exp -> Stmt
NoBindS (Exp -> Stmt) -> Q Exp -> Q Stmt
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` [| return $(tupE . map varE $ reverse tuplenames) |]
    Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Pat] -> Exp -> Exp
LamE [Name -> Pat
VarP Name
inputname] ([Stmt] -> Exp
DoE ([Stmt] -> Exp) -> ([Stmt] -> [Stmt]) -> [Stmt] -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Stmt] -> [Stmt]
forall a. [a] -> [a]
reverse ([Stmt] -> Exp) -> [Stmt] -> Exp
forall a b. (a -> b) -> a -> b
$ Stmt
returnS Stmt -> [Stmt] -> [Stmt]
forall a. a -> [a] -> [a]
: [Stmt]
stmts)


-- Tests
prop_bitPacking :: [(Int, Int)] -> Bool
prop_bitPacking :: [(Int, Int)] -> Bool
prop_bitPacking [(Int, Int)]
fields =
  [Int]
prevalues [Int] -> [Int] -> Bool
forall a. Eq a => a -> a -> Bool
== ((Integer -> Int) -> [Integer] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral [Integer]
postvalues) Bool -> Bool -> Bool
||
  (Int -> Bool) -> [Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1) (((Int, Int) -> Int) -> [(Int, Int)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Int) -> Int
forall a b. (a, b) -> a
fst [(Int, Int)]
fields) Bool -> Bool -> Bool
||
  (Int -> Bool) -> [Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0) (((Int, Int) -> Int) -> [(Int, Int)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Int) -> Int
forall a b. (a, b) -> b
snd [(Int, Int)]
fields)
  where
    undershoot :: Int
undershoot = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (((Int, Int) -> Int) -> [(Int, Int)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Int) -> Int
forall a b. (a, b) -> a
fst [(Int, Int)]
fields) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
8
    fields' :: [(Int, Int)]
fields' = if Int
undershoot Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
                then (Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
undershoot, Int
1) (Int, Int) -> [(Int, Int)] -> [(Int, Int)]
forall a. a -> [a] -> [a]
: [(Int, Int)]
fields
                else [(Int, Int)]
fields
    prevalues :: [Int]
prevalues = ((Int, Int) -> Int) -> [(Int, Int)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Int) -> Int
forall a b. (a, b) -> b
snd [(Int, Int)]
fields'
    packed :: ByteString
packed = BitBlock -> ByteString
bits (BitBlock -> ByteString) -> BitBlock -> ByteString
forall a b. (a -> b) -> a -> b
$ [(Int, Int)] -> BitBlock
PackBits [(Int, Int)]
fields'
    postvalues :: [Integer]
postvalues = [Integer] -> ByteString -> [Integer]
decodeBits (((Int, Int) -> Integer) -> [(Int, Int)] -> [Integer]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Integer) -> ((Int, Int) -> Int) -> (Int, Int) -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Int) -> Int
forall a b. (a, b) -> a
fst) [(Int, Int)]
fields') ByteString
packed

#if !MIN_VERSION_QuickCheck(2,1,2)
instance Arbitrary Word16 where
  arbitrary = (arbitrary :: Gen Int) >>= return . fromIntegral
instance Arbitrary Word32 where
  arbitrary = (arbitrary :: Gen Int) >>= return . fromIntegral
#endif

-- | This only works on little-endian machines as it checks that the foreign
--   functions (htonl and htons) match the native ones
prop_nativeByteShuffle32 :: Word32 -> Bool
prop_nativeByteShuffle32 :: Word32 -> Bool
prop_nativeByteShuffle32 Word32
x = Word32 -> Word32
endianSwitch32 Word32
x Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32 -> Word32
htonl Word32
x
prop_nativeByteShuffle16 :: Word16 -> Bool
prop_nativeByteShuffle16 :: Word16 -> Bool
prop_nativeByteShuffle16 Word16
x = Word16 -> Word16
endianSwitch16 Word16
x Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
== Word16 -> Word16
htons Word16
x
prop_littleEndian16 :: Word16 -> Bool
prop_littleEndian16 :: Word16 -> Bool
prop_littleEndian16 Word16
x = Word16 -> Word16
littleEndian16 Word16
x Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
== Word16
x
prop_littleEndian32 :: Word32 -> Bool
prop_littleEndian32 :: Word32 -> Bool
prop_littleEndian32 Word32
x = Word32 -> Word32
littleEndian32 Word32
x Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
x