haskey-btree 0.2.0.1 → 0.3.0.0
raw patch · 24 files changed
+813/−813 lines, 24 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
- Data.BTree.Impure: deleteTree :: (AllocM m, Key key, Value val) => key -> Tree key val -> m (Tree key val)
- Data.BTree.Impure: insertTree :: (AllocM m, Key key, Value val) => key -> val -> Tree key val -> m (Tree key val)
- Data.BTree.Impure: insertTreeMany :: (AllocM m, Key key, Value val) => Map key val -> Tree key val -> m (Tree key val)
- Data.BTree.Impure: lookupMaxTree :: (AllocReaderM m, Key key, Value val) => Tree key val -> m (Maybe (key, val))
- Data.BTree.Impure: lookupMinTree :: (AllocReaderM m, Key key, Value val) => Tree key val -> m (Maybe (key, val))
- Data.BTree.Impure: lookupTree :: forall m key val. (AllocReaderM m, Key key, Value val) => key -> Tree key val -> m (Maybe val)
- Data.BTree.Impure.Delete: deleteRec :: forall height key val m. (AllocM m, Key key, Value val) => key -> Height height -> NodeId height key val -> m (Node height key val)
- Data.BTree.Impure.Delete: deleteTree :: (AllocM m, Key key, Value val) => key -> Tree key val -> m (Tree key val)
- Data.BTree.Impure.Delete: mergeNodes :: (AllocM m, Key key, Value val) => Height height -> Node height key val -> key -> Node height key val -> m (Index key (Node height key val))
- Data.BTree.Impure.Delete: nodeNeedsMerge :: Node height key val -> Bool
- Data.BTree.Impure.Fold: foldMap :: (AllocReaderM m, Key k, Value a, Monoid c) => (a -> c) -> Tree k a -> m c
- Data.BTree.Impure.Fold: foldr :: (AllocReaderM m, Key k, Value a) => (a -> b -> b) -> b -> Tree k a -> m b
- Data.BTree.Impure.Fold: foldrIdWithKeyM :: (AllocReaderM m, Key k, Value a) => (k -> a -> b -> m b) -> b -> Height h -> NodeId h k a -> m b
- Data.BTree.Impure.Fold: foldrLeafItemsWithKeyM :: (AllocReaderM m, Key k, Value a) => (k -> a -> b -> m b) -> b -> Map k a -> m b
- Data.BTree.Impure.Fold: foldrM :: (AllocReaderM m, Key k, Value a) => (a -> b -> m b) -> b -> Tree k a -> m b
- Data.BTree.Impure.Fold: foldrNodeWithKeyM :: (AllocReaderM m, Key k, Value a) => (k -> a -> b -> m b) -> b -> Height h -> Node h k a -> m b
- Data.BTree.Impure.Fold: foldrWithKey :: (AllocReaderM m, Key k, Value a) => (k -> a -> b -> b) -> b -> Tree k a -> m b
- Data.BTree.Impure.Fold: foldrWithKeyM :: (AllocReaderM m, Key k, Value a) => (k -> a -> b -> m b) -> b -> Tree k a -> m b
- Data.BTree.Impure.Fold: toList :: (AllocReaderM m, Key k, Value a) => Tree k a -> m [(k, a)]
- Data.BTree.Impure.Insert: fixUp :: (AllocM m, Key key, Value val) => Height height -> Index key (NodeId height key val) -> m (Tree key val)
- Data.BTree.Impure.Insert: insertRec :: forall m height key val. (AllocM m, Key key, Value val) => key -> val -> Height height -> NodeId height key val -> m (Index key (NodeId height key val))
- Data.BTree.Impure.Insert: insertRecMany :: forall m height key val. (AllocM m, Key key, Value val) => Height height -> Map key val -> NodeId height key val -> m (Index key (NodeId height key val))
- Data.BTree.Impure.Insert: insertTree :: (AllocM m, Key key, Value val) => key -> val -> Tree key val -> m (Tree key val)
- Data.BTree.Impure.Insert: insertTreeMany :: (AllocM m, Key key, Value val) => Map key val -> Tree key val -> m (Tree key val)
- Data.BTree.Impure.Insert: splitIndex :: (AllocM m, Key key, Value val) => Height ( 'S height) -> Index key (NodeId height key val) -> m (Index key (Node ( 'S height) key val))
- Data.BTree.Impure.Insert: splitLeaf :: (AllocM m, Key key, Value val) => LeafItems key val -> m (Index key (Node 'Z key val))
- Data.BTree.Impure.Lookup: lookupMaxTree :: (AllocReaderM m, Key key, Value val) => Tree key val -> m (Maybe (key, val))
- Data.BTree.Impure.Lookup: lookupMinTree :: (AllocReaderM m, Key key, Value val) => Tree key val -> m (Maybe (key, val))
- Data.BTree.Impure.Lookup: lookupRec :: forall m height key val. (AllocReaderM m, Key key, Value val) => key -> Height height -> NodeId height key val -> m (Maybe val)
- Data.BTree.Impure.Lookup: lookupTree :: forall m key val. (AllocReaderM m, Key key, Value val) => key -> Tree key val -> m (Maybe val)
- Data.BTree.Impure.NonEmpty: fromNonEmptyList :: (AllocM m, Key k, Value v) => NonEmpty (k, v) -> m (NonEmptyTree k v)
- Data.BTree.Impure.NonEmpty: insertNonEmptyTree :: (AllocM m, Key k, Value v) => k -> v -> NonEmptyTree k v -> m (NonEmptyTree k v)
- Data.BTree.Impure.NonEmpty: insertNonEmptyTreeMany :: (AllocM m, Key k, Value v) => Map k v -> NonEmptyTree k v -> m (NonEmptyTree k v)
- Data.BTree.Impure.NonEmpty: nonEmptyToList :: (AllocReaderM m, Key k, Value v) => NonEmptyTree k v -> m (NonEmpty (k, v))
- Data.BTree.Impure.Overflow: fromLeafItems :: (AllocReaderM m, Value v) => LeafItems k v -> m (Map k v)
- Data.BTree.Impure.Overflow: fromLeafValue :: (AllocReaderM m, Value v) => LeafValue v -> m v
- Data.BTree.Impure.Overflow: toLeafItems :: (AllocM m, Value v) => Map k v -> m (LeafItems k v)
- Data.BTree.Impure.Overflow: toLeafValue :: (AllocM m, Value v) => v -> m (LeafValue v)
- Data.BTree.Impure.Setup: minFanout :: Int
- Data.BTree.Impure.Setup: minIdxKeys :: Int
- Data.BTree.Impure.Setup: minLeafItems :: Int
- Data.BTree.Impure.Structures: OverflowValue :: OverflowId -> LeafValue v
- Data.BTree.Impure.Structures: RawValue :: v -> LeafValue v
- Data.BTree.Impure.Structures: [Idx] :: {idxChildren :: Index key (NodeId height key val)} -> Node ( 'S height) key val
- Data.BTree.Impure.Structures: [Leaf] :: {leafItems :: LeafItems key val} -> Node 'Z key val
- Data.BTree.Impure.Structures: [Tree] :: {treeHeight :: Height height A term-level witness for the type-level height index., treeRootId :: Maybe (NodeId height key val) An empty tree is represented by 'Nothing'. Otherwise it's 'Just' a 'NodeId' pointer the root.} -> Tree key val
- Data.BTree.Impure.Structures: castNode :: forall n key1 val1 height1 key2 val2 height2. (Typeable key1, Typeable val1, Typeable key2, Typeable val2) => Height height1 -> Height height2 -> n height1 key1 val1 -> Maybe (n height2 key2 val2)
- Data.BTree.Impure.Structures: castNode' :: forall n h k v. (Typeable k, Typeable v) => Height h -> n h k v -> Either (n 'Z k v) (n ( 'S h) k v)
- Data.BTree.Impure.Structures: castValue :: (Typeable v1, Typeable v2) => v1 -> Maybe v2
- Data.BTree.Impure.Structures: data LeafValue v
- Data.BTree.Impure.Structures: data Node height key val
- Data.BTree.Impure.Structures: data Tree key val
- Data.BTree.Impure.Structures: getIndexNode :: (Binary key, Binary val) => Height ( 'S n) -> Get (Node ( 'S n) key val)
- Data.BTree.Impure.Structures: getLeafNode :: (Ord key, Binary key, Binary val) => Height 'Z -> Get (Node 'Z key val)
- Data.BTree.Impure.Structures: instance (Data.BTree.Primitives.Value.Value k, Data.BTree.Primitives.Value.Value v) => Data.BTree.Primitives.Value.Value (Data.BTree.Impure.Structures.Tree k v)
- Data.BTree.Impure.Structures: instance (GHC.Classes.Eq key, GHC.Classes.Eq val) => GHC.Classes.Eq (Data.BTree.Impure.Structures.Node height key val)
- Data.BTree.Impure.Structures: instance (GHC.Show.Show key, GHC.Show.Show val) => GHC.Show.Show (Data.BTree.Impure.Structures.Node height key val)
- Data.BTree.Impure.Structures: instance (GHC.Show.Show key, GHC.Show.Show val) => GHC.Show.Show (Data.BTree.Impure.Structures.Tree key val)
- Data.BTree.Impure.Structures: instance Data.Binary.Class.Binary (Data.BTree.Impure.Structures.Tree key val)
- Data.BTree.Impure.Structures: instance Data.Binary.Class.Binary v => Data.Binary.Class.Binary (Data.BTree.Impure.Structures.LeafValue v)
- Data.BTree.Impure.Structures: instance GHC.Classes.Eq v => GHC.Classes.Eq (Data.BTree.Impure.Structures.LeafValue v)
- Data.BTree.Impure.Structures: instance GHC.Show.Show v => GHC.Show.Show (Data.BTree.Impure.Structures.LeafValue v)
- Data.BTree.Impure.Structures: putIndexNode :: (Binary key, Binary val) => Node ( 'S n) key val -> Put
- Data.BTree.Impure.Structures: putLeafNode :: (Binary key, Binary val) => Node 'Z key val -> Put
- Data.BTree.Impure.Structures: type LeafItems k v = Map k (LeafValue v)
+ Data.BTree.Impure: delete :: (AllocM m, Key key, Value val) => key -> Tree key val -> m (Tree key val)
+ Data.BTree.Impure: insert :: (AllocM m, Key key, Value val) => key -> val -> Tree key val -> m (Tree key val)
+ Data.BTree.Impure: insertMany :: (AllocM m, Key key, Value val) => Map key val -> Tree key val -> m (Tree key val)
+ Data.BTree.Impure: lookup :: forall m key val. (AllocReaderM m, Key key, Value val) => key -> Tree key val -> m (Maybe val)
+ Data.BTree.Impure: lookupMax :: (AllocReaderM m, Key key, Value val) => Tree key val -> m (Maybe (key, val))
+ Data.BTree.Impure: lookupMin :: (AllocReaderM m, Key key, Value val) => Tree key val -> m (Maybe (key, val))
+ Data.BTree.Impure.Internal.Delete: delete :: (AllocM m, Key key, Value val) => key -> Tree key val -> m (Tree key val)
+ Data.BTree.Impure.Internal.Delete: deleteRec :: forall height key val m. (AllocM m, Key key, Value val) => key -> Height height -> NodeId height key val -> m (Node height key val)
+ Data.BTree.Impure.Internal.Delete: mergeNodes :: (AllocM m, Key key, Value val) => Height height -> Node height key val -> key -> Node height key val -> m (Index key (Node height key val))
+ Data.BTree.Impure.Internal.Delete: nodeNeedsMerge :: Node height key val -> Bool
+ Data.BTree.Impure.Internal.Fold: foldMap :: (AllocReaderM m, Key k, Value a, Monoid c) => (a -> c) -> Tree k a -> m c
+ Data.BTree.Impure.Internal.Fold: foldr :: (AllocReaderM m, Key k, Value a) => (a -> b -> b) -> b -> Tree k a -> m b
+ Data.BTree.Impure.Internal.Fold: foldrIdWithKeyM :: (AllocReaderM m, Key k, Value a) => (k -> a -> b -> m b) -> b -> Height h -> NodeId h k a -> m b
+ Data.BTree.Impure.Internal.Fold: foldrLeafItemsWithKeyM :: (AllocReaderM m, Key k, Value a) => (k -> a -> b -> m b) -> b -> Map k a -> m b
+ Data.BTree.Impure.Internal.Fold: foldrM :: (AllocReaderM m, Key k, Value a) => (a -> b -> m b) -> b -> Tree k a -> m b
+ Data.BTree.Impure.Internal.Fold: foldrNodeWithKeyM :: (AllocReaderM m, Key k, Value a) => (k -> a -> b -> m b) -> b -> Height h -> Node h k a -> m b
+ Data.BTree.Impure.Internal.Fold: foldrWithKey :: (AllocReaderM m, Key k, Value a) => (k -> a -> b -> b) -> b -> Tree k a -> m b
+ Data.BTree.Impure.Internal.Fold: foldrWithKeyM :: (AllocReaderM m, Key k, Value a) => (k -> a -> b -> m b) -> b -> Tree k a -> m b
+ Data.BTree.Impure.Internal.Fold: toList :: (AllocReaderM m, Key k, Value a) => Tree k a -> m [(k, a)]
+ Data.BTree.Impure.Internal.Insert: fixUp :: (AllocM m, Key key, Value val) => Height height -> Index key (NodeId height key val) -> m (Tree key val)
+ Data.BTree.Impure.Internal.Insert: insert :: (AllocM m, Key key, Value val) => key -> val -> Tree key val -> m (Tree key val)
+ Data.BTree.Impure.Internal.Insert: insertMany :: (AllocM m, Key key, Value val) => Map key val -> Tree key val -> m (Tree key val)
+ Data.BTree.Impure.Internal.Insert: insertRec :: forall m height key val. (AllocM m, Key key, Value val) => key -> val -> Height height -> NodeId height key val -> m (Index key (NodeId height key val))
+ Data.BTree.Impure.Internal.Insert: insertRecMany :: forall m height key val. (AllocM m, Key key, Value val) => Height height -> Map key val -> NodeId height key val -> m (Index key (NodeId height key val))
+ Data.BTree.Impure.Internal.Insert: splitIndex :: (AllocM m, Key key, Value val) => Height ( 'S height) -> Index key (NodeId height key val) -> m (Index key (Node ( 'S height) key val))
+ Data.BTree.Impure.Internal.Insert: splitLeaf :: (AllocM m, Key key, Value val) => LeafItems key val -> m (Index key (Node 'Z key val))
+ Data.BTree.Impure.Internal.Lookup: lookup :: forall m key val. (AllocReaderM m, Key key, Value val) => key -> Tree key val -> m (Maybe val)
+ Data.BTree.Impure.Internal.Lookup: lookupMax :: (AllocReaderM m, Key key, Value val) => Tree key val -> m (Maybe (key, val))
+ Data.BTree.Impure.Internal.Lookup: lookupMin :: (AllocReaderM m, Key key, Value val) => Tree key val -> m (Maybe (key, val))
+ Data.BTree.Impure.Internal.Lookup: lookupRec :: forall m height key val. (AllocReaderM m, Key key, Value val) => key -> Height height -> NodeId height key val -> m (Maybe val)
+ Data.BTree.Impure.Internal.Overflow: fromLeafItems :: (AllocReaderM m, Value v) => LeafItems k v -> m (Map k v)
+ Data.BTree.Impure.Internal.Overflow: fromLeafValue :: (AllocReaderM m, Value v) => LeafValue v -> m v
+ Data.BTree.Impure.Internal.Overflow: toLeafItems :: (AllocM m, Value v) => Map k v -> m (LeafItems k v)
+ Data.BTree.Impure.Internal.Overflow: toLeafValue :: (AllocM m, Value v) => v -> m (LeafValue v)
+ Data.BTree.Impure.Internal.Setup: minFanout :: Int
+ Data.BTree.Impure.Internal.Setup: minIdxKeys :: Int
+ Data.BTree.Impure.Internal.Setup: minLeafItems :: Int
+ Data.BTree.Impure.Internal.Structures: OverflowValue :: OverflowId -> LeafValue v
+ Data.BTree.Impure.Internal.Structures: RawValue :: v -> LeafValue v
+ Data.BTree.Impure.Internal.Structures: [Idx] :: {idxChildren :: Index key (NodeId height key val)} -> Node ( 'S height) key val
+ Data.BTree.Impure.Internal.Structures: [Leaf] :: {leafItems :: LeafItems key val} -> Node 'Z key val
+ Data.BTree.Impure.Internal.Structures: [Tree] :: {treeHeight :: Height height A term-level witness for the type-level height index., treeRootId :: Maybe (NodeId height key val) An empty tree is represented by 'Nothing'. Otherwise it's 'Just' a 'NodeId' pointer the root.} -> Tree key val
+ Data.BTree.Impure.Internal.Structures: castNode :: forall n key1 val1 height1 key2 val2 height2. (Typeable key1, Typeable val1, Typeable key2, Typeable val2) => Height height1 -> Height height2 -> n height1 key1 val1 -> Maybe (n height2 key2 val2)
+ Data.BTree.Impure.Internal.Structures: castNode' :: forall n h k v. (Typeable k, Typeable v) => Height h -> n h k v -> Either (n 'Z k v) (n ( 'S h) k v)
+ Data.BTree.Impure.Internal.Structures: castValue :: (Typeable v1, Typeable v2) => v1 -> Maybe v2
+ Data.BTree.Impure.Internal.Structures: data LeafValue v
+ Data.BTree.Impure.Internal.Structures: data Node height key val
+ Data.BTree.Impure.Internal.Structures: data Tree key val
+ Data.BTree.Impure.Internal.Structures: getIndexNode :: (Binary key, Binary val) => Height ( 'S n) -> Get (Node ( 'S n) key val)
+ Data.BTree.Impure.Internal.Structures: getLeafNode :: (Ord key, Binary key, Binary val) => Height 'Z -> Get (Node 'Z key val)
+ Data.BTree.Impure.Internal.Structures: instance (Data.BTree.Primitives.Value.Value k, Data.BTree.Primitives.Value.Value v) => Data.BTree.Primitives.Value.Value (Data.BTree.Impure.Internal.Structures.Tree k v)
+ Data.BTree.Impure.Internal.Structures: instance (GHC.Classes.Eq key, GHC.Classes.Eq val) => GHC.Classes.Eq (Data.BTree.Impure.Internal.Structures.Node height key val)
+ Data.BTree.Impure.Internal.Structures: instance (GHC.Show.Show key, GHC.Show.Show val) => GHC.Show.Show (Data.BTree.Impure.Internal.Structures.Node height key val)
+ Data.BTree.Impure.Internal.Structures: instance (GHC.Show.Show key, GHC.Show.Show val) => GHC.Show.Show (Data.BTree.Impure.Internal.Structures.Tree key val)
+ Data.BTree.Impure.Internal.Structures: instance Data.Binary.Class.Binary (Data.BTree.Impure.Internal.Structures.Tree key val)
+ Data.BTree.Impure.Internal.Structures: instance Data.Binary.Class.Binary v => Data.Binary.Class.Binary (Data.BTree.Impure.Internal.Structures.LeafValue v)
+ Data.BTree.Impure.Internal.Structures: instance GHC.Classes.Eq v => GHC.Classes.Eq (Data.BTree.Impure.Internal.Structures.LeafValue v)
+ Data.BTree.Impure.Internal.Structures: instance GHC.Show.Show v => GHC.Show.Show (Data.BTree.Impure.Internal.Structures.LeafValue v)
+ Data.BTree.Impure.Internal.Structures: putIndexNode :: (Binary key, Binary val) => Node ( 'S n) key val -> Put
+ Data.BTree.Impure.Internal.Structures: putLeafNode :: (Binary key, Binary val) => Node 'Z key val -> Put
+ Data.BTree.Impure.Internal.Structures: type LeafItems k v = Map k (LeafValue v)
+ Data.BTree.Impure.NonEmpty: fromList :: (AllocM m, Key k, Value v) => NonEmpty (k, v) -> m (NonEmptyTree k v)
+ Data.BTree.Impure.NonEmpty: insert :: (AllocM m, Key k, Value v) => k -> v -> NonEmptyTree k v -> m (NonEmptyTree k v)
+ Data.BTree.Impure.NonEmpty: insertMany :: (AllocM m, Key k, Value v) => Map k v -> NonEmptyTree k v -> m (NonEmptyTree k v)
+ Data.BTree.Impure.NonEmpty: toList :: (AllocReaderM m, Key k, Value v) => NonEmptyTree k v -> m (NonEmpty (k, v))
Files
- README.md +0/−1
- haskey-btree.cabal +8/−8
- src/Data/BTree/Alloc/Class.hs +1/−1
- src/Data/BTree/Alloc/Debug.hs +1/−1
- src/Data/BTree/Impure.hs +13/−13
- src/Data/BTree/Impure/Delete.hs +0/−132
- src/Data/BTree/Impure/Fold.hs +0/−68
- src/Data/BTree/Impure/Insert.hs +0/−202
- src/Data/BTree/Impure/Internal/Delete.hs +132/−0
- src/Data/BTree/Impure/Internal/Fold.hs +68/−0
- src/Data/BTree/Impure/Internal/Insert.hs +202/−0
- src/Data/BTree/Impure/Internal/Lookup.hs +116/−0
- src/Data/BTree/Impure/Internal/Overflow.hs +38/−0
- src/Data/BTree/Impure/Internal/Setup.hs +11/−0
- src/Data/BTree/Impure/Internal/Structures.hs +176/−0
- src/Data/BTree/Impure/Lookup.hs +0/−114
- src/Data/BTree/Impure/NonEmpty.hs +25/−24
- src/Data/BTree/Impure/Overflow.hs +0/−38
- src/Data/BTree/Impure/Setup.hs +0/−11
- src/Data/BTree/Impure/Structures.hs +0/−176
- tests/Integration/WriteOpenRead/Debug.hs +7/−7
- tests/Properties/Impure/Fold.hs +3/−4
- tests/Properties/Impure/Insert.hs +11/−12
- tests/Properties/Impure/Structures.hs +1/−1
README.md view
@@ -2,7 +2,6 @@ ============ [](https://travis-ci.org/haskell-haskey/haskey-btree)-[](https://coveralls.io/github/haskell-haskey/haskey-btree?branch=master) [](https://hackage.haskell.org/package/haskey-btree) [](http://stackage.org/nightly/package/haskey-btree) [](http://stackage.org/lts/package/haskey-btree)
haskey-btree.cabal view
@@ -1,5 +1,5 @@ name: haskey-btree-version: 0.2.0.1+version: 0.3.0.0 synopsis: B+-tree implementation in Haskell. description: This package provides two B+-tree implementations. The first one is a pure@@ -28,14 +28,14 @@ Data.BTree.Alloc.Class Data.BTree.Alloc.Debug Data.BTree.Impure- Data.BTree.Impure.Delete- Data.BTree.Impure.Fold- Data.BTree.Impure.Insert- Data.BTree.Impure.Lookup+ Data.BTree.Impure.Internal.Delete+ Data.BTree.Impure.Internal.Fold+ Data.BTree.Impure.Internal.Insert+ Data.BTree.Impure.Internal.Lookup+ Data.BTree.Impure.Internal.Overflow+ Data.BTree.Impure.Internal.Setup+ Data.BTree.Impure.Internal.Structures Data.BTree.Impure.NonEmpty- Data.BTree.Impure.Overflow- Data.BTree.Impure.Setup- Data.BTree.Impure.Structures Data.BTree.Primitives Data.BTree.Primitives.Exception Data.BTree.Primitives.Height
src/Data/BTree/Alloc/Class.hs view
@@ -11,7 +11,7 @@ import Data.Word (Word64) -import Data.BTree.Impure.Structures+import Data.BTree.Impure.Internal.Structures import Data.BTree.Primitives --------------------------------------------------------------------------------
src/Data/BTree/Alloc/Debug.hs view
@@ -19,7 +19,7 @@ import Data.BTree.Alloc.Class import Data.BTree.Impure-import Data.BTree.Impure.Structures+import Data.BTree.Impure.Internal.Structures import Data.BTree.Primitives data SomeNode = forall h k v. SomeNode (Height h) (Node h k v)
src/Data/BTree/Impure.hs view
@@ -13,14 +13,14 @@ , fromMap -- * Manipulation-, insertTree-, insertTreeMany-, deleteTree+, insert+, insertMany+, delete -- * Lookup-, lookupTree-, lookupMinTree-, lookupMaxTree+, lookup+, lookupMin+, lookupMax -- * Folds , foldr@@ -31,17 +31,17 @@ , toList ) where -import Prelude hiding (foldr, foldMap)+import Prelude hiding (lookup, foldr, foldMap) import Data.Map (Map) import qualified Data.Map as M import Data.BTree.Alloc.Class-import Data.BTree.Impure.Delete (deleteTree)-import Data.BTree.Impure.Structures (Tree(..), Node(..))-import Data.BTree.Impure.Fold (foldr, foldrM, foldrWithKey, foldrWithKeyM, foldMap, toList)-import Data.BTree.Impure.Insert (insertTree, insertTreeMany)-import Data.BTree.Impure.Lookup (lookupTree, lookupMinTree, lookupMaxTree)+import Data.BTree.Impure.Internal.Delete (delete)+import Data.BTree.Impure.Internal.Structures (Tree(..), Node(..))+import Data.BTree.Impure.Internal.Fold (foldr, foldrM, foldrWithKey, foldrWithKeyM, foldMap, toList)+import Data.BTree.Impure.Internal.Insert (insert, insertMany)+import Data.BTree.Impure.Internal.Lookup (lookup, lookupMin, lookupMax) import Data.BTree.Primitives @@ -59,4 +59,4 @@ fromMap :: (AllocM m, Key k, Value v) => Map k v -> m (Tree k v)-fromMap kvs = insertTreeMany kvs empty+fromMap kvs = insertMany kvs empty
− src/Data/BTree/Impure/Delete.hs
@@ -1,132 +0,0 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE ScopedTypeVariables #-}--- | Algorithms related to deletion from an impure B+-tree.-module Data.BTree.Impure.Delete where--import Data.Monoid-import Data.Traversable (traverse)-import qualified Data.Map as M--import Data.BTree.Alloc.Class-import Data.BTree.Impure.Insert-import Data.BTree.Impure.Setup-import Data.BTree.Impure.Structures-import Data.BTree.Primitives.Exception-import Data.BTree.Primitives-------------------------------------------------------------------------------------- | Check whether a node needs to be merged.-nodeNeedsMerge :: Node height key val -> Bool-nodeNeedsMerge (Idx children) =- indexNumKeys children < minIdxKeys-nodeNeedsMerge (Leaf items) =- M.size items < minLeafItems---- | Merge two nodes.-mergeNodes :: (AllocM m, Key key, Value val)- => Height height- -> Node height key val- -> key- -> Node height key val- -> m (Index key (Node height key val))-mergeNodes _ (Leaf leftItems) _middleKey (Leaf rightItems) =- splitLeaf (leftItems <> rightItems)-mergeNodes h (Idx leftIdx) middleKey (Idx rightIdx) =- splitIndex h (mergeIndex leftIdx middleKey rightIdx)------------------------------------------------------------------------------------deleteRec :: forall height key val m. (AllocM m, Key key, Value val)- => key- -> Height height- -> NodeId height key val- -> m (Node height key val)-deleteRec key = fetchAndGo- where- fetchAndGo :: forall hgt. Height hgt- -> NodeId hgt key val- -> m (Node hgt key val)- fetchAndGo hgt nid = do- node <- readNode hgt nid- freeNode hgt nid- recurse hgt node-- recurse :: forall hgt. Height hgt- -> Node hgt key val- -> m (Node hgt key val)- recurse hgt (Idx children) = do- let (ctx, childId) = valView key children- subHeight = decrHeight hgt- newChild <- fetchAndGo subHeight childId- let childNeedsMerge = nodeNeedsMerge newChild- if | childNeedsMerge, Just (rKey, rChildId, rCtx) <- rightView ctx -> do- rChild <- readNode subHeight rChildId- freeNode subHeight rChildId- newChildren <- mergeNodes subHeight newChild rKey rChild- newChildrenIds <- traverse (allocNode subHeight) newChildren- return (Idx (putIdx rCtx newChildrenIds))- | childNeedsMerge, Just (lCtx, lChildId, lKey) <- leftView ctx -> do- lChild <- readNode subHeight lChildId- freeNode subHeight lChildId- newChildren <- mergeNodes subHeight lChild lKey newChild- newChildrenIds <- traverse (allocNode subHeight) newChildren- return (Idx (putIdx lCtx newChildrenIds))- -- No left or right sibling? This is a constraint violation. Also- -- this couldn't be the root because it would've been shrunk- -- before.- | childNeedsMerge -> throw $ TreeAlgorithmError "deleteRec"- "constraint violation, found an index node with a single child"- | otherwise -> do- newChildId <- allocNode subHeight newChild- return (Idx (putVal ctx newChildId))- recurse _hgt (Leaf items) =- case M.lookup key items of- Nothing -> return $ Leaf items- Just (RawValue _) -> return $ Leaf (M.delete key items)- Just (OverflowValue oid) -> do- freeOverflow oid- return $ Leaf (M.delete key items)-------------------------------------------------------------------------------------- | Delete a node from the tree.-deleteTree :: (AllocM m, Key key, Value val)- => key- -> Tree key val- -> m (Tree key val)-deleteTree k tree- | Tree- { treeRootId = Nothing- } <- tree- = return tree- | Tree- { treeHeight = height- , treeRootId = Just rootId- } <- tree- = do- newRootNode <- deleteRec k height rootId- case newRootNode of- Idx index- | Just childNodeId <- fromSingletonIndex index ->- return $! Tree- { treeHeight = decrHeight height- , treeRootId = Just childNodeId- }- Leaf items- | M.null items ->- return $! Tree- { treeHeight = zeroHeight- , treeRootId = Nothing- }- _ -> do- newRootNodeId <- allocNode height newRootNode- return $! Tree- { treeHeight = height- , treeRootId = Just newRootNodeId- }----------------------------------------------------------------------------------
− src/Data/BTree/Impure/Fold.hs
@@ -1,68 +0,0 @@-{-# LANGUAGE GADTs #-}--- | Algorithms related to folding over an impure B+-tree.-module Data.BTree.Impure.Fold where--import Prelude hiding (foldr, foldl)--import Data.Map (Map)-import Data.Monoid (Monoid, (<>), mempty)-import qualified Data.Map as M-import qualified Data.Foldable as F--import Data.BTree.Alloc.Class-import Data.BTree.Impure.Overflow-import Data.BTree.Impure.Structures-import Data.BTree.Primitives-------------------------------------------------------------------------------------- | Perform a right-associative fold over the tree.-foldr :: (AllocReaderM m, Key k, Value a)- => (a -> b -> b) -> b -> Tree k a -> m b-foldr f = foldrM (\a b -> return (f a b))---- | Perform a right-associative fold over the tree key-value pairs.-foldrWithKey :: (AllocReaderM m, Key k, Value a)- => (k -> a -> b -> b) -> b -> Tree k a -> m b-foldrWithKey f = foldrWithKeyM (\k a b -> return (f k a b))---- | Perform a monadic right-associative fold over the tree.-foldrM :: (AllocReaderM m, Key k, Value a)- => (a -> b -> m b) -> b -> Tree k a -> m b-foldrM f = foldrWithKeyM (const f)---- | Perform a monadic right-assiciative fold over the tree key-value pairs.-foldrWithKeyM :: (AllocReaderM m, Key k, Value a)- => (k -> a -> b -> m b) -> b -> Tree k a -> m b-foldrWithKeyM _ x (Tree _ Nothing) = return x-foldrWithKeyM f x (Tree h (Just nid)) = foldrIdWithKeyM f x h nid--foldrIdWithKeyM :: (AllocReaderM m, Key k, Value a)- => (k -> a -> b -> m b) -> b -> Height h -> NodeId h k a -> m b-foldrIdWithKeyM f x h nid = readNode h nid >>= foldrNodeWithKeyM f x h--foldrNodeWithKeyM :: (AllocReaderM m, Key k, Value a)- => (k -> a -> b -> m b) -> b -> Height h -> Node h k a -> m b-foldrNodeWithKeyM f x _ (Leaf items) =- fromLeafItems items >>= foldrLeafItemsWithKeyM f x-foldrNodeWithKeyM f x h (Idx idx) =- F.foldrM (\nid x' -> foldrIdWithKeyM f x' (decrHeight h) nid) x idx--foldrLeafItemsWithKeyM :: (AllocReaderM m, Key k, Value a)- => (k -> a -> b -> m b) -> b -> Map k a -> m b-foldrLeafItemsWithKeyM f x items = M.foldlWithKey f' return items x- where f' m k a z = f k a z >>= m-------------------------------------------------------------------------------------- | Map each value of the tree to a monoid, and combine the results.-foldMap :: (AllocReaderM m, Key k, Value a, Monoid c)- => (a -> c) -> Tree k a -> m c-foldMap f = foldr ((<>) . f) mempty---- | Convert an impure B+-tree to a list of key-value pairs.-toList :: (AllocReaderM m, Key k, Value a)- => Tree k a -> m [(k, a)]-toList = foldrWithKey (\k v xs -> (k, v):xs) []----------------------------------------------------------------------------------
− src/Data/BTree/Impure/Insert.hs
@@ -1,202 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE ScopedTypeVariables #-}--- | Algorithms related to inserting key-value pairs in an impure B+-tree.-module Data.BTree.Impure.Insert where--import Data.Map (Map)-import Data.Traversable (traverse)-import qualified Data.Map as M--import Data.BTree.Alloc.Class-import Data.BTree.Impure.Overflow-import Data.BTree.Impure.Structures-import Data.BTree.Primitives.Exception-import Data.BTree.Primitives-------------------------------------------------------------------------------------- | Split an index node.------ This function is partial. It fails when the original index cannot be split,--- because it does not contain enough elements (underflow).-splitIndex :: (AllocM m, Key key, Value val) =>- Height ('S height) ->- Index key (NodeId height key val) ->- m (Index key (Node ('S height) key val))-splitIndex h index = do- m <- maxPageSize- nodePageSize' <- nodePageSize- let binPred n = nodePageSize' h n <= m- case extendIndexPred binPred Idx index of- Just extIndex -> return extIndex- Nothing -> throw $ TreeAlgorithmError "splitIndex"- "splitting failed, underflow"---- | Split a leaf node.------ This function is partial. It fails when the original leaf cannot be split,--- because it does not contain enough elements (underflow).-splitLeaf :: (AllocM m, Key key, Value val) =>- LeafItems key val ->- m (Index key (Node 'Z key val))-splitLeaf items = do- m <- maxPageSize- nodePageSize' <- nodePageSize- let binPred n = nodePageSize' zeroHeight n <= m- case splitLeafManyPred binPred Leaf items of- Just v -> return v- Nothing -> throw $ TreeAlgorithmError "splitLeaf"- "splitting failed, underflow"------------------------------------------------------------------------------------insertRec :: forall m height key val. (AllocM m, Key key, Value val)- => key- -> val- -> Height height- -> NodeId height key val- -> m (Index key (NodeId height key val))-insertRec k v = fetch- where- fetch :: forall hgt.- Height hgt- -> NodeId hgt key val- -> m (Index key (NodeId hgt key val))- fetch hgt nid = do- node <- readNode hgt nid- freeNode hgt nid- case node of- Idx children -> do- let (ctx,childId) = valView k children- newChildIdx <- fetch (decrHeight hgt) childId- newChildren <- splitIndex hgt (putIdx ctx newChildIdx)- traverse (allocNode hgt) newChildren- Leaf items -> do- case M.lookup k items of- Nothing -> return ()- Just (RawValue _) -> return ()- Just (OverflowValue oid) -> freeOverflow oid-- v' <- toLeafValue v- traverse (allocNode hgt) =<< splitLeaf (M.insert k v' items)--insertRecMany :: forall m height key val. (AllocM m, Key key, Value val)- => Height height- -> Map key val- -> NodeId height key val- -> m (Index key (NodeId height key val))-insertRecMany h kvs nid- | M.null kvs = return (singletonIndex nid)- | otherwise = do- n <- readNode h nid- freeNode h nid- case n of- Idx idx -> do- let dist = distribute kvs idx- newIndex <- dist `bindIndexM` uncurry (insertRecMany (decrHeight h))- newChildren <- splitIndex h newIndex- traverse (allocNode h) newChildren- Leaf items -> do- mapM_ (\k -> freeOverwrittenOverflowId $ M.lookup k items) $ M.keys kvs- kvs' <- toLeafItems kvs- traverse (allocNode h) =<< splitLeaf (M.union kvs' items)- where- freeOverwrittenOverflowId :: (AllocM m)- => Maybe (LeafValue v)- -> m ()- freeOverwrittenOverflowId = \case- Nothing -> return ()- Just (RawValue _) -> return ()- Just (OverflowValue oid) -> freeOverflow oid--------------------------------------------------------------------------------------- | Insert a key-value pair in an impure B+-tree.------ You are responsible to make sure the key is smaller than 'maxKeySize',--- otherwise a 'KeyTooLargeError' can (but not always will) be thrown.-insertTree :: (AllocM m, Key key, Value val)- => key- -> val- -> Tree key val- -> m (Tree key val)-insertTree key val tree- | Tree- { treeHeight = height- , treeRootId = Just rootId- } <- tree- = do- newRootIdx <- insertRec key val height rootId- case fromSingletonIndex newRootIdx of- Just newRootId ->- return $! Tree- { treeHeight = height- , treeRootId = Just newRootId- }- Nothing -> do- -- Root got split, so allocate a new root node.- let newHeight = incrHeight height- newRootId <- allocNode newHeight Idx- { idxChildren = newRootIdx }- return $! Tree- { treeHeight = newHeight- , treeRootId = Just newRootId- }- | Tree- { treeRootId = Nothing- } <- tree- = do -- Allocate new root node- leafItems' <- toLeafItems $ M.singleton key val- newRootId <- allocNode zeroHeight Leaf- { leafItems = leafItems'- }- return $! Tree- { treeHeight = zeroHeight- , treeRootId = Just newRootId- }---- | Bulk insert a bunch of key-value pairs in an impure B+-tree.------ You are responsible to make sure all keys is smaller than 'maxKeySize',--- otherwise a 'KeyTooLargeError' can (but not always will) be thrown.-insertTreeMany :: (AllocM m, Key key, Value val)- => Map key val- -> Tree key val- -> m (Tree key val)-insertTreeMany kvs tree- | Tree- { treeHeight = height- , treeRootId = Just rootId- } <- tree- = do- newRootIdx <- insertRecMany height kvs rootId- fixUp height newRootIdx- | Tree { treeRootId = Nothing } <- tree- = do- kvs' <- toLeafItems kvs- idx <- traverse (allocNode zeroHeight) =<< splitLeaf kvs'- fixUp zeroHeight $! idx---- | Fix up the root node of a tree.------ Fix up the root node of a tree, where all other nodes are valid, but the--- root node may contain more items than allowed. Do this by repeatedly--- splitting up the root node.-fixUp :: (AllocM m, Key key, Value val)- => Height height- -> Index key (NodeId height key val)- -> m (Tree key val)-fixUp h idx = case fromSingletonIndex idx of- Just newRootNid ->- return $! Tree { treeHeight = h- , treeRootId = Just newRootNid }- Nothing -> do- let newHeight = incrHeight h- children <- splitIndex newHeight idx- childrenNids <- traverse (allocNode newHeight) children- fixUp newHeight $! childrenNids----------------------------------------------------------------------------------
+ src/Data/BTree/Impure/Internal/Delete.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE ScopedTypeVariables #-}+-- | Algorithms related to deletion from an impure B+-tree.+module Data.BTree.Impure.Internal.Delete where++import Data.Monoid+import Data.Traversable (traverse)+import qualified Data.Map as M++import Data.BTree.Alloc.Class+import Data.BTree.Impure.Internal.Insert+import Data.BTree.Impure.Internal.Setup+import Data.BTree.Impure.Internal.Structures+import Data.BTree.Primitives.Exception+import Data.BTree.Primitives++--------------------------------------------------------------------------------++-- | Check whether a node needs to be merged.+nodeNeedsMerge :: Node height key val -> Bool+nodeNeedsMerge (Idx children) =+ indexNumKeys children < minIdxKeys+nodeNeedsMerge (Leaf items) =+ M.size items < minLeafItems++-- | Merge two nodes.+mergeNodes :: (AllocM m, Key key, Value val)+ => Height height+ -> Node height key val+ -> key+ -> Node height key val+ -> m (Index key (Node height key val))+mergeNodes _ (Leaf leftItems) _middleKey (Leaf rightItems) =+ splitLeaf (leftItems <> rightItems)+mergeNodes h (Idx leftIdx) middleKey (Idx rightIdx) =+ splitIndex h (mergeIndex leftIdx middleKey rightIdx)++--------------------------------------------------------------------------------++deleteRec :: forall height key val m. (AllocM m, Key key, Value val)+ => key+ -> Height height+ -> NodeId height key val+ -> m (Node height key val)+deleteRec key = fetchAndGo+ where+ fetchAndGo :: forall hgt. Height hgt+ -> NodeId hgt key val+ -> m (Node hgt key val)+ fetchAndGo hgt nid = do+ node <- readNode hgt nid+ freeNode hgt nid+ recurse hgt node++ recurse :: forall hgt. Height hgt+ -> Node hgt key val+ -> m (Node hgt key val)+ recurse hgt (Idx children) = do+ let (ctx, childId) = valView key children+ subHeight = decrHeight hgt+ newChild <- fetchAndGo subHeight childId+ let childNeedsMerge = nodeNeedsMerge newChild+ if | childNeedsMerge, Just (rKey, rChildId, rCtx) <- rightView ctx -> do+ rChild <- readNode subHeight rChildId+ freeNode subHeight rChildId+ newChildren <- mergeNodes subHeight newChild rKey rChild+ newChildrenIds <- traverse (allocNode subHeight) newChildren+ return (Idx (putIdx rCtx newChildrenIds))+ | childNeedsMerge, Just (lCtx, lChildId, lKey) <- leftView ctx -> do+ lChild <- readNode subHeight lChildId+ freeNode subHeight lChildId+ newChildren <- mergeNodes subHeight lChild lKey newChild+ newChildrenIds <- traverse (allocNode subHeight) newChildren+ return (Idx (putIdx lCtx newChildrenIds))+ -- No left or right sibling? This is a constraint violation. Also+ -- this couldn't be the root because it would've been shrunk+ -- before.+ | childNeedsMerge -> throw $ TreeAlgorithmError "deleteRec"+ "constraint violation, found an index node with a single child"+ | otherwise -> do+ newChildId <- allocNode subHeight newChild+ return (Idx (putVal ctx newChildId))+ recurse _hgt (Leaf items) =+ case M.lookup key items of+ Nothing -> return $ Leaf items+ Just (RawValue _) -> return $ Leaf (M.delete key items)+ Just (OverflowValue oid) -> do+ freeOverflow oid+ return $ Leaf (M.delete key items)++--------------------------------------------------------------------------------++-- | Delete a node from the tree.+delete :: (AllocM m, Key key, Value val)+ => key+ -> Tree key val+ -> m (Tree key val)+delete k tree+ | Tree+ { treeRootId = Nothing+ } <- tree+ = return tree+ | Tree+ { treeHeight = height+ , treeRootId = Just rootId+ } <- tree+ = do+ newRootNode <- deleteRec k height rootId+ case newRootNode of+ Idx index+ | Just childNodeId <- fromSingletonIndex index ->+ return $! Tree+ { treeHeight = decrHeight height+ , treeRootId = Just childNodeId+ }+ Leaf items+ | M.null items ->+ return $! Tree+ { treeHeight = zeroHeight+ , treeRootId = Nothing+ }+ _ -> do+ newRootNodeId <- allocNode height newRootNode+ return $! Tree+ { treeHeight = height+ , treeRootId = Just newRootNodeId+ }++--------------------------------------------------------------------------------
+ src/Data/BTree/Impure/Internal/Fold.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE GADTs #-}+-- | Algorithms related to folding over an impure B+-tree.+module Data.BTree.Impure.Internal.Fold where++import Prelude hiding (foldr, foldl)++import Data.Map (Map)+import Data.Monoid (Monoid, (<>), mempty)+import qualified Data.Map as M+import qualified Data.Foldable as F++import Data.BTree.Alloc.Class+import Data.BTree.Impure.Internal.Overflow+import Data.BTree.Impure.Internal.Structures+import Data.BTree.Primitives++--------------------------------------------------------------------------------++-- | Perform a right-associative fold over the tree.+foldr :: (AllocReaderM m, Key k, Value a)+ => (a -> b -> b) -> b -> Tree k a -> m b+foldr f = foldrM (\a b -> return (f a b))++-- | Perform a right-associative fold over the tree key-value pairs.+foldrWithKey :: (AllocReaderM m, Key k, Value a)+ => (k -> a -> b -> b) -> b -> Tree k a -> m b+foldrWithKey f = foldrWithKeyM (\k a b -> return (f k a b))++-- | Perform a monadic right-associative fold over the tree.+foldrM :: (AllocReaderM m, Key k, Value a)+ => (a -> b -> m b) -> b -> Tree k a -> m b+foldrM f = foldrWithKeyM (const f)++-- | Perform a monadic right-assiciative fold over the tree key-value pairs.+foldrWithKeyM :: (AllocReaderM m, Key k, Value a)+ => (k -> a -> b -> m b) -> b -> Tree k a -> m b+foldrWithKeyM _ x (Tree _ Nothing) = return x+foldrWithKeyM f x (Tree h (Just nid)) = foldrIdWithKeyM f x h nid++foldrIdWithKeyM :: (AllocReaderM m, Key k, Value a)+ => (k -> a -> b -> m b) -> b -> Height h -> NodeId h k a -> m b+foldrIdWithKeyM f x h nid = readNode h nid >>= foldrNodeWithKeyM f x h++foldrNodeWithKeyM :: (AllocReaderM m, Key k, Value a)+ => (k -> a -> b -> m b) -> b -> Height h -> Node h k a -> m b+foldrNodeWithKeyM f x _ (Leaf items) =+ fromLeafItems items >>= foldrLeafItemsWithKeyM f x+foldrNodeWithKeyM f x h (Idx idx) =+ F.foldrM (\nid x' -> foldrIdWithKeyM f x' (decrHeight h) nid) x idx++foldrLeafItemsWithKeyM :: (AllocReaderM m, Key k, Value a)+ => (k -> a -> b -> m b) -> b -> Map k a -> m b+foldrLeafItemsWithKeyM f x items = M.foldlWithKey f' return items x+ where f' m k a z = f k a z >>= m++--------------------------------------------------------------------------------++-- | Map each value of the tree to a monoid, and combine the results.+foldMap :: (AllocReaderM m, Key k, Value a, Monoid c)+ => (a -> c) -> Tree k a -> m c+foldMap f = foldr ((<>) . f) mempty++-- | Convert an impure B+-tree to a list of key-value pairs.+toList :: (AllocReaderM m, Key k, Value a)+ => Tree k a -> m [(k, a)]+toList = foldrWithKey (\k v xs -> (k, v):xs) []++--------------------------------------------------------------------------------
+ src/Data/BTree/Impure/Internal/Insert.hs view
@@ -0,0 +1,202 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+-- | Algorithms related to inserting key-value pairs in an impure B+-tree.+module Data.BTree.Impure.Internal.Insert where++import Data.Map (Map)+import Data.Traversable (traverse)+import qualified Data.Map as M++import Data.BTree.Alloc.Class+import Data.BTree.Impure.Internal.Overflow+import Data.BTree.Impure.Internal.Structures+import Data.BTree.Primitives.Exception+import Data.BTree.Primitives++--------------------------------------------------------------------------------++-- | Split an index node.+--+-- This function is partial. It fails when the original index cannot be split,+-- because it does not contain enough elements (underflow).+splitIndex :: (AllocM m, Key key, Value val) =>+ Height ('S height) ->+ Index key (NodeId height key val) ->+ m (Index key (Node ('S height) key val))+splitIndex h index = do+ m <- maxPageSize+ nodePageSize' <- nodePageSize+ let binPred n = nodePageSize' h n <= m+ case extendIndexPred binPred Idx index of+ Just extIndex -> return extIndex+ Nothing -> throw $ TreeAlgorithmError "splitIndex"+ "splitting failed, underflow"++-- | Split a leaf node.+--+-- This function is partial. It fails when the original leaf cannot be split,+-- because it does not contain enough elements (underflow).+splitLeaf :: (AllocM m, Key key, Value val) =>+ LeafItems key val ->+ m (Index key (Node 'Z key val))+splitLeaf items = do+ m <- maxPageSize+ nodePageSize' <- nodePageSize+ let binPred n = nodePageSize' zeroHeight n <= m+ case splitLeafManyPred binPred Leaf items of+ Just v -> return v+ Nothing -> throw $ TreeAlgorithmError "splitLeaf"+ "splitting failed, underflow"++--------------------------------------------------------------------------------++insertRec :: forall m height key val. (AllocM m, Key key, Value val)+ => key+ -> val+ -> Height height+ -> NodeId height key val+ -> m (Index key (NodeId height key val))+insertRec k v = fetch+ where+ fetch :: forall hgt.+ Height hgt+ -> NodeId hgt key val+ -> m (Index key (NodeId hgt key val))+ fetch hgt nid = do+ node <- readNode hgt nid+ freeNode hgt nid+ case node of+ Idx children -> do+ let (ctx,childId) = valView k children+ newChildIdx <- fetch (decrHeight hgt) childId+ newChildren <- splitIndex hgt (putIdx ctx newChildIdx)+ traverse (allocNode hgt) newChildren+ Leaf items -> do+ case M.lookup k items of+ Nothing -> return ()+ Just (RawValue _) -> return ()+ Just (OverflowValue oid) -> freeOverflow oid++ v' <- toLeafValue v+ traverse (allocNode hgt) =<< splitLeaf (M.insert k v' items)++insertRecMany :: forall m height key val. (AllocM m, Key key, Value val)+ => Height height+ -> Map key val+ -> NodeId height key val+ -> m (Index key (NodeId height key val))+insertRecMany h kvs nid+ | M.null kvs = return (singletonIndex nid)+ | otherwise = do+ n <- readNode h nid+ freeNode h nid+ case n of+ Idx idx -> do+ let dist = distribute kvs idx+ newIndex <- dist `bindIndexM` uncurry (insertRecMany (decrHeight h))+ newChildren <- splitIndex h newIndex+ traverse (allocNode h) newChildren+ Leaf items -> do+ mapM_ (\k -> freeOverwrittenOverflowId $ M.lookup k items) $ M.keys kvs+ kvs' <- toLeafItems kvs+ traverse (allocNode h) =<< splitLeaf (M.union kvs' items)+ where+ freeOverwrittenOverflowId :: (AllocM m)+ => Maybe (LeafValue v)+ -> m ()+ freeOverwrittenOverflowId = \case+ Nothing -> return ()+ Just (RawValue _) -> return ()+ Just (OverflowValue oid) -> freeOverflow oid+++--------------------------------------------------------------------------------++-- | Insert a key-value pair in an impure B+-tree.+--+-- You are responsible to make sure the key is smaller than 'maxKeySize',+-- otherwise a 'KeyTooLargeError' can (but not always will) be thrown.+insert :: (AllocM m, Key key, Value val)+ => key+ -> val+ -> Tree key val+ -> m (Tree key val)+insert key val tree+ | Tree+ { treeHeight = height+ , treeRootId = Just rootId+ } <- tree+ = do+ newRootIdx <- insertRec key val height rootId+ case fromSingletonIndex newRootIdx of+ Just newRootId ->+ return $! Tree+ { treeHeight = height+ , treeRootId = Just newRootId+ }+ Nothing -> do+ -- Root got split, so allocate a new root node.+ let newHeight = incrHeight height+ newRootId <- allocNode newHeight Idx+ { idxChildren = newRootIdx }+ return $! Tree+ { treeHeight = newHeight+ , treeRootId = Just newRootId+ }+ | Tree+ { treeRootId = Nothing+ } <- tree+ = do -- Allocate new root node+ leafItems' <- toLeafItems $ M.singleton key val+ newRootId <- allocNode zeroHeight Leaf+ { leafItems = leafItems'+ }+ return $! Tree+ { treeHeight = zeroHeight+ , treeRootId = Just newRootId+ }++-- | Bulk insert a bunch of key-value pairs in an impure B+-tree.+--+-- You are responsible to make sure all keys is smaller than 'maxKeySize',+-- otherwise a 'KeyTooLargeError' can (but not always will) be thrown.+insertMany :: (AllocM m, Key key, Value val)+ => Map key val+ -> Tree key val+ -> m (Tree key val)+insertMany kvs tree+ | Tree+ { treeHeight = height+ , treeRootId = Just rootId+ } <- tree+ = do+ newRootIdx <- insertRecMany height kvs rootId+ fixUp height newRootIdx+ | Tree { treeRootId = Nothing } <- tree+ = do+ kvs' <- toLeafItems kvs+ idx <- traverse (allocNode zeroHeight) =<< splitLeaf kvs'+ fixUp zeroHeight $! idx++-- | Fix up the root node of a tree.+--+-- Fix up the root node of a tree, where all other nodes are valid, but the+-- root node may contain more items than allowed. Do this by repeatedly+-- splitting up the root node.+fixUp :: (AllocM m, Key key, Value val)+ => Height height+ -> Index key (NodeId height key val)+ -> m (Tree key val)+fixUp h idx = case fromSingletonIndex idx of+ Just newRootNid ->+ return $! Tree { treeHeight = h+ , treeRootId = Just newRootNid }+ Nothing -> do+ let newHeight = incrHeight h+ children <- splitIndex newHeight idx+ childrenNids <- traverse (allocNode newHeight) children+ fixUp newHeight $! childrenNids++--------------------------------------------------------------------------------
+ src/Data/BTree/Impure/Internal/Lookup.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+-- | Algorithms related to looking up key-value pairs in an impure B+-tree.+module Data.BTree.Impure.Internal.Lookup where++import Prelude hiding (lookup)++import qualified Data.Map as M++import Control.Applicative ((<$>))++import Data.BTree.Alloc.Class+import Data.BTree.Impure.Internal.Overflow+import Data.BTree.Impure.Internal.Structures+import Data.BTree.Primitives++--------------------------------------------------------------------------------++lookupRec :: forall m height key val. (AllocReaderM m, Key key, Value val)+ => key+ -> Height height+ -> NodeId height key val+ -> m (Maybe val)+lookupRec k = fetchAndGo+ where+ fetchAndGo :: forall hgt.+ Height hgt ->+ NodeId hgt key val ->+ m (Maybe val)+ fetchAndGo hgt nid =+ readNode hgt nid >>= go hgt++ go :: forall hgt.+ Height hgt ->+ Node hgt key val ->+ m (Maybe val)+ go hgt (Idx children) = do+ let (_ctx,childId) = valView k children+ fetchAndGo (decrHeight hgt) childId+ go _hgt (Leaf items) =+ case M.lookup k items of Nothing -> return Nothing+ Just v -> Just <$> fromLeafValue v++-- | Lookup a value in an impure B+-tree.+lookup :: forall m key val. (AllocReaderM m, Key key, Value val)+ => key+ -> Tree key val+ -> m (Maybe val)+lookup k tree+ | Tree+ { treeHeight = height+ , treeRootId = Just rootId+ } <- tree+ = lookupRec k height rootId+ | Tree+ { treeRootId = Nothing+ } <- tree+ = return Nothing++--------------------------------------------------------------------------------++-- | The minimal key of the map, returns 'Nothing' if the map is empty.+lookupMin :: (AllocReaderM m, Key key, Value val)+ => Tree key val+ -> m (Maybe (key, val))+lookupMin tree+ | Tree { treeRootId = Nothing } <- tree = return Nothing+ | Tree { treeHeight = height+ , treeRootId = Just rootId } <- tree+ = lookupMinRec height rootId+ where+ lookupMinRec :: (AllocReaderM m, Key key, Value val)+ => Height height+ -> NodeId height key val+ -> m (Maybe (key, val))+ lookupMinRec h nid = readNode h nid >>= \case+ Idx children -> let (_, childId) = valViewMin children in+ lookupMinRec (decrHeight h) childId+ Leaf items -> case lookupMin' items of+ Nothing -> return Nothing+ Just (k, v) -> do+ v' <- fromLeafValue v+ return $ Just (k, v')++ lookupMin' m | M.null m = Nothing+ | otherwise = Just $! M.findMin m++-- | The maximal key of the map, returns 'Nothing' if the map is empty.+lookupMax :: (AllocReaderM m, Key key, Value val)+ => Tree key val+ -> m (Maybe (key, val))+lookupMax tree+ | Tree { treeRootId = Nothing } <- tree = return Nothing+ | Tree { treeHeight = height+ , treeRootId = Just rootId } <- tree+ = lookupMaxRec height rootId+ where+ lookupMaxRec :: (AllocReaderM m, Key key, Value val)+ => Height height+ -> NodeId height key val+ -> m (Maybe (key, val))+ lookupMaxRec h nid = readNode h nid >>= \case+ Idx children -> let (_, childId) = valViewMax children in+ lookupMaxRec (decrHeight h) childId+ Leaf items -> case lookupMax' items of+ Nothing -> return Nothing+ Just (k, v) -> do+ v' <- fromLeafValue v+ return $ Just (k, v')++ lookupMax' m | M.null m = Nothing+ | otherwise = Just $! M.findMax m++--------------------------------------------------------------------------------
+ src/Data/BTree/Impure/Internal/Overflow.hs view
@@ -0,0 +1,38 @@+-- | Functions related to overflow pages.+module Data.BTree.Impure.Internal.Overflow where++import Prelude hiding (max, mapM)++import Control.Applicative ((<$>))++import Data.Binary (encode)+import Data.Map (Map)+import Data.Traversable (mapM)+import qualified Data.ByteString.Lazy as BL++import Data.BTree.Alloc.Class+import Data.BTree.Impure.Internal.Structures+import Data.BTree.Primitives++toLeafValue :: (AllocM m, Value v)+ => v+ -> m (LeafValue v)+toLeafValue v = do+ max <- maxValueSize+ if BL.length (encode v) <= fromIntegral max+ then return $ RawValue v+ else OverflowValue <$> allocOverflow v++fromLeafValue :: (AllocReaderM m, Value v)+ => LeafValue v+ -> m v+fromLeafValue (RawValue v) = return v+fromLeafValue (OverflowValue oid) = readOverflow oid+++toLeafItems :: (AllocM m, Value v) => Map k v -> m (LeafItems k v)+toLeafItems = mapM toLeafValue+++fromLeafItems :: (AllocReaderM m, Value v) => LeafItems k v -> m (Map k v)+fromLeafItems = mapM fromLeafValue
+ src/Data/BTree/Impure/Internal/Setup.hs view
@@ -0,0 +1,11 @@+-- | Setup of an impure B+-tree+module Data.BTree.Impure.Internal.Setup where++minFanout :: Int+minFanout = 2++minLeafItems :: Int+minLeafItems = minFanout++minIdxKeys :: Int+minIdxKeys = minFanout - 1
+ src/Data/BTree/Impure/Internal/Structures.hs view
@@ -0,0 +1,176 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+-- | Basic structures of an impure B+-tree.+module Data.BTree.Impure.Internal.Structures (+ -- * Structures+ Tree(..)+, Node(..)+, LeafItems+, LeafValue(..)++ -- * Binary encoding+, putLeafNode+, getLeafNode+, putIndexNode+, getIndexNode++ -- * Casting+, castNode+, castNode'+, castValue+) where++import Control.Applicative ((<$>), (<*>))+import Control.Monad (replicateM)++import Data.Binary (Binary(..), Put, Get)+import Data.Bits ((.|.), shiftL, shiftR)+import Data.Map (Map)+import Data.Proxy (Proxy(..))+import Data.Typeable (Typeable, typeRep, cast)+import Data.Word (Word8, Word32)+import qualified Data.Map as M++import Numeric (showHex)++import Unsafe.Coerce++import Data.BTree.Primitives++--------------------------------------------------------------------------------++-- | A B+-tree.+--+-- This is a simple wrapper around a root 'Node'. The type-level height is+-- existentially quantified, but a term-level witness is stores.+data Tree key val where+ Tree :: { -- | A term-level witness for the type-level height index.+ treeHeight :: Height height+ , -- | An empty tree is represented by 'Nothing'. Otherwise it's+ -- 'Just' a 'NodeId' pointer the root.+ treeRootId :: Maybe (NodeId height key val)+ } -> Tree key val+ deriving (Typeable)++data LeafValue v = RawValue v | OverflowValue OverflowId+ deriving (Eq, Show)++instance Binary v => Binary (LeafValue v) where+ put (RawValue v) = put (0x00 :: Word8) >> put v+ put (OverflowValue v) = put (0x01 :: Word8) >> put v++ get = (get :: Get Word8) >>= \case+ 0x00 -> RawValue <$> get+ 0x01 -> OverflowValue <$> get+ t -> fail $ "unknown leaf value: " ++ showHex t ""++type LeafItems k v = Map k (LeafValue v)++-- | A node in a B+-tree.+--+-- Nodes are parameterized over the key and value types and are additionally+-- indexed by their height. All paths from the root to the leaves have the same+-- length. The height is the number of edges from the root to the leaves,+-- i.e. leaves are at height zero and index nodes increase the height.+--+-- Sub-trees are represented by a 'NodeId' that are used to resolve the actual+-- storage location of the sub-tree node.+data Node height key val where+ Idx :: { idxChildren :: Index key (NodeId height key val)+ } -> Node ('S height) key val+ Leaf :: { leafItems :: LeafItems key val+ } -> Node 'Z key val+ deriving (Typeable)++instance (Eq key, Eq val) => Eq (Node height key val) where+ Leaf x == Leaf y = x == y+ Idx x == Idx y = x == y++deriving instance (Show key, Show val) => Show (Node height key val)+deriving instance (Show key, Show val) => Show (Tree key val)++instance (Value k, Value v) => Value (Tree k v) where++--------------------------------------------------------------------------------++instance Binary (Tree key val) where+ put (Tree height rootId) = put height >> put rootId+ get = Tree <$> get <*> get++-- | Encode a 'Leaf' 'Node'.+putLeafNode :: (Binary key, Binary val) => Node 'Z key val -> Put+putLeafNode (Leaf items) = do+ encodeSize $ fromIntegral (M.size items)+ mapM_ put $ M.toList items+ where+ encodeSize :: Word32 -> Put+ encodeSize s = put msb1 >> put msb2 >> put msb3+ where+ msb1 = fromIntegral $ s `shiftR` 16 :: Word8+ msb2 = fromIntegral $ s `shiftR` 8 :: Word8+ msb3 = fromIntegral s :: Word8++-- | Decode a 'Leaf' 'Node'.+getLeafNode :: (Ord key, Binary key, Binary val) => Height 'Z -> Get (Node 'Z key val)+getLeafNode _ = do+ v <- decodeSize <$> get+ l <- replicateM (fromIntegral v) get+ return $ Leaf (M.fromList l)+ where+ decodeSize :: (Word8, Word8, Word8) -> Word32+ decodeSize (msb1, msb2, msb3) = msb1' .|. msb2' .|. msb3'+ where+ msb1' = (fromIntegral msb1 :: Word32) `shiftL` 16+ msb2' = (fromIntegral msb2 :: Word32) `shiftL` 8+ msb3' = fromIntegral msb3 :: Word32++-- | Encode an 'Idx' 'Node'.+putIndexNode :: (Binary key, Binary val) => Node ('S n) key val -> Put+putIndexNode (Idx idx) = put idx++-- | Decode an 'Idx' 'Node'.+getIndexNode :: (Binary key, Binary val) => Height ('S n) -> Get (Node ('S n) key val)+getIndexNode _ = Idx <$> get++--------------------------------------------------------------------------------++-- | Cast a node to a different type.+--+-- Essentially this is just a drop-in replacement for 'Data.Typeable.cast'.+castNode :: forall n key1 val1 height1 key2 val2 height2.+ (Typeable key1, Typeable val1, Typeable key2, Typeable val2)+ => Height height1 -- ^ Term-level witness for the source height.+ -> Height height2 -- ^ Term-level witness for the target height.+ -> n height1 key1 val1 -- ^ Node to cast.+ -> Maybe (n height2 key2 val2)+castNode height1 height2 n+ | typeRep (Proxy :: Proxy key1) == typeRep (Proxy :: Proxy key2)+ , typeRep (Proxy :: Proxy val1) == typeRep (Proxy :: Proxy val2)+ , fromHeight height1 == fromHeight height2+ = Just (unsafeCoerce n)+ | otherwise+ = Nothing++-- | Cast a node to one of the available types.+castNode' :: forall n h k v.+ (Typeable k, Typeable v)+ => Height h -- ^ Term-level witness for the source height+ -> n h k v -- ^ Node to cast.+ -> Either (n 'Z k v) (n ('S h) k v)+castNode' h n+ | Just v <- castNode h zeroHeight n = Left v+ | otherwise = Right (unsafeCoerce n)++--------------------------------------------------------------------------------++-- | Cast a value to a different type.+--+-- Essentially this is just a drop-in replacement for+-- 'Data.Typeable.cast'.+castValue :: (Typeable v1, Typeable v2) => v1 -> Maybe v2+castValue = cast
− src/Data/BTree/Impure/Lookup.hs
@@ -1,114 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE ScopedTypeVariables #-}--- | Algorithms related to looking up key-value pairs in an impure B+-tree.-module Data.BTree.Impure.Lookup where--import qualified Data.Map as M--import Control.Applicative ((<$>))--import Data.BTree.Alloc.Class-import Data.BTree.Impure.Overflow-import Data.BTree.Impure.Structures-import Data.BTree.Primitives------------------------------------------------------------------------------------lookupRec :: forall m height key val. (AllocReaderM m, Key key, Value val)- => key- -> Height height- -> NodeId height key val- -> m (Maybe val)-lookupRec k = fetchAndGo- where- fetchAndGo :: forall hgt.- Height hgt ->- NodeId hgt key val ->- m (Maybe val)- fetchAndGo hgt nid =- readNode hgt nid >>= go hgt-- go :: forall hgt.- Height hgt ->- Node hgt key val ->- m (Maybe val)- go hgt (Idx children) = do- let (_ctx,childId) = valView k children- fetchAndGo (decrHeight hgt) childId- go _hgt (Leaf items) =- case M.lookup k items of Nothing -> return Nothing- Just v -> Just <$> fromLeafValue v---- | Lookup a value in an impure B+-tree.-lookupTree :: forall m key val. (AllocReaderM m, Key key, Value val)- => key- -> Tree key val- -> m (Maybe val)-lookupTree k tree- | Tree- { treeHeight = height- , treeRootId = Just rootId- } <- tree- = lookupRec k height rootId- | Tree- { treeRootId = Nothing- } <- tree- = return Nothing-------------------------------------------------------------------------------------- | The minimal key of the map, returns 'Nothing' if the map is empty.-lookupMinTree :: (AllocReaderM m, Key key, Value val)- => Tree key val- -> m (Maybe (key, val))-lookupMinTree tree- | Tree { treeRootId = Nothing } <- tree = return Nothing- | Tree { treeHeight = height- , treeRootId = Just rootId } <- tree- = lookupMinRec height rootId- where- lookupMinRec :: (AllocReaderM m, Key key, Value val)- => Height height- -> NodeId height key val- -> m (Maybe (key, val))- lookupMinRec h nid = readNode h nid >>= \case- Idx children -> let (_, childId) = valViewMin children in- lookupMinRec (decrHeight h) childId- Leaf items -> case lookupMin items of- Nothing -> return Nothing- Just (k, v) -> do- v' <- fromLeafValue v- return $ Just (k, v')-- lookupMin m | M.null m = Nothing- | otherwise = Just $! M.findMin m---- | The maximal key of the map, returns 'Nothing' if the map is empty.-lookupMaxTree :: (AllocReaderM m, Key key, Value val)- => Tree key val- -> m (Maybe (key, val))-lookupMaxTree tree- | Tree { treeRootId = Nothing } <- tree = return Nothing- | Tree { treeHeight = height- , treeRootId = Just rootId } <- tree- = lookupMaxRec height rootId- where- lookupMaxRec :: (AllocReaderM m, Key key, Value val)- => Height height- -> NodeId height key val- -> m (Maybe (key, val))- lookupMaxRec h nid = readNode h nid >>= \case- Idx children -> let (_, childId) = valViewMax children in- lookupMaxRec (decrHeight h) childId- Leaf items -> case lookupMax items of- Nothing -> return Nothing- Just (k, v) -> do- v' <- fromLeafValue v- return $ Just (k, v')-- lookupMax m | M.null m = Nothing- | otherwise = Just $! M.findMax m----------------------------------------------------------------------------------
src/Data/BTree/Impure/NonEmpty.hs view
@@ -10,14 +10,14 @@ -- * Conversions , fromTree , toTree-, nonEmptyToList+, toList -- * Construction-, fromNonEmptyList+, fromList -- * Inserting-, insertNonEmptyTree-, insertNonEmptyTreeMany+, insert+, insertMany ) where import Control.Applicative ((<$>), (<*>))@@ -31,8 +31,9 @@ import qualified Data.Map as M import Data.BTree.Alloc.Class-import Data.BTree.Impure (Tree(..), Node(..), insertTree, insertTreeMany, empty, toList)+import Data.BTree.Impure (Tree(..), Node(..)) import Data.BTree.Primitives+import qualified Data.BTree.Impure as B -- | A non-empty variant of 'Tree'. data NonEmptyTree key val where@@ -63,28 +64,28 @@ toTree (NonEmptyTree h n) = Tree h (Just n) -- | Create a 'NonEmptyTree' from a 'NonEmpty' list.-fromNonEmptyList :: (AllocM m, Key k, Value v)- => NonEmpty (k, v)- -> m (NonEmptyTree k v)-fromNonEmptyList (x :| xs) = fromJust . fromTree <$> insertTreeMany (M.fromList (x:xs)) empty+fromList :: (AllocM m, Key k, Value v)+ => NonEmpty (k, v)+ -> m (NonEmptyTree k v)+fromList (x :| xs) = fromJust . fromTree <$> B.insertMany (M.fromList (x:xs)) B.empty -- | Insert an item into a 'NonEmptyTree'-insertNonEmptyTree :: (AllocM m, Key k, Value v)- => k- -> v- -> NonEmptyTree k v- -> m (NonEmptyTree k v)-insertNonEmptyTree k v tree = fromJust . fromTree <$> insertTree k v (toTree tree)+insert :: (AllocM m, Key k, Value v)+ => k+ -> v+ -> NonEmptyTree k v+ -> m (NonEmptyTree k v)+insert k v tree = fromJust . fromTree <$> B.insert k v (toTree tree) -- | Bulk insert a bunch of key-value pairs into a 'NonEmptyTree'.-insertNonEmptyTreeMany :: (AllocM m, Key k, Value v)- => Map k v- -> NonEmptyTree k v- -> m (NonEmptyTree k v)-insertNonEmptyTreeMany kvs tree = fromJust . fromTree <$> insertTreeMany kvs (toTree tree)+insertMany :: (AllocM m, Key k, Value v)+ => Map k v+ -> NonEmptyTree k v+ -> m (NonEmptyTree k v)+insertMany kvs tree = fromJust . fromTree <$> B.insertMany kvs (toTree tree) -- | Convert a non-empty tree to a list of key-value pairs.-nonEmptyToList :: (AllocReaderM m, Key k, Value v)- => NonEmptyTree k v- -> m (NonEmpty (k, v))-nonEmptyToList tree = NE.fromList <$> toList (toTree tree)+toList :: (AllocReaderM m, Key k, Value v)+ => NonEmptyTree k v+ -> m (NonEmpty (k, v))+toList tree = NE.fromList <$> B.toList (toTree tree)
− src/Data/BTree/Impure/Overflow.hs
@@ -1,38 +0,0 @@--- | Functions related to overflow pages.-module Data.BTree.Impure.Overflow where--import Prelude hiding (max, mapM)--import Control.Applicative ((<$>))--import Data.Binary (encode)-import Data.Map (Map)-import Data.Traversable (mapM)-import qualified Data.ByteString.Lazy as BL--import Data.BTree.Alloc.Class-import Data.BTree.Impure.Structures-import Data.BTree.Primitives--toLeafValue :: (AllocM m, Value v)- => v- -> m (LeafValue v)-toLeafValue v = do- max <- maxValueSize- if BL.length (encode v) <= fromIntegral max- then return $ RawValue v- else OverflowValue <$> allocOverflow v--fromLeafValue :: (AllocReaderM m, Value v)- => LeafValue v- -> m v-fromLeafValue (RawValue v) = return v-fromLeafValue (OverflowValue oid) = readOverflow oid---toLeafItems :: (AllocM m, Value v) => Map k v -> m (LeafItems k v)-toLeafItems = mapM toLeafValue---fromLeafItems :: (AllocReaderM m, Value v) => LeafItems k v -> m (Map k v)-fromLeafItems = mapM fromLeafValue
− src/Data/BTree/Impure/Setup.hs
@@ -1,11 +0,0 @@--- | Setup of an impure B+-tree-module Data.BTree.Impure.Setup where--minFanout :: Int-minFanout = 2--minLeafItems :: Int-minLeafItems = minFanout--minIdxKeys :: Int-minIdxKeys = minFanout - 1
− src/Data/BTree/Impure/Structures.hs
@@ -1,176 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}--- | Basic structures of an impure B+-tree.-module Data.BTree.Impure.Structures (- -- * Structures- Tree(..)-, Node(..)-, LeafItems-, LeafValue(..)-- -- * Binary encoding-, putLeafNode-, getLeafNode-, putIndexNode-, getIndexNode-- -- * Casting-, castNode-, castNode'-, castValue-) where--import Control.Applicative ((<$>), (<*>))-import Control.Monad (replicateM)--import Data.Binary (Binary(..), Put, Get)-import Data.Bits ((.|.), shiftL, shiftR)-import Data.Map (Map)-import Data.Proxy (Proxy(..))-import Data.Typeable (Typeable, typeRep, cast)-import Data.Word (Word8, Word32)-import qualified Data.Map as M--import Numeric (showHex)--import Unsafe.Coerce--import Data.BTree.Primitives-------------------------------------------------------------------------------------- | A B+-tree.------ This is a simple wrapper around a root 'Node'. The type-level height is--- existentially quantified, but a term-level witness is stores.-data Tree key val where- Tree :: { -- | A term-level witness for the type-level height index.- treeHeight :: Height height- , -- | An empty tree is represented by 'Nothing'. Otherwise it's- -- 'Just' a 'NodeId' pointer the root.- treeRootId :: Maybe (NodeId height key val)- } -> Tree key val- deriving (Typeable)--data LeafValue v = RawValue v | OverflowValue OverflowId- deriving (Eq, Show)--instance Binary v => Binary (LeafValue v) where- put (RawValue v) = put (0x00 :: Word8) >> put v- put (OverflowValue v) = put (0x01 :: Word8) >> put v-- get = (get :: Get Word8) >>= \case- 0x00 -> RawValue <$> get- 0x01 -> OverflowValue <$> get- t -> fail $ "unknown leaf value: " ++ showHex t ""--type LeafItems k v = Map k (LeafValue v)---- | A node in a B+-tree.------ Nodes are parameterized over the key and value types and are additionally--- indexed by their height. All paths from the root to the leaves have the same--- length. The height is the number of edges from the root to the leaves,--- i.e. leaves are at height zero and index nodes increase the height.------ Sub-trees are represented by a 'NodeId' that are used to resolve the actual--- storage location of the sub-tree node.-data Node height key val where- Idx :: { idxChildren :: Index key (NodeId height key val)- } -> Node ('S height) key val- Leaf :: { leafItems :: LeafItems key val- } -> Node 'Z key val- deriving (Typeable)--instance (Eq key, Eq val) => Eq (Node height key val) where- Leaf x == Leaf y = x == y- Idx x == Idx y = x == y--deriving instance (Show key, Show val) => Show (Node height key val)-deriving instance (Show key, Show val) => Show (Tree key val)--instance (Value k, Value v) => Value (Tree k v) where------------------------------------------------------------------------------------instance Binary (Tree key val) where- put (Tree height rootId) = put height >> put rootId- get = Tree <$> get <*> get---- | Encode a 'Leaf' 'Node'.-putLeafNode :: (Binary key, Binary val) => Node 'Z key val -> Put-putLeafNode (Leaf items) = do- encodeSize $ fromIntegral (M.size items)- mapM_ put $ M.toList items- where- encodeSize :: Word32 -> Put- encodeSize s = put msb1 >> put msb2 >> put msb3- where- msb1 = fromIntegral $ s `shiftR` 16 :: Word8- msb2 = fromIntegral $ s `shiftR` 8 :: Word8- msb3 = fromIntegral s :: Word8---- | Decode a 'Leaf' 'Node'.-getLeafNode :: (Ord key, Binary key, Binary val) => Height 'Z -> Get (Node 'Z key val)-getLeafNode _ = do- v <- decodeSize <$> get- l <- replicateM (fromIntegral v) get- return $ Leaf (M.fromList l)- where- decodeSize :: (Word8, Word8, Word8) -> Word32- decodeSize (msb1, msb2, msb3) = msb1' .|. msb2' .|. msb3'- where- msb1' = (fromIntegral msb1 :: Word32) `shiftL` 16- msb2' = (fromIntegral msb2 :: Word32) `shiftL` 8- msb3' = fromIntegral msb3 :: Word32---- | Encode an 'Idx' 'Node'.-putIndexNode :: (Binary key, Binary val) => Node ('S n) key val -> Put-putIndexNode (Idx idx) = put idx---- | Decode an 'Idx' 'Node'.-getIndexNode :: (Binary key, Binary val) => Height ('S n) -> Get (Node ('S n) key val)-getIndexNode _ = Idx <$> get-------------------------------------------------------------------------------------- | Cast a node to a different type.------ Essentially this is just a drop-in replacement for 'Data.Typeable.cast'.-castNode :: forall n key1 val1 height1 key2 val2 height2.- (Typeable key1, Typeable val1, Typeable key2, Typeable val2)- => Height height1 -- ^ Term-level witness for the source height.- -> Height height2 -- ^ Term-level witness for the target height.- -> n height1 key1 val1 -- ^ Node to cast.- -> Maybe (n height2 key2 val2)-castNode height1 height2 n- | typeRep (Proxy :: Proxy key1) == typeRep (Proxy :: Proxy key2)- , typeRep (Proxy :: Proxy val1) == typeRep (Proxy :: Proxy val2)- , fromHeight height1 == fromHeight height2- = Just (unsafeCoerce n)- | otherwise- = Nothing---- | Cast a node to one of the available types.-castNode' :: forall n h k v.- (Typeable k, Typeable v)- => Height h -- ^ Term-level witness for the source height- -> n h k v -- ^ Node to cast.- -> Either (n 'Z k v) (n ('S h) k v)-castNode' h n- | Just v <- castNode h zeroHeight n = Left v- | otherwise = Right (unsafeCoerce n)-------------------------------------------------------------------------------------- | Cast a value to a different type.------ Essentially this is just a drop-in replacement for--- 'Data.Typeable.cast'.-castValue :: (Typeable v1, Typeable v2) => v1 -> Maybe v2-castValue = cast
tests/Integration/WriteOpenRead/Debug.hs view
@@ -22,9 +22,9 @@ import Data.BTree.Alloc.Class import Data.BTree.Alloc.Debug-import Data.BTree.Impure+import Data.BTree.Impure (Tree) import Data.BTree.Primitives-import qualified Data.BTree.Impure as Tree+import qualified Data.BTree.Impure as B import Integration.WriteOpenRead.Transactions @@ -39,7 +39,7 @@ prop_debug_allocator :: Property prop_debug_allocator = forAll genTestSequence $ \(TestSequence txs) ->- let s = AllocatorState emptyPages Tree.empty+ let s = AllocatorState emptyPages B.empty m = runIdentity $ evalStateT (runSeq txs) s in m `seq` True@@ -79,7 +79,7 @@ readAll :: (AllocM m, Key k, Value v) => Tree k v -> m [(k, v)]-readAll = Tree.toList+readAll = B.toList doTx :: (AllocM m, Key k, Value v) => Tree k v@@ -88,9 +88,9 @@ doTx tree (TestTransaction actions) = foldl (>=>) return (map writeAction actions) tree where- writeAction (Insert k v) = insertTree k v- writeAction (Replace k v) = insertTree k v- writeAction (Delete k) = deleteTree k+ writeAction (Insert k v) = B.insert k v+ writeAction (Replace k v) = B.insert k v+ writeAction (Delete k) = B.delete k --------------------------------------------------------------------------------
tests/Properties/Impure/Fold.hs view
@@ -9,8 +9,7 @@ import qualified Data.Map as M import Data.BTree.Alloc.Debug-import Data.BTree.Impure.Insert-import qualified Data.BTree.Impure as Tree+import qualified Data.BTree.Impure as B tests :: Test tests = testGroup "Impure.Fold"@@ -20,6 +19,6 @@ prop_foldable_toList_fromList :: [(Int64, Integer)] -> Bool prop_foldable_toList_fromList kvs | (v, _) <- runDebug emptyPages $- foldl (>=>) return (map (uncurry insertTree) kvs) Tree.empty- >>= Tree.toList+ foldl (>=>) return (map (uncurry B.insert) kvs) B.empty+ >>= B.toList = v == M.toList (M.fromList kvs)
tests/Properties/Impure/Insert.hs view
@@ -10,35 +10,34 @@ import qualified Data.Map as M import Data.BTree.Alloc.Debug-import Data.BTree.Impure.Insert-import qualified Data.BTree.Impure as Tree+import qualified Data.BTree.Impure as B tests :: Test tests = testGroup "Impure.Insert"- [ testProperty "insertTreeMany" prop_insertTreeMany+ [ testProperty "insertMany" prop_insertMany , testProperty "insertOverflows" prop_insertOverflows ] -prop_insertTreeMany :: [(Int64, Integer)] -> [(Int64, Integer)] -> Bool-prop_insertTreeMany xs ys = ty1 == ty2+prop_insertMany :: [(Int64, Integer)] -> [(Int64, Integer)] -> Bool+prop_insertMany xs ys = ty1 == ty2 where- tx = insertAll xs Tree.empty+ tx = insertAll xs B.empty ty1 = evalDebug emptyPages $ tx >>= insertAll ys- >>= Tree.toList+ >>= B.toList ty2 = evalDebug emptyPages $ tx- >>= insertTreeMany (M.fromList ys)- >>= Tree.toList+ >>= B.insertMany (M.fromList ys)+ >>= B.toList - insertAll kvs = foldl (>=>) return (map (uncurry insertTree) kvs)+ insertAll kvs = foldl (>=>) return (map (uncurry B.insert) kvs) prop_insertOverflows :: M.Map Int64 [Word8] -> Bool prop_insertOverflows kvs | v <- evalDebug emptyPages $- insertTreeMany kvs Tree.empty- >>= Tree.toList+ B.insertMany kvs B.empty+ >>= B.toList = v == M.toList kvs
tests/Properties/Impure/Structures.hs view
@@ -15,7 +15,7 @@ import Data.Typeable import qualified Data.Binary as B -import Data.BTree.Impure.Structures+import Data.BTree.Impure.Internal.Structures import Data.BTree.Primitives import Properties.Primitives.Height (genNonZeroHeight)