packages feed

stable-tree 0.2.0 → 0.3.0

raw patch · 5 files changed

+91/−52 lines, 5 files

Files

demo/Main.hs view
@@ -41,10 +41,12 @@    prTrees trees values = do     tnum <- readIORef trees >>= return . Map.size-    tsum <- readIORef trees >>= return . sum . map (Map.size . snd) . Map.elems+    tsum <- readIORef trees >>= return . sum . map (Map.size . third) . Map.elems     vsum <- readIORef values >>= return . Map.size     putStrLn $ show (tsum+vsum) ++ " (" ++ show tnum ++ "," ++ show tsum                ++ "," ++ show vsum ++ ")"++  third (_,_,x) = x  -- |The typical way of storing key/value maps in SQL is to use a relational -- table, like this:
src/Data/StableTree/Persist.hs view
@@ -74,21 +74,27 @@ -- |Write appropriate functions here to load and store primitive parts of -- trees. data Store m e k v = Store-  { loadTree   :: Id -> m (Either e (Int, Map k Id))+  { loadTree   :: Id -> m (Either e (Depth, ValueCount, Map k Id))   , loadValue  :: Id -> m (Either e v)-  , storeTree  :: Id -> Int -> Map k Id -> m (Maybe e)+  , storeTree  :: Id -> Depth -> ValueCount -> Map k 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 :: (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 -load' :: (Monad m, IsKey k, Ord k, Error e) => Store m e k v -> Id -> ExceptT e m (StableTree k v)+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+    (0, _, contents)     -> loadBottom contents+    (depth, _, contents) -> loadBranch depth contents   where   loadBottom contents = do     vals <- loadValues contents Map.empty@@ -191,8 +197,9 @@    storeKeyIds key_ids =     let depth = getDepth tree+        vcount = getValueCount tree         valId = treeHash depth key_ids-    in do liftMaybe $ storeTree storage valId depth key_ids+    in do liftMaybe $ storeTree storage valId depth vcount key_ids           return valId  treeHash :: Build k => Int -> Map k Id -> Id
src/Data/StableTree/Persist/Ram.hs view
@@ -18,7 +18,8 @@ import Data.Text  ( Text )  -- |Error type for RAM storage. Not a lot can go wrong in RAM...-data RamError = NoKey+data RamError = NoTree Id+              | NoVal Id               | ApiError Text               deriving ( Show ) @@ -27,7 +28,7 @@  -- |Create a new RAM store storage :: IO ( Store IO RamError k v-              , IORef (Map Id (Int,Map k Id))+              , IORef (Map Id (Int,Int,Map k Id))               , IORef (Map Id v) ) storage = do   trees  <- newIORef Map.empty@@ -39,20 +40,21 @@   lt store tid = do     m <- readIORef store     case Map.lookup tid m of-      Nothing -> return $ Left NoKey-      Just pair -> return $ Right pair+      Nothing -> return $ Left $ NoTree tid+      Just tup -> return $ Right tup    lv store vid = do     m <- readIORef store     case Map.lookup vid m of-      Nothing -> return $ Left NoKey+      Nothing -> return $ Left $ NoVal vid       Just v -> return $ Right v -  st store tid depth tree = do-    modifyIORef store $ Map.insert tid (depth,tree)+  st store tid depth vcount tree = do+    modifyIORef store $ Map.insert tid (depth,vcount,tree)     return Nothing    sv store vid val = do+    -- putStrLn $ "Storing " ++ show vid     modifyIORef store $ Map.insert vid val     return Nothing
src/Data/StableTree/Types.hs view
@@ -15,6 +15,8 @@ , Tree(..) , Complete , Incomplete+, Depth+, ValueCount , nextBottom , nextBranch , getKey@@ -22,6 +24,7 @@ , treeContents , branchContents , getDepth+, getValueCount ) where  import Data.StableTree.Types.Key@@ -37,6 +40,12 @@ -- |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@@ -94,7 +103,8 @@          -> (Key Terminal k, v)          -> Tree Complete k v -  Branch :: Int+  Branch :: Depth+         -> ValueCount          -> (SomeKey k, Tree Complete k v)          -> (SomeKey k, Tree Complete k v)          -> Map (Key Nonterminal k) (Tree Complete k v)@@ -112,18 +122,21 @@            -> Tree Incomplete k v    -- A strut to lift an incomplete tree to the next level up-  IBranch0 :: Int+  IBranch0 :: Depth+           -> ValueCount            -> (SomeKey k, Tree Incomplete k v)            -> Tree Incomplete k v    -- A joining of a single complete and maybe an incomplete-  IBranch1 :: Int+  IBranch1 :: Depth+           -> ValueCount            -> (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+  IBranch2 :: Depth+           -> ValueCount            -> (SomeKey k, Tree Complete k v)            -> (SomeKey k, Tree Complete k v)            -> Map (Key Nonterminal k) (Tree Complete k v)@@ -173,9 +186,10 @@     Nothing ->        case mIncomplete of         Nothing       -> Left $ IBottom0 Nothing-        Just (ik, iv) -> Left $ IBranch0 depth (wrap ik, iv)+        Just (ik, iv) -> Left $ IBranch0 depth (getValueCount iv) (wrap ik, iv)     Just ((k,v), Nothing) ->-      Left $ IBranch1 depth (wrap k,v) $ wrapMKey mIncomplete+      let vcount = getValueCount v + maybe 0 (getValueCount . snd) mIncomplete+      in Left $ IBranch1 depth vcount (wrap k,v) $ wrapMKey mIncomplete     Just (f1, Just (f2, remain)) ->       go (wrapKey f1) (wrapKey f2) Map.empty remain @@ -184,9 +198,12 @@     let popd = Map.minViewWithKey remain >>= return . first wrapKey     in case popd of       Nothing ->-        Left $ IBranch2 depth f1 f2 accum $ wrapMKey mIncomplete+        let vcount = 2 + sum (map getValueCount $ Map.elems accum)+                       + maybe 0 (getValueCount . snd) mIncomplete+        in Left $ IBranch2 depth vcount f1 f2 accum $ wrapMKey mIncomplete       Just ((SomeKey_T term,v), remain') ->-        Right ( Branch depth f1 f2 accum (term, v), remain' )+        let vcount = 3 + sum (map getValueCount $ Map.elems accum)+        in Right ( Branch depth vcount f1 f2 accum (term, v), remain' )       Just ((SomeKey_N nonterm,v), remain') ->         go f1 f2 (Map.insert nonterm v accum) remain' @@ -213,20 +230,20 @@ -- |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+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+completeKey (Branch _ _ (k,_) _ _ _)   = unwrap k  -- |Convert an entire Tree into a k/v map. treeContents :: Ord k => Tree c k v -> Map k v@@ -239,15 +256,26 @@     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+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 (Branch _ c _ _ _ _)   = c+getValueCount (IBottom0 Nothing)     = 0+getValueCount (IBottom0 _)           = 1+getValueCount (IBottom1 _ _ m)       = 2 + Map.size m+getValueCount (IBranch0 _ c _)       = c+getValueCount (IBranch1 _ c _ _)     = c+getValueCount (IBranch2 _ c _ _ _ _) = c+ -- |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.@@ -263,7 +291,7 @@              $ Map.insert (fromKey kt) vt              terms'   in Right conts-branchContents (Branch _d (k1,v1) (k2,v2) terms (kt,vt)) =+branchContents (Branch _d _c (k1,v1) (k2,v2) terms (kt,vt)) =   let terms' = Map.mapKeys fromKey terms       conts  = Map.insert (unwrap k1) v1              $ Map.insert (unwrap k2) v2@@ -280,11 +308,11 @@              $ Map.insert (unwrap k2) v2              terms'   in Right conts-branchContents (IBranch0 _d incomplete) =+branchContents (IBranch0 _d _c incomplete) =   Left (Map.empty, Just $ first unwrap incomplete)-branchContents (IBranch1 _d (k1,v1) mIncomplete) =+branchContents (IBranch1 _d _c (k1,v1) mIncomplete) =   Left (Map.singleton (unwrap k1) v1, mIncomplete >>= return . first unwrap)-branchContents (IBranch2 _d (k1,v1) (k2,v2) terms mIncomplete) =+branchContents (IBranch2 _d _c (k1,v1) (k2,v2) terms mIncomplete) =   let terms' = Map.mapKeys fromKey terms       conts  = Map.insert (unwrap k1) v1              $ Map.insert (unwrap k2) v2@@ -292,13 +320,13 @@   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+  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 =
stable-tree.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/  name:                stable-tree-version:             0.2.0+version:             0.3.0 synopsis:            Trees whose branches are resistant to change -- description:          homepage:            https://github.com/tsuraan/stable-tree