stable-tree 0.5.0 → 0.6.0
raw patch · 12 files changed
+1458/−732 lines, 12 files
Files
- demo/Main.hs +1/−0
- src/Data/StableTree.hs +27/−65
- src/Data/StableTree/Build.hs +447/−0
- src/Data/StableTree/Conversion.hs +80/−63
- src/Data/StableTree/Fragment.hs +0/−69
- src/Data/StableTree/Mutate.hs +126/−0
- src/Data/StableTree/Persist.hs +16/−17
- src/Data/StableTree/Properties.hs +264/−0
- src/Data/StableTree/Tree.hs +0/−502
- src/Data/StableTree/Types.hs +396/−0
- stable-tree.cabal +6/−5
- tests/TestAll.hs +95/−11
demo/Main.hs view
@@ -7,6 +7,7 @@ ) where import Data.StableTree+import Data.StableTree.Persist import qualified Data.Map as Map import Control.Monad ( foldM )
src/Data/StableTree.hs view
@@ -3,76 +3,38 @@ -- Copyright : Jeremy Groven -- License : BSD3 ----- A Rose Tree designed for maximal stability under mutation. The StableTree--- structure is meant to be used in places where different versions of a--- key/value map are kept, such as in a versioning file system or a revision--- control system. As a tree's contents are mutated (inserted, updated,--- deleted), it will tend to keep the vast majority of its branches untouched,--- with generally just the immediate branch and its immediate ancestor chain--- being modified. Put another way, trees with similar contents will also share--- a majority of their branches.+-- A B-Tree variation designed for maximal stability under mutation. The+-- StableTree structure is meant to be used in places where different versions+-- of a key/value map are kept, such as in a versioning file system or a+-- revision control system. As a tree's contents are mutated (inserted,+-- updated, deleted), it will tend to keep the vast majority of its branches+-- untouched, with generally just the lowest branch and its immediate ancestor+-- chain being modified. Put another way, trees with similar contents will also+-- share a majority of their internal branches. ----- This module exports the public interface for StableTree. Right now, that's--- just a translation to the standard Data.Map and back. There's nothing about--- StableTree that forbids direct manipulation, but I've been playing with--- various implementations of this for way too long, and I just want to start--- using the dang thing now.+-- This module exports the public interface for StableTree. It largely mimics+-- the Data.Map interface, so it should be fairly familiar to Haskell users. module Data.StableTree-( StableTree(..)+( StableTree , fromMap+, empty+, insert+, delete+, size+, lookup+, keys+, elems+, assocs+, fmap+, append+, concat , toMap-, Error(..)-, load-, load'-, store-, store'-, Fragment(..) ) where -import qualified Data.StableTree.Tree as Tree-import Data.StableTree.Fragment ( Fragment(..) )-import Data.StableTree.Persist ( Error(..), load, load', store, store' )-import Data.StableTree.Tree ( StableTree(..) )--import qualified Data.Map as Map-import Data.Map ( Map )-import Data.Maybe ( isNothing )-import Data.Serialize ( Serialize )---- | Convert a 'Data.Map.Map' into a 'StableTree'.-fromMap :: (Ord k, Serialize k, Serialize v) => Map k v -> StableTree k v-fromMap m = go m Map.empty- where- go values accum =- case Tree.nextBottom values of- Left incomplete ->- if Map.null accum- then StableTree_I incomplete- else case Tree.getKey incomplete of- Just k -> buildParents accum (Just (k, incomplete)) Map.empty- Nothing -> buildParents accum Nothing Map.empty- Right (complete, remain) ->- if Map.null remain && Map.null accum- then StableTree_C complete- else go remain $ Map.insert (Tree.completeKey complete) complete accum-- buildParents completes mIncomplete accum =- case Tree.nextBranch completes mIncomplete of- Left incomplete ->- if Map.null accum- then StableTree_I incomplete- else case Tree.getKey incomplete of- Just k -> buildParents accum (Just (k, incomplete)) Map.empty- Nothing -> buildParents accum Nothing Map.empty- Right (complete, remain) ->- if Map.null remain && Map.null accum && isNothing mIncomplete- then StableTree_C complete- else - let accum' = Map.insert (Tree.completeKey complete) complete accum- in buildParents remain mIncomplete accum'+import Data.StableTree.Build ( fromMap, empty, append, concat )+import Data.StableTree.Mutate ( insert, delete, fmap )+import Data.StableTree.Properties ( toMap, size, lookup, keys, elems, assocs )+import Data.StableTree.Types ( StableTree ) --- | Convert a 'StableTree' back into a 'Data.Map.Map'-toMap :: Ord k => StableTree k v -> Map k v-toMap (StableTree_I t) = Tree.treeContents t-toMap (StableTree_C t) = Tree.treeContents t+import Prelude ()
+ src/Data/StableTree/Build.hs view
@@ -0,0 +1,447 @@+{-# LANGUAGE LambdaCase, OverloadedStrings, GADTs, ExistentialQuantification #-}+-- |+-- Module : Data.StableTree.Build+-- Copyright : Jeremy Groven+-- License : BSD3+--+-- This is the core implementation of the stable tree. The primary functions+-- exported by this module are 'nextBottom' and 'nextBranch', which gather+-- values or lower-level 'Tree's into 'Tree's of the next level.+--+-- This module is fairly esoteric. "Data.StableTree" is probably what you+-- actually want to be using.+module Data.StableTree.Build+( fromMap+, empty+, append+, concat+, consume+, consumeMap+, consumeBranches+, consumeBranches'+, nextBottom+, NextBranch(..)+, nextBranch+, merge+) where++import qualified Data.StableTree.Key as Key+import qualified Data.StableTree.Properties as Properties+import Data.StableTree.Key ( SomeKey(..), fromKey, unwrap )+import Data.StableTree.Types++import qualified Data.Map as Map+import Control.Arrow ( first, second )+import Data.Map ( Map )+import Data.Maybe ( maybeToList )+import Data.List ( sortBy )+import Data.Ord ( comparing )+import Data.Serialize ( Serialize )++import Prelude hiding ( concat )++-- |Convert a simple key/value map into a StableTree+fromMap :: (Ord k, Serialize k, Serialize v) => Map k v -> StableTree k v+fromMap = (uncurry consume) . consumeMap++-- |Create a new empty StableTree+empty :: (Ord k, Serialize k, Serialize v) => StableTree k v+empty = case consumeMap Map.empty of+ ([], Just inc) -> StableTree_I inc+ ([complete], Nothing) -> StableTree_C complete+ _ -> error "an empty tree _does not_ have more than one item"++-- |Smash two StableTree instances into a single one+append :: (Ord k, Serialize k, Serialize v)+ => StableTree k v -> StableTree k v -> StableTree k v+append l r = concat [l, r]++-- |Smash a whole bunch of StableTree instances into a single one+concat :: (Ord k, Serialize k, Serialize v)+ => [StableTree k v] -> StableTree k v+concat = go [] []+ where+ go :: (Ord k, Serialize k, Serialize v)+ => [Tree Z Complete k v] -> [Tree Z Incomplete k v] -> [StableTree k v]+ -> StableTree k v+ go completes incompletes [] = concat' completes incompletes+ go cs is (StableTree_C c:rest) =+ case c of+ Bottom _ _ _ _ _ -> go (c:cs) is rest+ Branch _ _ _ _ _ _ -> branch c cs is rest+ go cs is (StableTree_I i:rest) =+ case i of+ IBottom0 _ _ -> go cs (i:is) rest+ IBottom1 _ _ _ _ -> go cs (i:is) rest+ IBranch0 _ _ _ -> branch i cs is rest+ IBranch1 _ _ _ _ -> branch i cs is rest+ IBranch2 _ _ _ _ _ _ -> branch i cs is rest++ branch :: (Ord k, Serialize k, Serialize v)+ => Tree (S d) c k v+ -> [Tree Z Complete k v]+ -> [Tree Z Incomplete k v]+ -> [StableTree k v]+ -> StableTree k v+ branch i cs is rest =+ let (children, minc) = Properties.branchChildren i+ child' = map (StableTree_C . snd) $ Map.elems children+ inc' = map (\(_, _, t) -> StableTree_I t)+ (maybeToList minc)+ in go cs is (inc' ++ child' ++ rest)++-- |Helper function to convert a complete bunch of Tree instances (of the same+-- depth) into a single StableTree.+consume :: (Ord k, Serialize k, Serialize v)+ => [Tree d Complete k v]+ -> Maybe (Tree d Incomplete k v)+ -> StableTree k v+consume [] Nothing = empty+consume [c] Nothing = prune $ StableTree_C c+consume [] (Just i) = prune $ StableTree_I i+consume cs minc =+ (uncurry consume) (consumeBranches' cs minc)++-- |Helper function to reduce trees to their minimum height by removing root+-- branches that only have one child.+prune :: Ord k => StableTree k v -> StableTree k v+prune st =+ case Properties.stableChildren st of+ Left _ -> st+ Right m ->+ -- This may be too wasteful; we'll find out.+ case Map.elems m of+ [(_,c)] -> prune c+ _ -> st++-- |Convert a single key/value map into Tree bottom (zero-depth) instances. The+-- resulting list of Tree instances will never be overlapping, and will be+-- sorted such that each Tree's highest key is lower than the next Tree's+-- lowest key. This is not guaranteed by types because i don't think that can+-- be done in Haskell.+consumeMap :: (Ord k, Serialize k, Serialize v)+ => Map k v+ -> ([Tree Z Complete k v], Maybe (Tree Z Incomplete k v))+consumeMap = go []+ where+ go accum remain =+ case nextBottom remain of+ Left inc ->+ (reverse accum, Just inc)+ Right (comp, remain') ->+ if Map.null remain'+ then (reverse (comp:accum), Nothing)+ else go (comp:accum) remain'++-- |Given a mapping from each Tree's first key to that Tree, (and a final+-- incomplete Tree if desired), this will build the next level of Tree+-- instances. As with consumeMap, the resulting list of Tree instances will be+-- non-overlapping and ordered such that each Tree's highest key is smaller+-- than the next Tree's lowest key.+consumeBranches :: (Ord k, Serialize k, Serialize v)+ => Map k (Tree d Complete k v)+ -> Maybe (k, Tree d Incomplete k v)+ -> ([Tree (S d) Complete k v], Maybe (Tree (S d) Incomplete k v))+consumeBranches = go []+ where+ go accum remain minc =+ case nextBranch remain minc of+ Empty ->+ (reverse accum, Nothing) -- I think accum is probably [] here...+ Final inc ->+ (reverse accum, Just inc)+ More comp remain' ->+ go (comp:accum) remain' minc++-- |Given a simple listing of complete Trees and maybe an incomplete one, this+-- will build the next level ot Trees. This just builds a map and calls the+-- previous 'consumeBranches' function, but it's a convenient function to have.+consumeBranches' :: (Ord k, Serialize k, Serialize v)+ => [Tree d Complete k v]+ -> Maybe (Tree d Incomplete k v)+ -> ([Tree (S d) Complete k v], Maybe (Tree (S d) Incomplete k v))+consumeBranches' completes mincomplete =+ let ctree = Map.fromList [(Properties.completeKey c, c) | c <- completes]+ mpair = case mincomplete of+ Nothing -> Nothing+ Just inc ->+ case Properties.getKey inc of+ Nothing -> Nothing+ Just k -> Just (k, inc)+ in consumeBranches ctree mpair++-- |Wrap up some of a k/v map into a 'Tree'. A 'Right' result gives a complete+-- tree and the map updated to not have the key/values that went into that+-- tree. A 'Left' result gives an incomplete tree that contains everything that+-- the given map contained.+nextBottom :: (Ord k, Serialize k, Serialize v)+ => Map k v+ -> Either (Tree Z Incomplete k v)+ (Tree Z Complete k v, Map k v)+nextBottom values =+ case Map.minViewWithKey values >>= return . second Map.minViewWithKey of+ Just (f1, Just (f2, remain)) ->+ go (first Key.wrap f1) (first Key.wrap f2) Map.empty remain+ partial ->+ -- this is a bit odd, because I couldn't come up with a better way to tie+ -- the type of the Nothing to the type of the Just, so that+ -- iBottom0ObjectID would be satisfied.+ let m = case partial of+ Nothing -> Nothing+ Just ((k,v), Nothing) -> Just (Key.wrap k, v)+ _ ->+ error "This is just here to satisfy a broken exhaustion check"+ b = mkIBottom0 m+ in Left b++ where+ go f1 f2 accum remain =+ case Map.minViewWithKey remain of+ Nothing ->+ Left $ mkIBottom1 f1 f2 accum+ Just ((k, v), remain') ->+ case Key.wrap k of+ SomeKey_N nonterm ->+ go f1 f2 (Map.insert nonterm v accum) remain'+ SomeKey_T term ->+ Right (mkBottom f1 f2 accum (term, v), remain')++-- | Result of the 'nextBranch' function; values are described below.+data NextBranch d k v+ = Empty+ | Final (Tree (S d) Incomplete k v)+ | More (Tree (S d) Complete k v) (Map k (Tree d Complete k v))++-- |Generate a parent for a k/Tree map. An 'Empty' result means that the+-- function was called with an empty Map and 'Nothing' for an incomplete. A+-- 'Final' result means that an incomplete Tree was build and there is no more+-- work to be done. A 'More' result means that a complete Tree was built, and+-- there is (possibly) more work to do.+nextBranch :: (Ord k, Serialize k, Serialize v)+ => Map k (Tree d Complete k v)+ -> Maybe (k, Tree d Incomplete k v)+ -> NextBranch d k v+nextBranch branches mIncomplete =+ let freebies = Map.minViewWithKey branches+ >>= return . second Map.minViewWithKey+ in case freebies of+ Nothing -> + case mIncomplete of+ Nothing ->+ Empty+ Just (ik, iv) ->+ let tup = (Key.wrap ik, getValueCount iv, iv)+ b = mkIBranch0 depth tup+ in Final b+ Just ((k,v), Nothing) ->+ let tup = (Key.wrap k, getValueCount v, v)+ may = wrapMKey mIncomplete+ in Final $ mkIBranch1 depth tup may+ Just (f1, Just (f2, remain)) ->+ go (wrapKey f1) (wrapKey f2) Map.empty remain++ where+ go f1 f2 accum remain =+ let popd = Map.minViewWithKey remain >>= return . first wrapKey+ in case popd of+ Nothing ->+ let may = wrapMKey mIncomplete+ in Final $ mkIBranch2 depth f1 f2 accum may + Just ((SomeKey_T term,c,v), remain') ->+ let tup = (term, c, v)+ in More (mkBranch depth f1 f2 accum tup) remain'+ Just ((SomeKey_N nonterm,c,v), remain') ->+ go f1 f2 (Map.insert nonterm (c,v) accum) remain'++ wrapKey (k,v) = (Key.wrap k, getValueCount v, v)++ wrapMKey = (>>=return . wrapKey)++ depth = case Map.elems branches of+ [] ->+ case mIncomplete of+ Nothing -> 1+ Just (_, v) -> 1 + getDepth v+ elems ->+ let depths@(f:r) = map getDepth elems+ (best, rest) = case mIncomplete of+ Nothing -> (f, r)+ Just (_, v) -> (getDepth v, depths)+ in if all (==best) rest+ then 1 + best+ else error "Depth mismatch in nextBranch"++-- |Tree mutation functions (insert, delete) will generally wind up with a+-- bunch of Trees that come before the key that was to be changed, and then the+-- result of updating the relevant Tree, and then a bunch of Trees (and maybe+-- an incomplete Tree) that come after it. Merge can splice this result back+-- into a correctly ordered, non-overlapping list of complete Trees and maybe a+-- final incomplete one.+merge :: (Ord k, Serialize k, Serialize v)+ => [Tree d Complete k v]+ -> Maybe (Tree d Incomplete k v)+ -> [Tree d Complete k v]+ -> Maybe (Tree d Incomplete k v)+ -> ([Tree d Complete k v], Maybe (Tree d Incomplete k v))+merge before Nothing after minc =+ (before ++ after, minc)+merge before minc [] Nothing =+ (before, minc)+merge before (Just left) [] (Just right) =+ case left of+ (IBottom0 _ _) -> bottom before left right+ (IBottom1 _ _ _ _) -> bottom before left right+ (IBranch0 _ _ _) -> branch before left right+ (IBranch1 _ _ _ _) -> branch before left right+ (IBranch2 _ _ _ _ _ _) -> branch before left right++ where+ bottom b l r =+ let lc = Properties.bottomChildren l+ rc = Properties.bottomChildren r+ (after, minc) = consumeMap (Map.union lc rc)+ in (b ++ after, minc)++ branch :: (Ord k, Serialize k, Serialize v)+ => [Tree (S d) Complete k v]+ -> Tree (S d) Incomplete k v+ -> Tree (S d) Incomplete k v+ -> ([Tree (S d) Complete k v], Maybe (Tree (S d) Incomplete k v))+ branch b l r =+ let (c1, i1) = Properties.branchChildren l+ c1' = map snd $ Map.elems c1+ i1' = fmap (\(_,_,x) -> x) i1+ (c2, i2) = Properties.branchChildren r+ c2' = map snd $ Map.elems c2+ i2' = fmap (\(_,_,x) -> x) i2+ (lcomp, linc) = merge c1' i1' c2' i2'+ lcomp' = Map.fromList [(Properties.completeKey i,i)|i<-lcomp]+ linc' = case linc of+ Nothing -> Nothing+ Just i ->+ case Properties.getKey i of+ Nothing -> Nothing+ Just k -> Just (k,i)+ (after, minc) = consumeBranches lcomp' linc'+ in (b ++ after, minc)++merge before (Just inc) (after:rest) minc =+ case inc of+ (IBottom0 _ _) -> bottom before inc after rest minc+ (IBottom1 _ _ _ _) -> bottom before inc after rest minc+ (IBranch0 _ _ _) -> branch before inc after rest minc+ (IBranch1 _ _ _ _) -> branch before inc after rest minc+ (IBranch2 _ _ _ _ _ _) -> branch before inc after rest minc+ where+ bottom :: (Ord k, Serialize k, Serialize v)+ => [Tree Z Complete k v]+ -> Tree Z Incomplete k v+ -> Tree Z Complete k v+ -> [Tree Z Complete k v]+ -> Maybe (Tree Z Incomplete k v)+ -> ([Tree Z Complete k v], Maybe (Tree Z Incomplete k v))+ bottom b i a r m =+ let ic = Properties.bottomChildren i+ ac = Properties.bottomChildren a+ in case consumeMap (Map.union ic ac) of+ (comp, Nothing) -> (b++comp++r, m)+ (comp, justinc) -> merge (b++comp) justinc r m++ branch :: (Ord k, Serialize k, Serialize v)+ => [Tree (S d) Complete k v]+ -> Tree (S d) Incomplete k v+ -> Tree (S d) Complete k v+ -> [Tree (S d) Complete k v]+ -> Maybe (Tree (S d) Incomplete k v)+ -> ([Tree (S d) Complete k v], Maybe (Tree (S d) Incomplete k v))+ branch b i a r m =+ let (ci, ii) = Properties.branchChildren i+ ci' = map snd $ Map.elems ci+ ii' = fmap (\(_,_,x) -> x) ii+ (ca, ia) = Properties.branchChildren a+ ca' = map snd $ Map.elems ca+ ia' = fmap (\(_,_,x) -> x) ia+ (low_comp, low_minc) = merge ci' ii' ca' ia'+ lcomp' = Map.fromList [ (Properties.completeKey lc, lc)+ | lc <- low_comp]+ linc' = case low_minc of+ Nothing -> Nothing+ Just low_inc ->+ case Properties.getKey low_inc of+ Nothing -> Nothing+ Just k -> Just (k,low_inc)+ (newcomp, newminc) = consumeBranches lcomp' linc'+ in merge (b ++ newcomp) newminc r m++concat' :: (Ord k, Serialize k, Serialize v)+ => [Tree Z Complete k v]+ -> [Tree Z Incomplete k v]+ -> StableTree k v+concat' completes incompletes =+ let c_triplets = [ (Properties.completeKey c, completeEnd c, Right c)+ | c <- completes ]+ i_triplets = sort' [ (k, e, Left i) | (Just k, Just e, i) <- + [ (Properties.getKey i, getEnd i, i)+ | i <- incompletes ] ]+ sorted = sort' $ c_triplets ++ i_triplets+ in go [] sorted++ where+ go accum [] =+ consume accum Nothing+ go accum [(_, _, Left i)] =+ consume accum (Just i)+ go accum (triple:triples) =+ let (cont, rest) = eatList Map.empty triple triples+ in case cont of+ (cs, Nothing) ->+ go (accum ++ cs) rest+ (cs, Just incomplete) ->+ case (Properties.getKey incomplete, getEnd incomplete) of+ (Just ibegin, Just iend) ->+ go (accum ++ cs) ((ibegin, iend, Left incomplete):rest)+ _ ->+ go (accum ++ cs) rest+ + eatList kvmap (_, _, Left i) [] | Map.null kvmap =+ (([], Just i), [])+ eatList kvmap (_, _, Right c) [] | Map.null kvmap =+ (([c], Nothing), [])+ eatList kvmap (_, _, x) [] =+ let cont = case x of+ Left i -> Properties.bottomChildren i+ Right c -> Properties.bottomChildren c+ both = Map.union kvmap cont+ in ( consumeMap both, [] )+ eatList kvmap (_, lhi, Right c) rest@((rlow, _, _):_) | Map.null kvmap && lhi < rlow =+ (([c], Nothing), rest)+ eatList kvmap (_, lhi, Right c) rest@((rlow, _, _):_) | lhi < rlow =+ let cont = Properties.bottomChildren c+ both = Map.union kvmap cont+ nxt = consumeMap both+ in ( nxt, rest )+ eatList kvmap (_, _, x) (nxt:rest) =+ let cont = case x of+ Left l -> Properties.bottomChildren l+ Right r -> Properties.bottomChildren r+ both = Map.union kvmap cont+ in eatList both nxt rest++ sort' = sortBy (comparing (\(a,b,_) -> (a,b)))++ completeEnd :: Tree Z Complete k v -> k+ completeEnd (Bottom _ _ _ _ (tk, _tv)) = fromKey tk++ getEnd :: Tree Z Incomplete k v -> Maybe k+ getEnd (IBottom0 _ Nothing) =+ Nothing+ getEnd (IBottom0 _ (Just (sk, _v))) =+ Just $ unwrap sk+ getEnd (IBottom1 _ _ (sk, _v) ntmap) =+ case Map.toDescList ntmap of+ [] -> Just $ unwrap sk+ (k,_v):_ -> Just $ fromKey k++ _1 (x, _, _) = x+ _2 (_, x, _) = x+ _3 (_, _, x) = x
src/Data/StableTree/Conversion.hs view
@@ -4,90 +4,107 @@ -- Copyright : Jeremy Groven -- License : BSD3 ----- Functions for converting between Tree and Fragment types+-- Functions for converting between `Tree` and `Fragment` types module Data.StableTree.Conversion ( toFragments , fromFragments+, fragsToMap ) where -import Data.StableTree.Fragment-import Data.StableTree.Tree+import Data.StableTree.Properties ( stableChildren )+import Data.StableTree.Build ( consume, consumeMap )+import Data.StableTree.Types import qualified Data.Map as Map import qualified Data.Text as Text-import Control.Arrow ( second ) import Data.Map ( Map ) import Data.ObjectID ( ObjectID ) import Data.Serialize ( Serialize ) import Data.Text ( Text ) -toFragments :: Ord k => Tree c k v -> [(ObjectID, Fragment k v)]+-- |Convert a 'StableTree' 'Tree' into a list of storable 'Fragment's. The+-- resulting list is guaranteed to be in an order where each 'Fragment' will be+-- seen after all its children.+toFragments :: Ord k => StableTree k v -> [(ObjectID, Fragment k v)] toFragments tree =- case branchContents tree of- Right bottom -> [(getObjectID tree, FragmentBottom bottom)]- Left ( completes, mIncomplete ) ->- let depth = getDepth tree- cont = Map.map (second getObjectID) completes- cont' = case mIncomplete of- Nothing -> cont- Just (key,c,t) -> Map.insert key (c,getObjectID t) cont- this = FragmentBranch depth cont'- below = concat $ map (toFragments . snd) $ Map.elems completes- below' = case mIncomplete of- Nothing -> below- Just (_,_,t) -> below ++ toFragments t- in below' ++ [(getObjectID tree, this)]+ let oid = getObjectID tree+ frag = makeFragment tree+ in case stableChildren tree of+ Left _ -> [(oid, frag)]+ Right children ->+ let below = concat $ map (toFragments . snd) $ Map.elems children+ in below ++ [(oid, frag)] +-- |Recover a 'Tree' from a single 'Fragment' and a map of the fragments as+-- returned from 'toFragments'. If the fragment set was already stored, it is+-- the caller's responsibility to load all the child fragments into a map+-- (probably involving finding children using the fragmentChildren field of the+-- Fragment type). fromFragments :: (Ord k, Serialize k, Serialize v) => Map ObjectID (Fragment k v) -> Fragment k v- -> Either Text (Either (Tree Incomplete k v)- (Tree Complete k v))-fromFragments _ (FragmentBottom assocs) =- case nextBottom assocs of- Left i -> Right $ Left i- Right (c, remain)- | Map.null remain -> Right $ Right c- | otherwise -> Left "Fragment had leftovers!?"-fromFragments loaded (FragmentBranch depth children) =- case readChildren Map.empty (Map.toAscList children) of- Left err -> Left err- Right (tmap, minc) ->- case nextBranch tmap minc of- Left i -> Right $ Left i- Right (c, remain)- | Map.null remain && getDepth c == depth -> Right $ Right c- | otherwise -> Left "Fragment rebuild failed"+ -> Either Text (StableTree k v)+fromFragments loaded top = do+ (complete, mincomplete) <- fragsToBottoms loaded top+ return $ consume complete mincomplete +-- |Directly convert a bunch of `Fragment`s and a root fragment into a+-- `Data.Map.Map` instance. Mostly useful for testing the correctness of the+-- `fromFragments` function.+fragsToMap :: Ord k+ => Map ObjectID (Fragment k v)+ -> Fragment k v+ -> Either Text (Map k v)+fragsToMap loaded = go Map.empty where- readChildren _ [] = Left "Invalid empty branch"- readChildren accum [(key,(cnt,oid))] =- case Map.lookup oid loaded of- Nothing -> Left $ cannotFind oid- Just frag ->- case fromFragments loaded frag of- Left err -> Left err- Right (Right c)- | getValueCount c == cnt -> Right (Map.insert key c accum, Nothing)- | otherwise -> Left "Value Count Mismatch"- Right (Left l)- | getValueCount l == cnt -> Right (accum, Just (key, l))- | otherwise -> Left "Value Count Mismatch"+ go accum (FragmentBottom m) = Right $ Map.union accum m+ go accum (FragmentBranch _ children) =+ go' accum $ map snd $ Map.elems children - readChildren accum ((key,(cnt,oid)):rest) =- case Map.lookup oid loaded of- Nothing -> Left $ cannotFind oid- Just frag ->- case fromFragments loaded frag of- Left err -> Left err- Right (Right c)- | getValueCount c == cnt ->- readChildren (Map.insert key c accum) rest- | otherwise -> Left "Value Count Mismatch"- _ -> Left "Got incomplete branch in non-right position"+ go' accum [] = Right accum+ go' accum (first:rest) =+ case Map.lookup first loaded of+ Nothing -> notFound first+ Just frag -> do+ nxt <- go accum frag+ go' nxt rest + notFound objectid =+ Left $ Text.append "Failed to find Fragment with ID "+ (Text.pack $ show objectid) - cannotFind oid =- Text.append "Failed to find object with ObjectID "- (Text.pack $ show oid)+-- |Build a list of the 'Tree Z' instances that come from the given 'Fragment'.+-- The resulting Trees non-overlapping and ordered such that each Tree's+-- highest key is lower than the next Tree's lowest key, but illegal Fragments+-- could break that.+fragsToBottoms :: (Ord k, Serialize k, Serialize v)+ => Map ObjectID (Fragment k v)+ -> Fragment k v+ -> Either Text ( [Tree Z Complete k v]+ , Maybe (Tree Z Incomplete k v))+fragsToBottoms _ (FragmentBottom m) = Right $ consumeMap m+fragsToBottoms frags top =+ let content = fragmentChildren top+ asList = Map.toAscList content+ oids = map (snd.snd) asList+ in go oids+ where+ go [] = Right ([], Nothing)+ go [oid] =+ case Map.lookup oid frags of+ Nothing -> Left "Failed to lookup a fragment"+ Just frag -> fragsToBottoms frags frag+ go (oid:oids) =+ case Map.lookup oid frags of+ Nothing -> Left "Failed to lookup a fragment"+ Just frag ->+ case fragsToBottoms frags frag of+ Left err -> Left err+ Right (completes, Nothing) ->+ case go oids of+ Left err -> Left err+ Right (nxtC, nxtE) ->+ Right (completes ++ nxtC, nxtE)+ _ ->+ Left "Got an Incomplete bottom in a non-terminal position"
− src/Data/StableTree/Fragment.hs
@@ -1,69 +0,0 @@-{-# LANGUAGE LambdaCase, OverloadedStrings, GADTs #-}--- |--- Module : Data.StableTree.Types--- Copyright : Jeremy Groven--- License : BSD3------ This is the implementation of tree fragments, which are stand-alone chunks--- of data representing each branch within a 'Data.StableTree.Types.Tree'. This--- module is also used by the Tree code for generating each branch's--- 'ObjectID'.-module Data.StableTree.Fragment-( Fragment(..)-) where--import Data.StableTree.Types ( Depth, ValueCount )--import qualified Data.Map as Map-import Control.Monad ( replicateM )-import Data.ObjectID ( ObjectID )-import Data.Serialize ( Serialize(..) )-import Control.Applicative ( (<$>) )-import Data.Serialize.Put ( Put, putByteString )-import Data.Serialize.Get ( Get, getByteString )-import Data.Map ( Map )---- |A 'Fragment' is a user-visible part of a tree, i.e. a single node in the--- tree that can actually be manipulated by a user. This is useful when doing--- the work of persisting trees.-data Fragment k v- = FragmentBranch- { fragmentDepth :: Depth- , fragmentChildren :: Map k (ValueCount, ObjectID)- }- | FragmentBottom- { fragmentMap :: Map k v- }- deriving( Eq, Ord, Show )--instance (Ord k, Serialize k, Serialize v) => Serialize (Fragment k v) where- put (FragmentBranch depth children) = fragPut depth children- put (FragmentBottom values) = fragPut 0 values-- get =- getByteString 12 >>= \case- "stable-tree\0" -> do- get >>= \case- 0 -> do- count <- get- children <- Map.fromList <$> replicateM count getPair- return $ FragmentBottom children- depth -> do- count <- get- children <- Map.fromList <$> replicateM count getPair- return $ FragmentBranch depth children- _ -> fail "Not a serialized Fragment"- where- getPair :: (Serialize k, Serialize v) => Get (k,v)- getPair = do- k <- get- v <- get- return (k,v)--fragPut :: (Serialize k, Serialize v) => Depth -> Map k v -> Put-fragPut depth items = do- putByteString "stable-tree\0"- put depth- put $ Map.size items- mapM_ (\(k,v) -> put k >> put v) (Map.toAscList items)-
+ src/Data/StableTree/Mutate.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE LambdaCase, GADTs #-}+module Data.StableTree.Mutate+( insert+, delete+, fmap+) where++import Data.StableTree.Types+import Data.StableTree.Build ( consume, consumeBranches', consumeMap, merge )+import Data.StableTree.Properties ( bottomChildren, selectNode )++import qualified Data.Map as Map+import Data.Map ( Map )+import Data.Serialize ( Serialize )++import qualified Prelude+import Prelude hiding ( fmap )++-- |Insert a key/value into a 'StableTree'. If the key exists, its existing+-- value is overwritten.+insert :: (Ord k, Serialize k, Serialize v)+ => k -> v -> StableTree k v -> StableTree k v+insert k v (StableTree_C c) = (uncurry consume) $ insert' k v c+insert k v (StableTree_I i) = (uncurry consume) $ insert' k v i++-- |Remove a key from the 'StableTree'. If the key is not found, the tree is+-- returned unchanged.+delete :: (Ord k, Serialize k, Serialize v)+ => k -> StableTree k v -> StableTree k v+delete k (StableTree_C c) = (uncurry consume) $ delete' k c+delete k (StableTree_I i) = (uncurry consume) $ delete' k i++-- |Same as 'insert', but works on a 'Tree', and returns a list of completes+-- and a maybe incomplete instead of returning something that probably can't be+-- expressed in Haskell's type system.+insert' :: (Ord k, Serialize k, Serialize v)+ => k+ -> v+ -> Tree d c k v+ -> ([Tree d Complete k v], Maybe (Tree d Incomplete k v))+insert' k v = mutateBottom k $ Map.insert k v++-- |Same as 'delete', but works on a 'Tree', and returns a list of completes+-- and a maybe incomplete instead of returning something that probably can't be+-- expressed in Haskell's type system.+delete' :: (Ord k, Serialize k, Serialize v)+ => k+ -> Tree d c k v+ -> ([Tree d Complete k v], Maybe (Tree d Incomplete k v))+delete' k = mutateBottom k $ Map.delete k++-- |Find the 'Tree Z' instance that should contain the given key, and call the+-- given function on its contents. Once that's done, splice the result back+-- into a new tree, which will probably be really similar to the original, but+-- have the desired changes applied.+mutateBottom :: (Ord k, Serialize k, Serialize v)+ => k+ -> (Map k v -> Map k v)+ -> Tree d c k v+ -> ([Tree d Complete k v], Maybe (Tree d Incomplete k v))+mutateBottom search_key mut_fn = \case+ bottom@(Bottom _ _ _ _ _) -> consumeMap $ mut_fn $ bottomChildren bottom+ bottom@(IBottom0 _ _) -> consumeMap $ mut_fn $ bottomChildren bottom+ bottom@(IBottom1 _ _ _ _) -> consumeMap $ mut_fn $ bottomChildren bottom+ branch@(Branch _ _ _ _ _ _) -> mutate search_key mut_fn branch+ branch@(IBranch0 _ _ _) -> mutate search_key mut_fn branch+ branch@(IBranch1 _ _ _ _) -> mutate search_key mut_fn branch+ branch@(IBranch2 _ _ _ _ _ _) -> mutate search_key mut_fn branch+ where++ mutate :: (Ord k, Serialize k, Serialize v)+ => k+ -> (Map k v -> Map k v)+ -> Tree (S d) c k v+ -> ([Tree (S d) Complete k v], Maybe (Tree (S d) Incomplete k v))+ mutate key fn b =+ case selectNode key b of+ (Left (before, incomplete)) ->+ let (mut_before, mut_minc) = mutateBottom key fn incomplete+ in consumeBranches' (before++mut_before) mut_minc+ (Right (before, tree, after, mincomplete)) ->+ let (mut_before, mut_minc) = mutateBottom key fn tree+ (merged_before, merged_minc) = merge (before++mut_before)+ mut_minc+ after+ mincomplete+ in consumeBranches' merged_before merged_minc++class SerialFunctor f where+ -- |Same as the 'fmap' instance of 'Functor', but with the restriction that+ -- the input and output of the mutation function must be 'Serialize'-able.+ -- Using the real instance would be really cool, but we need that Serialize+ -- instance.+ fmap :: (Serialize a, Serialize b) => (a -> b) -> f a -> f b++instance (Ord k, Serialize k) => SerialFunctor (Tree d c k) where+ fmap fn (Bottom _ (k1, v1) (k2, v2) nonterms (kt, vt)) =+ mkBottom (k1, fn v1) (k2, fn v2) (Map.map fn nonterms) (kt, fn vt)+ fmap fn (IBottom0 _ mpair) =+ mkIBottom0 (Prelude.fmap (\(k,v) -> (k, fn v)) mpair)+ fmap fn (IBottom1 _ (k1, v1) (k2, v2) nonterms) =+ mkIBottom1 (k1, fn v1) (k2, fn v2) (Map.map fn nonterms)+ fmap fn (Branch _ d (k1, c1, t1) (k2, c2, t2) nonterms (kt, ct, tt)) =+ mkBranch d+ (k1, c1, fmap fn t1)+ (k2, c2, fmap fn t2)+ (Map.map (\(c,t) -> (c, fmap fn t)) nonterms)+ (kt, ct, fmap fn tt)+ fmap fn (IBranch0 _ d (k1, c1, t1)) =+ mkIBranch0 d+ (k1, c1, fmap fn t1)+ fmap fn (IBranch1 _ d (k1, c1, t1) mtriple) =+ mkIBranch1 d+ (k1, c1, fmap fn t1)+ (Prelude.fmap (\(k, c, t) -> (k, c, fmap fn t)) mtriple)+ fmap fn (IBranch2 _ d (k1, c1, t1) (k2, c2, t2) nonterms mtriple) =+ mkIBranch2 d+ (k1, c1, fmap fn t1)+ (k2, c2, fmap fn t2)+ (Map.map (\(c, t) -> (c, fmap fn t)) nonterms)+ (Prelude.fmap (\(k, c, t) -> (k, c, fmap fn t)) mtriple)++instance (Ord k, Serialize k) => SerialFunctor (StableTree k) where+ fmap fn (StableTree_I i) = StableTree_I $ fmap fn i+ fmap fn (StableTree_C c) = StableTree_C $ fmap fn c+
src/Data/StableTree/Persist.hs view
@@ -5,22 +5,21 @@ -- License : BSD3 -- -- Logic for dealing with the actual persistence of Stable Trees. The key--- exports here are 'Error', 'Store', 'load', and 'store'. A user needs to--- implement the 'loadTree', 'loadValue', 'storeTree' and 'storeValue' parts of--- 'Store', and make an appropriate Error type to report storage errors, and--- then the 'load' and 'store' functions can just do their thing. If necessary,--- a user can also implement 'Serialize' for custom data types.+-- exports here are 'Error', 'load', and 'store'. A user needs to make an+-- appropriate Error type to report storage errors, and then the 'load' and+-- 'store' functions can just do their thing. If necessary, a user can also+-- implement 'Serialize' for custom data types. module Data.StableTree.Persist ( Error(..)-, load-, load'+, Fragment(..) , store , store'+, load+, load' ) where import Data.StableTree.Conversion ( toFragments, fromFragments )-import Data.StableTree.Fragment ( Fragment(..) )-import Data.StableTree.Tree ( StableTree(..) )+import Data.StableTree.Types ( StableTree(..), Fragment(..) ) import qualified Data.Map as Map import Data.ObjectID ( ObjectID )@@ -47,10 +46,7 @@ -> a -> StableTree k v -> m (Either e a)-store fn a0 tree =- case tree of- (StableTree_I i) -> go a0 $ toFragments i- (StableTree_C c) -> go a0 $ toFragments c+store fn a0 = go a0 . toFragments where go accum [] = return $ Right accum go accum ((fragid, frag):frags) =@@ -58,6 +54,8 @@ Left err -> return $ Left err Right accum' -> go accum' frags +-- |Alternate store function that acts more like a map than a fold. See 'store'+-- for details. store' :: (Monad m, Error e, Ord k) => (ObjectID -> Fragment k v -> m (Maybe e)) -> StableTree k v@@ -69,6 +67,9 @@ Nothing -> return $ Right oid Just err -> return $ Left err +-- |Reverse of 'store'. As with 'store', this acts like a fold, but converts an+-- 'ObjectID' into a tree, rather than storing a tree. This will always build+-- the tree from the top down. load :: (Monad m, Error e, Ord k, Serialize k, Serialize v) => (a -> ObjectID -> m (Either e (a, Fragment k v))) -> a@@ -85,10 +86,7 @@ Just frag -> case fromFragments frags frag of Left err -> return $ Left (stableTreeError err)- Right (Left t) ->- return $ Right (accum, StableTree_I t)- Right (Right t) ->- return $ Right (accum, StableTree_C t)+ Right t -> return $ Right (accum, t) where recur accum frags [] = return $ Right (accum, frags)@@ -101,6 +99,7 @@ oids = map snd $ Map.elems children in recur accum' (Map.insert oid frag frags) (oids ++ rest) +-- |Version of 'load' that acts like a map rather than a fold. load' :: (Monad m, Error e, Ord k, Serialize k, Serialize v) => (ObjectID -> m (Either e (Fragment k v))) -> ObjectID
+ src/Data/StableTree/Properties.hs view
@@ -0,0 +1,264 @@+{-# LANGUAGE GADTs #-}+-- |+-- Module : Data.StableTree+-- Copyright : Jeremy Groven+-- License : BSD3+--+-- Various functions for getting interested data about 'StableTree's and+-- 'Tree's.+module Data.StableTree.Properties+( getKey+, completeKey+, size+, lookup+, keys+, elems+, assocs+, treeContents+, toMap+, stableChildren+, bottomChildren+, branchChildren+, selectNode+) where++import qualified Data.StableTree.Key as Key+import Data.StableTree.Types++import qualified Data.Map as Map+import Control.Arrow ( second )+import Data.Map ( Map )++import Prelude hiding ( lookup )++-- |Get the key of the first entry in this branch. If the branch is empty,+-- returns Nothing.+getKey :: Tree d c k v -> Maybe k+getKey (Bottom _ (k,_) _ _ _) = Just $ Key.unwrap k+getKey (IBottom0 _ Nothing) = Nothing+getKey (IBottom0 _ (Just (k,_))) = Just $ Key.unwrap k+getKey (IBottom1 _ (k,_) _ _) = Just $ Key.unwrap k+getKey (Branch _ _ (k,_,_) _ _ _) = Just $ Key.unwrap k+getKey (IBranch0 _ _ (k,_,_)) = Just $ Key.unwrap k+getKey (IBranch1 _ _ (k,_,_) _) = Just $ Key.unwrap k+getKey (IBranch2 _ _ (k,_,_) _ _ _) = Just $ Key.unwrap k++-- |Get the key of the first entry in this complete branch. This function is+-- total.+completeKey :: Tree d Complete k v -> k+completeKey (Bottom _ (k,_) _ _ _) = Key.unwrap k+completeKey (Branch _ _ (k,_,_) _ _ _) = Key.unwrap k++-- |Get the total number of k/v pairs in the tree+size :: StableTree k v -> ValueCount+size = getValueCount++-- |Get the value associated with the given key, or Nothing if there is no+-- value for the key.+lookup :: Ord k => k -> StableTree k v -> Maybe v+lookup key tree =+ case tree of+ StableTree_I i -> lookup' key i+ StableTree_C c -> lookup' key c+ where+ lookup' :: Ord k => k -> Tree d c k v -> Maybe v+ lookup' k t =+ case t of+ Bottom _ _ _ _ _ -> Map.lookup k $ bottomChildren t+ IBottom0 _ _ -> Map.lookup k $ bottomChildren t+ IBottom1 _ _ _ _ -> Map.lookup k $ bottomChildren t+ Branch _ _ _ _ _ _ -> lookup'' k t+ IBranch0 _ _ _ -> lookup'' k t+ IBranch1 _ _ _ _ -> lookup'' k t+ IBranch2 _ _ _ _ _ _ -> lookup'' k t++ lookup'' :: Ord k => k -> Tree (S d) c k v -> Maybe v+ lookup'' k t =+ case selectNode k t of+ Left (_, inc) -> lookup' k inc+ Right (_, comp, _, _) -> lookup' k comp++-- |Get the keys in the map+keys :: Ord k => StableTree k v -> [k]+keys = map fst . assocs++-- |Get the elements stored in the map+elems :: Ord k => StableTree k v -> [v]+elems = map snd . assocs++-- |Get the key/value pairs in the map+assocs :: Ord k => StableTree k v -> [(k, v)]+assocs tree =+ case tree of+ StableTree_I i -> assocs' i+ StableTree_C c -> assocs' c+ where+ assocs' :: Ord k => Tree d c k v -> [(k, v)]+ assocs' t =+ case t of+ Bottom _ _ _ _ _ -> Map.assocs $ bottomChildren t+ IBottom0 _ _ -> Map.assocs $ bottomChildren t+ IBottom1 _ _ _ _ -> Map.assocs $ bottomChildren t+ Branch _ _ _ _ _ _ -> assocs'' t+ IBranch0 _ _ _ -> assocs'' t+ IBranch1 _ _ _ _ -> assocs'' t+ IBranch2 _ _ _ _ _ _ -> assocs'' t++ assocs'' :: Ord k => Tree (S d) c k v -> [(k, v)]+ assocs'' t =+ let (completes, mincomplete) = branchChildren t+ ckeys = concat [assocs' ct | (_, ct) <- Map.elems completes]+ ikeys = case mincomplete of+ Nothing -> []+ Just (_, _, it) -> assocs' it+ in ckeys ++ ikeys+++-- |Convert an entire Tree into a k/v map.+treeContents :: Ord k => Tree d c k v -> Map k v+treeContents t =+ case t of+ (Bottom _ _ _ _ _) -> bottomChildren t+ (IBottom0 _ _) -> bottomChildren t+ (IBottom1 _ _ _ _) -> bottomChildren t+ (Branch _ _ _ _ _ _) -> recur $ branchChildren t+ (IBranch0 _ _ _) -> recur $ branchChildren t+ (IBranch1 _ _ _ _) -> recur $ branchChildren t+ (IBranch2 _ _ _ _ _ _) -> recur $ branchChildren t++ where+ recur :: Ord k+ => ( Map k (ValueCount, Tree d Complete k v)+ , Maybe (k, ValueCount, Tree d Incomplete k v))+ -> Map k v+ recur x =+ case x of+ ( completes, Nothing) ->+ Map.unions $ map (treeContents . snd) $ Map.elems completes+ ( completes, Just (_k, _c, iv)) ->+ Map.unions $ treeContents iv:map (treeContents . snd) (Map.elems completes)++-- |Convert a 'StableTree' into a normal key/value Map+toMap :: Ord k => StableTree k v -> Map k v+toMap (StableTree_I i) = treeContents i+toMap (StableTree_C c) = treeContents c++-- |Either get the StableTree "children" of a 'StableTree', or get the+-- key/value map if the tree is already a bottom.+stableChildren :: Ord k+ => StableTree k v+ -> Either (Map k v) (Map k (ValueCount, StableTree k v))+stableChildren tree =+ case tree of+ StableTree_I i -> stableChildren' i+ StableTree_C c -> stableChildren' c+ where+ stableChildren' :: Ord k+ => Tree d c k v+ -> Either (Map k v) (Map k (ValueCount, StableTree k v))+ stableChildren' t =+ case t of+ (Bottom _ _ _ _ _) -> Left $ bottomChildren t+ (IBottom0 _ _) -> Left $ bottomChildren t+ (IBottom1 _ _ _ _) -> Left $ bottomChildren t+ (Branch _ _ _ _ _ _) -> Right $ branchChildren' t+ (IBranch0 _ _ _) -> Right $ branchChildren' t+ (IBranch1 _ _ _ _) -> Right $ branchChildren' t+ (IBranch2 _ _ _ _ _ _) -> Right $ branchChildren' t++ branchChildren' :: Ord k+ => Tree (S d) c k v+ -> Map k (ValueCount, StableTree k v)+ branchChildren' t =+ let (compMap, minc) = branchChildren t+ stableMap = Map.map (second StableTree_C) compMap+ fullMap = case minc of+ Nothing ->+ stableMap+ Just (k, c, i) ->+ Map.insert k (c, StableTree_I i) stableMap+ in fullMap++-- |Non-recursive function to simply get the immediate children of the given+-- branch. This will either give the key/value map of a Bottom, or the key/tree+-- map of a non-bottom branch.+bottomChildren :: Ord k+ => Tree Z c k v+ -> Map k v+bottomChildren (Bottom _ (k1,v1) (k2,v2) terms (kt,vt)) =+ let terms' = Map.mapKeys Key.fromKey terms+ conts = Map.insert (Key.unwrap k1) v1+ $ Map.insert (Key.unwrap k2) v2+ $ Map.insert (Key.fromKey kt) vt+ terms'+ in conts+bottomChildren (IBottom0 _ Nothing) =+ Map.empty+bottomChildren (IBottom0 _ (Just (k,v))) =+ Map.singleton (Key.unwrap k) v+bottomChildren (IBottom1 _ (k1,v1) (k2,v2) terms) =+ let terms' = Map.mapKeys Key.fromKey terms+ conts = Map.insert (Key.unwrap k1) v1+ $ Map.insert (Key.unwrap k2) v2+ terms'+ in conts++-- |Get the 'Tree's stored under the given Tree. The Tree type prevents this+-- function from being called on bottom Trees.+branchChildren :: Ord k+ => Tree (S d) c k v+ -> ( Map k (ValueCount, Tree d Complete k v)+ , Maybe (k, ValueCount, Tree d Incomplete k v))+branchChildren (Branch _ _d (k1,c1,v1) (k2,c2,v2) terms (kt,ct,vt)) =+ let terms' = Map.mapKeys Key.fromKey terms+ conts = Map.insert (Key.unwrap k1) (c1,v1)+ $ Map.insert (Key.unwrap k2) (c2,v2)+ $ Map.insert (Key.fromKey kt) (ct,vt)+ terms'+ in (conts, Nothing)+branchChildren (IBranch0 _ _d (ik,ic,iv)) =+ (Map.empty, Just (Key.unwrap ik, ic, iv))+branchChildren (IBranch1 _ _d (k1,c1,v1) mIncomplete) =+ ( Map.singleton (Key.unwrap k1) (c1,v1)+ , mIncomplete >>= (\(k,c,v) -> return (Key.unwrap k,c,v)))+branchChildren (IBranch2 _ _d (k1,c1,v1) (k2,c2,v2) terms mIncomplete) =+ let terms' = Map.mapKeys Key.fromKey terms+ conts = Map.insert (Key.unwrap k1) (c1,v1)+ $ Map.insert (Key.unwrap k2) (c2,v2)+ terms'+ in (conts, mIncomplete >>= \(k,c,v) -> return (Key.unwrap k, c, v))++-- |Choose the child node most likely to hold the given key. If this returns+-- Left, then the chosen node is the Incomplete node. In the Right case, the+-- sole Complete node is the best node. The Complete nodes in the first slot of+-- the quad are the nodes that came before the chosen node, while the nodes in+-- the third slot are the nodes that came after. This is useful for changing a+-- specific node, and then patching things back together with the+-- `Data.StableTree.Build.merge` function.+selectNode :: Ord k+ => k+ -> Tree (S d) c k v+ -> Either ( [Tree d Complete k v], Tree d Incomplete k v )+ ( [Tree d Complete k v], Tree d Complete k v+ , [Tree d Complete k v], Maybe (Tree d Incomplete k v) )+selectNode key branch =+ let (completes, minc) = branchChildren branch+ pairs = Map.toAscList completes+ minc_t = Prelude.fmap (\(_, _, t) -> t) minc+ test = \(k, _) -> k <= key+ -- begin_k is every tree whose lowest key is leq to the given key+ (begin_k, after_k) = span test pairs+ begin = [ t | (_, (_, t)) <- begin_k ]+ after = [ t | (_, (_, t)) <- after_k ]+ in case (reverse begin, after, minc) of+ ([], [], Nothing) -> -- empty branch+ error "this is totally unreachable. branches are _not_ empty"+ ([], [], Just (_, _, i)) -> -- only choice is the incomplete+ Left ([], i)+ (_, [], Just (k, _, t)) | k <= key -> -- key goes with the incomplete+ Left (begin, t)+ ([], t:rest, _) -> -- key is before everything+ Right ([], t, rest, minc_t)+ (t:rest, _, _) -> -- key goes with "t"+ Right (reverse rest, t, after, minc_t)+
− src/Data/StableTree/Tree.hs
@@ -1,502 +0,0 @@-{-# LANGUAGE LambdaCase, OverloadedStrings, GADTs #-}--- |--- Module : Data.StableTree.Tree--- Copyright : Jeremy Groven--- License : BSD3------ This is the core implementation of the stable tree. The primary functions--- exported by this module are 'nextBottom' and 'nextBranch', which gather--- values or lower-level 'Tree's into 'Tree's of the next level.------ This module is fairly esoteric. "Data.StableTree" or "Data.StableTree.IO"--- are probably what you actually want to be using.-module Data.StableTree.Tree-( StableTree(..)-, Tree-, Complete-, Incomplete-, nextBottom-, nextBranch-, getKey-, completeKey-, treeContents-, branchContents-, getObjectID-, getDepth-, getValueCount-) where--import qualified Data.StableTree.Key as Key-import Data.StableTree.Fragment ( Fragment(..) )-import Data.StableTree.Key ( SomeKey(..), Key, Terminal, Nonterminal )-import Data.StableTree.Types ( ValueCount, Depth )--import qualified Data.Map as Map-import Control.Arrow ( first, second )-import Data.List ( intercalate )-import Data.Map ( Map )-import Data.ObjectID ( ObjectID, calculateSerialize )-import Data.Serialize ( Serialize )---- | @StableTree@ is the user-visible type that wraps the actual 'Tree'--- implementation. All the public functions operate on this type.-data StableTree k v = StableTree_I (Tree Incomplete k v)- | StableTree_C (Tree Complete k v)---- |Used to indicate that a 'Tree' is not complete-data Incomplete ---- |Used to indicate that a 'Tree' is complete-data Complete ---- |The actual Rose Tree structure. StableTree is built on one main idea: every--- 'Key' is either 'Terminal' or 'Nonterminal'. A complete 'Tree' is one whose--- final element's Key is terminal, and the rest of the Keys are not (exept for--- two freebies at the beginning to guarantee convergence). A complete tree--- always has complete children.------ If we don't have enough data to generate a complete tree (i.e. we ran out of--- elements before hitting a terminal key), then an 'Incomplete' tree is--- generated. Incomplete trees are always contained by other incomplete trees,--- and a tree built from only the complete chlidren of an incomplete tree would--- never itself be complete.------ It is easiest to understand how this structure promotes stability by looking--- at how trees typically work. The easiest tree to understand is a simple,--- well balanced, binary tree. In that case, we would have a structure like this:------ @--- |D|--- |B| |F|--- |A| |C| |E| |G|--- @------ Now, suppose that we want to delete the data stored in @|A|@. Then, we'll--- get a new structure that shares nothing in common with the original one:------ @--- |E|--- |C| |G|--- |B| |D| |F|--- @------ The entire tree had to be re-written. This structure is clearly unstable--- under mutation. Making the tree wider doesn't help much if the tree's size--- is changing. Simple updates to existing keys are handled well by branches--- with many children, but deleting from or adding to the beginning of the tree--- will always cause every single branch to change, which is what this--- structure is trying to avoid.------ Instead, the stable tree branches have variable child counts. A branch is--- considered full when its highest key is "terminal", which is determined by--- hashing the key and looking at some bits of the hash. I've found that a--- target branch size of 16 children works fairly well, so we check to see if--- the hash has its least-significant four bits set; if that's the case, the--- key is terminal. A branch gets two free children (meaning it doesn't care--- about whether the keys are temrinal or not), and then a run of nonterminal--- keys, and a final, terminal key. Under this scheme, inserting a new entry--- into a branch will probably mean inserting a nonterminal key, and it will--- probably be inserted into the run of nonterminal children. If that's the--- case, no neighbors will be affected, and only the parents will have to--- change to point to the new branch. Stability is acheived!-data Tree c k v where- Bottom :: ObjectID- -> (SomeKey k, v)- -> (SomeKey k, v)- -> Map (Key Nonterminal k) v- -> (Key Terminal k, v)- -> Tree Complete k v-- Branch :: ObjectID- -> Depth- -> (SomeKey k, ValueCount, Tree Complete k v)- -> (SomeKey k, ValueCount, Tree Complete k v)- -> Map (Key Nonterminal k) (ValueCount, Tree Complete k v)- -> (Key Terminal k, ValueCount, Tree Complete k v)- -> Tree Complete k v-- -- Either an empty or a singleton tree- IBottom0 :: ObjectID- -> Maybe (SomeKey k, v)- -> Tree Incomplete k v-- -- Any number of items, but not ending with a terminal key- IBottom1 :: ObjectID- -> (SomeKey k, v)- -> (SomeKey k, v)- -> Map (Key Nonterminal k) v- -> Tree Incomplete k v-- -- A strut to lift an incomplete tree to the next level up- IBranch0 :: ObjectID- -> Depth- -> (SomeKey k, ValueCount, Tree Incomplete k v)- -> Tree Incomplete k v-- -- A joining of a single complete and maybe an incomplete- IBranch1 :: ObjectID- -> Depth- -> (SomeKey k, ValueCount, Tree Complete k v)- -> Maybe (SomeKey k, ValueCount, Tree Incomplete k v)- -> Tree Incomplete k v-- -- A branch that doesn't have a terminal, and that might have an IBranch- IBranch2 :: ObjectID- -> Depth- -> (SomeKey k, ValueCount, Tree Complete k v)- -> (SomeKey k, ValueCount, Tree Complete k v)- -> Map (Key Nonterminal k) (ValueCount, Tree Complete k v)- -> Maybe (SomeKey k, ValueCount, Tree Incomplete k v)- -> Tree Incomplete k v---- |Wrap up some of a k/v map into a 'Tree'. A 'Right' result gives a complete--- tree and the map updated to not have the key/values that went into that--- tree. A 'Left' result gives an incomplete tree that contains everything that--- the given map contained.-nextBottom :: (Ord k, Serialize k, Serialize v)- => Map k v- -> Either (Tree Incomplete k v)- (Tree Complete k v, Map k v)-nextBottom values =- case Map.minViewWithKey values >>= return . second Map.minViewWithKey of- Just (f1, Just (f2, remain)) ->- go (first Key.wrap f1) (first Key.wrap f2) Map.empty remain- partial ->- -- this is a bit odd, because I couldn't come up with a better way to tie- -- the type of the Nothing to the type of the Just, so that- -- iBottom0ObjectID would be satisfied.- let m = case partial of- Nothing -> Nothing- Just ((k,v), Nothing) -> Just (Key.wrap k, v)- _ ->- error "This is just here to satisfy a broken exhaustion check"- o = iBottom0ObjectID m- b = IBottom0 o m- in Left b-- where- go f1 f2 accum remain =- case Map.minViewWithKey remain of- Nothing ->- Left $ IBottom1 (iBottom1ObjectID f1 f2 accum) f1 f2 accum- Just ((k, v), remain') ->- case Key.wrap k of- SomeKey_N nonterm ->- go f1 f2 (Map.insert nonterm v accum) remain'- SomeKey_T term ->- let oid = bottomObjectID f1 f2 accum (term, v)- in Right (Bottom oid f1 f2 accum (term, v), remain')---- |Generate a parent for a k/Tree map. A 'Right' result gives a complete tree--- and the map updated to not have the key/trees that went into that tree. A--- 'Left' result gives an incomplete tree that contains everything that the--- given map contained.-nextBranch :: (Ord k, Serialize k, Serialize v)- => Map k (Tree Complete k v)- -> Maybe (k, Tree Incomplete k v)- -> Either (Tree Incomplete k v)- (Tree Complete k v, Map k (Tree Complete k v))-nextBranch branches mIncomplete =- let freebies = Map.minViewWithKey branches- >>= return . second Map.minViewWithKey- in case freebies of- Nothing -> - case mIncomplete of- Nothing ->- Left $ IBottom0 (iBottom0ObjectID (nothing branches)) Nothing- Just (ik, iv) ->- let tup = (Key.wrap ik, getValueCount iv, iv)- oid = iBranch0ObjectID depth tup- in Left $ IBranch0 oid depth tup- Just ((k,v), Nothing) ->- let tup = (Key.wrap k, getValueCount v, v)- may = wrapMKey mIncomplete- oid = iBranch1ObjectID depth tup may- in Left $ IBranch1 oid depth tup may- Just (f1, Just (f2, remain)) ->- go (wrapKey f1) (wrapKey f2) Map.empty remain-- where- go f1 f2 accum remain =- let popd = Map.minViewWithKey remain >>= return . first wrapKey- in case popd of- Nothing ->- let may = wrapMKey mIncomplete- oid = iBranch2ObjectID depth f1 f2 accum may- in Left $ IBranch2 oid depth f1 f2 accum may - Just ((SomeKey_T term,c,v), remain') ->- let tup = (term, c, v)- oid = branchObjectID depth f1 f2 accum tup- in Right ( Branch oid depth f1 f2 accum tup, remain' )- Just ((SomeKey_N nonterm,c,v), remain') ->- go f1 f2 (Map.insert nonterm (c,v) accum) remain'-- wrapKey (k,v) = (Key.wrap k, getValueCount v, v)-- wrapMKey = (>>=return . wrapKey)-- depth = case Map.elems branches of- [] ->- case mIncomplete of- Nothing -> 1- Just (_, v) -> 1 + getDepth v- elems ->- let depths@(f:r) = map getDepth elems- (best, rest) = case mIncomplete of- Nothing -> (f, r)- Just (_, v) -> (getDepth v, depths)- in if all (==best) rest- then 1 + best- else error "Depth mismatch in nextBranch"-- nothing :: Map k (Tree Complete k v) -> Maybe (SomeKey k, v)- nothing _ = Nothing---- |Get the key of the first entry in this branch. If the branch is empty,--- returns Nothing.-getKey :: Tree c k v -> Maybe k-getKey (Bottom _ (k,_) _ _ _) = Just $ Key.unwrap k-getKey (IBottom0 _ Nothing) = Nothing-getKey (IBottom0 _ (Just (k,_))) = Just $ Key.unwrap k-getKey (IBottom1 _ (k,_) _ _) = Just $ Key.unwrap k-getKey (Branch _ _ (k,_,_) _ _ _) = Just $ Key.unwrap k-getKey (IBranch0 _ _ (k,_,_)) = Just $ Key.unwrap k-getKey (IBranch1 _ _ (k,_,_) _) = Just $ Key.unwrap k-getKey (IBranch2 _ _ (k,_,_) _ _ _) = Just $ Key.unwrap k---- |Get the key of the fist entry in this complete branch. This function is--- total.-completeKey :: Tree Complete k v -> k-completeKey (Bottom _ (k,_) _ _ _) = Key.unwrap k-completeKey (Branch _ _ (k,_,_) _ _ _) = Key.unwrap k---- |Convert an entire Tree into a k/v map.-treeContents :: Ord k => Tree c k v -> Map k v-treeContents t =- case branchContents t of- Left ( completes, Nothing) ->- Map.unions $ map (treeContents . snd) $ Map.elems completes- Left ( completes, Just (_k, _c, iv)) ->- Map.unions $ treeContents iv:map (treeContents . snd) (Map.elems completes)- Right x -> x---- |Get the ObjectID of a tree node-getObjectID :: Tree c k v -> ObjectID-getObjectID (Bottom o _ _ _ _) = o-getObjectID (Branch o _ _ _ _ _) = o-getObjectID (IBottom0 o _) = o-getObjectID (IBottom1 o _ _ _) = o-getObjectID (IBranch0 o _ _) = o-getObjectID (IBranch1 o _ _ _) = o-getObjectID (IBranch2 o _ _ _ _ _) = o---- |Get the number of levels of branches that live below this one-getDepth :: Tree c k v -> Depth-getDepth (Bottom _ _ _ _ _) = 0-getDepth (Branch _ d _ _ _ _) = d-getDepth (IBottom0 _ _) = 0-getDepth (IBottom1 _ _ _ _) = 0-getDepth (IBranch0 _ d _) = d-getDepth (IBranch1 _ d _ _) = d-getDepth (IBranch2 _ d _ _ _ _) = d---- |Get the number of actual values that live below this branch-getValueCount :: Tree c k v -> ValueCount-getValueCount (Bottom _ _ _ m _) = 3 + Map.size m-getValueCount (IBottom0 _ Nothing) = 0-getValueCount (IBottom0 _ _) = 1-getValueCount (IBottom1 _ _ _ m) = 2 + Map.size m--getValueCount (Branch _ _ (_,c1,_) (_,c2,_) nterm (_,c3,_)) =- c1 + c2 + c3 + sum (map fst $ Map.elems nterm)-getValueCount (IBranch0 _ _ (_,c,_)) =- c-getValueCount (IBranch1 _ _ (_,c,_) Nothing) =- c-getValueCount (IBranch1 _ _ (_,c1,_) (Just (_,c2,_))) =- c1+c2-getValueCount (IBranch2 _ _ (_,c1,_) (_,c2,_) m i) =- c1 + c2 + sum (map fst $ Map.elems m) + maybe 0 (\(_,c3,_)->c3) i---- |Non-recursive function to simply get the immediate children of the given--- branch. This will either give the key/value map of a Bottom, or the key/tree--- map of a non-bottom branch.-branchContents :: Ord k- => Tree c k v- -> Either ( Map k (ValueCount, Tree Complete k v)- , Maybe (k, ValueCount, Tree Incomplete k v))- ( Map k v )-branchContents (Bottom _ (k1,v1) (k2,v2) terms (kt,vt)) =- let terms' = Map.mapKeys Key.fromKey terms- conts = Map.insert (Key.unwrap k1) v1- $ Map.insert (Key.unwrap k2) v2- $ Map.insert (Key.fromKey kt) vt- terms'- in Right conts-branchContents (Branch _ _d (k1,c1,v1) (k2,c2,v2) terms (kt,ct,vt)) =- let terms' = Map.mapKeys Key.fromKey terms- conts = Map.insert (Key.unwrap k1) (c1,v1)- $ Map.insert (Key.unwrap k2) (c2,v2)- $ Map.insert (Key.fromKey kt) (ct,vt)- terms'- in Left (conts, Nothing)-branchContents (IBottom0 _ Nothing) =- Right Map.empty-branchContents (IBottom0 _ (Just (k,v))) =- Right $ Map.singleton (Key.unwrap k) v-branchContents (IBottom1 _ (k1,v1) (k2,v2) terms) =- let terms' = Map.mapKeys Key.fromKey terms- conts = Map.insert (Key.unwrap k1) v1- $ Map.insert (Key.unwrap k2) v2- terms'- in Right conts-branchContents (IBranch0 _ _d (ik,ic,iv)) =- Left (Map.empty, Just (Key.unwrap ik, ic, iv))-branchContents (IBranch1 _ _d (k1,c1,v1) mIncomplete) =- Left ( Map.singleton (Key.unwrap k1) (c1,v1)- , mIncomplete >>= (\(k,c,v) -> return (Key.unwrap k,c,v)))-branchContents (IBranch2 _ _d (k1,c1,v1) (k2,c2,v2) terms mIncomplete) =- let terms' = Map.mapKeys Key.fromKey terms- conts = Map.insert (Key.unwrap k1) (c1,v1)- $ Map.insert (Key.unwrap k2) (c2,v2)- terms'- in Left (conts, mIncomplete >>= \(k,c,v) -> return (Key.unwrap k, c, v))--instance Eq (Tree c k v) where- t1 == t2 = getObjectID t1 == getObjectID t2--instance (Ord k, Show k, Show v) => Show (Tree c k v) where- show t@(Bottom _ _ _ _ _) = branchShow "Bottom" t- show t@(Branch _ _ _ _ _ _) = branchShow "Branch" t- show t@(IBottom0 _ _) = branchShow "IBottom" t- show t@(IBottom1 _ _ _ _) = branchShow "IBottom" t- show t@(IBranch0 _ _ _) = branchShow "IBranch" t- show t@(IBranch1 _ _ _ _) = branchShow "IBranch" t- show t@(IBranch2 _ _ _ _ _ _) = branchShow "IBranch" t--branchShow :: (Ord k, Show k, Show v) => String -> Tree c k v -> String-branchShow header t =- case branchContents t of- Left (ts, Nothing) ->- let strs = [show k ++ " => " ++ show v | (k, v) <- Map.toAscList ts]- str = intercalate ", " strs- in header ++ "(" ++ show (getDepth t) ++ ")<" ++ str ++ ">"- Left (ts, Just (ik, _ic, iv)) ->- let strs = [ show k ++ " => " ++ show v | (k, v) <- Map.toAscList ts- ] ++ [show ik ++ " => " ++ show iv]- str = intercalate ", " strs- in header ++ "(" ++ show (getDepth t) ++ ")<" ++ str ++ ">"- Right vals ->- let strs = [ show k ++ " => " ++ show v | (k, v) <- Map.toAscList vals ]- str = intercalate ", " strs- in header ++ "(" ++ show (getDepth t) ++ ")<" ++ str ++ ">"--bottomObjectID :: (Ord k, Serialize k, Serialize v)- => (SomeKey k, v)- -> (SomeKey k, v)- -> Map (Key Nonterminal k) v- -> (Key Terminal k, v)- -> ObjectID-bottomObjectID (sk1, v1) (sk2, v2) ntmap (tk3, v3) =- let m = Map.insert (Key.unwrap sk1) v1- $ Map.insert (Key.unwrap sk2) v2- $ Map.insert (Key.fromKey tk3) v3- $ Map.mapKeys Key.fromKey ntmap- in calculateSerialize $ FragmentBottom m--branchObjectID :: (Ord k, Serialize k, Serialize v)- => Depth- -> (SomeKey k, ValueCount, Tree Complete k v)- -> (SomeKey k, ValueCount, Tree Complete k v)- -> Map (Key Nonterminal k) (ValueCount, Tree Complete k v)- -> (Key Terminal k, ValueCount, Tree Complete k v)- -> ObjectID-branchObjectID d (sk1, c1, t1) (sk2, c2, t2) ntmap (tk3, c3, t3) =- let m = Map.insert (Key.unwrap sk1) (c1,getObjectID t1)- $ Map.insert (Key.unwrap sk2) (c2,getObjectID t2)- $ Map.insert (Key.fromKey tk3) (c3,getObjectID t3)- $ Map.map (second getObjectID)- $ Map.mapKeys Key.fromKey ntmap- b = FragmentBranch d m- _ = witness t1 b- in calculateSerialize b--iBottom0ObjectID :: (Ord k, Serialize k, Serialize v)- => Maybe (SomeKey k, v)- -> ObjectID-iBottom0ObjectID mkv =- let m = Map.empty- -- This funny dance ties the type of 'm' to the types of 'k' and 'v', so- -- our empty fragment bottom can type check- f = case mkv of- Nothing -> FragmentBottom m- Just (sk, v) -> FragmentBottom $ Map.insert (Key.unwrap sk) v m- in calculateSerialize f--iBottom1ObjectID :: (Ord k, Serialize k, Serialize v)- => (SomeKey k, v)- -> (SomeKey k, v)- -> Map (Key Nonterminal k) v- -> ObjectID-iBottom1ObjectID (sk1, v1) (sk2, v2) ntmap =- let m = Map.insert (Key.unwrap sk1) v1- $ Map.insert (Key.unwrap sk2) v2- $ Map.mapKeys Key.fromKey ntmap- b = FragmentBottom m- in calculateSerialize b--iBranch0ObjectID :: (Ord k, Serialize k, Serialize v)- => Depth- -> (SomeKey k, ValueCount, Tree Incomplete k v)- -> ObjectID-iBranch0ObjectID d (sk,c,t) =- let m = Map.singleton (Key.unwrap sk) (c, getObjectID t)- b = FragmentBranch d m- _ = witness t b- in calculateSerialize b--iBranch1ObjectID :: (Ord k, Serialize k, Serialize v)- => Depth- -> (SomeKey k, ValueCount, Tree Complete k v)- -> Maybe (SomeKey k, ValueCount, Tree Incomplete k v)- -> ObjectID-iBranch1ObjectID d (sk, c, t) minc =- let m = Map.singleton (Key.unwrap sk) (c, getObjectID t)- m' = case minc of- Nothing -> m- Just (sk', c', t') ->- Map.insert (Key.unwrap sk') (c', getObjectID t') m- b = FragmentBranch d m'- _ = witness t b- in calculateSerialize b--iBranch2ObjectID :: (Ord k, Serialize k, Serialize v)- => Depth- -> (SomeKey k, ValueCount, Tree Complete k v)- -> (SomeKey k, ValueCount, Tree Complete k v)- -> Map (Key Nonterminal k) (ValueCount, Tree Complete k v)- -> Maybe (SomeKey k, ValueCount, Tree Incomplete k v)- -> ObjectID-iBranch2ObjectID d (sk1, c1, t1) (sk2, c2, t2) ntmap minc =- let m = Map.insert (Key.unwrap sk1) (c1, getObjectID t1)- $ Map.insert (Key.unwrap sk2) (c2, getObjectID t2)- $ Map.mapKeys Key.fromKey- $ Map.map (second getObjectID) ntmap- m' = case minc of- Nothing -> m- Just (sk3, c3, t3) ->- Map.insert (Key.unwrap sk3) (c3, getObjectID t3) m- b = FragmentBranch d m'- _ = witness t1 b- in calculateSerialize b---- 'FragmentBranch' doesn't rely at all on the 'v' part of the given trees,--- as it only maps keys to ObjectIDs. This witness ties the fragment to the--- tree so the type checker can guarantee the 'Serialize v' instance that--- allows us to calculate the ObjectID.-witness :: Tree c k v -> Fragment k v -> ()-witness _ _ = ()--instance (Ord k, Show k, Show v) => Show (StableTree k v) where- show (StableTree_I t) = show t- show (StableTree_C t) = show t
src/Data/StableTree/Types.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE LambdaCase, OverloadedStrings, GADTs, ExistentialQuantification, StandaloneDeriving #-} -- | -- Module : Data.StableTree.Types -- Copyright : Jeremy Groven@@ -7,11 +8,406 @@ module Data.StableTree.Types ( Depth , ValueCount+, StableTree(..)+, Incomplete+, Complete+, Z+, S+, Tree(..)+, Fragment(..)+, mkBottom+, mkIBottom0+, mkIBottom1+, mkBranch+, mkIBranch0+, mkIBranch1+, mkIBranch2+, getObjectID+, getDepth+, getValueCount+, calcObjectID+, fixObjectID+, makeFragment ) where +import qualified Data.StableTree.Key as Key+import Data.StableTree.Key ( SomeKey(..), Key(..), Terminal, Nonterminal )++import qualified Data.Map as Map+import Control.Applicative ( (<$>) )+import Control.Arrow ( second )+import Control.Monad ( replicateM )+import Data.Serialize ( Serialize(..) )+import Data.Serialize.Put ( Put, putByteString )+import Data.Serialize.Get ( Get, getByteString )+import Data.ObjectID ( ObjectID, calculateSerialize )+import Data.Map ( Map )+ -- |Alias to indicate how deep a branch in a tree is. Bottoms have depth 0 type Depth = Int -- |Alias that indicates the total number of values underneath a tree type ValueCount = Int++-- | @StableTree@ is the user-visible type that wraps the actual 'Tree'+-- implementation. All the public functions operate on this type.+data StableTree k v = forall d. StableTree_I (Tree d Incomplete k v)+ | forall d. StableTree_C (Tree d Complete k v)++-- |Used to indicate that a 'Tree' is not complete+data Incomplete ++-- |Used to indicate that a 'Tree' is complete+data Complete ++-- |Empty type to indicate a Tree with Zero depth (a bottom node)+data Z++-- |Empty type to indicate a Tree with some known height (a branch)+data S a++-- |The actual B-Tree variant. StableTree is built on one main idea: every+-- 'Key' is either 'Terminal' or 'Nonterminal', and every 'Tree' is 'Complete'+-- or 'Incomplete'. A complete 'Tree' is one whose final element's Key is+-- terminal, and the rest of the Keys are not (exept for two freebies at the+-- beginning to guarantee convergence). A complete tree always has complete+-- children.+--+-- If we don't have enough data to generate a complete tree (i.e. we ran out of+-- elements before hitting a terminal key), then an 'Incomplete' tree is+-- generated. Incomplete trees are always contained by other incomplete trees,+-- and a tree built from only the complete children of an incomplete tree would+-- never itself be complete.+--+-- It is easiest to understand how this structure promotes stability by looking+-- at how trees typically work. The easiest tree to understand is a simple,+-- well balanced, binary tree. In that case, we would have a structure like this:+--+-- @+-- |D|+-- |B| |F|+-- |A| |C| |E| |G|+-- @+--+-- Now, suppose that we want to delete the data stored in @|A|@. Then, we'll+-- get a new structure that shares nothing in common with the original one:+--+-- @+-- |E|+-- |C| |G|+-- |B| |D| |F|+-- @+--+-- The entire tree had to be re-written. This structure is clearly unstable+-- under mutation. Making the tree wider doesn't help much if the tree's size+-- is changing. Simple updates to existing keys are handled well by branches+-- with many children, but deleting from or adding to the beginning of the tree+-- will always cause every single branch to change, which is what this+-- structure is trying to avoid.+--+-- Instead, the stable tree branches have variable child counts. A branch is+-- considered full when its highest key is "terminal", which is determined by+-- hashing the key and looking at some bits of the hash. I've found that a+-- target branch size of 16 children works fairly well, so we check to see if+-- the hash has its least-significant four bits set; if that's the case, the+-- key is terminal. A branch gets two free children (meaning it doesn't care+-- about whether the keys are terminal or not), and then a run of nonterminal+-- keys, and a final, terminal key. Under this scheme, inserting a new entry+-- into a branch will probably mean inserting a nonterminal key, and it will+-- probably be inserted into the run of nonterminal children. If that's the+-- case, no neighbors will be affected, and only the parents will have to+-- change to point to the new branch. Stability is achieved!+data Tree d c k v where+ Bottom :: ObjectID+ -> (SomeKey k, v)+ -> (SomeKey k, v)+ -> Map (Key Nonterminal k) v+ -> (Key Terminal k, v)+ -> Tree Z Complete k v++ -- Either an empty or a singleton tree+ IBottom0 :: ObjectID+ -> Maybe (SomeKey k, v)+ -> Tree Z Incomplete k v++ -- Any number of items, but not ending with a terminal key+ IBottom1 :: ObjectID+ -> (SomeKey k, v)+ -> (SomeKey k, v)+ -> Map (Key Nonterminal k) v+ -> Tree Z Incomplete k v++ Branch :: ObjectID+ -> Depth+ -> (SomeKey k, ValueCount, Tree d Complete k v)+ -> (SomeKey k, ValueCount, Tree d Complete k v)+ -> Map (Key Nonterminal k) (ValueCount, Tree d Complete k v)+ -> (Key Terminal k, ValueCount, Tree d Complete k v)+ -> Tree (S d) Complete k v++ -- A strut to lift an incomplete tree to the next level up+ IBranch0 :: ObjectID+ -> Depth+ -> (SomeKey k, ValueCount, Tree d Incomplete k v)+ -> Tree (S d) Incomplete k v++ -- A joining of a single complete and maybe an incomplete+ IBranch1 :: ObjectID+ -> Depth+ -> (SomeKey k, ValueCount, Tree d Complete k v)+ -> Maybe (SomeKey k, ValueCount, Tree d Incomplete k v)+ -> Tree (S d) Incomplete k v++ -- A branch that doesn't have a terminal, and that might have an IBranch+ IBranch2 :: ObjectID+ -> Depth+ -> (SomeKey k, ValueCount, Tree d Complete k v)+ -> (SomeKey k, ValueCount, Tree d Complete k v)+ -> Map (Key Nonterminal k) (ValueCount, Tree d Complete k v)+ -> Maybe (SomeKey k, ValueCount, Tree d Incomplete k v)+ -> Tree (S d) Incomplete k v++-- |Helper to create a 'Bottom' instance with a calculated ObjectID+mkBottom :: (Ord k, Serialize k, Serialize v)+ => (SomeKey k, v) -> (SomeKey k, v) -> Map (Key Nonterminal k) v+ -> (Key Terminal k, v) -> Tree Z Complete k v+mkBottom p1 p2 nts t = fixObjectID $ Bottom undefined p1 p2 nts t++-- |Helper to create an 'IBottom0' instance with a calculated ObjectID+mkIBottom0 :: (Ord k, Serialize k, Serialize v)+ => Maybe (SomeKey k, v) -> Tree Z Incomplete k v+mkIBottom0 mp = fixObjectID $ IBottom0 undefined mp++-- |Helper to create an 'IBottom1' instance with a calculated ObjectID+mkIBottom1 :: (Ord k, Serialize k, Serialize v)+ => (SomeKey k, v) -> (SomeKey k, v) -> Map (Key Nonterminal k) v+ -> Tree Z Incomplete k v+mkIBottom1 p1 p2 nts = fixObjectID $ IBottom1 undefined p1 p2 nts++-- |Helper to create a 'Branch' instance with a calculated ObjectID+mkBranch :: (Ord k, Serialize k, Serialize v)+ => Depth+ -> (SomeKey k, ValueCount, Tree d Complete k v)+ -> (SomeKey k, ValueCount, Tree d Complete k v)+ -> Map (Key Nonterminal k) (ValueCount, Tree d Complete k v)+ -> (Key Terminal k, ValueCount, Tree d Complete k v)+ -> Tree (S d) Complete k v+mkBranch d t1 t2 nts t = fixObjectID $ Branch undefined d t1 t2 nts t++-- |Helper to create an 'IBranch0' instance with a calculated ObjectID+mkIBranch0 :: (Ord k, Serialize k, Serialize v)+ => Depth+ -> (SomeKey k, ValueCount, Tree d Incomplete k v)+ -> Tree (S d) Incomplete k v+mkIBranch0 d inc = fixObjectID $ IBranch0 undefined d inc++-- |Helper to create an 'IBranch1' instance with a calculated ObjectID+mkIBranch1 :: (Ord k, Serialize k, Serialize v)+ => Depth+ -> (SomeKey k, ValueCount, Tree d Complete k v)+ -> Maybe (SomeKey k, ValueCount, Tree d Incomplete k v)+ -> Tree (S d) Incomplete k v+mkIBranch1 d tup minc = fixObjectID $ IBranch1 undefined d tup minc++-- |Helper to create an 'IBranch2' instance with a calculated ObjectID+mkIBranch2 :: (Ord k, Serialize k, Serialize v)+ => Depth+ -> (SomeKey k, ValueCount, Tree d Complete k v)+ -> (SomeKey k, ValueCount, Tree d Complete k v)+ -> Map (Key Nonterminal k) (ValueCount, Tree d Complete k v)+ -> Maybe (SomeKey k, ValueCount, Tree d Incomplete k v)+ -> Tree (S d) Incomplete k v+mkIBranch2 d t1 t2 nts minc = fixObjectID $ IBranch2 undefined d t1 t2 nts minc++-- |A 'Fragment' is a user-visible part of a tree, i.e. a single node in the+-- tree that can actually be manipulated by a user. This is useful when doing+-- the work of persisting trees, and its serialize instance is also used to+-- calculate Tree ObjectIDs. See `Data.StableTree.Conversion.toFragments` and+-- `Data.StableTree.Conversion.fromFragments` for functions to convert between+-- Fragments and Trees. see `Data.StableTree.Persist.store` and+-- `Data.StableTree.Persist.load` for functions related to storing and+-- retrieving Fragments.+data Fragment k v+ = FragmentBranch+ { fragmentDepth :: Depth+ , fragmentChildren :: Map k (ValueCount, ObjectID)+ }+ | FragmentBottom+ { fragmentMap :: Map k v+ }+ deriving( Eq, Ord, Show )++class TreeNode n where+ -- |Get the ObjectID of a 'Tree' or 'StableTree'+ getObjectID :: n k v -> ObjectID+ -- |Get the depth (height?) of a 'Tree' or 'StableTree'+ getDepth :: n k v -> Depth+ -- |Get the total number of key/value pairs stored under this 'Tree' or+ -- 'StableTree'+ getValueCount :: n k v -> ValueCount+ -- |Do the (expensive) calculation of a 'Tree' or 'StableTree'; generally+ -- used to do the initial ObjectID calculation when constructing an instance+ calcObjectID :: (Ord k, Serialize k, Serialize v) => n k v -> ObjectID+ -- |Recalculate the object's ObjectID and return the updated object;+ -- pretty much a convenience function around 'calcObjectID'+ fixObjectID :: (Ord k, Serialize k, Serialize v) => n k v -> n k v+ -- |Get the 'Fragment' representing this exact 'Tree' node, used for+ -- persistent storage+ makeFragment :: Ord k => n k v -> Fragment k v+ -- getFullContents :: n k v -> Map k v++instance TreeNode (Tree d c) where+ getObjectID (Bottom o _ _ _ _) = o+ getObjectID (IBottom0 o _) = o+ getObjectID (IBottom1 o _ _ _) = o+ getObjectID (Branch o _ _ _ _ _) = o+ getObjectID (IBranch0 o _ _) = o+ getObjectID (IBranch1 o _ _ _) = o+ getObjectID (IBranch2 o _ _ _ _ _) = o++ getDepth (Bottom _ _ _ _ _) = 0+ getDepth (IBottom0 _ _) = 0+ getDepth (IBottom1 _ _ _ _) = 0+ getDepth (Branch _ d _ _ _ _) = d+ getDepth (IBranch0 _ d _) = d+ getDepth (IBranch1 _ d _ _) = d+ getDepth (IBranch2 _ d _ _ _ _) = d++ getValueCount (Bottom _ _ _ m _) = 3 + Map.size m+ getValueCount (IBottom0 _ Nothing) = 0+ getValueCount (IBottom0 _ _) = 1+ getValueCount (IBottom1 _ _ _ m) = 2 + Map.size m+ + getValueCount (Branch _ _ (_,c1,_) (_,c2,_) nterm (_,c3,_)) =+ c1 + c2 + c3 + sum (map fst $ Map.elems nterm)+ getValueCount (IBranch0 _ _ (_,c,_)) =+ c+ getValueCount (IBranch1 _ _ (_,c,_) Nothing) =+ c+ getValueCount (IBranch1 _ _ (_,c1,_) (Just (_,c2,_))) =+ c1+c2+ getValueCount (IBranch2 _ _ (_,c1,_) (_,c2,_) m i) =+ c1 + c2 + sum (map fst $ Map.elems m) + maybe 0 (\(_,c3,_)->c3) i++ calcObjectID tree = calculateSerialize $ makeFragment tree++ fixObjectID t@(Bottom _ a b c d) = Bottom (calcObjectID t) a b c d+ fixObjectID t@(IBottom0 _ a) = IBottom0 (calcObjectID t) a+ fixObjectID t@(IBottom1 _ a b c) = IBottom1 (calcObjectID t) a b c+ fixObjectID t@(Branch _ a b c d e) = Branch (calcObjectID t) a b c d e+ fixObjectID t@(IBranch0 _ a b) = IBranch0 (calcObjectID t) a b+ fixObjectID t@(IBranch1 _ a b c) = IBranch1 (calcObjectID t) a b c+ fixObjectID t@(IBranch2 _ a b c d e) = IBranch2 (calcObjectID t) a b c d e++ makeFragment tree =+ case tree of+ (Bottom _ p1 p2 m pt) ->+ fragBottom p1 p2 m (Just pt)+ (IBottom0 _ Nothing) ->+ FragmentBottom Map.empty+ (IBottom0 _ (Just (k1,v1))) ->+ FragmentBottom $ Map.singleton (Key.unwrap k1) v1+ (IBottom1 _ p1 p2 m) ->+ fragBottom p1 p2 m Nothing+ (Branch _ d (k1,c1,t1) (k2,c2,t2) m (kt,ct,tt)) ->+ let cont = Map.insert (Key.unwrap k1) (c1,getObjectID t1)+ $ Map.insert (Key.unwrap k2) (c2,getObjectID t2)+ $ Map.insert (fromKey kt) (ct,getObjectID tt)+ $ Map.mapKeys fromKey+ $ Map.map (second getObjectID) m+ in FragmentBranch d cont+ (IBranch0 _ d (k,c,t)) ->+ FragmentBranch d $ Map.singleton (Key.unwrap k) (c,getObjectID t)+ (IBranch1 _ d (k,c,t) Nothing) ->+ FragmentBranch d $ Map.singleton (Key.unwrap k) (c,getObjectID t)+ (IBranch1 _ d (k,c,t) (Just (ki,ci,ti))) ->+ let cont = Map.fromList [ (Key.unwrap k, (c, getObjectID t))+ , (Key.unwrap ki, (ci, getObjectID ti)) ]+ in FragmentBranch d cont+ (IBranch2 _ d (k1,c1,t1) (k2,c2,t2) m minc) ->+ let cont = Map.insert (Key.unwrap k1) (c1,getObjectID t1)+ $ Map.insert (Key.unwrap k2) (c2,getObjectID t2)+ $ Map.mapKeys fromKey+ $ Map.map (second getObjectID) m+ cont' = case minc of+ Nothing -> cont+ (Just (ki,ci,ti)) ->+ Map.insert (Key.unwrap ki) (ci, getObjectID ti) cont+ in FragmentBranch d cont'+ where+ fragBottom (k1,v1) (k2,v2) mapping mterm =+ let cont = Map.insert (Key.unwrap k1) v1+ $ Map.insert (Key.unwrap k2) v2+ $ Map.mapKeys fromKey mapping+ cont' = case mterm of+ Nothing -> cont+ (Just (tk, tv)) -> Map.insert (fromKey tk) tv cont+ in FragmentBottom cont'++instance TreeNode StableTree where+ getObjectID (StableTree_I t) = getObjectID t+ getObjectID (StableTree_C t) = getObjectID t++ getDepth (StableTree_I t) = getDepth t+ getDepth (StableTree_C t) = getDepth t++ getValueCount (StableTree_I t) = getValueCount t+ getValueCount (StableTree_C t) = getValueCount t++ calcObjectID (StableTree_I t) = calcObjectID t+ calcObjectID (StableTree_C t) = calcObjectID t++ fixObjectID (StableTree_I t) = StableTree_I $ fixObjectID t+ fixObjectID (StableTree_C t) = StableTree_C $ fixObjectID t++ makeFragment (StableTree_I t) = makeFragment t+ makeFragment (StableTree_C t) = makeFragment t++instance Eq (Tree d c k v) where+ t1 == t2 = getObjectID t1 == getObjectID t2++instance Eq (StableTree k v) where+ (StableTree_I t1) == (StableTree_I t2) = getObjectID t1 == getObjectID t2+ (StableTree_C t1) == (StableTree_C t2) = getObjectID t1 == getObjectID t2+ (StableTree_I _) == (StableTree_C _) = False+ (StableTree_C _) == (StableTree_I _) = False++instance Ord (StableTree k v) where+ compare l r = compare (getObjectID l) (getObjectID r)++deriving instance (Ord k, Show k, Show v) => Show (StableTree k v)+deriving instance (Ord k, Show k, Show v) => Show (Tree d c k v)++instance (Ord k, Serialize k, Serialize v) => Serialize (Fragment k v) where+ put frag =+ case frag of+ (FragmentBranch depth children) -> fragPut depth children+ (FragmentBottom values) -> fragPut 0 values+ where+ fragPut :: (Serialize k, Serialize v) => Depth -> Map k v -> Put+ fragPut depth items = do+ putByteString "stable-tree\0"+ put depth+ put $ Map.size items+ mapM_ (\(k,v) -> put k >> put v) (Map.toAscList items)++ get =+ getByteString 12 >>= \case+ "stable-tree\0" -> do+ get >>= \case+ 0 -> do+ count <- get+ children <- Map.fromList <$> replicateM count getPair+ return $ FragmentBottom children+ depth -> do+ count <- get+ children <- Map.fromList <$> replicateM count getPair+ return $ FragmentBranch depth children+ _ -> fail "Not a serialized Fragment"+ where+ getPair :: (Serialize k, Serialize v) => Get (k,v)+ getPair = do+ k <- get+ v <- get+ return (k,v)
stable-tree.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: stable-tree-version: 0.5.0+version: 0.6.0 synopsis: Trees whose branches are resistant to change -- description: homepage: https://github.com/tsuraan/stable-tree@@ -30,11 +30,12 @@ library exposed-modules: Data.StableTree- , Data.StableTree.Conversion- , Data.StableTree.Fragment , Data.StableTree.Types+ , Data.StableTree.Properties , Data.StableTree.Key- , Data.StableTree.Tree+ , Data.StableTree.Conversion+ , Data.StableTree.Build+ , Data.StableTree.Mutate , Data.StableTree.Persist -- other-modules: -- other-extensions: @@ -68,4 +69,4 @@ , tasty-quickcheck hs-source-dirs: tests default-language: Haskell2010- ghc-options: -Wall+ ghc-options: -O2 -Wall -threaded
tests/TestAll.hs view
@@ -4,10 +4,14 @@ ) where import qualified Data.StableTree as ST-import Data.StableTree ( Fragment, Error(..) )+import qualified Data.StableTree.Persist as SP+import Data.StableTree ( StableTree )+import Data.StableTree.Persist ( Fragment(..), Error(..) ) import qualified Data.Map as Map+import qualified Data.Set as Set import Control.Arrow ( first )+import Control.Applicative ( (<$>) ) import Control.Monad.State.Strict ( State, runState, modify, gets ) import Data.ByteString ( ByteString ) import Data.ByteString.Arbitrary ( ArbByteString(..) )@@ -16,8 +20,13 @@ import Data.Serialize ( Serialize, encode, decode ) import Data.Text ( Text ) import Test.Tasty-import Test.Tasty.QuickCheck ( testProperty )+import Test.Tasty.QuickCheck ( Arbitrary, testProperty, oneof, arbitrary )+import Test.QuickCheck ( Gen, elements ) +-- import Debug.Trace ( trace )+-- trace :: a -> b -> b+-- trace _ b = b+ main :: IO () main = defaultMain $ testGroup "StableTree"@@ -34,24 +43,98 @@ ] where - int_int :: [(Int,Int)] -> Bool+ int_int :: [(Int,Int)] -> Gen Bool int_int pairs = let m = Map.fromList pairs st = ST.fromMap m- in m == ST.toMap st+ in if m == ST.toMap st && Map.keys m == ST.keys st && Map.elems m == ST.elems st+ then do+ and <$> sequence [ test_delete pairs+ , return $ test_lookup (Map.toList m) st+ , test_insert pairs+ , test_mutate st ]+ else return False - float_int :: [(Float,Int)] -> Bool+ float_int :: [(Float,Int)] -> Gen Bool float_int pairs = let m = Map.fromList pairs st = ST.fromMap m- in m == ST.toMap st+ in if m == ST.toMap st && Map.keys m == ST.keys st && Map.elems m == ST.elems st+ then do+ and <$> sequence [ test_delete pairs+ , return $ test_lookup (Map.toList m) st+ , test_insert pairs+ , test_mutate st ]+ else return False - bytestring_int :: [(ArbByteString,Int)] -> Bool+ bytestring_int :: [(ArbByteString,Int)] -> Gen Bool bytestring_int pairs =- let m = Map.fromList $ map (first fromABS) pairs+ let p' = map (first fromABS) pairs+ m = Map.fromList p' st = ST.fromMap m- in m == ST.toMap st+ in if m == ST.toMap st && Map.keys m == ST.keys st && Map.elems m == ST.elems st+ then do+ and <$> sequence [ test_delete p'+ , return $ test_lookup (Map.toList m) st+ , test_insert p' ]+ else return False + test_lookup :: (Ord k, Show k, Eq v, Show v) => [(k,v)] -> StableTree k v -> Bool+ test_lookup [] _ = True+ test_lookup ((k,v):rest) t =+ case ST.lookup k t of+ Just v' | v' == v -> test_lookup rest t+ _ -> False++ test_delete :: (Show k, Ord k, Serialize k, Show v, Serialize v)+ => [(k,v)]+ -> Gen Bool+ test_delete [] = return True+ test_delete kvs = do+ delkey <- elements (map fst kvs)+ let m = Map.fromList kvs+ m' = Map.delete delkey m+ s = ST.fromMap m+ s' = ST.delete delkey s+ return (s' == ST.fromMap m')++ test_insert :: (Show k, Ord k, Serialize k, Show v, Serialize v)+ => [(k,v)]+ -> Gen Bool+ test_insert [] = return True+ test_insert kvs = do+ (inskey, insval) <- elements kvs+ let kvs' = [(k,v) | (k,v) <- kvs, k /= inskey]+ m = Map.fromList kvs'+ m' = Map.insert inskey insval m+ s = ST.fromMap m+ s' = ST.insert inskey insval s+ return (s' == ST.fromMap m')++ test_mutate :: (Arbitrary k, Show k, Ord k, Serialize k, Arbitrary v, Show v, Serialize v)+ => StableTree k v+ -> Gen Bool+ test_mutate tree | ST.size tree == 0 = return True+ test_mutate tree = mutate (10::Int) (Set.fromList $ ST.keys tree) tree tree+ where+ mutate 0 _ reference accum = return $ reference == accum+ mutate n keys ref accum = do+ accum' <- oneof [insert, delete]+ mutate (n-1) keys ref accum'+ where+ insert = do+ key <- arbitrary+ if Set.member key keys+ then insert+ else do+ val <- arbitrary+ return $ ST.delete key $ ST.insert key val accum++ delete = do+ key <- elements $ ST.keys accum+ let Just val = ST.lookup key accum+ return $ ST.insert key val $ ST.delete key accum+ store_int_int :: [(Int,Int)] -> Bool store_int_int = action @@ -67,8 +150,8 @@ go = do let m = Map.fromList pairs st = ST.fromMap m- Right tid <- ST.store' store st- Right st' <- ST.load' load tid+ Right tid <- SP.store' store st+ Right st' <- SP.load' load tid return $ m == ST.toMap st' -- |Error type for RAM storage. Not a lot can go wrong in RAM...@@ -97,4 +180,5 @@ case decode fragBS of Left err -> return $ Left $ SerializationError err Right frag -> return $ Right frag+