{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE TypeFamilies #-}
module Data.BitVector.LittleEndian
( BitVector()
, fromBits
, toBits
, fromNumber
, toSignedNumber
, toUnsignedNumber
, dimension
, isZeroVector
, subRange
) where
import Control.DeepSeq
import Data.Bits
import Data.Data
import Data.Foldable
import Data.Hashable
import Data.Key
import Data.List.NonEmpty (NonEmpty(..))
import Data.Maybe
import Data.Monoid ()
import Data.MonoTraversable
import Data.MonoTraversable.Keys
import Data.Ord
import Data.Primitive.ByteArray
import Data.Semigroup
import Data.Word
import GHC.Exts
import GHC.Generics
import GHC.Integer.GMP.Internals
import GHC.Integer.Logarithms
import GHC.Natural
import Test.QuickCheck (Arbitrary(..), CoArbitrary(..), NonNegative(..), choose, suchThat, variant)
import TextShow (TextShow(showb))
data BitVector
= BV
{ dim :: {-# UNPACK #-} !Word
, nat :: !Natural
} deriving ( Data
, Generic
, Typeable
)
type instance Element BitVector = Bool
type instance MonoKey BitVector = Word
instance Arbitrary BitVector where
arbitrary = do
n <- choose (0, 25 :: Word)
case n of
0 -> boundaryValue
1 -> allBitsOn
2 -> allBitsOn
3 -> allBitsOff
4 -> allBitsOff
_ -> anyBitValue
where
allBitsOn = genBitVector $ Just True
allBitsOff = genBitVector $ Just False
anyBitValue = genBitVector $ Nothing
boundaryValue = do
let wrdVal = maxBound :: Word
let dimVal = toEnum $ popCount wrdVal
let numVal = wordToNatural wrdVal
underBoundary <- arbitrary
let (lowerBound, naturalVal)
| underBoundary = (dimVal , numVal )
| otherwise = (dimVal + 1, numVal + 1)
widthVal <- (getNonNegative <$> arbitrary) `suchThat` (>= lowerBound)
pure $ BV widthVal naturalVal
genBitVector spec = do
dimVal <- getNonNegative <$> arbitrary
let upperBound = shiftL 1 dimVal
natVal <- case spec of
Just False -> pure $ intToNat 0
Just True -> pure . intToNat $ upperBound - 1
Nothing -> fmap intToNat $
(getNonNegative <$> arbitrary) `suchThat` (< upperBound)
pure $ BV (toEnum dimVal) natVal
instance Bits BitVector where
{-# INLINE (.&.) #-}
(BV w1 a) .&. (BV w2 b) = BV (max w1 w2) $ a .&. b
{-# INLINE (.|.) #-}
(BV w1 a) .|. (BV w2 b) = BV (max w1 w2) $ a .|. b
{-# INLINE xor #-}
(BV w1 a) `xor` (BV w2 b) = BV (max w1 w2) $ a `xor` b
{-# INLINE complement #-}
complement (BV w n) = BV w $ shiftL 1 (fromEnum w) - 1 - n
{-# INLINE zeroBits #-}
zeroBits = BV 0 0
{-# INLINE bit #-}
bit i = BV (succ $ toEnum i) (shiftL 1 i)
{-# INLINE clearBit #-}
clearBit bv@(BV w n) i
| i < 0 || toEnum i >= w = bv
| otherwise =
let !allBits = pred . shiftL 1 $ fromEnum w
!mask = bit i `xor` allBits
in BV w $ n .&. mask
{-# INLINE setBit #-}
setBit bv@(BV w n) i
| i < 0 = bv
| otherwise = BV (max w j) $ n `setBit` i
where
!j = toEnum i + 1
{-# INLINE testBit #-}
testBit (BV w n) i = i >= 0 && toEnum i < w && n `testBit` i
bitSize (BV w _) = fromEnum w
{-# INLINE bitSizeMaybe #-}
bitSizeMaybe (BV w _) = Just $ fromEnum w
{-# INLINE isSigned #-}
isSigned = const False
{-# INLINE shiftL #-}
shiftL (BV w n) k
| toEnum k > w = BV w 0
| otherwise = BV w $ shiftL n k .&. pred (shiftL 1 (fromEnum w))
{-# INLINE shiftR #-}
shiftR (BV w n) k
| toEnum k > w = BV w 0
| otherwise = BV w $ shiftR n k
{-# INLINE rotateL #-}
rotateL bv 0 = bv
rotateL bv@(BV 0 _) _ = bv
rotateL bv@(BV 1 _) _ = bv
rotateL bv@(BV w n) k
| k < 0 = bv
| j >= w = go . fromEnum $ j `mod` w
| otherwise = go k
where
!j = toEnum k
go 0 = bv
go !i = BV w $ h + l
where
!v = fromEnum w
!d = v - i
!m = pred $ shiftL 1 d
!l = n `shiftR` d
!h = (n .&. m) `shiftL` i
{-# INLINE rotateR #-}
rotateR bv 0 = bv
rotateR bv@(BV 0 _) _ = bv
rotateR bv@(BV 1 _) _ = bv
rotateR bv@(BV w n) k
| k < 0 = bv
| j >= w = go . fromEnum $ j `mod` w
| otherwise = go k
where
!j = toEnum k
go 0 = bv
go !i = BV w $ h + l
where
!v = fromEnum w
!d = v - i
!m = pred $ shiftL 1 i
!l = n `shiftR` i
!h = (n .&. m) `shiftL` d
{-# INLINE popCount #-}
popCount = popCount . nat
instance CoArbitrary BitVector where
coarbitrary bv = variant (dimension bv)
instance Eq BitVector where
{-# INLINE (==) #-}
(==) (BV w1 m) (BV w2 n) = w1 == w2 && naturalToBigNat m == naturalToBigNat n
where
naturalToBigNat (NatS# w ) = wordToBigNat w
naturalToBigNat (NatJ# bn) = bn
instance FiniteBits BitVector where
{-# INLINE finiteBitSize #-}
finiteBitSize = fromEnum . dim
{-# INLINE countTrailingZeros #-}
countTrailingZeros (BV w n) = max 0 $ fromEnum w - lastSetBit - 1
where
lastSetBit = I# (integerLog2# (toInteger n))
{-# INLINE countLeadingZeros #-}
countLeadingZeros (BV w 0) = fromEnum w
countLeadingZeros (BV w natVal) =
case natVal of
NatS# v -> countTrailingZeros $ iMask .|. W# v
NatJ# (BN# v) -> f $ ByteArray v
where
iMask = complement zeroBits `xor` (2 ^ w - 1)
!x = fromEnum w
f :: ByteArray -> Int
f byteArr = g 0
where
(q, r) = x `quotRem` 64
wMask = complement zeroBits `xor` (2 ^ r - 1) :: Word64
g :: Int -> Int
g !i
| i >= q = countTrailingZeros $ wMask .|. value
| otherwise =
case countTrailingZeros value of
64 -> 64 + g (i+1)
v -> v
where
value :: Word64
value = byteArr `indexByteArray` i
instance Hashable BitVector where
hash (BV w n) = fromEnum w `hashWithSalt` hash n
hashWithSalt salt bv = salt `hashWithSalt` hash bv
instance Monoid BitVector where
{-# INLINE mappend #-}
mappend = (<>)
{-# INLINE mconcat #-}
mconcat bs =
case bs of
[] -> mempty
x:xs -> sconcat $ x:|xs
{-# INLINE mempty #-}
mempty = BV 0 0
instance MonoAdjustable BitVector where
{-# INLINE oadjust #-}
oadjust f k bv@(BV w n)
| k >= w = bv
| v == b = bv
| otherwise = bv `complementBit` i
where
!i = fromEnum k
!v = n `testBit` i
!b = f v
{-# INLINE oreplace #-}
oreplace k v bv@(BV w _)
| k >= w = bv
| v = bv `setBit` i
| otherwise = bv `clearBit` i
where
!i = fromEnum k
instance MonoFoldable BitVector where
{-# INLINE ofoldMap #-}
ofoldMap f (BV w n) = go m
where
!m = fromEnum w
go 0 = mempty
go !c = let !i = m - c
!j = c - 1
!b = n `testBit` i
in f b `mappend` go j
{-# INLINE ofoldr #-}
ofoldr f e (BV w n) =
let !m = fromEnum w
go 0 acc = acc
go !c acc = let !i = m - c
!j = c - 1
!b = n `testBit` i
in f b $ go j acc
in go m e
{-# INLINE ofoldl' #-}
ofoldl' f e (BV w n) = go m e
where
!m = fromEnum w
go 0 acc = acc
go !c acc = let !i = m - c
!j = c - 1
!b = n `testBit` i
!a = f acc b
in go j a
{-# INLINE otoList #-}
otoList = toBits
{-# INLINE oall #-}
oall _ (BV 0 _) = True
oall f (BV w n) =
case (f False, f True) of
(False, False) -> False
(True , True ) -> True
(False, True ) -> n == bit (fromEnum w) - 1
(True , False) -> n == 0
{-# INLINE oany #-}
oany _ (BV 0 _) = False
oany f (BV w n) =
case (f False, f True) of
(False, False) -> False
(True , True ) -> True
(False, True ) -> n > 0
(True , False) -> n < bit (fromEnum w) - 1
{-# INLINE onull #-}
onull = (== 0) . dim
{-# INLINE olength #-}
olength = fromEnum . dim
{-# INLINE olength64 #-}
olength64 = toEnum . olength
{-# INLINE otraverse_ #-}
otraverse_ f (BV w n) = go (fromEnum w)
where
go 0 = pure ()
go !c = let !j = c - 1
!a = f (n `testBit` j)
in a *> go j
{-# INLINE ofoldlM #-}
ofoldlM f e (BV w n) = go (fromEnum w) e
where
go 0 acc = pure acc
go !c acc = let !j = c - 1
!x = f acc (n `testBit` j)
in x >>= go j
{-# INLINE ofoldMap1Ex #-}
ofoldMap1Ex _ (BV 0 _) = Prelude.error "Data.MonoTraversable.ofoldMap1Ex on an empty BitVector!"
ofoldMap1Ex f (BV w n) = go 0
where
!m = fromEnum w
go !c
| c >= m - 1 = f $ n `testBit` c
| otherwise = let !j = c + 1
!b = n `testBit` c
in f b <> go j
{-# INLINE ofoldr1Ex #-}
ofoldr1Ex _ (BV 0 _) = Prelude.error "Data.MonoTraversable.ofoldr1Ex on an empty BitVector!"
ofoldr1Ex _ (BV 1 n) = n > 0
ofoldr1Ex f bv@(BV w n) =
case (f True True, f True False, f False True, f False False) of
(False, False, False, False) -> False
(False, False, False, True ) -> let !lzs = toEnum $ countLeadingZeros bv
in if (w - lzs) == 1 || n == 0
then even lzs
else odd lzs
(False, False, True , False) -> n == bit (fromEnum w - 1)
(False, False, True , True ) -> not (n `testBit` 0)
(False, True , False, False) -> let !los = countLeadingZeros $ complement bv
in odd los
(False, True , False, True ) -> let !v = n `testBit` (fromEnum w - 1)
in if even w then not v else v
(False, True , True , False) -> odd $ popCount n
(False, True , True , True ) -> let !los = countLeadingZeros $ complement bv
!x = bit (fromEnum w - 1) - 1
!y = bit (fromEnum w ) - 1
in if n == x || n == y
then odd los
else even los
(True , False, False, False) -> n == bit (fromEnum w) - 1
(True , False, False, True ) -> let !pc = popCount n
in if even w
then even pc
else odd pc
(True , False, True , False) -> n `testBit` (fromEnum w - 1)
(True , False, True , True ) -> let !i = fromEnum w - 1
in n /= bit i - 1
(True , True , False, False) -> n `testBit` 0
(True , True , False, True ) -> even $ countLeadingZeros bv
(True , True , True , False) -> n > 0
(True , True , True , True ) -> True
{-# INLINE ofoldl1Ex' #-}
ofoldl1Ex' _ (BV 0 _) = Prelude.error "Data.MonoTraversable.ofoldl1Ex' on an empty BitVector!"
ofoldl1Ex' _ (BV 1 n) = n > 0
ofoldl1Ex' f bv@(BV w n) =
case (f True True, f True False, f False True, f False False) of
(False, False, False, False) -> False
(False, False, False, True ) -> let !tzs = toEnum $ countTrailingZeros bv
in if (w - tzs) == 1 || n == 0
then even tzs
else odd tzs
(False, False, True , False) -> let !tzs = countTrailingZeros $ complement bv
in odd tzs
(False, False, True , True ) -> even w == even n
(False, True , False, False) -> n == 1
(False, True , False, True ) -> not $ n `testBit` (fromEnum w - 1)
(False, True , True , False) -> odd $ popCount n
(False, True , True , True ) -> let !tos = countTrailingZeros $ complement bv
!x = bit (fromEnum w) - 1
!y = bit (fromEnum w) - 2
in if n == x || n == y
then odd tos
else even tos
(True , False, False, False) -> n == bit (fromEnum w) - 1
(True , False, False, True ) -> let !pc = popCount n
in if even w
then even pc
else odd pc
(True , False, True , False) -> n `testBit` (fromEnum w - 1)
(True , False, True , True ) -> even $ countTrailingZeros bv
(True , True , False, False) -> n `testBit` 0
(True , True , False, True ) -> n /= bit (fromEnum w) - 2
(True , True , True , False) -> n > 0
(True , True , True , True ) -> True
{-# INLINE headEx #-}
headEx (BV 0 _) = error "Call to Data.MonoFoldable.headEx on an empty BitVector!"
headEx (BV _ n) = n `testBit` 0
{-# INLINE lastEx #-}
lastEx (BV 0 _) = error "Call to Data.MonoFoldable.lastEx on an empty BitVector!"
lastEx (BV w n) = n `testBit` (fromEnum w - 1)
{-# INLINE maximumByEx #-}
maximumByEx _ (BV 0 _) = error "Call to Data.MonoFoldable.maximumByEx on an empty BitVector!"
maximumByEx _ (BV 1 n) = n /= 0
maximumByEx f bv = maximumBy f $ toBits bv
{-# INLINE minimumByEx #-}
minimumByEx _ (BV 0 _) = error "Call to Data.MonoFoldable.minimumByEx on an empty BitVector!"
minimumByEx _ (BV 1 n) = n /= 0
minimumByEx f bv = minimumBy f $ toBits bv
{-# INLINE oelem #-}
oelem _ (BV 0 _) = False
oelem True (BV _ n) = n > 0
oelem False (BV w n) = n < bit (fromEnum w) - 1
{-# INLINE onotElem #-}
onotElem e = not . oelem e
instance MonoFoldableWithKey BitVector where
{-# INLINE otoKeyedList #-}
otoKeyedList (BV w n) =
let go 0 = []
go !c = let !k = w - c
!v = n `testBit` fromEnum k
!i = c - 1
in (k, v) : go i
in go w
{-# INLINE ofoldMapWithKey #-}
ofoldMapWithKey f (BV w n) =
let go 0 = mempty
go !c = let !k = w - c
!v = n `testBit` fromEnum k
!i = c - 1
!m = f k v
in m `mappend` go i
in go w
{-# INLINE ofoldrWithKey #-}
ofoldrWithKey f e (BV w n) =
let go 0 acc = acc
go !c acc = let !k = w - c
!i = c - 1
!b = n `testBit` fromEnum k
in f k b $ go i acc
in go w e
{-# INLINE ofoldlWithKey #-}
ofoldlWithKey f e (BV w n) = go w e
where
go 0 acc = acc
go !c acc = let !k = w - c
!i = c - 1
!b = n `testBit` fromEnum k
!a = f acc k b
in go i a
instance MonoFunctor BitVector where
{-# INLINE omap #-}
omap f bv@(BV w n) =
case (f False, f True) of
(False, False) -> BV w 0
(True , True ) -> BV w $ bit (fromEnum w) - 1
(False, True ) -> bv
(True , False) -> let !allOnes = bit (fromEnum w) - 1
in BV w $ n `xor` allOnes
instance MonoIndexable BitVector where
{-# INLINE oindex #-}
oindex bv@(BV w _) i = fromMaybe errorMessage $ i `olookup` bv
where
errorMessage = error $ mconcat
[ "Data.BitVector.LittleEndian.oindex: "
, "The index "
, show i
, " was greater than or equal to the length of the bit vector "
, show w
]
instance MonoKeyed BitVector where
{-# INLINE omapWithKey #-}
omapWithKey f (BV w n) =
let go 0 acc = acc
go !c acc = let !k = w - c
!i = fromEnum k
!j = c - 1
!b = n `testBit` i
!a | f k b = acc `setBit` i
| otherwise = acc
in go j a
in go w $ BV w 0
instance MonoLookup BitVector where
{-# INLINE olookup #-}
olookup k (BV w n)
| k <= w = Nothing
| otherwise = Just $ n `testBit` fromEnum k
instance MonoTraversable BitVector where
{-# INLINE otraverse #-}
otraverse f = fmap fromBits . traverse f . toBits
{-# INLINE omapM #-}
omapM = otraverse
instance MonoTraversableWithKey BitVector where
{-# INLINE otraverseWithKey #-}
otraverseWithKey f = fmap fromBits . traverseWithKey (f . toEnum) . toBits
instance MonoZip BitVector where
{-# INLINE ozipWith #-}
ozipWith f lhs@(BV w1 p) rhs@(BV w2 q) =
let !w0 = min w1 w2
!mask = bit (fromEnum w0) - 1
bv = BV w0 . (mask .&.)
not' = nat . complement
in case (f True True, f True False, f False True, f False False) of
(False, False, False, False) -> bv 0
(False, False, False, True ) -> bv $ not' lhs .&. not' rhs
(False, False, True , False) -> bv $ not' lhs .&. q
(False, False, True , True ) -> bv $ not' lhs
(False, True , False, False) -> bv $ p .&. not' rhs
(False, True , False, True ) -> bv $ not' rhs
(False, True , True , False) -> bv $ p `xor` q
(False, True , True , True ) -> bv $ not' lhs .|. not' rhs
(True , False, False, False) -> bv $ p .&. q
(True , False, False, True ) -> bv $ (p .&. q) .|. (not' lhs .&. not' rhs)
(True , False, True , False) -> bv q
(True , False, True , True ) -> bv $ not' lhs .|. q
(True , True , False, False) -> bv p
(True , True , False, True ) -> bv $ p .|. not' rhs
(True , True , True , False) -> bv $ p .|. q
(True , True , True , True ) -> bv $ bit (fromEnum w0) - 1
instance MonoZipWithKey BitVector where
{-# INLINE ozipWithKey #-}
ozipWithKey f (BV w1 n) (BV w2 m) =
let w0 = min w1 w2
go 0 _ = 0
go c e = let !k = w0 - c
!i = fromEnum k
!j = c - 1
!b = f k (n `testBit` i) (m `testBit` i)
!a = e `shiftL` 1
!v = if b then e else 0
in v + go j a
in BV w0 $ go w0 1
instance NFData BitVector where
{-# INLINE rnf #-}
rnf = const ()
instance Ord BitVector where
{-# INLINE compare #-}
compare lhs rhs =
case comparing dim lhs rhs of
EQ -> comparing nat lhs rhs
v -> v
instance Semigroup BitVector where
{-# INLINE (<>) #-}
(<>) (BV x m) (BV y n) = BV (x + y) $ (n `shiftL` fromEnum x) + m
{-# INLINABLE sconcat #-}
sconcat xs = BV w' n'
where
(w', _, n') = foldl' f (0, 0, 0) xs
f (bitCountW, bitCountI, natVal) (BV w n) =
(bitCountW + w, bitCountI + fromEnum w, natVal + (n `shiftL` bitCountI))
{-# INLINE stimes #-}
stimes 0 _ = mempty
stimes e (BV w n) = BV limit $ go start n
where
!x = fromEnum w
!start = fromEnum $ limit - w
!limit = (toEnum . fromEnum) e * w
go 0 !acc = acc
go !k !acc = go (k-x) $ (n `shiftL` k) + acc
instance Show BitVector where
show (BV w n) = mconcat [ "[", show w, "]", show n ]
instance TextShow BitVector where
showb (BV w n) = mconcat [ "[", showb w, "]", showb n ]
{-# INLINE fromBits #-}
fromBits :: Foldable f => f Bool -> BitVector
fromBits bs = BV (toEnum n) k
where
(!n, !k) = foldl' go (0, 0) bs
go (!i, !v) b
| b = (i+1, v `setBit` i)
| otherwise = (i+1, v)
{-# INLINE toBits #-}
toBits :: BitVector -> [Bool]
toBits (BV w n) = go (fromEnum w) []
where
go 0 bs = bs
go i bs = let !j = i - 1
in go j $ n `testBit` j : bs
{-# INLINE[1] fromNumber #-}
fromNumber
:: Integral v
=> Word
-> v
-> BitVector
fromNumber !dimValue !intValue = BV dimValue . intToNat $ mask .&. v
where
!v | signum int < 0 = negate $ shiftL 1 intBits - int
| otherwise = int
!int = toInteger intValue
!intBits = I# (integerLog2# int)
!mask = 2 ^ dimValue - 1
{-# RULES
"fromNumber/Natural" forall w (n :: Natural). fromNumber w n = BV w n
"fromNumber/Word" forall w (v :: Word ). fromNumber w v = BV w (wordToNatural v)
#-}
{-# INLINE toSignedNumber #-}
toSignedNumber :: Num a => BitVector -> a
toSignedNumber (BV w n) = fromInteger v
where
!i = toInteger n
!v | n `testBit` (fromEnum w - 1) = negate $ shiftL 1 (fromEnum w) - i
| otherwise = i
{-# INLINE[1] toUnsignedNumber #-}
toUnsignedNumber :: Num a => BitVector -> a
toUnsignedNumber = fromInteger . toInteger . nat
{-# RULES
"toUnsignedNumber/Natural" toUnsignedNumber = nat
#-}
{-# INLINE dimension #-}
dimension :: BitVector -> Word
dimension = dim
{-# INLINE isZeroVector #-}
isZeroVector :: BitVector -> Bool
isZeroVector = (0 ==) . nat
{-# INLINE subRange #-}
subRange :: (Word, Word) -> BitVector -> BitVector
subRange (!lower, !upper) (BV _ n)
| lower > upper = zeroBits
| otherwise =
case toInt lower of
Nothing -> zeroBits
Just i ->
let b = n `shiftR` i
in case toInt upper of
Nothing ->
let m = toEnum $ maxBound - i + 1
in BV m $ n `shiftR` i
Just j ->
let x = j - i
m | x == maxBound = x
| otherwise = x + 1
in BV (toEnum m) $ b .&. pred (1 `shiftL` m)
toInt :: Word -> Maybe Int
toInt w
| w > maxInt = Nothing
| otherwise = Just $ fromEnum w
where
maxInt = toEnum (maxBound :: Int)
{-# INLINE intToNat #-}
intToNat :: Integer -> Natural
intToNat (S# i#) | isTrue# (i# >=# 0#) = NatS# (int2Word# i#)
intToNat (Jp# bn) | isTrue# (sizeofBigNat# bn ==# 1#) = NatS# (bigNatToWord bn)
| otherwise = NatJ# bn
intToNat _ = NatS# (int2Word# 0#)