{-# LANGUAGE PatternGuards #-}
module Data.Bits.Bitwise
(
repeat
, map
, zipWith
, or
, and
, any
, all
, isUniform
, mask
, splitAt
, joinAt
, fromBool
, fromListLE
, toListLE
, fromListBE
, toListBE
, packWord8LE
, unpackWord8LE
, packWord8BE
, unpackWord8BE
) where
import Prelude hiding (repeat, map, zipWith, any, all, or, and, splitAt)
import qualified Prelude as P
import Data.Bits (Bits(complement, (.&.), (.|.), xor, bit, shiftL, shiftR, testBit, bitSizeMaybe, zeroBits),
FiniteBits(finiteBitSize))
import Data.List (foldl')
import Data.Word (Word8)
{-# INLINE repeat #-}
repeat :: (Bits b) => Bool -> b
repeat False = zeroBits
repeat True = complement zeroBits
{-# INLINE map #-}
map :: (Bits b) => (Bool -> Bool) -> b -> b
map f = case (f False, f True) of
(False, False) -> \_ -> zeroBits
(False, True ) -> id
(True, False) -> complement
(True, True ) -> \_ -> complement zeroBits
{-# INLINE zipWith #-}
zipWith :: (Bits b) => (Bool -> Bool -> Bool) -> b -> b -> b
zipWith f = case (f False False, f False True, f True False, f True True) of
(False, False, False, False) -> \_ _ -> zeroBits
(False, False, False, True ) -> (.&.)
(False, False, True, False) -> \x y -> x .&. complement y
(False, False, True, True ) -> \x _ -> x
(False, True, False, False) -> \x y -> complement x .&. y
(False, True, False, True ) -> \_ y -> y
(False, True, True, False) -> xor
(False, True, True, True ) -> (.|.)
(True, False, False, False) -> \x y -> complement (x .|. y)
(True, False, False, True ) -> \x y -> complement (x `xor` y)
(True, False, True, False) -> \_ y -> complement y
(True, False, True, True ) -> \x y -> x .|. complement y
(True, True, False, False) -> \x _ -> complement x
(True, True, False, True ) -> \x y -> complement x .|. y
(True, True, True, False) -> \x y -> complement (x .&. y)
(True, True, True, True ) -> \_ _ -> complement zeroBits
{-# INLINE or #-}
or :: (Bits b) => b -> Bool
or b = b /= zeroBits
{-# INLINE and #-}
and :: (Bits b) => b -> Bool
and b = b == complement zeroBits
{-# INLINE any #-}
any :: (Bits b) => (Bool -> Bool) -> b -> Bool
any f = or . map f
{-# INLINE all #-}
all :: (Bits b) => (Bool -> Bool) -> b -> Bool
all f = and . map f
{-# INLINE isUniform #-}
isUniform :: (Bits b) => b -> Maybe Bool
isUniform b
| b == zeroBits = Just False
| b == complement zeroBits = Just True
| otherwise = Nothing
{-# INLINE mask #-}
mask :: (Num b, Bits b) => Int -> b
mask n = bit n - bit 0
{-# INLINE splitAt #-}
splitAt :: (Num b, Bits b) => Int -> b -> (b, b)
splitAt n b = (b .&. mask n, b `shiftR` n)
{-# INLINE joinAt #-}
joinAt :: (Bits b) => Int -> b -> b -> b
joinAt n lsb msb = lsb .|. (msb `shiftL` n)
{-# INLINE packWord8LE #-}
packWord8LE :: Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Word8
packWord8LE a b c d e f g h = z a 1 .|. z b 2 .|. z c 4 .|. z d 8 .|. z e 16 .|. z f 32 .|. z g 64 .|. z h 128
where z False _ = 0
z True n = n
{-# INLINE packWord8BE #-}
packWord8BE :: Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Word8
packWord8BE a b c d e f g h = packWord8LE h g f e d c b a
{-# INLINE unpackWord8LE #-}
unpackWord8LE :: Word8 -> (Bool, Bool, Bool, Bool, Bool, Bool, Bool, Bool)
unpackWord8LE w = (b 1, b 2, b 4, b 8, b 16, b 32, b 64, b 128)
where b z = w .&. z /= 0
{-# INLINE unpackWord8BE #-}
unpackWord8BE :: Word8 -> (Bool, Bool, Bool, Bool, Bool, Bool, Bool, Bool)
unpackWord8BE w = (b 128, b 64, b 32, b 16, b 8, b 4, b 2, b 1)
where b z = w .&. z /= 0
{-# INLINE fromBool #-}
fromBool :: (Bits b) => Bool -> b
fromBool False = zeroBits
fromBool True = bit 0
{-# INLINE fromListLE #-}
fromListLE :: (Bits b) => [Bool] -> b
fromListLE = foldr f zeroBits
where
f b i = fromBool b .|. (i `shiftL` 1)
{-# INLINE toListLE #-}
toListLE :: (Bits b) => b -> [Bool]
toListLE b0 | Just n <- bitSizeMaybe b0 = P.map (testBit b0) [0..n-1]
| otherwise = go b0
where go b | zeroBits == b = []
| otherwise = testBit b 0 : go (b `shiftR` 1)
{-# INLINE fromListBE #-}
fromListBE :: (Bits b) => [Bool] -> b
fromListBE = foldl' f zeroBits
where
f i b = (i `shiftL` 1) .|. fromBool b
{-# INLINE toListBE #-}
toListBE :: (FiniteBits b) => b -> [Bool]
toListBE b = P.map (testBit b) [finiteBitSize b - 1, finiteBitSize b - 2 .. 0]