diff --git a/btree.cabal b/btree.cabal --- a/btree.cabal +++ b/btree.cabal @@ -1,5 +1,5 @@ name: btree -version: 0.3.1 +version: 0.4.0 synopsis: B-Tree on Unmanaged Heap -- description: homepage: https://github.com/andrewthad/btree @@ -8,7 +8,7 @@ author: Andrew Martin maintainer: andrew.thaddeus@gmail.com copyright: 2017 Andrew Martin -category: Web +category: Data build-type: Simple extra-source-files: README.md cabal-version: >=1.10 @@ -20,9 +20,9 @@ BTree BTree.Store BTree.Linear - ArrayList build-depends: base >= 4.9 && < 5 + , initialize >= 0.1.1.0 && < 0.2.0.0 , ghc-prim >= 0.5 && < 0.6 , primitive >= 0.6.4 && < 0.7 default-language: Haskell2010 diff --git a/src/ArrayList.hs b/src/ArrayList.hs deleted file mode 100644 --- a/src/ArrayList.hs +++ /dev/null @@ -1,322 +0,0 @@ -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE UnboxedTuples #-} - -module ArrayList - ( ArrayList - , size - , with - , new - , free - , pushR - , pushArrayR - , popL - , dropWhileL - , dropWhileScanL - , dropScanL - , dropL - , dump - , dumpMap - , dumpList - , clear - , showDebug - ) where - -import Foreign.Ptr -import Foreign.Storable -import Foreign.Marshal.Array -import Data.Primitive.PrimArray -import GHC.Prim (RealWorld) -import GHC.Int (Int(..)) -import GHC.Ptr (Ptr(..)) -import GHC.IO (IO(..)) -import GHC.Prim ((*#),copyAddrToByteArray#) -import Data.Primitive hiding (sizeOf) -import Data.Primitive.Types -import Data.Bits (unsafeShiftR) -import BTree.Store (Initialize(..),Deinitialize(..)) -import Control.Monad (when) -import Data.Primitive.Ptr (copyPtrToMutablePrimArray) -import qualified Data.Primitive as PM -import qualified Foreign.Marshal.Alloc as FMA -import qualified Foreign.Storable as FS - --- Special value for Ptr: If the pointer is null, then --- it is understood that the ArrayList is of length 0. --- For such an ArrayList, it is understood that --- all of the fields should be 0. -data ArrayList a = ArrayList - {-# UNPACK #-} !Int -- start index (in elements) - {-# UNPACK #-} !Int -- used length (in elements) - {-# UNPACK #-} !Int -- buffer length (in elements) - {-# UNPACK #-} !(Ptr a) -- all the data - -instance Storable (ArrayList a) where - sizeOf _ = wordSz * 4 - alignment _ = wordSz - {-# INLINE peek #-} - peek ptr = ArrayList - <$> peek (castPtr ptr) - <*> peek (plusPtr ptr wordSz) - <*> peek (plusPtr ptr (wordSz + wordSz)) - <*> peek (plusPtr ptr (wordSz + wordSz + wordSz)) - {-# INLINE poke #-} - poke ptr (ArrayList a b c d) = do - poke (castPtr ptr) a - poke (plusPtr ptr wordSz) b - poke (plusPtr ptr (wordSz + wordSz)) c - poke (plusPtr ptr (wordSz + wordSz + wordSz)) d - -instance Storable a => Initialize (ArrayList a) where - {-# INLINE initialize #-} - initialize (Ptr addr#) = setAddr (Addr addr#) 4 (0 :: Int) - -wordSz :: Int -wordSz = PM.sizeOf (undefined :: Int) - -initialSize :: Int -initialSize = 4 - -size :: ArrayList a -> Int -size (ArrayList _ len _ _) = len - -with :: Storable a => (ArrayList a -> IO (ArrayList a,b)) -> IO b -with f = do - initial <- new - (final,a) <- f initial - free final - return a - -new :: forall a. Storable a => IO (ArrayList a) -new = return (ArrayList 0 0 0 nullPtr) - -{-# INLINABLE pushR #-} -pushR :: forall a. Storable a => ArrayList a -> a -> IO (ArrayList a) -pushR (ArrayList start len bufLen ptr) a = if start + len < bufLen - then do - poke (advancePtr ptr (start + len)) a - return (ArrayList start (len + 1) bufLen ptr) - else if - | len == 0 -> do - when (bufLen /= 0) (fail "ArrayList.pushR: invariant violated") - when (start /= 0) (fail "ArrayList.pushR: invariant violated") - when (ptr /= nullPtr) (fail "ArrayList.pushR: invariant violated") - ptr <- FMA.mallocBytes (FS.sizeOf (undefined :: a) * initialSize) - poke ptr a - return (ArrayList 0 1 initialSize ptr) - | len < half bufLen -> do - moveArray ptr (advancePtr ptr start) len - poke (advancePtr ptr len) a - return (ArrayList 0 (len + 1) bufLen ptr) - | otherwise -> do - newPtr <- FMA.mallocBytes (FS.sizeOf (undefined :: a) * bufLen * 2) - moveArray newPtr (advancePtr ptr start) len - FMA.free ptr - poke (advancePtr newPtr len) a - return (ArrayList 0 (len + 1) (bufLen * 2) newPtr) - -{-# INLINE pushArrayR #-} -pushArrayR :: forall a. (Storable a, Prim a) => ArrayList a -> PrimArray a -> IO (ArrayList a) -pushArrayR (ArrayList start len bufLen ptr) as = - -- I think this should actually be less than or equal to - if start + len + asLen < bufLen - then do - copyPrimArrayToPtr (advancePtr ptr (start + len)) as 0 asLen - return (ArrayList start (len + asLen) bufLen ptr) - else if - -- this might give poor guarentees concerning worst - -- case behaviors, but whatever for now. - | len == 0 -> do - when (bufLen /= 0) (fail "ArrayList.pushArrayR: invariant violated") - when (start /= 0) (fail "ArrayList.pushArrayR: invariant violated") - when (ptr /= nullPtr) (fail "ArrayList.pushArrayR: invariant violated") - let newBufLen = twiceUntilExceeds initialSize asLen - ptr <- FMA.mallocBytes (FS.sizeOf (undefined :: a) * newBufLen) - copyPrimArrayToPtr ptr as 0 asLen - return (ArrayList 0 asLen newBufLen ptr) - | len < half bufLen && asLen < half bufLen -> do - moveArray ptr (advancePtr ptr start) len - copyPrimArrayToPtr (advancePtr ptr len) as 0 asLen - return (ArrayList 0 (len + asLen) bufLen ptr) - | otherwise -> do - let newBufLen = twiceUntilExceeds (2 * bufLen) (len + asLen) - newPtr <- FMA.mallocBytes (FS.sizeOf (undefined :: a) * newBufLen) - moveArray newPtr (advancePtr ptr start) len - FMA.free ptr - copyPrimArrayToPtr (advancePtr newPtr len) as 0 asLen - return (ArrayList 0 (len + asLen) newBufLen newPtr) - where - asLen = sizeofPrimArray as - -twiceUntilExceeds :: Int -> Int -> Int -twiceUntilExceeds !i !limit = go i where - go !n = if n > limit - then n - else go (n * 2) - - -popL :: forall a. Storable a => ArrayList a -> IO (ArrayList a, Maybe a) -popL xs@(ArrayList start len bufLen ptr) - | len < 1 = return (xs, Nothing) - | otherwise = do - a <- peek (advancePtr ptr start) - newArrList <- minimizeMemory (ArrayList (start + 1) (len - 1) bufLen ptr) - return (newArrList, Just a) - -{-# INLINE dropWhileL #-} -dropWhileL :: forall a. Storable a - => ArrayList a - -> (a -> IO Bool) -- ^ predicate - -> IO (ArrayList a,Int) -dropWhileL (ArrayList start len bufLen ptr) p = do - let go :: Int -> IO Int - go !i = if i < len - then do - a <- peek (advancePtr ptr (start + i)) - b <- p a - if b - then go (i + 1) - else return i - else return i - dropped <- go 0 - newArrList <- minimizeMemory $ ArrayList (start + dropped) (len - dropped) bufLen ptr - return (newArrList,dropped) - -{-# INLINE dropWhileScanL #-} -dropWhileScanL :: forall a b. Storable a - => ArrayList a - -> b - -> (b -> a -> IO (Bool,b)) - -> IO (ArrayList a,Int,b) -dropWhileScanL (ArrayList start len bufLen ptr) b0 p = do - let go :: Int -> b -> IO (Int,b) - go !i !b = if i < len - then do - !a <- peek (advancePtr ptr (start + i)) - (!shouldContinue,!b') <- p b a - if shouldContinue - then go (i + 1) b' - else return (i,b') - else return (i,b) - (dropped,b') <- go 0 b0 - newArrList <- minimizeMemory $ ArrayList (start + dropped) (len - dropped) bufLen ptr - return (newArrList,dropped,b') - -{-# INLINE dropScanL #-} -dropScanL :: forall a b. Storable a - => ArrayList a - -> Int - -> b - -> (b -> a -> IO b) - -> IO (ArrayList a, b) -dropScanL (ArrayList start len bufLen ptr) n b0 p = do - let !m = min n len - let go :: Int -> b -> IO b - go !i !b = if i < m - then do - a <- peek (advancePtr ptr (start + i)) - b' <- p b a - go (i + 1) b' - else return b - b' <- go 0 b0 - newArrList <- minimizeMemory $ ArrayList (start + m) (len - m) bufLen ptr - return (newArrList,b') - -{-# INLINE dropL #-} -dropL :: forall a. Storable a => ArrayList a -> Int -> IO (ArrayList a) -dropL (ArrayList start len bufLen ptr) n = do - let m = min n len - minimizeMemory $ ArrayList (start + m) (len - m) bufLen ptr - -{-# INLINE minimizeMemory #-} -minimizeMemory :: forall a. Storable a => ArrayList a -> IO (ArrayList a) -minimizeMemory xs@(ArrayList start len bufLen ptr) - -- We do not drop below a certain size, since then we would - -- end up doing frequent reallocations. Although, once the size - -- reaches zero, we deallocate entirely since this can save a lot - -- of memory when we have many empty ArrayLists. - | len == 0 = do - FMA.free ptr - return (ArrayList 0 0 0 nullPtr) - | bufLen <= initialSize = return xs - | len < eighth bufLen = do - newPtr <- FMA.mallocBytes (FS.sizeOf (undefined :: a) * div bufLen 2) - moveArray newPtr (advancePtr ptr start) len - FMA.free ptr - return (ArrayList 0 len (div bufLen 2) newPtr) - | otherwise = return (ArrayList start len bufLen ptr) - - -{-# INLINE half #-} -half :: Int -> Int -half x = unsafeShiftR x 1 - -{-# INLINE quarter #-} -quarter :: Int -> Int -quarter x = unsafeShiftR x 2 - -{-# INLINE eighth #-} -eighth :: Int -> Int -eighth x = unsafeShiftR x 3 - -{-# INLINE sixteenth #-} -sixteenth :: Int -> Int -sixteenth x = unsafeShiftR x 4 - --- | This should not be used in production code. -dumpList :: (Prim a, Storable a) => ArrayList a -> IO (ArrayList a, [a]) -dumpList xs@(ArrayList _ len _ _) = do - marr <- newPrimArray len - newXs <- dump xs marr 0 - arr <- unsafeFreezePrimArray marr - return (newXs,primArrayToListN len arr) - -primArrayToListN :: forall a. Prim a => Int -> PrimArray a -> [a] -primArrayToListN len arr = go 0 - where - go :: Int -> [a] - go !ix = if ix < len - then indexPrimArray arr ix : go (ix + 1) - else [] - --- | Deletes all elements from the linked list, copying them --- into the buffer specified by the pointer. Returns an --- empty linked list. -dump :: (Prim a, Storable a) - => ArrayList a -> MutablePrimArray RealWorld a -> Int -> IO (ArrayList a) -dump xs@(ArrayList start len _ ptr) marr ix = do - copyPtrToMutablePrimArray marr ix (advancePtr ptr start) len - clear xs - --- | Dump the elements into a 'MutablePrimArray', mapping over them --- first. This is a fairly niche function. -dumpMap :: (Storable a, Prim b) - => ArrayList a -> (a -> b) -> MutablePrimArray RealWorld b -> Int -> IO (ArrayList a) -dumpMap xs@(ArrayList start len _ ptr) f marr ix = do - let go :: Int -> IO () - go !i = if i < len - then do - a <- peekElemOff ptr (start + i) - writePrimArray marr (ix + i) (f a) - else return () - go 0 - clear xs - --- | Does not affect the contents of the ArrayList -showDebug :: forall a. (Prim a, Storable a, Show a) => ArrayList a -> IO String -showDebug (ArrayList start len _ ptr) = do - marr <- newPrimArray len - copyPtrToMutablePrimArray marr 0 (plusPtr ptr (start * PM.sizeOf (undefined :: a))) len - arr <- unsafeFreezePrimArray marr - return (show (primArrayToListN len arr :: [a])) - -clear :: Storable a => ArrayList a -> IO (ArrayList a) -clear xs@(ArrayList _ len _ _) = dropL xs len - --- | Final consumer of the ArrayList. -free :: ArrayList a -> IO () -free (ArrayList _ _ _ ptr) = FMA.free ptr - diff --git a/src/BTree/Store.hs b/src/BTree/Store.hs --- a/src/BTree/Store.hs +++ b/src/BTree/Store.hs @@ -30,6 +30,7 @@ , inlineModifyWithM ) where +import Initialize import Prelude hiding (lookup) import Foreign.Storable import Foreign.Ptr @@ -49,46 +50,6 @@ data Node k v -class Storable a => Initialize a where - initialize :: Ptr a -> IO () - -- ^ Initialize the memory at a pointer. An implementation - -- of this function may do nothing, or if the data contains - -- more pointers, @initialize@ may allocate additional memory. - initializeElemOff :: Ptr a -> Int -> IO () - -- ^ Can be overridden for efficiency - initializeElemOff ptr ix = do - initialize (plusPtr ptr (ix * sizeOf (undefined :: a)) :: Ptr a) - initializeElems :: Ptr a -> Int -> IO () - -- ^ Initialize a pointer representing an array with - -- a given number of elements. This has a default implementation - -- but may be overriden for efficency. - initializeElems ptr n = go 0 - where - go !i = if i < n - then do - initialize (plusPtr ptr (i * sizeOf (undefined :: a)) :: Ptr a) - go (i + 1) - else return () - -class Storable a => Deinitialize a where - deinitialize :: Ptr a -> IO () - deinitializeElemOff :: Ptr a -> Int -> IO () - -- ^ Can be overridden for efficiency - deinitializeElemOff ptr ix = - deinitialize (plusPtr ptr (ix * sizeOf (undefined :: a)) :: Ptr a) - -- ^ Free any memory in the data structure pointed to. - deinitializeElems :: Ptr a -> Int -> IO () - -- ^ Free any memory pointed to by elements of the array. - -- This has a default implementation - -- but may be overriden for efficency. - deinitializeElems ptr n = go 0 - where - go !i = if i < n - then do - deinitialize (plusPtr ptr (i * sizeOf (undefined :: a)) :: Ptr a) - go (i + 1) - else return () - instance Storable (BTree k v) where sizeOf _ = 2 * sizeOf (undefined :: Int) alignment _ = alignment (undefined :: Int) @@ -116,103 +77,8 @@ bt <- peek ptr free bt -newtype Uninitialized a = Uninitialized a - deriving (Storable) - -instance Storable a => Initialize (Uninitialized a) where - initialize _ = return () - initializeElemOff _ _ = return () - initializeElems _ _ = return () - -instance Storable a => Deinitialize (Uninitialized a) where - deinitialize _ = return () - deinitializeElemOff _ _ = return () - deinitializeElems _ _ = return () - -instance Initialize Word8 where - initialize _ = return () - initializeElemOff _ _ = return () - initializeElems _ _ = return () - -instance Deinitialize Word8 where - deinitialize _ = return () - deinitializeElemOff _ _ = return () - deinitializeElems _ _ = return () - -instance Initialize Word16 where - initialize _ = return () - initializeElemOff _ _ = return () - initializeElems _ _ = return () - -instance Deinitialize Word16 where - deinitialize _ = return () - deinitializeElemOff _ _ = return () - deinitializeElems _ _ = return () - -instance Initialize Word64 where - initialize _ = return () - initializeElemOff _ _ = return () - initializeElems _ _ = return () - -instance Deinitialize Word64 where - deinitialize _ = return () - deinitializeElemOff _ _ = return () - deinitializeElems _ _ = return () - - -instance Initialize Word where - initialize ptr = poke ptr (0 :: Word) - initializeElemOff ptr off = pokeElemOff ptr off (0 :: Word) - initializeElems ptr elemLen = PA.setAddr (ptrToAddr ptr) elemLen (0 :: Word) - -instance Deinitialize Word where - deinitialize _ = return () - deinitializeElemOff _ _ = return () - deinitializeElems _ _ = return () - -instance Initialize Int where - initialize ptr = poke ptr (0 :: Int) - initializeElemOff ptr off = pokeElemOff ptr off (0 :: Int) - initializeElems ptr elemLen = PA.setAddr (ptrToAddr ptr) elemLen (0 :: Int) - -instance Initialize Int64 where - initialize ptr = poke ptr (0 :: Int64) - initializeElemOff ptr off = pokeElemOff ptr off (0 :: Int64) - initializeElems ptr elemLen = PA.setAddr (ptrToAddr ptr) elemLen (0 :: Int64) - ptrToAddr :: Ptr a -> PA.Addr ptrToAddr (Ptr x) = PA.Addr x - -instance Initialize Word32 where - initialize _ = return () - initializeElemOff _ _ = return () - initializeElems _ _ = return () - -instance Deinitialize Word32 where - deinitialize _ = return () - deinitializeElemOff _ _ = return () - deinitializeElems _ _ = return () - -instance Deinitialize Int where - deinitialize _ = return () - deinitializeElemOff _ _ = return () - deinitializeElems _ _ = return () - -instance Deinitialize Int64 where - deinitialize _ = return () - deinitializeElemOff _ _ = return () - deinitializeElems _ _ = return () - -instance Initialize Char where - initialize _ = return () - initializeElemOff _ _ = return () - initializeElems _ _ = return () - -instance Deinitialize Char where - deinitialize _ = return () - deinitializeElemOff _ _ = return () - deinitializeElems _ _ = return () - newtype Arr a = Arr { getArr :: Ptr a } data KeysValues k v = KeysValues !(Arr k) !(Arr v) diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -44,7 +44,6 @@ import qualified BTree as B import qualified BTree.Linear as BTL import qualified BTree.Store as BTS -import qualified ArrayList as AL import qualified Data.Set as S import qualified Data.Primitive.PrimArray as P @@ -121,18 +120,6 @@ -- , testPropDepth 1050 "large maps with Word16" (over word16SeriesSingles f) ] -arraylistTests :: [TestTree] -arraylistTests = - [ testPropDepth 10 "arraylist inserts followed by dump (short)" (over word16Series arrayListInsertions) - , testPropDepth 150 "arraylist inserts followed by dump (long)" (over word32Series arrayListInsertions) - , testPropDepth 150 "arraylist inserts followed by repeated pop (long)" (over word32Series pushPop) - , testPropDepth 50 "arraylist dropWhile" (over word32Series arrayListDropWhile) - , testPropDepth 50 "insert array" (over word32Series arrayListInsertArray) - , testPropDepth 100 "insert big array" (over word32Series arrayListInsertBigArray) - , testPropDepth 100 "insert big arrays" (over word32Series arrayListInsertArrays) - -- , testPropDepth 150 "arraylist push, pop, twice (long)" (over word32Series pushPopTwice) - ] - scProps :: TestTree scProps = testGroup "smallcheck" [ testGroup "unmanaged heap" (smallcheckTests orderingStorable) @@ -141,90 +128,8 @@ -- , testGroup "unmanaged heap nested diverse" (smallcheckTests orderingNestedDiverse) -- deletion does not work yet -- , testGroup "unmanaged heap deletions" (smallcheckTests deletionStorable) - , testGroup "arraylist" arraylistTests ] -arrayListInsertions :: (Eq a, Show a, Prim a, Storable a) => [a] -> Either String String -arrayListInsertions xs = unsafePerformIO $ AL.with $ \a0 -> do - a1 <- foldlM AL.pushR a0 xs - (a2,ys) <- AL.dumpList a1 - return $ (,) a2 $ if xs == ys - then Right "good" - else Left ("expected " ++ show xs ++ " but got " ++ show ys) - -pushPop :: forall a. (Eq a, Show a, Prim a, Storable a) => [a] -> Either String String -pushPop xs = unsafePerformIO $ AL.with $ \a0 -> do - a1 <- foldlM AL.pushR a0 xs - let go :: AL.ArrayList a -> IO (AL.ArrayList a, [a]) - go al = do - (al',m) <- AL.popL al - case m of - Nothing -> return (al',[]) - Just a -> fmap (second (a:)) (go al') - (a2,ys) <- go a1 - return $ (,) a2 $ if xs == ys - then Right "good" - else Left $ "expected " ++ show xs ++ " but got " ++ show ys - -arrayListDropWhile :: forall a. (Hashable a, Eq a, Show a, Prim a, Storable a) => [a] -> Either String String -arrayListDropWhile xs = unsafePerformIO $ AL.with $ \a0 -> - case deterministicShuffle xs of - [] -> return (a0, Right "good") - x : _ -> do - a1 <- foldlM AL.pushR a0 xs - (a2,_) <- AL.dropWhileL a1 (\y -> return (y /= x)) - (a3,ys) <- AL.dumpList a2 - let expected = L.dropWhile (/= x) xs - return $ (,) a3 $ if expected == ys - then Right "good" - else Left ("expected " ++ show expected ++ " but got " ++ show ys ++ " using pivot of " ++ show x) - -arrayListInsertArray :: forall a. (Hashable a, Eq a, Show a, Prim a, Storable a) - => [a] -> Either String String -arrayListInsertArray xs = unsafePerformIO $ AL.with $ \a0 -> do - a1 <- foldlM AL.pushArrayR a0 (map singletonPrimArray xs) - let go :: AL.ArrayList a -> IO (AL.ArrayList a, [a]) - go al = do - (al',m) <- AL.popL al - case m of - Nothing -> return (al',[]) - Just a -> fmap (second (a:)) (go al') - (a2,ys) <- go a1 - return $ (,) a2 $ if xs == ys - then Right "good" - else Left $ "expected " ++ show xs ++ " but got " ++ show ys - -arrayListInsertBigArray :: forall a. (Hashable a, Eq a, Show a, Prim a, Storable a) - => [a] -> Either String String -arrayListInsertBigArray xs = unsafePerformIO $ AL.with $ \a0 -> do - a1 <- AL.pushArrayR a0 (fromList xs) - let go :: AL.ArrayList a -> IO (AL.ArrayList a, [a]) - go al = do - (al',m) <- AL.popL al - case m of - Nothing -> return (al',[]) - Just a -> fmap (second (a:)) (go al') - (a2,ys) <- go a1 - return $ (,) a2 $ if xs == ys - then Right "good" - else Left $ "expected " ++ show xs ++ " but got " ++ show ys - -arrayListInsertArrays :: forall a. (Hashable a, Eq a, Show a, Prim a, Storable a) - => [a] -> Either String String -arrayListInsertArrays xs = unsafePerformIO $ AL.with $ \a0 -> do - a1 <- AL.pushArrayR a0 (fromList xs) - a2 <- AL.pushArrayR a1 (fromList xs) - let go :: AL.ArrayList a -> IO (AL.ArrayList a, [a]) - go al = do - (al',m) <- AL.popL al - case m of - Nothing -> return (al',[]) - Just a -> fmap (second (a:)) (go al') - (a3,zs) <- go a2 - return $ (,) a3 $ if zs == (xs ++ xs) - then Right "good" - else Left $ "expected " ++ show (xs ++ xs) ++ " but got " ++ show zs - unitTests :: TestTree unitTests = testGroup "Unit tests" [ testCase "put followed by get (tests lookup,insert,toAscList)" $ do @@ -263,12 +168,6 @@ xs' = map (\x -> (x,x)) xs actual <- return (runST (B.fromList (B.Context (BTL.Context 4)) xs' >>= B.toAscList)) actual @?= S.toAscList (S.fromList xs') - , testCase "ArrayList dropWhileScanL on empty" $ do - xs <- AL.new - (xs',n,r) <- AL.dropWhileScanL xs (55 :: Word32) (\b a -> return (True,b + a)) - n @?= 0 - r @?= 55 - AL.free xs' ] testPropDepth :: Testable IO a => Int -> String -> a -> TestTree @@ -343,21 +242,6 @@ then Right "good" else Left (notice (show expected) (show actual) layout) --- orderingCompact :: (Show n, Ord n, Prim n) --- => Int -- ^ degree of b-tree --- -> [Positive n] -- ^ values to insert --- -> Either Reason Reason --- orderingCompact degree xs' = --- let xs = map getPositive xs' --- expected = map (\x -> (x,x)) $ S.toAscList $ S.fromList xs --- (actual,layout) = runST $ withToken $ \c -> do --- m0 <- BTC.new c degree --- m1 <- foldlM (\ !m !x -> BTC.insert c m x x) m0 xs --- (,) <$> BTC.toAscList m1 <*> BTC.debugMap m1 --- in if actual == expected --- then Right "good" --- else Left (notice (show expected) (show actual) layout) - orderingStorable :: (Hashable x, Show x, Eq x, Ord x, Storable x, BTS.Initialize x, BTS.Deinitialize x) => [x] -- ^ values to insert -> Either Reason Reason @@ -371,23 +255,6 @@ else Left (notice (show expected) (show actual) "layout not available") return (e,m1) in result - --- this does all insertions followed by all deletions --- deletionStorable :: KnownNat n --- => [Padded n] -- ^ values to insert --- -> Either Reason Reason --- deletionStorable xs = --- let expected = map (\x -> (x,x)) $ S.toAscList $ S.fromList xs --- result = unsafePerformIO $ BTS.with $ \m0 -> do --- m1 <- foldlM (\ !m !x -> BTS.insert m x x) m0 xs --- m2 <- foldlM (\ !m !x -> BTS.delete m x) m1 (deterministicShuffle xs) --- actual <- BTS.toAscList m2 --- let e = if actual == [] --- then Right "good" --- else Left (notice "empty list" (show actual) "layout not available") --- return (e,m2) --- in result - -- let us begin the most dangerous game. orderingNested :: (Bounded x, Integral x, Hashable x, Show x, Eq x, Ord x, Storable x, BTS.Initialize x, BTS.Deinitialize x)