stable-tree 0.4.1 → 0.5.0
raw patch · 12 files changed
+942/−888 lines, 12 filesdep +objectiddep −cryptohash
Dependencies added: objectid
Dependencies removed: cryptohash
Files
- demo/Main.hs +35/−27
- src/Data/StableTree.hs +22/−21
- src/Data/StableTree/Conversion.hs +93/−0
- src/Data/StableTree/Fragment.hs +69/−0
- src/Data/StableTree/Key.hs +68/−0
- src/Data/StableTree/Persist.hs +83/−268
- src/Data/StableTree/Persist/Ram.hs +0/−61
- src/Data/StableTree/Tree.hs +502/−0
- src/Data/StableTree/Types.hs +2/−330
- src/Data/StableTree/Types/Key.hs +0/−146
- stable-tree.cabal +14/−4
- tests/TestAll.hs +54/−31
demo/Main.hs view
@@ -6,46 +6,54 @@ ( main ) where -import Data.StableTree ( fromMap )-import Data.StableTree.Persist ( store )-import Data.StableTree.Persist.Ram ( storage )+import Data.StableTree import qualified Data.Map as Map-import Data.IORef ( readIORef )+import Control.Monad ( foldM )+import Control.Monad.State.Strict ( State, runState, modify )+import Data.Map ( Map )+import Data.ObjectID ( ObjectID )+import Data.Text ( Text ) +type S = Map ObjectID (Fragment Int Int)++data DemoError = ApiError Text+instance Error DemoError where+ stableTreeError = ApiError+ -- |Make a ton of related maps, storing all of them in a RAM store and printing -- out the total number of unique entries in that store and how many database -- entries would be required from a naive database implementation every -- so-often. main :: IO () main = do- (s, trees, values) <- storage- mapM_ (doRun s trees values) [0,100..1000::Int]- Right _ <- store s (fromMap $ Map.fromList [(a,a+1)|a<-[100..1000]])- prTrees trees values- Right _ <- store s (fromMap $ Map.fromList [(a,a+1)|a<-[200..1000]])- prTrees trees values- Right _ <- store s (fromMap $ Map.fromList [(a,a+1)|a<-[0..400]++[600..1000]])- prTrees trees values+ m0 <- foldM doRun Map.empty [0,100..1000::Int]+ let m1 = upd m0 [100..1000]+ prTrees m1+ let m2 = upd m1 [200..1000]+ prTrees m2+ let m3 = upd m2 $ [0..400] ++ [600..1000]+ prTrees m3 where- doRun s trees values i = do- mapM_ (upd s) [i..i+100]- putStr $ stupidCount (i+100) ++ " "- prTrees trees values+ doRun :: S -> Int -> IO S+ doRun m0 i0 = do+ let m' = foldl (\m i -> upd m [0..i]) m0 [i0..i0+100]+ putStr $ "naive gives: " ++ stupidCount (i0+100) ++ " / stable gives: "+ prTrees m'+ return m' - upd s i = do- let m = Map.fromList [(a,a+1) | a <- [0..i]]- t = fromMap m- store s t+ upd :: S -> [Int] -> S+ upd m is =+ let t = fromMap $ Map.fromList [(a,a+1) | a <- is]+ (_,m') = runState (save t) m+ in m' - prTrees trees values = do- trMap <- readIORef trees- let tnum = Map.size trMap- tsum = sum $ map (Map.size . snd) $ Map.elems trMap- vsum <- readIORef values >>= return . Map.size- putStrLn $ show (tsum+vsum) ++ " (" ++ show tnum ++ "," ++ show tsum- ++ "," ++ show vsum ++ ")"+ save :: StableTree Int Int -> State S (Either DemoError ObjectID)+ save = store' (\oid frag -> modify (Map.insert oid frag) >> return Nothing)++ prTrees m = do+ putStrLn $ (show $ Map.size m) ++ " unique entries" -- |The typical way of storing key/value maps in SQL is to use a relational -- table, like this:
src/Data/StableTree.hs view
@@ -19,59 +19,60 @@ -- using the dang thing now. module Data.StableTree ( StableTree(..)-, IsKey(..) , fromMap , toMap+, Error(..)+, load+, load'+, store+, store'+, Fragment(..) ) where -import Data.StableTree.Types+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 )---- | @StableTree@ is the opaque 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)+import Data.Map ( Map )+import Data.Maybe ( isNothing )+import Data.Serialize ( Serialize ) -- | Convert a 'Data.Map.Map' into a 'StableTree'.-fromMap :: (Ord k, IsKey k) => Map k v -> StableTree k v+fromMap :: (Ord k, Serialize k, Serialize v) => Map k v -> StableTree k v fromMap m = go m Map.empty where go values accum =- case nextBottom values of+ case Tree.nextBottom values of Left incomplete -> if Map.null accum then StableTree_I incomplete- else case getKey incomplete of+ 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 (completeKey complete) complete accum+ else go remain $ Map.insert (Tree.completeKey complete) complete accum buildParents completes mIncomplete accum =- case nextBranch completes mIncomplete of+ case Tree.nextBranch completes mIncomplete of Left incomplete -> if Map.null accum then StableTree_I incomplete- else case getKey incomplete of+ 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 (completeKey complete) complete accum+ let accum' = Map.insert (Tree.completeKey complete) complete accum in buildParents remain mIncomplete accum' -- | Convert a 'StableTree' back into a 'Data.Map.Map' toMap :: Ord k => StableTree k v -> Map k v-toMap (StableTree_I t) = treeContents t-toMap (StableTree_C t) = treeContents t+toMap (StableTree_I t) = Tree.treeContents t+toMap (StableTree_C t) = Tree.treeContents t -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/Conversion.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE OverloadedStrings #-}+-- |+-- Module : Data.StableTree.Conversion+-- Copyright : Jeremy Groven+-- License : BSD3+--+-- Functions for converting between Tree and Fragment types+module Data.StableTree.Conversion+( toFragments+, fromFragments+) where++import Data.StableTree.Fragment+import Data.StableTree.Tree++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)]+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)]++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"++ 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"++ 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"+++ cannotFind oid =+ Text.append "Failed to find object with ObjectID "+ (Text.pack $ show oid)+
+ src/Data/StableTree/Fragment.hs view
@@ -0,0 +1,69 @@+{-# 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/Key.hs view
@@ -0,0 +1,68 @@+-- |+-- Module : Data.StableTree.Types.Key+-- Copyright : Jeremy Groven+-- License : BSD3+--+-- Tools for working with StableTree keys.+module Data.StableTree.Key+( Key(fromKey)+, SomeKey(..)+, Terminal+, Nonterminal+, wrap+, unwrap+) where++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 )++-- |Used to indicate that a 'Key' is terminal+data Terminal++-- |Used to indicate that a 'Key' is not terminal+data Nonterminal++-- |A wrapper for keys; this has an ephemeral 't' that will be either+-- 'Terminal' or 'Nonterminal' depending on the result of @byte k@.+newtype Key t k = Key { fromKey :: k } deriving ( Eq, Ord, Show )++-- |A sum type to contain either a 'Terminal' or a 'Nonterminal' 'Key'+data SomeKey k = SomeKey_T (Key Terminal k)+ | SomeKey_N (Key Nonterminal k)+ deriving ( Eq, Ord, Show )++-- |Do the magic of wrapping up a key into a 'SomeKey'+wrap :: Serialize k => k -> SomeKey k+wrap k =+ let w8 = byte k+ x = w8 `xor` (w8 `shiftR` 4)+ w4 = x .&. 0xf+ in if w4 == 0xf+ then SomeKey_T $ Key k+ else SomeKey_N $ Key k++-- |Extract the original key from a wrapped one+unwrap :: SomeKey k -> k+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+ w32 = fnv `xor` (fnv `shiftR` 32)+ w16 = w32 `xor` (w32 `shiftR` 16)+ w8 = w16 `xor` (w16 `shiftR` 8)+ in toEnum $ fromEnum $ 0xff .&. w8++fnv1a :: ByteString -> Word64+fnv1a = BS.foldl upd basis+ where+ upd hsh oct = prime * (hsh `xor` (toEnum $ fromEnum oct))+ prime = 1099511628211+ basis = 14695981039346656037+
src/Data/StableTree/Persist.hs view
@@ -9,42 +9,23 @@ -- 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 'Build' for custom data types.+-- a user can also implement 'Serialize' for custom data types. module Data.StableTree.Persist-( Store(..)-, Build(..)-, Error(..)-, Id-, encodeId-, decodeId+( Error(..) , load+, load' , store-, buildBinary-, buildSerialize+, store' ) where -import Data.StableTree.Types hiding ( hash )-import Data.StableTree ( StableTree(..) )+import Data.StableTree.Conversion ( toFragments, fromFragments )+import Data.StableTree.Fragment ( Fragment(..) )+import Data.StableTree.Tree ( StableTree(..) ) -import qualified Data.Binary as B-import qualified Data.ByteString as BS-import qualified Data.ByteString.Lazy as Lazy import qualified Data.Map as Map-import qualified Data.Serialize as S-import Blaze.ByteString.Builder ( Builder, toByteString )-import Blaze.ByteString.Builder.ByteString ( fromByteString, fromLazyByteString )-import Blaze.ByteString.Builder.Char8 ( fromShow, fromString, fromChar )-import Blaze.ByteString.Builder.Word ( fromWord64be )-import Control.Arrow ( second )-import Control.Monad.Except ( ExceptT, runExceptT, lift, throwError )-import Crypto.Hash.Skein256 ( hash )-import Data.ByteString ( ByteString )-import Data.Int ( Int8, Int16, Int32, Int64 )-import Data.Map ( Map )-import Data.Monoid ( (<>), mconcat )-import Data.Serialize.Get ( runGet, getWord64be )-import Data.Text ( Text )-import Data.Word ( Word, Word8, Word16, Word32, Word64 )+import Data.ObjectID ( ObjectID )+import Data.Serialize ( Serialize(..) )+import Data.Text ( Text ) -- |Things go wrong with end-user storage, but things can also go wrong with -- reconstructing tree values. Implement 'stableTreeError' to allow 'load' and@@ -52,251 +33,85 @@ class Error e where stableTreeError :: Text -> e --- |The opaque type to identify values and branches of trees.-data Id = Id !Word64 !Word64 !Word64 !Word64 deriving ( Show, Eq, Ord )---- |Convert an Id into a 32-byte ByteString. Useful for actual storage of Ids-encodeId :: Id -> ByteString-encodeId = toByteString . build---- |Convert a stored ByteString back into an Id. Gives a "Left err" if the--- given ByteString isn't 32 bytes long-decodeId :: ByteString -> Either String Id-decodeId = runGet decode+-- |Record the tree into storage. This works like a fold, where the function+-- takes an accumulating state and each tree fragment to store, while returning+-- either an error message (which will abort the loop immediately) or the next+-- state for the accumulator.+--+-- Any fragment referring to other fragments ('FragmentBranch' fragments) will+-- 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)+ => (a -> ObjectID -> Fragment k v -> m (Either e a))+ -> 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 where- decode = do- a <- getWord64be- b <- getWord64be- c <- getWord64be- d <- getWord64be- return $ Id a b c d---- |Write appropriate functions here to load and store primitive parts of--- trees.-data Store m e k v = Store- { loadTree :: Id -> m (Either e (Depth, Map k (ValueCount, Id)))- , loadValue :: Id -> m (Either e v)- , storeTree :: Id -> Depth -> Map k (ValueCount, Id) -> m (Maybe e)- , storeValue :: Id -> v -> m (Maybe e)- }---- |Retrieve a tree given its id.-load :: (Monad m, IsKey k, Ord k, Error e)- => Store m e k v- -> Id- -> m (Either e (StableTree k v))-load s i = runExceptT $ load' s i+ go accum [] = return $ Right accum+ go accum ((fragid, frag):frags) =+ fn accum fragid frag >>= \case+ Left err -> return $ Left err+ Right accum' -> go accum' frags -load' :: (Monad m, IsKey k, Ord k, Error e)- => Store m e k v- -> Id- -> ExceptT e m (StableTree k v)-load' storage treeId =- liftEither (loadTree storage treeId) >>= \case- (0, contents) -> loadBottom contents- (depth, contents) -> loadBranch depth contents+store' :: (Monad m, Error e, Ord k)+ => (ObjectID -> Fragment k v -> m (Maybe e))+ -> StableTree k v+ -> m (Either e ObjectID)+store' fn = store fn' undefined where- loadBottom contents = do- vals <- loadValues contents Map.empty- case nextBottom vals of- Left i -> return $ StableTree_I i- Right (c,r) ->- if Map.null r- then return $ StableTree_C c- else err "Too many terminal keys in loadBottom"-- loadValues cont accum =- case Map.minViewWithKey cont of- Nothing -> return accum- Just ((k,(_,valId)),rest) -> do- v <- liftEither $ loadValue storage valId- loadValues rest $ Map.insert k v accum-- loadBranch depth contents = do- children <- loadChildren contents Map.empty- let classify s = case s of StableTree_I i -> Right i- StableTree_C c -> Left c- (cs, is) = Map.mapEither classify children- case Map.minViewWithKey is >>= return . second Map.minViewWithKey of- Nothing -> go cs Nothing- Just (_, Just (_,_)) ->- err "Too many incomplete trees in loadBranch"- Just ((ik,iv), Nothing) ->- case Map.maxViewWithKey cs of- Nothing -> go cs $ Just (ik, iv)- Just ((ck,_), _) ->- if ck > ik- then err "Saw complete trees after incomplete..."- else go cs $ Just (ik, iv)- where- go completes mIncomplete =- case nextBranch completes mIncomplete of- Left i ->- if getDepth i == depth- then return $ StableTree_I i- else err "Depth mismatch in loadBranch"- Right (c,m) | Map.null m ->- if getDepth c == depth- then return $ StableTree_C c- else err "Depth mismatch in loadBranch"- _ -> err "Too many terminal keys in loadBranch"-- loadChildren cont accum =- case Map.minViewWithKey cont of- Nothing -> return accum- Just ((k,(_,valId)),rest) -> do- subtree <- load' storage valId- loadChildren rest $ Map.insert k subtree accum-- err = throwError . stableTreeError---- |Store a tree using a 'Store' and return its calculated 'Id'-store :: (Monad m, Build k, Ord k, Build v)- => Store m e k v- -> StableTree k v- -> m (Either e Id)-store storage (StableTree_I i) = runExceptT $ store' storage i-store storage (StableTree_C c) = runExceptT $ store' storage c+ fn' _accum oid frag =+ fn oid frag >>= \case+ Nothing -> return $ Right oid+ Just err -> return $ Left err -store' :: (Monad m, Build k, Ord k, Build v)- => Store m e k v- -> Tree c k v- -> ExceptT e m Id-store' storage tree =- case branchContents tree of- Left subtrees -> storeBranch subtrees- Right kvmap -> storeBottom kvmap+load :: (Monad m, Error e, Ord k, Serialize k, Serialize v)+ => (a -> ObjectID -> m (Either e (a, Fragment k v)))+ -> a+ -> ObjectID+ -> m (Either e (a, StableTree k v))+load fn a0 top =+ recur a0 Map.empty [top] >>= \case+ Left err ->+ return $ Left err+ Right (accum, frags) ->+ case Map.lookup top frags of+ Nothing ->+ return $ Left (stableTreeError "load/recur failed to find top")+ 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) where- storeBranch (complete, mIncomplete) = do- key_ids <- storeSubtrees complete Map.empty- case mIncomplete of- Nothing -> storeKeyIds key_ids- Just (k,c,v) -> do- treeId <- store' storage v- storeKeyIds $ Map.insert k (c,treeId) key_ids-- storeSubtrees kvmap accum =- case Map.minViewWithKey kvmap of- Nothing -> return accum- Just ((k,(c,t)), rest) -> do- treeId <- store' storage t- storeSubtrees rest $ Map.insert k (c,treeId) accum-- storeBottom kvmap = do- key_ids <- storeValues kvmap Map.empty- storeKeyIds key_ids-- storeValues kvmap accum = do- case Map.minViewWithKey kvmap of- Nothing -> return accum- Just ((k,v), rest) -> do- let valId = calcId $ build v- _ <- liftMaybe $ storeValue storage valId v- storeValues rest $ Map.insert k (1,valId) accum-- storeKeyIds key_ids =- let depth = getDepth tree- valId = treeHash depth $ Map.map snd key_ids- in do liftMaybe $ storeTree storage valId depth key_ids- return valId--treeHash :: Build k => Int -> Map k Id -> Id-treeHash depth contents =- let builders = [(build k, build v) | (k,v) <- Map.toAscList contents]- w_len = [(len k, k, v) | (k, v) <- builders]- bodybs = toByteString $ mconcat [l <> k <> v | (l,k,v) <- w_len]- bodylen = fromShow $ BS.length bodybs- header = (fromString "tree ")- <> bodylen <> fromChar ' '- <> fromShow depth <> fromChar '\0'- in calcId $ header <> fromByteString bodybs- where- len = fromShow . BS.length . toByteString+ 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 _)) ->+ recur accum' (Map.insert oid frag frags) rest+ Right (accum', frag) ->+ let children = fragmentChildren frag+ oids = map snd $ Map.elems children+ in recur accum' (Map.insert oid frag frags) (oids ++ rest) -calcId :: Builder -> Id-calcId = right . decodeId . hash 256 . toByteString+load' :: (Monad m, Error e, Ord k, Serialize k, Serialize v)+ => (ObjectID -> m (Either e (Fragment k v)))+ -> ObjectID+ -> m (Either e (StableTree k v))+load' fn top =+ load fn' undefined top >>= \case+ Left err -> return $ Left err+ Right (_, tree) -> return $ Right tree where- right ei =- case ei of- Left _ -> error "Got a left!?"- Right v -> v--liftEither :: Monad m => m (Either a b) -> ExceptT a m b-liftEither act =- lift act >>= \case- Left err -> throwError err- Right val -> return val--liftMaybe :: Monad m => m (Maybe e) -> ExceptT e m ()-liftMaybe act =- lift act >>= \case- Just err -> throwError err- Nothing -> return ()---- |Typeclass to generate unique 'ByteString's for StableTree keys and values.--- Used to generate the unique identities for values and branches.-class Build t where- build :: t -> Builder---- |Generate a builder for something that is already a 'Binary'-buildBinary :: B.Binary t => t -> Builder-buildBinary = fromLazyByteString . B.encode---- |Generate a builder for something that is already a 'Serialize'-buildSerialize :: S.Serialize t => t -> Builder-buildSerialize = fromByteString . S.encode--instance Build Id where- build (Id a b c d) = w a <> w b <> w c <> w d- where- w = fromWord64be--instance Build Char where- build = buildSerialize--instance Build Double where- build = buildSerialize--instance Build Float where- build = buildSerialize--instance Build Int where- build = buildSerialize--instance Build Int8 where- build = buildSerialize--instance Build Int16 where- build = buildSerialize--instance Build Int32 where- build = buildSerialize--instance Build Int64 where- build = buildSerialize--instance Build Integer where- build = buildSerialize--instance Build Word where- build = buildSerialize--instance Build Word8 where- build = buildSerialize--instance Build Word16 where- build = buildSerialize--instance Build Word32 where- build = buildSerialize--instance Build Word64 where- build = buildSerialize--instance Build ByteString where- build = fromByteString--instance Build Lazy.ByteString where- build = fromLazyByteString+ fn' st oid =+ fn oid >>= \case+ Left err -> return $ Left err+ Right frag -> return $ Right (st, frag)
− src/Data/StableTree/Persist/Ram.hs
@@ -1,61 +0,0 @@--- |--- Module : Data.StableTree.Persist.Ram--- Copyright : Jeremy Groven--- License : BSD3------ A sample implementation of StableTree storage that just writes stuff to some--- Maps that are wrapped in IORefs.-module Data.StableTree.Persist.Ram-( RamError(..)-, storage-) where--import Data.StableTree.Persist ( Id, Error(..), Store(..) )--import qualified Data.Map as Map-import Data.IORef ( IORef, newIORef, readIORef, modifyIORef )-import Data.Map ( Map )-import Data.Text ( Text )---- |Error type for RAM storage. Not a lot can go wrong in RAM...-data RamError = NoTree Id- | NoVal Id- | ApiError Text- deriving ( Show )--instance Error RamError where- stableTreeError = ApiError---- |Create a new RAM store-storage :: IO ( Store IO RamError k v- , IORef (Map Id (Int,Map k (Int,Id)))- , IORef (Map Id v) )-storage = do- trees <- newIORef Map.empty- values <- newIORef Map.empty- return ( Store (lt trees) (lv values) (st trees) (sv values)- , trees- , values )- where- lt store tid = do- m <- readIORef store- case Map.lookup tid m of- Nothing -> return $ Left $ NoTree tid- Just (depth, children) ->- return $ Right (depth, children)-- lv store vid = do- m <- readIORef store- case Map.lookup vid m of- Nothing -> return $ Left $ NoVal vid- Just v -> return $ Right v-- st store tid depth tree = do- modifyIORef store $ Map.insert tid (depth,tree)- return Nothing-- sv store vid val = do- -- putStrLn $ "Storing " ++ show vid- modifyIORef store $ Map.insert vid val- return Nothing-
+ src/Data/StableTree/Tree.hs view
@@ -0,0 +1,502 @@+{-# 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,345 +1,17 @@-{-# LANGUAGE GADTs #-} -- | -- Module : Data.StableTree.Types -- 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.+-- Definitions of primitive types used in different modules of stable-tree module Data.StableTree.Types-( IsKey(..)-, Tree(..)-, Complete-, Incomplete-, Depth+( Depth , ValueCount-, nextBottom-, nextBranch-, getKey-, completeKey-, treeContents-, branchContents-, getDepth-, getValueCount ) where -import Data.StableTree.Types.Key--import qualified Data.Map as Map-import Control.Arrow ( first, second )-import Data.Map ( Map )-import Data.List ( intercalate )---- |Used to indicate that a 'Tree' is not complete-data Incomplete ---- |Used to indicate that a 'Tree' is complete-data Complete - -- |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---- |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 :: (SomeKey k, v)- -> (SomeKey k, v)- -> Map (Key Nonterminal k) v- -> (Key Terminal k, v)- -> Tree Complete k v-- Branch :: 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 :: Maybe (SomeKey k, v)- -> Tree Incomplete k v-- -- Any number of items, but not ending with a terminal key- IBottom1 :: (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 :: Depth- -> (SomeKey k, ValueCount, Tree Incomplete k v)- -> Tree Incomplete k v-- -- A joining of a single complete and maybe an incomplete- IBranch1 :: 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 :: 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, IsKey k)- => 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- Nothing -> Left $ IBottom0 Nothing- Just ((k,v), Nothing) -> Left $ IBottom0 $ Just (wrap k, v)- Just (f1, Just (f2, remain)) ->- go (first wrap f1) (first wrap f2) Map.empty remain-- where- go f1 f2 accum remain =- case Map.minViewWithKey remain of- Nothing ->- Left $ IBottom1 f1 f2 accum- Just ((k, v), remain') ->- case wrap k of- SomeKey_N nonterm ->- go f1 f2 (Map.insert nonterm v accum) remain'- SomeKey_T term ->- Right (Bottom 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, IsKey k)- => 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 Nothing- Just (ik, iv) -> Left $ IBranch0 depth (wrap ik, getValueCount iv, iv)- Just ((k,v), Nothing) ->- Left $ IBranch1 depth (wrap k, getValueCount v, v) $ wrapMKey mIncomplete- 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 ->- Left $ IBranch2 depth f1 f2 accum $ wrapMKey mIncomplete- Just ((SomeKey_T term,c,v), remain') ->- Right ( Branch depth f1 f2 accum (term, c, v), remain' )- Just ((SomeKey_N nonterm,c,v), remain') ->- go f1 f2 (Map.insert nonterm (c,v) accum) remain'-- wrapKey (k,v) = (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"---- |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 $ unwrap k-getKey (IBottom0 Nothing) = Nothing-getKey (IBottom0 (Just (k,_))) = Just $ unwrap k-getKey (IBottom1 (k,_) _ _) = Just $ unwrap k-getKey (Branch _ (k,_,_) _ _ _) = Just $ unwrap k-getKey (IBranch0 _ (k,_,_)) = Just $ unwrap k-getKey (IBranch1 _ (k,_,_) _) = Just $ unwrap k-getKey (IBranch2 _ (k,_,_) _ _ _) = Just $ 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,_) _ _ _) = unwrap k-completeKey (Branch _ (k,_,_) _ _ _) = 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 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 fromKey terms- conts = Map.insert (unwrap k1) v1- $ Map.insert (unwrap k2) v2- $ Map.insert (fromKey kt) vt- terms'- in Right conts-branchContents (Branch _d (k1,c1,v1) (k2,c2,v2) terms (kt,ct,vt)) =- let terms' = Map.mapKeys fromKey terms- conts = Map.insert (unwrap k1) (c1,v1)- $ Map.insert (unwrap k2) (c2,v2)- $ Map.insert (fromKey kt) (ct,vt)- terms'- in Left (conts, Nothing)-branchContents (IBottom0 Nothing) =- Right Map.empty-branchContents (IBottom0 (Just (k,v))) =- Right $ Map.singleton (unwrap k) v-branchContents (IBottom1 (k1,v1) (k2,v2) terms) =- let terms' = Map.mapKeys fromKey terms- conts = Map.insert (unwrap k1) v1- $ Map.insert (unwrap k2) v2- terms'- in Right conts-branchContents (IBranch0 _d (ik,ic,iv)) =- Left (Map.empty, Just (unwrap ik, ic, iv))-branchContents (IBranch1 _d (k1,c1,v1) mIncomplete) =- Left ( Map.singleton (unwrap k1) (c1,v1)- , mIncomplete >>= (\(k,c,v) -> return (unwrap k,c,v)))-branchContents (IBranch2 _d (k1,c1,v1) (k2,c2,v2) terms mIncomplete) =- let terms' = Map.mapKeys fromKey terms- conts = Map.insert (unwrap k1) (c1,v1)- $ Map.insert (unwrap k2) (c2,v2)- terms'- in Left (conts, mIncomplete >>= \(k,c,v) -> return (unwrap k, c, v))--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 ++ ">"
− src/Data/StableTree/Types/Key.hs
@@ -1,146 +0,0 @@--- |--- Module : Data.StableTree.Types.Key--- Copyright : Jeremy Groven--- License : BSD3------ Tools for working with StableTree keys. Just about anything can be a key, so--- long as there's a sane way to implement IsKey and the standard Ord class.------ Typical users don't need to worry about anything here other than perhaps--- IsKey.-module Data.StableTree.Types.Key-( IsKey(..)-, Key(fromKey)-, SomeKey(..)-, Terminal-, Nonterminal-, wrap-, unwrap-, hashSerialize-, hashBinary-, hashByteString-) where--import qualified Data.ByteString.Lazy as Lazy-import qualified Data.ByteString as BS-import qualified Data.Serialize as S-import qualified Data.Binary as B-import Data.Bits ( (.&.), shiftR, xor )-import Data.ByteString ( ByteString )-import Data.Int ( Int8, Int16, Int32, Int64 )-import Data.Word ( Word, Word8, Word16, Word32, Word64 )---- |Used to indicate that a 'Key' is terminal-data Terminal---- |Used to indicate that a 'Key' is not terminal-data Nonterminal---- |A wrapper for keys; this has an ephemeral 't' that will be either--- 'Terminal' or 'Nonterminal' depending on the result of @hash k@.-newtype Key t k = Key { fromKey :: k } deriving ( Eq, Ord, Show )---- |A sum type to contain either a 'Terminal' or a 'Nonterminal' 'Key'-data SomeKey k = SomeKey_T (Key Terminal k)- | SomeKey_N (Key Nonterminal k)- deriving ( Eq, Ord, Show )---- |Do the magic of wrapping up a key into a 'SomeKey'-wrap :: IsKey k => k -> SomeKey k-wrap k =- let w8 = hash k- x = w8 `xor` (w8 `shiftR` 4)- w4 = x .&. 0xf- in if w4 == 0xf- then SomeKey_T $ Key k- else SomeKey_N $ Key k---- |Extract the original key from a wrapped one-unwrap :: SomeKey k -> k-unwrap (SomeKey_T (Key k)) = k-unwrap (SomeKey_N (Key k)) = k---- |Calculate a hash for an instance of 'S.Serialize'-hashSerialize :: S.Serialize t => t -> Word8-hashSerialize = hashByteString . S.encode---- |Calculate a hash for an instance of 'B.Binary'-hashBinary :: B.Binary t => t -> Word8-hashBinary = hashByteString . Lazy.toStrict . B.encode---- |Calculate a hash for a 'ByteString'-hashByteString :: ByteString -> Word8-hashByteString bs =- let fnv = fnv1a bs- w32 = fnv `xor` (fnv `shiftR` 32)- w16 = w32 `xor` (w32 `shiftR` 16)- w8 = w16 `xor` (w16 `shiftR` 8)- in toEnum $ fromEnum $ 0xff .&. w8---- | Type class for anything that we can use as a key. The goal here is to wrap--- up a function that can generate a high-entropy eight-bit "hash". Speed is--- somewhat important here, but since we only actually look at four bits of the--- hash, it really shouldn't be a problem to quickly generate sufficiently--- random data.------ Implementors probably want to use 'hashSerialize', 'hashBinary', or--- 'hashByteString' when writing their 'hash' functions.-class IsKey k where- -- |Generate an 8-bit hash- hash :: k -> Word8--instance IsKey Char where- hash = hashSerialize--instance IsKey Double where- hash = hashSerialize--instance IsKey Float where- hash = hashSerialize--instance IsKey Int where- hash = hashSerialize--instance IsKey Int8 where- hash = hashSerialize--instance IsKey Int16 where- hash = hashSerialize--instance IsKey Int32 where- hash = hashSerialize--instance IsKey Int64 where- hash = hashSerialize--instance IsKey Integer where- hash = hashSerialize--instance IsKey Word where- hash = hashSerialize--instance IsKey Word8 where- hash = hashSerialize--instance IsKey Word16 where- hash = hashSerialize--instance IsKey Word32 where- hash = hashSerialize--instance IsKey Word64 where- hash = hashSerialize--instance IsKey ByteString where- hash = hashByteString--instance IsKey Lazy.ByteString where- hash = hashByteString . Lazy.toStrict--fnv1a :: ByteString -> Word64-fnv1a = BS.foldl upd basis- where- upd hsh oct = prime * (hsh `xor` (toEnum $ fromEnum oct))- prime = 1099511628211- basis = 14695981039346656037-
stable-tree.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: stable-tree-version: 0.4.1+version: 0.5.0 synopsis: Trees whose branches are resistant to change -- description: homepage: https://github.com/tsuraan/stable-tree@@ -19,7 +19,10 @@ executable demo build-depends: base >=4.6 && <4.8 , containers+ , mtl >= 2.2.1+ , objectid , stable-tree+ , text hs-source-dirs: demo main-is: Main.hs default-language: Haskell2010@@ -27,10 +30,12 @@ library exposed-modules: Data.StableTree+ , Data.StableTree.Conversion+ , Data.StableTree.Fragment , Data.StableTree.Types- , Data.StableTree.Types.Key+ , Data.StableTree.Key+ , Data.StableTree.Tree , Data.StableTree.Persist- , Data.StableTree.Persist.Ram -- other-modules: -- other-extensions: build-depends: base >=4.6 && <4.8@@ -39,8 +44,8 @@ , bytestring , cereal , containers- , cryptohash >= 0.5.1 , mtl >= 2.2.1+ , objectid >= 0.1.0.2 , text hs-source-dirs: src default-language: Haskell2010@@ -50,10 +55,15 @@ type: exitcode-stdio-1.0 main-is: TestAll.hs build-depends: base >=4.6 && < 4.8+ , bytestring , bytestring-arbitrary+ , cereal , containers+ , mtl >= 2.2.1+ , objectid , QuickCheck >= 2.1 , stable-tree+ , text , tasty , tasty-quickcheck hs-source-dirs: tests
tests/TestAll.hs view
@@ -1,18 +1,22 @@+{-# LANGUAGE LambdaCase #-} module Main ( main ) where import qualified Data.StableTree as ST-import Data.StableTree.Persist ( store, load )-import Data.StableTree.Persist.Ram ( storage )+import Data.StableTree ( Fragment, Error(..) ) import qualified Data.Map as Map-import Control.Arrow ( first )-import Data.ByteString.Arbitrary ( ArbByteString(..) )+import Control.Arrow ( first )+import Control.Monad.State.Strict ( State, runState, modify, gets )+import Data.ByteString ( ByteString )+import Data.ByteString.Arbitrary ( ArbByteString(..) )+import Data.Map ( Map )+import Data.ObjectID ( ObjectID )+import Data.Serialize ( Serialize, encode, decode )+import Data.Text ( Text ) import Test.Tasty-import Test.Tasty.QuickCheck ( testProperty )-import Test.QuickCheck-import Test.QuickCheck.Monadic+import Test.Tasty.QuickCheck ( testProperty ) main :: IO () main = defaultMain $@@ -48,30 +52,49 @@ st = ST.fromMap m in m == ST.toMap st - store_int_int :: [(Int,Int)] -> Property- store_int_int pairs = monadicIO $ do- (s,_,_) <- run storage- let m = Map.fromList pairs- st = ST.fromMap m- Right tid <- run $ store s st- Right st' <- run $ load s tid- assert $ m == ST.toMap st'+ store_int_int :: [(Int,Int)] -> Bool+ store_int_int = action - store_float_int :: [(Float,Int)] -> Property- store_float_int pairs = monadicIO $ do- (s,_,_) <- run storage- let m = Map.fromList pairs- st = ST.fromMap m- Right tid <- run $ store s st- Right st' <- run $ load s tid- assert $ m == ST.toMap st'+ store_float_int :: [(Float,Int)] -> Bool+ store_float_int = action - store_bytestring_int :: [(ArbByteString,Int)] -> Property- store_bytestring_int pairs = monadicIO $ do- (s,_,_) <- run storage- let m = Map.fromList $ map (first fromABS) pairs- st = ST.fromMap m- Right tid <- run $ store s st- Right st' <- run $ load s tid- assert $ m == ST.toMap st'+ 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 pairs = fst $ runState go Map.empty+ where+ go = do+ let m = Map.fromList pairs+ st = ST.fromMap m+ Right tid <- ST.store' store st+ Right st' <- ST.load' load tid+ return $ m == ST.toMap st'++-- |Error type for RAM storage. Not a lot can go wrong in RAM...+data RamError = NotFound ObjectID+ | SerializationError String+ | ApiError Text+ deriving ( Show )++instance Error RamError where+ stableTreeError = ApiError++type StableTreeState = State (Map ByteString ByteString)++store :: (Ord k, Serialize 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)+ => ObjectID -> StableTreeState (Either RamError (Fragment k v))+load oid =+ gets (Map.lookup $ encode oid) >>= \case+ Nothing -> return $ Left $ NotFound oid+ Just fragBS ->+ case decode fragBS of+ Left err -> return $ Left $ SerializationError err+ Right frag -> return $ Right frag