croaring-ffi-1.0: test/Test/Bitmap.hs
{-# LANGUAGE OverloadedRecordDot #-}
module Test.Bitmap
( tests
, genValues
, fromValues
, modelRank
, symmetricDifference
, collect
, visiting
) where
import Control.Exception (IOException, throw, try)
import Control.Monad (forM, forM_)
import Control.Monad.Trans.Resource (allocate)
import Data.Bitmap.Roaring.FFI.Bitmap (Bitmap (..))
import Data.Bitmap.Roaring.FFI.Bitmap qualified as Bitmap
import Data.Bitmap.Roaring.FFI.Bitmap.BulkContext (BulkContext (..))
import Data.Bitmap.Roaring.FFI.Bitmap.BulkContext qualified as BulkContext
import Data.Bitmap.Roaring.FFI.Bitmap.Statistics (Statistics (..))
import Data.Bitmap.Roaring.FFI.Bitset (Bitset (..))
import Data.Bitmap.Roaring.FFI.Bitset qualified as Bitset
import Data.Bitmap.Roaring.FFI.NullHandle (NullHandle (..))
import Data.IORef (IORef, modifyIORef', newIORef, readIORef)
import Data.Maybe (fromMaybe)
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Word (Word32, Word64, Word8)
import Foreign.C.ConstPtr (ConstPtr (..))
import Foreign.C.String (peekCString)
import Foreign.C.Types (CChar, CSize)
import Foreign.ForeignPtr (finalizeForeignPtr, newForeignPtr, withForeignPtr)
import Foreign.Marshal.Alloc (alloca)
import Foreign.Marshal.Array (advancePtr, allocaArray, peekArray, pokeArray, withArrayLen)
import Foreign.Marshal.Utils (fillBytes)
import Foreign.Ptr (FunPtr, Ptr, castPtr, freeHaskellFunPtr, nullPtr, plusPtr)
import Foreign.Storable (peek, poke)
import Hedgehog (Gen, Property, annotate, assert, evalIO, forAll, (===))
import Hedgehog.Gen qualified as Gen
import Hedgehog.Range qualified as Range
import Test.Property (Test, returns)
import Test.Property qualified as Property
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.Hedgehog (testProperty)
tests :: TestTree
tests =
testGroup
"Bitmap"
[ testGroup
"marshalling"
[ testProperty "bool results in both polarities" boolResults
, testProperty "bool arguments through copy-on-write" boolArguments
]
, testGroup
"model"
[ testProperty "contents and queries" contentsAndQueries
, testProperty "set algebra" setAlgebra
, testProperty "in-place set algebra" inplaceSetAlgebra
, testProperty "many-bitmap operations" manyBitmaps
, testProperty "lazy union after repair" lazyUnion
, testProperty "ranges" ranges
, testProperty "offset" offset
, testProperty "rankMany and rangeUint32Array" bulkQueries
, testProperty "copy-on-write shares and unshares containers" copyOnWrite
]
, testGroup
"serialization"
[ testProperty "native round-trip" nativeRoundTrip
, testProperty "portable round-trip" portableRoundTrip
, testProperty "portable frozen round-trip" portableFrozenRoundTrip
, testProperty "frozen view round-trip" frozenRoundTrip
, testProperty "bounded portable load rejects a truncated buffer" truncatedPortable
, testProperty "bounded load accepts unsorted values that validation rejects" corruptedPortable
]
, testGroup
"layout"
[ testProperty "statistics of known containers" knownStatistics
, testProperty "statistics poke and peek agree" statisticsStorable
, testProperty "bitmap in caller memory" callerMemory
, testProperty "bulk context in caller memory" bulkContext
]
, testGroup
"callbacks"
[ testProperty "iterate visits every value" iterateAll
, testProperty "iterate stops when the callback says so" iterateStop
, testProperty "iterate64 ORs in the high bits" iterate64HighBits
]
, testGroup
"helpers"
[ testProperty "with frees the bitmap and rejects NULL" scoped
, testProperty "withPortableFrozen views valid bytes in place" portableFrozenScope
, testProperty "withPortableFrozen rejects offsets past the bytes" portableFrozenOffsets
, testProperty "withFrozenView views aligned bytes in place" frozenViewScope
, testProperty "iterateWith visits, stops and rethrows" callbackHelpers
, testProperty "in-place operations with the same bitmap twice" selfAliasing
, testProperty "BulkContext.with" scopedBulkContext
]
, testGroup
"interop"
[ testProperty "toBitset and wordRangeToBitset" bitsets
, testProperty "finalizerFree releases through a ForeignPtr" finalizer
]
]
genValues :: Gen [Word32]
genValues = concat <$> Gen.list (Range.linear 0 60) (Gen.choice [pure <$> genValue, genRun])
where
genRun = do
start <- genValue
len <- Gen.int $ Range.linear 0 3000
pure . take len $ enumFrom start
genValue :: Gen Word32
genValue =
Gen.choice
[ Gen.word32 $ Range.constant 0 200000
, Gen.word32 Range.constantBounded
, Gen.word32 $ Range.constant (maxBound - 200000) maxBound
]
adopt :: IO Bitmap -> Test Bitmap
adopt = Property.adopt (Bitmap nullPtr) Bitmap.free
owned :: IO Bitmap -> Test Bitmap
owned = Property.owned (Bitmap nullPtr) Bitmap.free
fromValues :: [Word32] -> Test Bitmap
fromValues values = owned . withArrayLen values $ \count ptr -> Bitmap.ofPtr (fromIntegral count) ptr
elements :: Bitmap -> IO [Word32]
elements bitmap = do
count <- fromIntegral <$> Bitmap.getCardinality bitmap
allocaArray count $ \ptr -> do
Bitmap.toUint32Array bitmap ptr
peekArray count ptr
toList :: Bitmap -> Test [Word32]
toList = evalIO . elements
visiting :: ((value -> IO Bool) -> IO Bool) -> (value -> IO Bool) -> IO (Either IOException Bool, [value])
visiting iteration decide = do
seen <- newIORef []
outcome <- try . iteration $ \value -> modifyIORef' seen (value :) >> decide value
(,) outcome . reverse <$> readIORef seen
modelRank :: (Ord a, Num rank) => Set a -> a -> rank
modelRank model value = fromIntegral . Set.size $ Set.takeWhileAntitone (<= value) model
symmetricDifference :: (Ord a) => Set a -> Set a -> Set a
symmetricDifference left right = Set.union left right `Set.difference` Set.intersection left right
collect :: ((value -> Ptr () -> IO Bool) -> IO (FunPtr callback)) -> (value -> Bool) -> Test (IORef [value], FunPtr callback)
collect wrap continue = do
seen <- evalIO $ newIORef []
(_, callback) <- allocate (wrap $ \value _ -> modifyIORef' seen (value :) >> pure (continue value)) freeHaskellFunPtr
pure (seen, callback)
boolResults :: Property
boolResults =
Property.example $ do
bitmap <- owned Bitmap.create
Bitmap.addChecked bitmap 7 `returns` True
Bitmap.addChecked bitmap 7 `returns` False
Bitmap.removeChecked bitmap 7 `returns` True
Bitmap.removeChecked bitmap 7 `returns` False
Bitmap.isEmpty bitmap `returns` True
boolArguments :: Property
boolArguments =
Property.example $ do
bitmap <- owned Bitmap.create
Bitmap.getCopyOnWrite bitmap `returns` False
evalIO $ Bitmap.setCopyOnWrite bitmap True
Bitmap.getCopyOnWrite bitmap `returns` True
evalIO $ Bitmap.setCopyOnWrite bitmap False
Bitmap.getCopyOnWrite bitmap `returns` False
contentsAndQueries :: Property
contentsAndQueries =
Property.generated $ do
values <- forAll genValues
probes <- forAll $ Gen.list (Range.linear 0 50) genValue
bitmap <- fromValues values
let model = Set.fromList values
toList bitmap >>= (=== Set.toAscList model)
Bitmap.getCardinality bitmap `returns` fromIntegral (Set.size model)
Bitmap.isEmpty bitmap `returns` Set.null model
Bitmap.minimum bitmap `returns` maybe maxBound fst (Set.minView model)
Bitmap.maximum bitmap `returns` maybe 0 fst (Set.maxView model)
Bitmap.internalValidate bitmap nullPtr `returns` True
forM (values <> probes) (probe bitmap) `returns` map (modelProbe model) (values <> probes)
forM [0 .. fromIntegral (Set.size model)] (select bitmap) `returns` (map Just (Set.toAscList model) <> [Nothing])
where
probe bitmap value = (,,) <$> Bitmap.contains bitmap value <*> Bitmap.rank bitmap value <*> Bitmap.getIndex bitmap value
modelProbe model value =
( Set.member value model
, modelRank model value
, maybe (-1) fromIntegral $ Set.lookupIndex value model
)
select bitmap rank =
alloca $ \out -> do
found <- Bitmap.select bitmap rank out
if found then Just <$> peek out else pure Nothing
setAlgebra :: Property
setAlgebra =
Property.generated $ do
leftValues <- forAll genValues
rightValues <- forAll genValues
left <- fromValues leftValues
right <- fromValues rightValues
let
leftModel = Set.fromList leftValues
rightModel = Set.fromList rightValues
intersection = Set.intersection leftModel rightModel
union = Set.union leftModel rightModel
difference = Set.difference leftModel rightModel
symmetric = symmetricDifference leftModel rightModel
owned (Bitmap.and left right) >>= toList >>= (=== Set.toAscList intersection)
owned (Bitmap.or left right) >>= toList >>= (=== Set.toAscList union)
owned (Bitmap.andnot left right) >>= toList >>= (=== Set.toAscList difference)
owned (Bitmap.xor left right) >>= toList >>= (=== Set.toAscList symmetric)
Bitmap.andCardinality left right `returns` fromIntegral (Set.size intersection)
Bitmap.orCardinality left right `returns` fromIntegral (Set.size union)
Bitmap.andnotCardinality left right `returns` fromIntegral (Set.size difference)
Bitmap.xorCardinality left right `returns` fromIntegral (Set.size symmetric)
Bitmap.intersect left right `returns` not (Set.disjoint leftModel rightModel)
Bitmap.isSubset left right `returns` Set.isSubsetOf leftModel rightModel
Bitmap.isStrictSubset left right `returns` Set.isProperSubsetOf leftModel rightModel
Bitmap.equals left right `returns` (leftModel == rightModel)
inplaceSetAlgebra :: Property
inplaceSetAlgebra =
Property.generated $ do
leftValues <- forAll genValues
rightValues <- forAll genValues
right <- fromValues rightValues
let
leftModel = Set.fromList leftValues
rightModel = Set.fromList rightValues
applied :: (Bitmap -> Bitmap -> IO ()) -> Test [Word32]
applied operation = do
left <- fromValues leftValues
evalIO $ operation left right
toList left
applied Bitmap.andInplace >>= (=== Set.toAscList (Set.intersection leftModel rightModel))
applied Bitmap.orInplace >>= (=== Set.toAscList (Set.union leftModel rightModel))
applied Bitmap.andnotInplace >>= (=== Set.toAscList (Set.difference leftModel rightModel))
applied Bitmap.xorInplace >>= (=== Set.toAscList (symmetricDifference leftModel rightModel))
self <- fromValues leftValues
evalIO $ Bitmap.andInplace self self
toList self >>= (=== Set.toAscList leftModel)
manyBitmaps :: Property
manyBitmaps =
Property.generated $ do
valueLists <- forAll $ Gen.list (Range.linear 0 10) genValues
bitmaps <- mapM fromValues valueLists
handles <- Property.array $ length bitmaps
evalIO $ pokeArray handles bitmaps
let
count = length bitmaps
union = Set.toAscList . Set.unions $ map Set.fromList valueLists
symmetric = Set.toAscList . foldr (symmetricDifference . Set.fromList) Set.empty $ valueLists
owned (Bitmap.orMany (fromIntegral count) handles) >>= toList >>= (=== union)
owned (Bitmap.orManyHeap (fromIntegral count) handles) >>= toList >>= (=== union)
owned (Bitmap.xorMany (fromIntegral count) handles) >>= toList >>= (=== symmetric)
lazyUnion :: Property
lazyUnion =
Property.generated $ do
leftValues <- forAll genValues
rightValues <- forAll genValues
left <- fromValues leftValues
right <- fromValues rightValues
union <- owned $ Bitmap.lazyOr left right False
evalIO $ do
Bitmap.lazyOrInplace union left True
Bitmap.repairAfterLazy union
Bitmap.internalValidate union nullPtr `returns` True
toList union >>= (=== Set.toAscList (Set.fromList leftValues `Set.union` Set.fromList rightValues))
ranges :: Property
ranges =
Property.generated $ do
values <- forAll genValues
start <- forAll genValue
len <- forAll . Gen.word64 $ Range.linear 0 100000
bitmap <- fromValues values
let
model = Set.fromList values
end = min (fromIntegral start + len) $ 2 ^ (32 :: Int)
spanned = Set.fromList . take (fromIntegral end - fromIntegral start) $ enumFrom start
inRange = Set.intersection model spanned
modified :: (Bitmap -> Word64 -> Word64 -> IO ()) -> Test [Word32]
modified operation = do
copy <- fromValues values
evalIO $ operation copy (fromIntegral start) end
toList copy
Bitmap.rangeCardinality bitmap (fromIntegral start) end `returns` fromIntegral (Set.size inRange)
Bitmap.containsRange bitmap (fromIntegral start) end `returns` (inRange == spanned)
Bitmap.intersectWithRange bitmap (fromIntegral start) end `returns` not (Set.null inRange)
owned (Bitmap.flip bitmap (fromIntegral start) end) >>= toList >>= (=== Set.toAscList (symmetricDifference model spanned))
modified Bitmap.flipInplace >>= (=== Set.toAscList (symmetricDifference model spanned))
modified Bitmap.addRange >>= (=== Set.toAscList (Set.union model spanned))
modified Bitmap.removeRange >>= (=== Set.toAscList (Set.difference model spanned))
offset :: Property
offset =
Property.generated $ do
values <- forAll genValues
shift <- forAll . Gen.int64 $ Range.constant (-300000) 300000
bitmap <- fromValues values
let moved = map ((+ shift) . fromIntegral) . Set.toAscList $ Set.fromList values
owned (Bitmap.addOffset bitmap shift) >>= toList >>= (=== [fromIntegral value | value <- moved, value >= 0, value < 2 ^ (32 :: Int)])
bulkQueries :: Property
bulkQueries =
Property.generated $ do
values <- forAll genValues
probes <- forAll $ Gen.list (Range.linear 0 50) genValue
start <- forAll . Gen.int $ Range.linear 0 5000
limit <- forAll . Gen.int $ Range.linear 0 5000
bitmap <- fromValues values
let
model = Set.fromList values
sortedProbes = Set.toAscList $ Set.fromList probes
window = take limit . drop start $ Set.toAscList model
ranks = withArrayLen sortedProbes $ \count begin ->
allocaArray count $ \out -> do
Bitmap.rankMany bitmap begin (advancePtr begin count) out
peekArray count out
windowed =
allocaArray (length window) $ \out -> do
done <- Bitmap.rangeUint32Array bitmap (fromIntegral start) (fromIntegral limit) out
found <- peekArray (length window) out
pure (done, found)
ranks `returns` map (modelRank model) sortedProbes
windowed `returns` (True, window)
copyOnWrite :: Property
copyOnWrite =
Property.example $ do
bitmap <- fromValues [1, 2, 3, 70000]
evalIO $ Bitmap.setCopyOnWrite bitmap True
copied <- owned $ Bitmap.copy bitmap
Bitmap.containsShared bitmap `returns` True
evalIO $ Bitmap.add copied 4
toList bitmap >>= (=== [1, 2, 3, 70000])
toList copied >>= (=== [1, 2, 3, 4, 70000])
Bitmap.unshareAll bitmap `returns` True
Bitmap.containsShared bitmap `returns` False
evalIO $ Bitmap.setCopyOnWrite copied False
Bitmap.containsShared copied `returns` False
serialized :: (Bitmap -> IO CSize) -> (Bitmap -> Ptr CChar -> IO a) -> Bitmap -> Test (Ptr CChar, CSize, a)
serialized measure write bitmap = do
size <- evalIO $ measure bitmap
buffer <- Property.array $ fromIntegral size
written <- evalIO $ write bitmap buffer
pure (buffer, size, written)
nativeRoundTrip :: Property
nativeRoundTrip =
Property.generated $ do
values <- forAll genValues
bitmap <- fromValues values
(buffer, size, written) <- serialized Bitmap.sizeInBytes Bitmap.serialize bitmap
written === size
owned (Bitmap.deserializeBounded (castPtr buffer) written) >>= toList >>= (=== Set.toAscList (Set.fromList values))
owned (fromMaybe (Bitmap nullPtr) <$> Bitmap.deserializeValidated (castPtr buffer) written) >>= toList >>= (=== Set.toAscList (Set.fromList values))
owned (Bitmap.deserialize $ castPtr buffer) >>= toList >>= (=== Set.toAscList (Set.fromList values))
portableRoundTrip :: Property
portableRoundTrip =
Property.generated $ do
values <- forAll genValues
bitmap <- fromValues values
(buffer, size, written) <- serialized Bitmap.portableSizeInBytes Bitmap.portableSerialize bitmap
written === size
Bitmap.portableDeserializeSize buffer written `returns` written
owned (Bitmap.portableDeserializeBounded buffer written) >>= toList >>= (=== Set.toAscList (Set.fromList values))
owned (fromMaybe (Bitmap nullPtr) <$> Bitmap.portableDeserializeValidated buffer written) >>= toList >>= (=== Set.toAscList (Set.fromList values))
owned (Bitmap.portableDeserialize buffer) >>= toList >>= (=== Set.toAscList (Set.fromList values))
portableFrozenRoundTrip :: Property
portableFrozenRoundTrip =
Property.generated $ do
values <- forAll genValues
bitmap <- fromValues values
(buffer, _, _) <- serialized Bitmap.portableSizeInBytes Bitmap.portableSerialize bitmap
owned (Bitmap.portableDeserializeFrozen buffer) >>= toList >>= (=== Set.toAscList (Set.fromList values))
frozenRoundTrip :: Property
frozenRoundTrip =
Property.generated $ do
values <- forAll genValues
bitmap <- fromValues values
size <- evalIO $ Bitmap.frozenSizeInBytes bitmap
buffer <- Property.alignedBytes (fromIntegral size) 32
evalIO $ Bitmap.frozenSerialize bitmap buffer
owned (viewed $ Bitmap.frozenView buffer size) >>= toList >>= (=== Set.toAscList (Set.fromList values))
adopt (viewed $ Bitmap.frozenView (buffer `plusPtr` 1) size) >>= (=== Bitmap nullPtr)
where
viewed = fmap $ Bitmap . unConstPtr
truncatedPortable :: Property
truncatedPortable =
Property.example $ do
bitmap <- fromValues [1, 2, 3, 100000]
(buffer, _, written) <- serialized Bitmap.portableSizeInBytes Bitmap.portableSerialize bitmap
Bitmap.portableDeserializeSize buffer (written - 1) `returns` 0
adopt (Bitmap.portableDeserializeBounded buffer $ written - 1) >>= (=== Bitmap nullPtr)
Bitmap.portableDeserializeValidated buffer (written - 1) `returns` Nothing
corruptedPortable :: Property
corruptedPortable =
Property.example $ do
bitmap <- fromValues [1, 2, 3]
(buffer, _, written) <- serialized Bitmap.portableSizeInBytes Bitmap.portableSerialize bitmap
written === 22
let payload = castPtr buffer `plusPtr` 16 :: Ptr Word8
peekArray 6 payload `returns` [1, 0, 2, 0, 3, 0]
evalIO $ pokeArray payload [2, 0, 1, 0, 3, 0]
Bitmap.portableDeserializeValidated buffer written `returns` Nothing
loaded <- owned $ Bitmap.portableDeserializeBounded buffer written
reasonPtr <- Property.array 1
evalIO . poke reasonPtr $ ConstPtr nullPtr
Bitmap.internalValidate loaded reasonPtr `returns` False
Bitmap.withPortableFrozen buffer written elements `returns` Nothing
ConstPtr reason <- evalIO $ peek reasonPtr
assert $ reason /= nullPtr
message <- evalIO $ peekCString reason
annotate message
assert . not $ null message
knownStatistics :: Property
knownStatistics =
Property.example $ do
bitmap <- owned $ Bitmap.fromRange 131072 (131072 + 65536) 2
evalIO $ do
forM_ [0, 2 .. 18] $ Bitmap.add bitmap
Bitmap.addRange bitmap 65536 $ 65536 + 10000
Bitmap.runOptimize bitmap `returns` True
statistics <- evalIO . alloca $ \ptr -> Bitmap.statistics bitmap ptr >> peek ptr
Bitmap.getStatistics bitmap `returns` statistics
statistics
=== Statistics
{ containers = 3
, arrayContainers = 1
, runContainers = 1
, bitsetContainers = 1
, valuesArrayContainers = 10
, valuesRunContainers = 10000
, valuesBitsetContainers = 32768
, bytesArrayContainers = statistics.bytesArrayContainers
, bytesRunContainers = statistics.bytesRunContainers
, bytesBitsetContainers = 8192
, maxValue = 131072 + 65534
, minValue = 0
, cardinality = 10 + 10000 + 32768
}
assert $ statistics.bytesArrayContainers >= 20
assert $ statistics.bytesRunContainers >= 4
statisticsStorable :: Property
statisticsStorable =
Property.example $ do
let statistics = Statistics 1 2 3 4 5 6 7 8 9 10 11 12 13
ptr <- Property.array 1
evalIO $ poke ptr statistics
peek ptr `returns` statistics
callerMemory :: Property
callerMemory =
Property.example $ do
memory <- Property.alignedBytes Bitmap.size Bitmap.alignment
let bitmap = Bitmap memory
_ <- allocate (Bitmap.initCleared bitmap) . const $ Bitmap.clear bitmap
evalIO . forM_ [5, 70000, 3] $ Bitmap.add bitmap
toList bitmap >>= (=== [3, 5, 70000])
evalIO $ Bitmap.clear bitmap
Bitmap.initWithCapacity bitmap 4 `returns` True
evalIO $ Bitmap.add bitmap 9
toList bitmap >>= (=== [9])
bulkContext :: Property
bulkContext =
Property.example $ do
bitmap <- owned Bitmap.create
memory <- Property.alignedBytes BulkContext.size BulkContext.alignment
let
context = BulkContext memory
values = [1, 2, 3, 70000, 70001, 4000000]
reset = evalIO $ fillBytes memory 0 BulkContext.size
reset
evalIO . forM_ values $ Bitmap.addBulk bitmap context
reset
forM (values <> [4, 70002]) (Bitmap.containsBulk bitmap context) `returns` (map (const True) values <> [False, False])
toList bitmap >>= (=== values)
iterateAll :: Property
iterateAll =
Property.example $ do
bitmap <- fromValues [9, 1, 70000, 5]
(seen, callback) <- collect Bitmap.wrapCallback $ const True
Bitmap.iterate bitmap callback nullPtr `returns` True
reverse <$> readIORef seen `returns` [1, 5, 9, 70000]
iterateStop :: Property
iterateStop =
Property.example $ do
bitmap <- fromValues [1 .. 10]
(seen, callback) <- collect Bitmap.wrapCallback (< 3)
Bitmap.iterate bitmap callback nullPtr `returns` False
reverse <$> readIORef seen `returns` [1, 2, 3]
iterate64HighBits :: Property
iterate64HighBits =
Property.example $ do
bitmap <- fromValues [2, 70000]
(seen, callback) <- collect Bitmap.wrapCallback64 $ const True
Bitmap.iterate64 bitmap callback (7 * 2 ^ (32 :: Int)) nullPtr `returns` True
reverse <$> readIORef seen `returns` [7 * 2 ^ (32 :: Int) + 2, 7 * 2 ^ (32 :: Int) + 70000]
bitsets :: Property
bitsets =
Property.example $ do
bitmap <- fromValues [0, 63, 64, 1000]
(_, bitset) <- allocate Bitset.create Bitset.free
assert $ bitset /= Bitset nullPtr
Bitmap.toBitset bitmap bitset `returns` True
Bitset.count bitset `returns` 4
forM [0, 1, 63, 64, 1000, 1001] (Bitset.get bitset) `returns` [True, False, True, True, True, False]
output <- Property.array 2
evalIO $ Bitmap.wordRangeToBitset bitmap 0 2 output
peekArray 2 output `returns` [2 ^ (63 :: Int) + 1, 1 :: Word64]
finalizer :: Property
finalizer =
Property.example $ do
total <- evalIO $ do
Bitmap ptr <- withArrayLen [1, 2, 3] $ \count values -> Bitmap.ofPtr (fromIntegral count) values
foreignPtr <- newForeignPtr Bitmap.finalizerFree ptr
cardinality <- withForeignPtr foreignPtr $ Bitmap.getCardinality . Bitmap
finalizeForeignPtr foreignPtr
pure cardinality
total === 3
scoped :: Property
scoped =
Property.example $ do
Bitmap.with (withArrayLen [1, 5, 9] $ \count values -> Bitmap.ofPtr (fromIntegral count) values) elements `returns` [1, 5, 9]
outcome <- evalIO . try $ Bitmap.with (pure $ Bitmap nullPtr) elements
outcome === Left (NullHandle "Data.Bitmap.Roaring.FFI.Bitmap.with")
portableFrozenScope :: Property
portableFrozenScope =
Property.generated $ do
values <- forAll genValues
bitmap <- fromValues values
(buffer, _, written) <- serialized Bitmap.portableSizeInBytes Bitmap.portableSerialize bitmap
Bitmap.withPortableFrozen buffer written elements `returns` Just (Set.toAscList $ Set.fromList values)
Bitmap.withPortableFrozen buffer (written - 1) elements `returns` Nothing
portableFrozenOffsets :: Property
portableFrozenOffsets =
Property.example $ do
buffer <- Property.array 20
let
viewedAt :: [Word8] -> IO (Maybe [Word32])
viewedAt containerOffset = do
pokeArray buffer $ [0x3A, 0x30, 0, 0, 1, 0, 0, 0, 0, 0, 1, 0] <> containerOffset <> [1, 0, 2, 0]
Bitmap.withPortableFrozen (castPtr buffer) 20 elements
viewedAt [16, 0, 0, 0] `returns` Just [1, 2]
Bitmap.portableDeserializeSize (castPtr buffer) 20 `returns` 20
viewedAt [0, 0, 0, 0x40] `returns` Nothing
viewedAt [17, 0, 0, 0] `returns` Nothing
frozenViewScope :: Property
frozenViewScope =
Property.generated $ do
values <- forAll genValues
bitmap <- fromValues values
size <- evalIO $ Bitmap.frozenSizeInBytes bitmap
buffer <- Property.alignedBytes (fromIntegral size) 32
evalIO $ Bitmap.frozenSerialize bitmap buffer
Bitmap.withFrozenView buffer size elements `returns` Just (Set.toAscList $ Set.fromList values)
Bitmap.withFrozenView (buffer `plusPtr` 1) size elements `returns` Nothing
callbackHelpers :: Property
callbackHelpers =
Property.example $ do
bitmap <- fromValues [1 .. 10]
visiting (Bitmap.iterateWith bitmap) (const $ pure True) `returns` (Right True, [1 .. 10])
visiting (Bitmap.iterateWith bitmap) (pure . (< 3)) `returns` (Right False, [1, 2, 3])
visiting (Bitmap.iterateWith bitmap) stopAtThree `returns` (Left $ userError "stop", [1, 2, 3])
visiting (Bitmap.iterateWith bitmap) lazilyStopAtThree `returns` (Left $ userError "lazy", [1, 2, 3])
visiting (Bitmap.iterate64With bitmap highBits) (const $ pure True) `returns` (Right True, map (+ highBits) [1 .. 10])
where
stopAtThree value = if value == 3 then ioError $ userError "stop" else pure True
lazilyStopAtThree value = pure $ value /= 3 || throw (userError "lazy")
highBits = 7 * 2 ^ (32 :: Int)
selfAliasing :: Property
selfAliasing =
Property.generated $ do
values <- forAll genValues
let
expected = Set.toAscList $ Set.fromList values
applied :: (Bitmap -> Bitmap -> IO ()) -> Test [Word32]
applied operation = do
bitmap <- fromValues values
evalIO $ operation bitmap bitmap
toList bitmap
applied Bitmap.orInplace >>= (=== expected)
applied lazyOr >>= (=== expected)
applied Bitmap.xorInplace >>= (=== [])
applied Bitmap.andnotInplace >>= (=== [])
applied Bitmap.lazyXorInplace >>= (=== [])
applied Bitmap.andInplace >>= (=== expected)
bitmap <- fromValues values
Bitmap.overwrite bitmap bitmap `returns` True
toList bitmap >>= (=== expected)
where
lazyOr target other = Bitmap.lazyOrInplace target other True
scopedBulkContext :: Property
scopedBulkContext =
Property.example $ do
bitmap <- owned Bitmap.create
evalIO . BulkContext.with $ \context -> forM_ values $ Bitmap.addBulk bitmap context
BulkContext.with (\context -> forM (values <> [4]) $ Bitmap.containsBulk bitmap context) `returns` (map (const True) values <> [False])
toList bitmap >>= (=== values)
where
values = [1, 2, 3, 70000, 4000000]