stable-tree 0.6.1 → 0.7.0
raw patch · 11 files changed
+549/−470 lines, 11 files
Files
- src/Data/StableTree.hs +1/−2
- src/Data/StableTree/Build.hs +46/−47
- src/Data/StableTree/Conversion.hs +135/−21
- src/Data/StableTree/Key.hs +138/−10
- src/Data/StableTree/Mutate.hs +23/−58
- src/Data/StableTree/Persist.hs +11/−10
- src/Data/StableTree/Properties.hs +47/−47
- src/Data/StableTree/Types.hs +114/−246
- src/Data/StableTree/Walk.hs +21/−21
- stable-tree.cabal +2/−2
- tests/TestAll.hs +11/−6
src/Data/StableTree.hs view
@@ -25,14 +25,13 @@ , keys , elems , assocs-, fmap , append , concat , toMap ) where import Data.StableTree.Build ( fromMap, empty, append, concat )-import Data.StableTree.Mutate ( insert, delete, fmap )+import Data.StableTree.Mutate ( insert, delete ) import Data.StableTree.Properties ( toMap, size, lookup, keys, elems, assocs ) import Data.StableTree.Types ( StableTree )
src/Data/StableTree/Build.hs view
@@ -27,7 +27,7 @@ import qualified Data.StableTree.Key as Key import qualified Data.StableTree.Properties as Properties-import Data.StableTree.Key ( SomeKey(..), fromKey, unwrap )+import Data.StableTree.Key ( StableKey, SomeKey(..), fromKey, unwrap ) import Data.StableTree.Types import qualified Data.Map as Map@@ -36,48 +36,47 @@ 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 :: (Ord k, StableKey k) => 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 :: (Ord k, StableKey k) => 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)+append :: (Ord k, StableKey k) => 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)+concat :: (Ord k, StableKey k) => [StableTree k v] -> StableTree k v concat = go [] [] where- go :: (Ord k, Serialize k, Serialize v)+ go :: (Ord k, StableKey k) => [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+ 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+ 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)+ branch :: (Ord k, StableKey k) => Tree (S d) c k v -> [Tree Z Complete k v] -> [Tree Z Incomplete k v]@@ -92,7 +91,7 @@ -- |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)+consume :: (Ord k, StableKey k) => [Tree d Complete k v] -> Maybe (Tree d Incomplete k v) -> StableTree k v@@ -119,7 +118,7 @@ -- 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)+consumeMap :: (Ord k, StableKey k) => Map k v -> ([Tree Z Complete k v], Maybe (Tree Z Incomplete k v)) consumeMap = go []@@ -138,7 +137,7 @@ -- 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)+consumeBranches :: (Ord k, StableKey k) => 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))@@ -156,7 +155,7 @@ -- |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)+consumeBranches' :: (Ord k, StableKey k) => [Tree d Complete k v] -> Maybe (Tree d Incomplete k v) -> ([Tree (S d) Complete k v], Maybe (Tree (S d) Incomplete k v))@@ -174,7 +173,7 @@ -- 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)+nextBottom :: (Ord k, StableKey k) => Map k v -> Either (Tree Z Incomplete k v) (Tree Z Complete k v, Map k v)@@ -191,20 +190,20 @@ Just ((k,v), Nothing) -> Just (Key.wrap k, v) _ -> error "This is just here to satisfy a broken exhaustion check"- b = mkIBottom0 m+ b = IBottom0 m in Left b where go f1 f2 accum remain = case Map.minViewWithKey remain of Nothing ->- Left $ mkIBottom1 f1 f2 accum+ Left $ IBottom1 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')+ Right (Bottom f1 f2 accum (term, v), remain') -- | Result of the 'nextBranch' function; values are described below. data NextBranch d k v@@ -217,7 +216,7 @@ -- '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)+nextBranch :: (Ord k, StableKey k) => Map k (Tree d Complete k v) -> Maybe (k, Tree d Incomplete k v) -> NextBranch d k v@@ -231,12 +230,12 @@ Empty Just (ik, iv) -> let tup = (Key.wrap ik, getValueCount iv, iv)- b = mkIBranch0 depth tup+ b = IBranch0 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+ in Final $ IBranch1 depth tup may Just (f1, Just (f2, remain)) -> go (wrapKey f1) (wrapKey f2) Map.empty remain @@ -246,10 +245,10 @@ in case popd of Nothing -> let may = wrapMKey mIncomplete- in Final $ mkIBranch2 depth f1 f2 accum may + in Final $ IBranch2 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'+ in More (Branch depth f1 f2 accum tup) remain' Just ((SomeKey_N nonterm,c,v), remain') -> go f1 f2 (Map.insert nonterm (c,v) accum) remain' @@ -277,7 +276,7 @@ -- 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)+merge :: (Ord k, StableKey k) => [Tree d Complete k v] -> Maybe (Tree d Incomplete k v) -> [Tree d Complete k v]@@ -289,11 +288,11 @@ (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+ (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 =@@ -302,7 +301,7 @@ (after, minc) = consumeMap (Map.union lc rc) in (b ++ after, minc) - branch :: (Ord k, Serialize k, Serialize v)+ branch :: (Ord k, StableKey k) => [Tree (S d) Complete k v] -> Tree (S d) Incomplete k v -> Tree (S d) Incomplete k v@@ -327,13 +326,13 @@ 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+ (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)+ bottom :: (Ord k, StableKey k) => [Tree Z Complete k v] -> Tree Z Incomplete k v -> Tree Z Complete k v@@ -347,7 +346,7 @@ (comp, Nothing) -> (b++comp++r, m) (comp, justinc) -> merge (b++comp) justinc r m - branch :: (Ord k, Serialize k, Serialize v)+ branch :: (Ord k, StableKey k) => [Tree (S d) Complete k v] -> Tree (S d) Incomplete k v -> Tree (S d) Complete k v@@ -373,7 +372,7 @@ (newcomp, newminc) = consumeBranches lcomp' linc' in merge (b ++ newcomp) newminc r m -concat' :: (Ord k, Serialize k, Serialize v)+concat' :: (Ord k, StableKey k) => [Tree Z Complete k v] -> [Tree Z Incomplete k v] -> StableTree k v@@ -430,14 +429,14 @@ sort' = sortBy (comparing (\(a,b,_) -> (a,b))) completeEnd :: Tree Z Complete k v -> k- completeEnd (Bottom _ _ _ _ (tk, _tv)) = fromKey tk+ completeEnd (Bottom _ _ _ (tk, _tv)) = fromKey tk getEnd :: Tree Z Incomplete k v -> Maybe k- getEnd (IBottom0 _ Nothing) =+ getEnd (IBottom0 Nothing) = Nothing- getEnd (IBottom0 _ (Just (sk, _v))) =+ getEnd (IBottom0 (Just (sk, _v))) = Just $ unwrap sk- getEnd (IBottom1 _ _ (sk, _v) ntmap) =+ getEnd (IBottom1 _ (sk, _v) ntmap) = case Map.toDescList ntmap of [] -> Just $ unwrap sk (k,_v):_ -> Just $ fromKey k
src/Data/StableTree/Conversion.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings, LambdaCase, GADTs #-} -- | -- Module : Data.StableTree.Conversion -- Copyright : Jeremy Groven@@ -6,41 +6,103 @@ -- -- Functions for converting between `Tree` and `Fragment` types module Data.StableTree.Conversion-( toFragments+( Fragment(..)+, toFragments , fromFragments , fragsToMap ) where -import Data.StableTree.Properties ( stableChildren )+import Data.StableTree.Properties ( bottomChildren, branchChildren ) import Data.StableTree.Build ( consume, consumeMap )+import Data.StableTree.Key ( StableKey ) import Data.StableTree.Types import qualified Data.Map as Map import qualified Data.Text as Text-import Data.Map ( Map )-import Data.ObjectID ( ObjectID )-import Data.Serialize ( Serialize )-import Data.Text ( Text )+import Control.Applicative ( (<$>) )+import Control.Monad ( replicateM )+import Data.Map ( Map )+import Data.ObjectID ( ObjectID, calculateSerialize )+import Data.Serialize ( Serialize, get, put )+import Data.Serialize.Get ( Get, getByteString )+import Data.Serialize.Put ( Put, putByteString )+import Data.Text ( Text ) +-- |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. 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+ { fragmentObjectID :: ObjectID+ , fragmentDepth :: Depth+ , fragmentChildren :: Map k (ValueCount, ObjectID)+ }+ | FragmentBottom+ { fragmentObjectID :: ObjectID+ , fragmentMap :: Map k v+ }+ deriving( Eq, Ord, Show )+ -- |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 =- 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)]+toFragments :: (Ord k, Serialize k, StableKey k, Serialize v)+ => StableTree k v -> [Fragment k v]+toFragments (StableTree_I i) = snd $ toFragments' i+toFragments (StableTree_C c) = snd $ toFragments' c +-- |Convert a 'Tree' into 'Fragment's. This returns a pair, where the first+-- element is the 'Fragment' that came directly from the 'Tree', and the second+-- element is the list of all the 'Fragment's beneath the 'Tree', and the+-- 'Tree's fragment itself. The list is always sorted lowest to highest, so its+-- last element is always the same entity as the first element of the pair. +toFragments' :: (Ord k, Serialize k, StableKey k, Serialize v)+ => Tree d c k v -> (Fragment k v, [Fragment k v])+toFragments' b@(Bottom{}) = bottomToFragments b+toFragments' b@(IBottom0{}) = bottomToFragments b+toFragments' b@(IBottom1{}) = bottomToFragments b+toFragments' b@(Branch{}) = branchToFragments b+toFragments' b@(IBranch0{}) = branchToFragments b+toFragments' b@(IBranch1{}) = branchToFragments b+toFragments' b@(IBranch2{}) = branchToFragments b++-- |Make a Bottom element into a FragmentBottom. Always returns+-- (fragment, [fragment])+bottomToFragments :: (Ord k, Serialize k, StableKey k, Serialize v)+ => Tree Z c k v -> (Fragment k v, [Fragment k v])+bottomToFragments tree =+ let children = bottomChildren tree+ frag = fixFragmentID $ FragmentBottom undefined children+ in (frag, [frag])++-- |Make a Branch into a bunch of Fragments+branchToFragments :: (Ord k, Serialize k, StableKey k, Serialize v)+ => Tree (S d) c k v -> (Fragment k v, [Fragment k v])+branchToFragments tree =+ let (completes, mInc) = branchChildren tree+ compFrags = Map.map (\(v, t) -> (v, toFragments' t)) completes+ allFrags = case mInc of+ Nothing ->+ compFrags+ Just (k, v, t) ->+ Map.insert k (v, toFragments' t) compFrags+ getChildPair = \(v, (f, _)) -> (v, fragmentObjectID f)+ children = Map.map getChildPair allFrags+ cumulative = concat $ map (snd . snd) $ Map.elems allFrags+ depth = getDepth tree+ frag = fixFragmentID $ FragmentBranch undefined depth children+ in (frag, cumulative ++ [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)+fromFragments :: (Ord k, Serialize k, StableKey k, Serialize v) => Map ObjectID (Fragment k v) -> Fragment k v -> Either Text (StableTree k v)@@ -57,8 +119,8 @@ -> Either Text (Map k v) fragsToMap loaded = go Map.empty where- go accum (FragmentBottom m) = Right $ Map.union accum m- go accum (FragmentBranch _ children) =+ go accum (FragmentBottom _ m) = Right $ Map.union accum m+ go accum (FragmentBranch _ _ children) = go' accum $ map snd $ Map.elems children go' accum [] = Right accum@@ -77,12 +139,12 @@ -- 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)+fragsToBottoms :: (Ord k, Serialize k, StableKey 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 _ (FragmentBottom _ m) = Right $ consumeMap m fragsToBottoms frags top = let content = fragmentChildren top asList = Map.toAscList content@@ -107,4 +169,56 @@ Right (completes ++ nxtC, nxtE) _ -> Left "Got an Incomplete bottom in a non-terminal position"++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" ->+ get >>= \case+ 0 -> do+ count <- get+ children <- Map.fromList <$> replicateM count getPair+ -- Having to create a broken fragment, serialize it, and then+ -- calculate that bytestring's ObjectID is gross, when we already+ -- have the serialized form of the fragment, but I have no idea how+ -- to access the underlying bytestring. This should be correct, but+ -- it's not very efficient.+ return $ fixFragmentID $ FragmentBottom undefined children+ depth -> do+ count <- get+ children <- Map.fromList <$> replicateM count getPair+ return $ fixFragmentID $ FragmentBranch undefined 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)++-- |Calculate the 'Fragment's 'ObjectID', and patch it into place. This is+-- generally used to create a 'Fragment', like so:+--+-- @+-- fixFragmentID $ FragmentBottom undefined foo+-- fixFragmentID $ FragmentBranch undefined foo bar+-- @+fixFragmentID :: (Ord k, Serialize k, Serialize v)+ => Fragment k v -> Fragment k v+fixFragmentID frag@(FragmentBottom _ children) =+ FragmentBottom (calculateSerialize frag) children+fixFragmentID frag@(FragmentBranch _ depth children) =+ FragmentBranch (calculateSerialize frag) depth children
src/Data/StableTree/Key.hs view
@@ -1,5 +1,5 @@ -- |--- Module : Data.StableTree.Types.Key+-- Module : Data.StableTree.Key -- Copyright : Jeremy Groven -- License : BSD3 --@@ -7,17 +7,28 @@ module Data.StableTree.Key ( Key(fromKey) , SomeKey(..)+, StableKey(..) , Terminal , Nonterminal , wrap , unwrap+, hashBs ) where +import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString as BS-import Data.Serialize ( Serialize, encode ) import Data.Bits ( (.&.), shiftR, xor ) import Data.ByteString ( ByteString )-import Data.Word ( Word8, Word64 )+import Data.Int ( Int8, Int16, Int32, Int64 )+import Data.IntMap ( IntMap )+import Data.IntSet ( IntSet )+import Data.Map ( Map )+import Data.Ratio ( Ratio )+import Data.Sequence ( Seq )+import Data.Serialize ( Serialize, encode )+import Data.Set ( Set )+import Data.Tree ( Tree )+import Data.Word ( Word, Word8, Word16, Word32, Word64 ) -- |Used to indicate that a 'Key' is terminal data Terminal@@ -34,10 +45,16 @@ | SomeKey_N (Key Nonterminal k) deriving ( Eq, Ord, Show ) +-- |Type class for 'StableTree' keys+class StableKey k where+ -- |Get the "hash" of a key; this is just a single-byte, of which only four+ -- bits are really used. Just enough to allow one key in 16 to be 'Terminal'+ hash :: k -> Word8+ -- |Do the magic of wrapping up a key into a 'SomeKey'-wrap :: Serialize k => k -> SomeKey k+wrap :: StableKey k => k -> SomeKey k wrap k =- let w8 = byte k+ let w8 = hash k x = w8 `xor` (w8 `shiftR` 4) w4 = x .&. 0xf in if w4 == 0xf@@ -49,11 +66,122 @@ unwrap (SomeKey_T (Key k)) = k unwrap (SomeKey_N (Key k)) = k --- |Calculate a single-byte hash for a 'Serialize'-byte :: Serialize t => t -> Word8-byte val =- let bs = encode val- fnv = fnv1a bs+instance StableKey Bool where+ hash = hashBs . encode++instance StableKey Char where+ hash = hashBs . encode++instance StableKey Double where+ hash = hashBs . encode++instance StableKey Float where+ hash = hashBs . encode++instance StableKey Int where+ hash = hashBs . encode++instance StableKey Int8 where+ hash = hashBs . encode++instance StableKey Int16 where+ hash = hashBs . encode++instance StableKey Int32 where+ hash = hashBs . encode++instance StableKey Int64 where+ hash = hashBs . encode++instance StableKey Integer where+ hash = hashBs . encode++instance StableKey Ordering where+ hash = hashBs . encode++instance StableKey Word where+ hash = hashBs . encode++instance StableKey Word8 where+ hash = hashBs . encode++instance StableKey Word16 where+ hash = hashBs . encode++instance StableKey Word32 where+ hash = hashBs . encode++instance StableKey Word64 where+ hash = hashBs . encode++instance StableKey ByteString where+ hash = hashBs . encode++instance StableKey LBS.ByteString where+ hash = hashBs . encode++instance StableKey IntSet where+ hash = hashBs . encode++instance Serialize a => StableKey [a] where+ hash = hashBs . encode++instance (Serialize a, Integral a) => StableKey (Ratio a) where+ hash = hashBs . encode++instance Serialize a => StableKey (Maybe a) where+ hash = hashBs . encode++instance Serialize e => StableKey (IntMap e) where+ hash = hashBs . encode++instance (Ord a, Serialize a) => StableKey (Set a) where+ hash = hashBs . encode++instance Serialize e => StableKey (Tree e) where+ hash = hashBs . encode++instance Serialize e => StableKey (Seq e) where+ hash = hashBs . encode++instance (Serialize a, Serialize b) => StableKey (Either a b) where+ hash = hashBs . encode++instance (Serialize a, Serialize b) => StableKey (a, b) where+ hash = hashBs . encode++instance (Ord k, Serialize k, Serialize e) => StableKey (Map k e) where+ hash = hashBs . encode++instance (Serialize a, Serialize b, Serialize c) => StableKey (a, b, c) where+ hash = hashBs . encode++instance (Serialize a, Serialize b, Serialize c, Serialize d) => StableKey (a, b, c, d) where+ hash = hashBs . encode++instance (Serialize a, Serialize b, Serialize c, Serialize d, Serialize e) => StableKey (a, b, c, d, e) where+ hash = hashBs . encode++instance (Serialize a, Serialize b, Serialize c, Serialize d, Serialize e, Serialize f) => StableKey (a, b, c, d, e, f) where+ hash = hashBs . encode++instance (Serialize a, Serialize b, Serialize c, Serialize d, Serialize e, Serialize f, Serialize g) => StableKey (a, b, c, d, e, f, g) where+ hash = hashBs . encode++instance (Serialize a, Serialize b, Serialize c, Serialize d, Serialize e, Serialize f, Serialize g, Serialize h) => StableKey (a, b, c, d, e, f, g, h) where+ hash = hashBs . encode++instance (Serialize a, Serialize b, Serialize c, Serialize d, Serialize e, Serialize f, Serialize g, Serialize h, Serialize i) => StableKey (a, b, c, d, e, f, g, h, i) where+ hash = hashBs . encode++instance (Serialize a, Serialize b, Serialize c, Serialize d, Serialize e, Serialize f, Serialize g, Serialize h, Serialize i, Serialize j) => StableKey (a, b, c, d, e, f, g, h, i, j) where+ hash = hashBs . encode+++-- |Calculate a single-byte hash for a 'ByteString'+hashBs :: ByteString -> Word8+hashBs bs =+ let fnv = fnv1a bs w32 = fnv `xor` (fnv `shiftR` 32) w16 = w32 `xor` (w32 `shiftR` 16) w8 = w16 `xor` (w16 `shiftR` 8)
src/Data/StableTree/Mutate.hs view
@@ -1,31 +1,34 @@ {-# LANGUAGE LambdaCase, GADTs #-}+-- |+-- Module : Data.StableTree+-- Copyright : Jeremy Groven+-- License : BSD3+--+-- Functions for "updating" StableTrees, in the functional sense. This covers+-- insertion, deletion, etc. module Data.StableTree.Mutate ( insert , delete-, fmap ) where -import Data.StableTree.Types import Data.StableTree.Build ( consume, consumeBranches', consumeMap, merge )+import Data.StableTree.Key ( StableKey ) import Data.StableTree.Properties ( bottomChildren, selectNode )+import Data.StableTree.Types import qualified Data.Map as Map-import Data.Map ( Map )-import Data.Serialize ( Serialize )--import qualified Prelude-import Prelude hiding ( fmap )+import Data.Map ( Map ) -- |Insert a key/value into a 'StableTree'. If the key exists, its existing -- value is overwritten.-insert :: (Ord k, Serialize k, Serialize v)+insert :: (Ord k, StableKey k) => 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)+delete :: (Ord k, StableKey k) => 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@@ -33,7 +36,7 @@ -- |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)+insert' :: (Ord k, StableKey k) => k -> v -> Tree d c k v@@ -43,7 +46,7 @@ -- |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)+delete' :: (Ord k, StableKey k) => k -> Tree d c k v -> ([Tree d Complete k v], Maybe (Tree d Incomplete k v))@@ -53,22 +56,22 @@ -- 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)+mutateBottom :: (Ord k, StableKey k) => 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+ 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)+ mutate :: (Ord k, StableKey k) => k -> (Map k v -> Map k v) -> Tree (S d) c k v@@ -85,42 +88,4 @@ 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
@@ -18,12 +18,13 @@ , load' ) where -import Data.StableTree.Conversion ( toFragments, fromFragments )-import Data.StableTree.Types ( StableTree(..), Fragment(..) )+import Data.StableTree.Conversion ( Fragment(..), toFragments, fromFragments )+import Data.StableTree.Key ( StableKey )+import Data.StableTree.Types ( StableTree(..) ) import qualified Data.Map as Map import Data.ObjectID ( ObjectID )-import Data.Serialize ( Serialize(..) )+import Data.Serialize ( Serialize ) import Data.Text ( Text ) -- |Things go wrong with end-user storage, but things can also go wrong with@@ -41,7 +42,7 @@ -- be given to the fold only after all their children have been given to the -- fold. Exact ordering beyond that is not guaranteed, but the current -- behaviour is post-order depth-first traversal.-store :: (Monad m, Error e, Ord k)+store :: (Monad m, Error e, Ord k, Serialize k, StableKey k, Serialize v) => (a -> ObjectID -> Fragment k v -> m (Either e a)) -> a -> StableTree k v@@ -49,14 +50,14 @@ store fn a0 = go a0 . toFragments where go accum [] = return $ Right accum- go accum ((fragid, frag):frags) =- fn accum fragid frag >>= \case+ go accum (frag:frags) =+ fn accum (fragmentObjectID frag) frag >>= \case 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)+store' :: (Monad m, Error e, Ord k, Serialize k, StableKey k, Serialize v) => (ObjectID -> Fragment k v -> m (Maybe e)) -> StableTree k v -> m (Either e ObjectID)@@ -70,7 +71,7 @@ -- |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)+load :: (Monad m, Error e, Ord k, Serialize k, StableKey k, Serialize v) => (a -> ObjectID -> m (Either e (a, Fragment k v))) -> a -> ObjectID@@ -92,7 +93,7 @@ recur accum frags [] = return $ Right (accum, frags) recur accum frags (oid:rest) = fn accum oid >>= \case Left err -> return $ Left err- Right (accum', frag@(FragmentBottom _)) ->+ Right (accum', frag@(FragmentBottom{})) -> recur accum' (Map.insert oid frag frags) rest Right (accum', frag) -> let children = fragmentChildren frag@@ -100,7 +101,7 @@ 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)+load' :: (Monad m, Error e, Ord k, Serialize k, StableKey k, Serialize v) => (ObjectID -> m (Either e (Fragment k v))) -> ObjectID -> m (Either e (StableTree k v))
src/Data/StableTree/Properties.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE GADTs #-} -- |--- Module : Data.StableTree+-- Module : Data.StableTree.Properties -- Copyright : Jeremy Groven -- License : BSD3 --@@ -34,20 +34,20 @@ -- |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+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+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@@ -64,13 +64,13 @@ 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+ 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 =@@ -96,13 +96,13 @@ 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+ 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 =@@ -118,13 +118,13 @@ 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+ (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@@ -158,13 +158,13 @@ -> 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+ (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@@ -185,18 +185,18 @@ bottomChildren :: Ord k => Tree Z c k v -> Map k v-bottomChildren (Bottom _ (k1,v1) (k2,v2) terms (kt,vt)) =+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) =+bottomChildren (IBottom0 Nothing) = Map.empty-bottomChildren (IBottom0 _ (Just (k,v))) =+bottomChildren (IBottom0 (Just (k,v))) = Map.singleton (Key.unwrap k) v-bottomChildren (IBottom1 _ (k1,v1) (k2,v2) terms) =+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@@ -209,19 +209,19 @@ => 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)) =+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)) =+branchChildren (IBranch0 _d (ik,ic,iv)) = (Map.empty, Just (Key.unwrap ik, ic, iv))-branchChildren (IBranch1 _ _d (k1,c1,v1) mIncomplete) =+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) =+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)
src/Data/StableTree/Types.hs view
@@ -14,33 +14,14 @@ , 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.StableTree.Key as Key+import Data.StableTree.Key ( StableKey, 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@@ -118,27 +99,23 @@ -- 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)+ Bottom :: (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)+ IBottom0 :: 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)+ IBottom1 :: (SomeKey k, v) -> (SomeKey k, v) -> Map (Key Nonterminal k) v -> Tree Z Incomplete k v - Branch :: ObjectID- -> Depth+ Branch :: 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)@@ -146,268 +123,159 @@ -> Tree (S d) Complete k v -- A strut to lift an incomplete tree to the next level up- IBranch0 :: ObjectID- -> Depth+ IBranch0 :: 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+ IBranch1 :: 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+ IBranch2 :: 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+ 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 (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,_)) =+ getValueCount (Branch _ (_,c1,_) (_,c2,_) nterm (_,c3,_)) = c1 + c2 + c3 + sum (map fst $ Map.elems nterm)- getValueCount (IBranch0 _ _ (_,c,_)) =+ getValueCount (IBranch0 _ (_,c,_)) = c- getValueCount (IBranch1 _ _ (_,c,_) Nothing) =+ getValueCount (IBranch1 _ (_,c,_) Nothing) = c- getValueCount (IBranch1 _ _ (_,c1,_) (Just (_,c2,_))) =+ getValueCount (IBranch1 _ (_,c1,_) (Just (_,c2,_))) = c1+c2- getValueCount (IBranch2 _ _ (_,c1,_) (_,c2,_) m i) =+ 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+instance (Eq k, Eq v) => Eq (Tree d c k v) where+ (Bottom lp1 lp2 lnts lt) == (Bottom rp1 rp2 rnts rt) =+ (lp1 == rp1) && (lp2 == rp2) && (lnts == rnts) && (lt == rt)+ (IBottom0 l) == (IBottom0 r) = l == r+ (IBottom1 lp1 lp2 lnts) == (IBottom1 rp1 rp2 rnts) = + (lp1 == rp1) && (lp2 == rp2) && (lnts == rnts) - makeFragment (StableTree_I t) = makeFragment t- makeFragment (StableTree_C t) = makeFragment t+ -- We _could_ check the depth parameter as well, but that's also in the type+ -- signature, so why bother?+ (Branch _ lt1 lt2 lnts lt) == (Branch _ rt1 rt2 rnts rt) =+ (lt1 == rt1) && (lt2 == rt2) && (lnts == rnts) && (lt == rt)+ (IBranch0 _ lt) == (IBranch0 _ rt) = lt == rt+ (IBranch1 _ lt li) == (IBranch1 _ rt ri) = (lt == rt) && (li == ri)+ (IBranch2 _ lt1 lt2 lnts li) == (IBranch2 _ rt1 rt2 rnts ri) =+ (lt1 == rt1) && (lt2 == rt2) && (lnts == rnts) && (li == ri)+ _ == _ = False -instance Eq (Tree d c k v) where- t1 == t2 = getObjectID t1 == getObjectID t2+instance (Eq k, Eq v) => Eq (StableTree k v) where+ (StableTree_I t1) == (StableTree_I t2) = t1 `equals` t2+ (StableTree_C t1) == (StableTree_C t2) = t1 `equals` t2+ _ == _ = False -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+equals :: (Eq k, Eq v) => Tree d1 c1 k v -> Tree d2 c2 k v -> Bool+equals l@(Bottom{}) r@(Bottom{}) = l == r+equals l@(IBottom0{}) r@(IBottom0{}) = l == r+equals l@(IBottom1{}) r@(IBottom1{}) = l == r+equals (Branch ld (lk1, lv1, lt1) (lk2, lv2, lt2) lnts (lkt, lvt, ltt))+ (Branch rd (rk1, rv1, rt1) (rk2, rv2, rt2) rnts (rkt, rvt, rtt)) =+ (ld == rd) &&+ (lk1 == rk1) && (lk2 == rk2) && (lkt == rkt) &&+ (lv1 == rv1) && (lv2 == rv2) && (lvt == rvt) &&+ (lt1 `equals` rt1) && (lt2 `equals` rt2) && (ltt `equals` rtt) &&+ (ntEquals lnts rnts)+equals (IBranch0 ld (lk, lv, lt)) (IBranch0 rd (rk, rv, rt)) =+ (ld == rd) && (lk == rk) && (lv == rv) && (lt `equals` rt)+equals (IBranch1 ld (lk, lv, lt) Nothing) (IBranch1 rd (rk, rv, rt) Nothing) =+ (ld == rd) && (lk == rk) && (lv == rv) && (lt `equals` rt)+equals (IBranch1 ld (lk, lv, lt) (Just (lki, lvi, lti)))+ (IBranch1 rd (rk, rv, rt) (Just (rki, rvi, rti))) =+ (ld == rd) && (lk == rk) && (lv == rv) && (lki == rki) && (lvi == rvi) &&+ (lt `equals` rt) && (lti `equals` rti)+equals (IBranch2 ld (lk1, lv1, lt1) (lk2, lv2, lt2) lnts Nothing)+ (IBranch2 rd (rk1, rv1, rt1) (rk2, rv2, rt2) rnts Nothing) =+ (ld == rd) &&+ (lk1 == rk1) && (lk2 == rk2) && (lv1 == rv1) && (lv2 == rv2) &&+ (lt1 `equals` rt1) && (lt2 `equals` rt2) && (ntEquals lnts rnts)+equals (IBranch2 ld (lk1, lv1, lt1) (lk2, lv2, lt2) lnts (Just (lki, lvi, lti)))+ (IBranch2 rd (rk1, rv1, rt1) (rk2, rv2, rt2) rnts (Just (rki, rvi, rti))) =+ (ld == rd) &&+ (lk1 == rk1) && (lk2 == rk2) && (lv1 == rv1) && (lv2 == rv2) &&+ (lki == rki) && (lvi == rvi) && (lti `equals` rti) &&+ (lt1 `equals` rt1) && (lt2 `equals` rt2) && (ntEquals lnts rnts)+equals _ _ = False -instance Ord (StableTree k v) where- compare l r = compare (getObjectID l) (getObjectID r)+ntEquals :: (Eq k, Eq v)+ => Map (Key Nonterminal k) (ValueCount, Tree d1 Complete k v)+ -> Map (Key Nonterminal k) (ValueCount, Tree d2 Complete k v)+ -> Bool+ntEquals lnts rnts =+ (Map.keys lnts == Map.keys rnts) &&+ (map fst (Map.elems lnts) == map fst (Map.elems rnts)) &&+ (all (==True) (zipWith (\l r -> (snd l) `equals` (snd r))+ (Map.elems lnts)+ (Map.elems rnts))) 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)+instance (Ord k, StableKey k) => Functor (Tree d c k) where+ fmap fn (Bottom (k1, v1) (k2, v2) nonterms (kt, vt)) =+ Bottom (k1, fn v1) (k2, fn v2) (Map.map fn nonterms) (kt, fn vt)+ fmap fn (IBottom0 mpair) =+ IBottom0 (Prelude.fmap (\(k,v) -> (k, fn v)) mpair)+ fmap fn (IBottom1 (k1, v1) (k2, v2) nonterms) =+ IBottom1 (k1, fn v1) (k2, fn v2) (Map.map fn nonterms)+ fmap fn (Branch d (k1, c1, t1) (k2, c2, t2) nonterms (kt, ct, tt)) =+ Branch 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)) =+ IBranch0 d+ (k1, c1, fmap fn t1)+ fmap fn (IBranch1 d (k1, c1, t1) mtriple) =+ IBranch1 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) =+ IBranch2 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) - 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)+instance (Ord k, StableKey k) => Functor (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/Walk.hs view
@@ -34,13 +34,13 @@ => (a -> k -> v -> m a) -> a -> Tree d c k v -> m a foldM' f accum t = case t of- Bottom _ _ _ _ _ -> bottom f accum t- IBottom0 _ _ -> bottom f accum t- IBottom1 _ _ _ _ -> bottom f accum t- Branch _ _ _ _ _ _ -> branch f accum t- IBranch0 _ _ _ -> branch f accum t- IBranch1 _ _ _ _ -> branch f accum t- IBranch2 _ _ _ _ _ _ -> branch f accum t+ Bottom _ _ _ _ -> bottom f accum t+ IBottom0 _ -> bottom f accum t+ IBottom1 _ _ _ -> bottom f accum t+ Branch _ _ _ _ _ -> branch f accum t+ IBranch0 _ _ -> branch f accum t+ IBranch1 _ _ _ -> branch f accum t+ IBranch2 _ _ _ _ _ -> branch f accum t bottom :: (Monad m, Ord k) => (a -> k -> v -> m a) -> a -> Tree Z c k v -> m a@@ -70,13 +70,13 @@ foldr' :: Ord k => (k -> v -> a -> a) -> a -> Tree d c k v -> a foldr' f accum t = case t of- Bottom _ _ _ _ _ -> bottom f accum t- IBottom0 _ _ -> bottom f accum t- IBottom1 _ _ _ _ -> bottom f accum t- Branch _ _ _ _ _ _ -> branch f accum t- IBranch0 _ _ _ -> branch f accum t- IBranch1 _ _ _ _ -> branch f accum t- IBranch2 _ _ _ _ _ _ -> branch f accum t+ Bottom _ _ _ _ -> bottom f accum t+ IBottom0 _ -> bottom f accum t+ IBottom1 _ _ _ -> bottom f accum t+ Branch _ _ _ _ _ -> branch f accum t+ IBranch0 _ _ -> branch f accum t+ IBranch1 _ _ _ -> branch f accum t+ IBranch2 _ _ _ _ _ -> branch f accum t bottom :: Ord k => (k -> v -> a -> a) -> a -> Tree Z c k v -> a bottom f accum t =@@ -105,13 +105,13 @@ foldl' :: Ord k => (a -> k -> v -> a) -> a -> Tree d c k v -> a foldl' f accum t = case t of- Bottom _ _ _ _ _ -> bottom f accum t- IBottom0 _ _ -> bottom f accum t- IBottom1 _ _ _ _ -> bottom f accum t- Branch _ _ _ _ _ _ -> branch f accum t- IBranch0 _ _ _ -> branch f accum t- IBranch1 _ _ _ _ -> branch f accum t- IBranch2 _ _ _ _ _ _ -> branch f accum t+ Bottom _ _ _ _ -> bottom f accum t+ IBottom0 _ -> bottom f accum t+ IBottom1 _ _ _ -> bottom f accum t+ Branch _ _ _ _ _ -> branch f accum t+ IBranch0 _ _ -> branch f accum t+ IBranch1 _ _ _ -> branch f accum t+ IBranch2 _ _ _ _ _ -> branch f accum t bottom :: Ord k => (a -> k -> v -> a) -> a -> Tree Z c k v -> a bottom f accum t =
stable-tree.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: stable-tree-version: 0.6.1+version: 0.7.0 synopsis: Trees whose branches are resistant to change -- description: homepage: https://github.com/tsuraan/stable-tree@@ -51,7 +51,7 @@ , text hs-source-dirs: src default-language: Haskell2010- ghc-options: -Wall -fllvm+ ghc-options: -Wall -fllvm -fno-max-relevant-binds test-suite test-all type: exitcode-stdio-1.0
tests/TestAll.hs view
@@ -7,6 +7,7 @@ import qualified Data.StableTree.Persist as SP import Data.StableTree ( StableTree ) import Data.StableTree.Persist ( Fragment(..), Error(..) )+import Data.StableTree.Key ( StableKey ) import qualified Data.Map as Map import qualified Data.Set as Set@@ -86,7 +87,8 @@ Just v' | v' == v -> test_lookup rest t _ -> False - test_delete :: (Show k, Ord k, Serialize k, Show v, Serialize v)+ test_delete :: ( Eq k, Show k, Ord k, Serialize k, StableKey k+ , Eq v, Show v, Serialize v) => [(k,v)] -> Gen Bool test_delete [] = return True@@ -98,7 +100,8 @@ s' = ST.delete delkey s return (s' == ST.fromMap m') - test_insert :: (Show k, Ord k, Serialize k, Show v, Serialize v)+ test_insert :: ( Eq k, Show k, Ord k, Serialize k, StableKey k+ , Eq v, Show v, Serialize v) => [(k,v)] -> Gen Bool test_insert [] = return True@@ -111,7 +114,8 @@ 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)+ test_mutate :: ( Arbitrary k, Eq k, Show k, Ord k, Serialize k, StableKey k+ , Arbitrary v, Eq v, Show v, Serialize v) => StableTree k v -> Gen Bool test_mutate tree | ST.size tree == 0 = return True@@ -144,7 +148,8 @@ store_bytestring_int :: [(ArbByteString,Int)] -> Bool store_bytestring_int = action . map (first fromABS) - action :: (Eq k, Ord k, Serialize k, Eq v, Serialize v) => [(k,v)] -> Bool+ action :: (Eq k, Ord k, Serialize k, StableKey k, Eq v, Serialize v)+ => [(k,v)] -> Bool action pairs = fst $ runState go Map.empty where go = do@@ -165,13 +170,13 @@ type StableTreeState = State (Map ByteString ByteString) -store :: (Ord k, Serialize k, Serialize v)+store :: (Ord k, Serialize k, StableKey k, Serialize v) => ObjectID -> Fragment k v -> StableTreeState (Maybe RamError) store oid frag = do modify $ Map.insert (encode oid) (encode frag) return Nothing -load :: (Ord k, Serialize k, Serialize v)+load :: (Ord k, Serialize k, StableKey k, Serialize v) => ObjectID -> StableTreeState (Either RamError (Fragment k v)) load oid = gets (Map.lookup $ encode oid) >>= \case