packages feed

stable-tree (empty) → 0.0.1

raw patch · 10 files changed

+1117/−0 lines, 10 filesdep +QuickCheckdep +basedep +binarysetup-changed

Dependencies added: QuickCheck, base, binary, blaze-builder, bytestring, bytestring-arbitrary, cereal, containers, hs-blake2, mtl, stable-tree, tasty, tasty-quickcheck, text

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2014, jay groven++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of jay groven nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ demo/Main.hs view
@@ -0,0 +1,63 @@+-- |A small demo program to demonstrate how stable trees behave compared with+-- how one might naively implement versioned trees in a relational database.+-- More detailed explanation of the naive storage is in the stupidCount+-- function.+module Main+( main+) where++import Data.StableTree        ( fromMap )+import Data.StableTree.IO     ( store )+import Data.StableTree.IO.Ram ( storage )++import qualified Data.Map as Map+import Data.IORef ( readIORef )++-- |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 = do+  (s, trees, values) <- storage+  mapM_ (doRun s trees) [0,100..1000::Int]+  store s (fromMap $ Map.fromList [(a,a+1)|a<-[100..1000]])+  prTrees trees+  store s (fromMap $ Map.fromList [(a,a+1)|a<-[200..1000]])+  prTrees trees+  store s (fromMap $ Map.fromList [(a,a+1)|a<-[0..400]++[600..1000]])+  prTrees trees++  where+  doRun s trees i = do+    mapM_ (upd s) [i..i+100]+    putStr $ stupidCount (i+100) ++ " "+    prTrees trees++  upd s i = do+    let m = Map.fromList [(a,a+1) | a <- [0..i]]+        t = fromMap m+    store s t++  prTrees trees = +    readIORef trees >>= return . length . Map.keys >>= print++-- |The typical way of storing key/value maps in SQL is to use a relational+-- table, like this:+--+-- @+-- CREATE TABLE Trees ( id serial primary key, name text );+-- CREATE TABLE Values ( id serial primary key, value bytea );+-- CREATE TABLE tree_entries ( tree_id integer references trees+--                           , value_id integer references values+--                           , name text+--                           , unique(tree_id, name)+--                           );+-- @+--+-- Using this strategy works poorly when trees are related, such as when doing+-- version control on a set of directories. In that case, supposing one were to+-- make a new version every time a file were added to a directory, the size of+-- tree_entries grows as the square of the size of trees. This function does+-- that calculation.+stupidCount :: Int -> String+stupidCount i = show $ i*(i-1) `div` 2
+ src/Data/StableTree.hs view
@@ -0,0 +1,77 @@+-- |+-- Module    : Data.StableTree+-- Copyright : Jeremy Groven+-- License   : BSD3+--+-- A Rose Tree designed for maximal stability under mutation. The StableTree+-- structure is meant to be used in places where different versions of a+-- key/value map are kept, such as in a versioning file system or a revision+-- control system. As a tree's contents are mutated (inserted, updated,+-- deleted), it will tend to keep the vast majority of its branches untouched,+-- with generally just the immediate branch and its immediate ancestor chain+-- being modified. Put another way, trees with similar contents will also share+-- a majority of their branches.+--+-- This module exports the public interface for StableTree. Right now, that's+-- just a translation to the standard Data.Map and back. There's nothing about+-- StableTree that forbids direct manipulation, but I've been playing with+-- various implementations of this for way too long, and I just want to start+-- using the dang thing now.+module Data.StableTree+( StableTree(..)+, IsKey(..)+, fromMap+, toMap+) where++import Data.StableTree.Types++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)++-- | Convert a 'Data.Map.Map' into a 'StableTree'.+fromMap :: (Ord k, IsKey k) => Map k v -> StableTree k v+fromMap m = go m Map.empty+  where+  go values accum =+    case nextBottom values of+      Left incomplete ->+        if Map.null accum+          then StableTree_I incomplete+          else case 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++  buildParents completes mIncomplete accum =+    case nextBranch completes mIncomplete of+      Left incomplete ->+        if Map.null accum+          then StableTree_I incomplete+          else case 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+            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++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/IO.hs view
@@ -0,0 +1,285 @@+{-# LANGUAGE LambdaCase, OverloadedStrings #-}+-- |+-- Module    : Data.StableTree.IO+-- Copyright : Jeremy Groven+-- License   : BSD3+--+-- Logic for dealing with the actual storage of Stable Trees. The key exports+-- here are 'Error', 'Store', 'load', and 'store'. A user needs to implement+-- the 'loadTree', 'loadValue', 'storeTree' and 'storeValue' parts of 'Store',+-- and make an appropriate Error type to report storage errors, and then the+-- 'load' and 'store' functions can just do their thing. If necessary, a user+-- can also implement 'Build' for custom data types.+module Data.StableTree.IO+( Store(..)+, Build(..)+, Error(..)+, Id+, load+, store+, buildBinary+, buildSerialize+) where++import Data.StableTree.Types hiding ( hash )+import Data.StableTree ( 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, liftIO, throwError )+import Crypto.Hash.Tsuraan.Blake2          ( 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 )++-- |Things go wrong with end-user storage, but things can also go wrong with+-- reconstructing tree values. Implement 'stableTreeError' to allow 'load' and+-- 'store' to report their own errors.+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 )++-- |Write appropriate functions here to load and store primitive parts of+-- trees.+data Store e k v = Store+  { loadTree   :: Id -> IO (Either e (Int, Map k Id))+  , loadValue  :: Id -> IO (Either e v)+  , storeTree  :: Id -> Int -> Map k Id -> IO (Maybe e)+  , storeValue :: Id -> v -> IO (Maybe e)+  }++-- |Retrieve a tree given its id.+load :: (IsKey k, Ord k, Error e) => Store e k v -> Id -> IO (Either e (StableTree k v))+load s i = runExceptT $ load' s i++load' :: (IsKey k, Ord k, Error e) => Store e k v -> Id -> ExceptT e IO (StableTree k v)+load' storage treeId =+  liftEitherIO (loadTree storage treeId) >>= \case+    (0, contents)     -> loadBottom contents+    (depth, contents) -> loadBranch depth contents+  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 <- liftEitherIO $ 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 :: (Build k, Ord k, Build v)+      => Store e k v+      -> StableTree k v+      -> IO (Either e Id)+store storage (StableTree_I i) = runExceptT $ store' storage i+store storage (StableTree_C c) = runExceptT $ store' storage c++store' :: (Build k, Ord k, Build v)+       => Store e k v+       -> Tree c k v+       -> ExceptT e IO Id+store' storage tree =+  case branchContents tree of+    Left subtrees -> storeBranch subtrees+    Right kvmap -> storeBottom kvmap++  where+  storeBranch (complete, mIncomplete) = do+    key_ids <- storeSubtrees complete Map.empty+    case mIncomplete of+      Nothing -> storeKeyIds key_ids+      Just (k,v) -> do+        treeId <- store' storage v+        storeKeyIds $ Map.insert k treeId key_ids++  storeSubtrees kvmap accum =+    case Map.minViewWithKey kvmap of+      Nothing -> return accum+      Just ((k,t), rest) -> do+        treeId <- store' storage t+        storeSubtrees rest $ Map.insert k 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+        _ <- liftMaybeIO $ storeValue storage valId v+        storeValues rest $ Map.insert k valId accum++  storeKeyIds key_ids =+    let depth = getDepth tree+        valId = treeHash depth key_ids+    in do liftMaybeIO $ 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++calcId :: Builder -> Id+calcId = right . runGet get . hash 32 . toByteString+  where+  right ei =+    case ei of+      Left _ -> error "Got a left!?"+      Right v -> v++  get = do+    a <- getWord64be+    b <- getWord64be+    c <- getWord64be+    d <- getWord64be+    return $ Id a b c d++liftEitherIO :: IO (Either a b) -> ExceptT a IO b+liftEitherIO act =+  liftIO act >>= \case+    Left err -> throwError err+    Right val -> return val++liftMaybeIO :: IO (Maybe e) -> ExceptT e IO ()+liftMaybeIO act =+  liftIO 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+
+ src/Data/StableTree/IO/Ram.hs view
@@ -0,0 +1,58 @@+-- |+-- Module    : Data.StableTree.IO.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.IO.Ram+( RamError(..)+, storage+) where++import Data.StableTree.IO ( 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 = NoKey+              | ApiError Text+              deriving ( Show )++instance Error RamError where+  stableTreeError = ApiError++-- |Create a new RAM store+storage :: IO ( Store RamError k v+              , IORef (Map Id (Int,Map k 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 NoKey+      Just pair -> return $ Right pair++  lv store vid = do+    m <- readIORef store+    case Map.lookup vid m of+      Nothing -> return $ Left NoKey+      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+    modifyIORef store $ Map.insert vid val+    return Nothing+
+ src/Data/StableTree/Types.hs view
@@ -0,0 +1,319 @@+{-# 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.+module Data.StableTree.Types+( IsKey(..)+, Tree(..)+, Complete+, Incomplete+, nextBottom+, nextBranch+, getKey+, completeKey+, treeContents+, branchContents+, getDepth+) 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   ++-- |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 :: Int+         -> (SomeKey k, Tree Complete k v)+         -> (SomeKey k, Tree Complete k v)+         -> Map (Key Nonterminal k) (Tree Complete k v)+         -> (Key Terminal k, 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 :: Int+           -> (SomeKey k, Tree Incomplete k v)+           -> Tree Incomplete k v++  -- A joining of a single complete and maybe an incomplete+  IBranch1 :: Int+           -> (SomeKey k, Tree Complete k v)+           -> Maybe (SomeKey k, Tree Incomplete k v)+           -> Tree Incomplete k v++  -- A branch that doesn't have a terminal, and that might have an IBranch+  IBranch2 :: Int+           -> (SomeKey k, Tree Complete k v)+           -> (SomeKey k, Tree Complete k v)+           -> Map (Key Nonterminal k) (Tree Complete k v)+           -> Maybe (SomeKey k, 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, iv)+    Just ((k,v), Nothing) ->+      Left $ IBranch1 depth (wrap k,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,v), remain') ->+        Right ( Branch depth f1 f2 accum (term, v), remain' )+      Just ((SomeKey_N nonterm,v), remain') ->+        go f1 f2 (Map.insert nonterm v accum) remain'++  wrapKey :: IsKey k => (k,v) -> (SomeKey k, v)+  wrapKey = first wrap++  wrapMKey :: IsKey k => Maybe (k,v) -> Maybe (SomeKey k, 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 (Branch _ (k,_) _ _ _)   = Just $ unwrap k+getKey (IBottom0 Nothing)       = Nothing+getKey (IBottom0 (Just (k,_)))  = Just $ unwrap k+getKey (IBottom1 (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 $ Map.elems completes+    Left ( completes, Just (_k, iv)) ->+      Map.unions $ treeContents iv:map treeContents (Map.elems completes)+    Right x -> x++-- |Get the number of levels of branches that live below this one+getDepth :: Tree c k v -> Int+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++-- |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 (Tree Complete k v)+                         , Maybe (k, 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,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 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 incomplete) =+  Left (Map.empty, Just $ first unwrap incomplete)+branchContents (IBranch1 _d (k1,v1) mIncomplete) =+  Left (Map.singleton (unwrap k1) v1, mIncomplete >>= return . first unwrap)+branchContents (IBranch2 _d (k1,v1) (k2,v2) terms mIncomplete) =+  let terms' = Map.mapKeys fromKey terms+      conts  = Map.insert (unwrap k1) v1+             $ Map.insert (unwrap k2) v2+             terms'+  in Left (conts, mIncomplete >>= return . first unwrap)++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, 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 view
@@ -0,0 +1,146 @@+-- |+-- 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
@@ -0,0 +1,60 @@+-- Initial stable-tree.cabal generated by cabal init.  For further +-- documentation, see http://haskell.org/cabal/users-guide/++name:                stable-tree+version:             0.0.1+synopsis:            Trees whose branches are resistant to change+-- description:         +homepage:            https://github.com/tsuraan/stable-tree+license:             BSD3+license-file:        LICENSE+author:              jay groven+maintainer:          tsuraan@gmail.com+-- copyright:           +category:            Data+build-type:          Simple+-- extra-source-files:  +cabal-version:       >=1.10++executable demo+  build-depends:       base >=4.6 && <4.8+                     , containers+                     , stable-tree+  hs-source-dirs:      demo+  main-is:             Main.hs+  default-language:    Haskell2010++library+  exposed-modules:     Data.StableTree+                     , Data.StableTree.Types+                     , Data.StableTree.Types.Key+                     , Data.StableTree.IO+                     , Data.StableTree.IO.Ram+  -- other-modules:       +  -- other-extensions:    +  build-depends:       base >=4.6 && <4.8+                     , binary+                     , blaze-builder+                     , bytestring+                     , cereal+                     , containers+                     , hs-blake2+                     , mtl+                     , text+  hs-source-dirs:      src+  default-language:    Haskell2010+  ghc-options:         -Wall -fllvm++test-suite test-all+  type:                exitcode-stdio-1.0+  main-is:             TestAll.hs+  build-depends:       base >=4.6 && < 4.8+                     , bytestring-arbitrary+                     , containers+                     , QuickCheck+                     , stable-tree+                     , tasty+                     , tasty-quickcheck+  hs-source-dirs:      tests+  default-language:    Haskell2010+  ghc-options:         -Wall
+ tests/TestAll.hs view
@@ -0,0 +1,77 @@+module Main+( main+) where++import qualified Data.StableTree as ST+import Data.StableTree.IO ( store, load )+import Data.StableTree.IO.Ram ( storage )++import qualified Data.Map as Map+import Control.Arrow ( first )+import Data.ByteString.Arbitrary ( ArbByteString(..) )+import Test.Tasty+import Test.Tasty.QuickCheck ( testProperty )+import Test.QuickCheck+import Test.QuickCheck.Monadic++main :: IO ()+main = defaultMain $+  testGroup "StableTree"+  [ testGroup "Pure"+    [ testProperty "Int/Int" int_int+    , testProperty "Float/Int" float_int+    , testProperty "ByteString/Int" bytestring_int+    ]+  , testGroup "Stored"+    [ testProperty "Int/Int" store_int_int+    , testProperty "Float/Int" store_float_int+    , testProperty "ByteString/Int" store_bytestring_int+    ]+  ]+  where++  int_int :: [(Int,Int)] -> Bool+  int_int pairs =+    let m = Map.fromList pairs+        st = ST.fromMap m+    in m == ST.toMap st++  float_int :: [(Float,Int)] -> Bool+  float_int pairs =+    let m = Map.fromList pairs+        st = ST.fromMap m+    in m == ST.toMap st++  bytestring_int :: [(ArbByteString,Int)] -> Bool+  bytestring_int pairs =+    let m = Map.fromList $ map (first fromABS) pairs+        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_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_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'+