diff --git a/Data/BTree/BTree.hs b/Data/BTree/BTree.hs
new file mode 100644
--- /dev/null
+++ b/Data/BTree/BTree.hs
@@ -0,0 +1,670 @@
+{-# LANGUAGE FlexibleContexts
+           , FlexibleInstances
+           , ScopedTypeVariables
+           , BangPatterns
+           , UndecidableInstances
+           , ConstraintKinds
+           , Rank2Types
+  #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Data.BTree.BTree
+-- Concurrent BTree with relaxed balance.
+--
+--      This module is inspired by the paper
+--      /B-Trees with Relaxed Balance/,
+--        Kim S. Larsen and Rolf Fagerberg, 1993
+--          Department of Mathematics and Computer Science, Odense University, Denmark.
+--
+-- This implementation is not full, and has some serious limitations:
+--
+-- 1. The rebalance logic to handle underful leafs has not been implemented.
+--
+-- 1. 'toList', 'foldli', 'foldri', 'search', 'findMin' and 'findMax' may fail
+-- if run in parallel with 'rebalanceProcess'. The current implementations of
+-- these operations are therefore considered unsafe.
+--
+-- 1. 'findMin' and 'findMax' may fail in the case where the outer leaf is empty.
+--
+-- It is important to note, that these limitations are limitations of the
+-- current implementation and not of the original design. They are solely due to
+-- lack of time.
+--
+-- To clarify: @Safe operations@ are those that support rebalancing during the
+-- operations, while @unsafe operations@ may fail if run during rebalancing.
+-----------------------------------------------------------------------------
+
+
+module Data.BTree.BTree
+       ( -- * Setup and execution:
+         makeParam
+       , execTree
+         -- * Class and type aliases
+       , Key
+       , Value
+       , Interval(..)
+       , TreeBackend
+       , TreeResult
+         -- * Safe operations:
+       , insert
+       , delete
+       , lookup
+       , modify
+       , save
+         -- * Rebalancing:
+       , rebalanceProcess
+         -- * Unsafe operations:
+       , toList
+       , foldli
+       , foldri
+       , search
+       , search_
+       , findMin
+       , findMax
+       , height
+       ) where
+
+import Data.BTree.Types
+import Data.Maybe
+
+import Control.Concurrent
+import Control.Concurrent.STM
+import Control.Exception
+import Control.Monad.Reader
+import Control.Monad.Trans
+import System.Random (randomIO)
+
+
+import qualified Data.List as L
+import qualified Data.Map as M
+import qualified Data.ByteString as B
+import Data.Serialize (Serialize)
+
+import qualified Data.BTree.Cache.Class as C
+import qualified Data.BTree.Cache.STM   as Cstm
+import qualified Data.BTree.KVBackend.Class as KV
+-- import GHC.Conc
+
+import Debug.Trace
+
+import Prelude hiding (lookup, catch)
+
+
+-- | Type aliases to ease reading.
+type CacheSTM  m k v = Cstm.CacheSTM m (Ref (Node k v)) (Node k v)
+type CacheSTMP m k v = Cstm.Param    m (Ref (Node k v)) (Node k v)
+
+
+-- | Some type-fu. Context (Key k) gives the context (Ord k, Serialize k, ...)
+class (Ord k, Serialize k, Interval k)    => Key k
+-- | Dummy instance.
+instance (Ord k, Serialize k, Interval k) => Key k
+
+
+-- | Some type-fu. Context (Value v) gives the context (Eq v, Serialize v, ...)
+class (Eq  v, Serialize v)    => Value v
+-- | Dummy instance.
+instance (Eq  v, Serialize v) => Value v
+
+
+-- | Needed to generate the split-keys used in branch nodes.
+class Interval k where
+  -- | Given two keys, a < c, compute a new key b, such that a <= b < c.
+  -- Default is to choose a, however a smarter instance exist for ByteString.
+  between :: k -> k -> k
+  between = const
+
+
+-- | Instance for Bytestring that yields short keys.
+instance Interval B.ByteString where
+  between a b = if n < B.length b then B.take n b
+                else a  -- can't use full b, since not (b < b)
+    where
+      n = 1 + (length $ takeWhile (uncurry equals) $ B.zip a b)
+
+
+-- | Type aliases to shorten cache type.
+type TreeBackend mc k v    = KV.KVBackend mc (Ref (Node k v)) B.ByteString -- (Node k v)
+
+-- | Type aliases to shorten result types.
+type TreeResult m mc k v a = BTreeM m (Cstm.Param mc (Ref (Node k v)) (Node k v)) k v a
+
+
+
+-- | helpers
+ifM :: Monad m => m Bool -> m a -> m a -> m a
+ifM m t f | true <- m = t
+          | otherwise = f
+
+equals a b = a `compare` b == EQ
+
+
+-- | Make a new tree parameter from order, root node and cache parameter. When
+-- no root node is given, 'Ref' 0 will be used and a new tree initialised
+-- here. This may overwrite an existing tree. Is used together with 'execTree'.
+makeParam :: (MonadIO mIO, C.Cache m p (Ref a) (Node k v))
+             => Int                               -- ^ Order of tree.
+             -> Maybe (Ref (Node k1 v1))          -- ^ Optional root node.
+             -> p                                 -- ^ Cache parameter.
+             -> mIO (Param p k1 v1)               -- ^ The result in monadIO
+makeParam ord mroot cacheP = do
+  -- Init tree when root is Nothing
+  un <- liftIO $ newTVarIO []
+  tv <- liftIO $ newTVarIO $ fromMaybe 0 mroot
+  when (isNothing mroot) $
+    liftIO $ C.eval cacheP $ C.store Nothing (Ref 0) emptyTree
+  -- New channel for rebalance msgs
+  rebCh <- liftIO $ newTChanIO
+  return $ Param ord tv cacheP rebCh un
+  where
+    emptyTree = Leaf M.empty
+
+
+
+-- | 'execTree' takes a tree parameter and a group of operations in a BTreeM
+-- monad and exectures the operations.
+execTree :: Param st k v                          -- ^ Tree parameter (see 'makeParam')
+         -> BTreeM m st k v a                     -- ^ Tree instance
+         -> m a                                   -- ^ The result inside the chosen monad
+execTree p m =
+  runReaderT (runBTreeM m) p
+
+
+
+-- | Get next unique node reference id
+newRef p = do
+  ls <- Cstm.liftSTM $ readTVar $ unused p
+  case ls of
+    (r:rs) -> do Cstm.liftSTM $ writeTVar (unused p) rs
+                 return r
+    _      -> Cstm.fail newNode
+  where
+    newNode = do
+      refids <- map Ref `fmap` replicateM 8 randomIO
+      -- Collisions are rare, but not impossible
+      forM_ refids $ \ref -> C.eval (state p) $ do
+        n <- C.fetch ref
+        case n of
+          Nothing -> do Cstm.liftSTM $ do ls <- readTVar $ unused p
+                                          writeTVar (unused p) $ ref : ls
+          Just _  -> return ()
+
+
+-- | Queue marked node for rebalancing
+addMarked p k = do
+  Cstm.liftSTM $ writeTChan (marked p) k
+
+-- | Get root reference id
+root' p = do
+  liftIO $ atomically $ readTVar $ root p
+
+-- | Fetch node from reference id; error when not found
+fetch' ref = do
+  n <- C.fetch ref
+  return $ fromMaybe (error $ "invalid tree: " ++ show ref) n
+
+-- | Store node in new ref
+storeNew p parent ns = do
+  refs <- replicateM (length ns) $ newRef p
+  mapM_ (\(r, n) -> C.store (Just parent) r n) $ zip refs ns
+  return refs
+
+-- | Split a node in two, resulting in a new parent node
+split p parent r (Leaf ks) = do
+  [refL, refR] <- storeNew p r [leafL, leafR]
+  when (keyL > keyB || keyR <= keyB) $ error "Between has failed!"
+  let branch = Branch [keyB] [refL, refR]
+  C.store (Just parent) r $! branch
+  return branch
+  where
+    (keyL, keyR) = ((fst $ last keysL), (fst $ head keysR))
+    keyB = keyL `between` keyR
+    keys = M.toList ks
+    (keysL, keysR) = L.splitAt (order p) keys
+    leafL = Leaf $! M.fromAscList keysL
+    leafR = Leaf $! M.fromAscList keysR
+
+split p parent r (Branch keys rs) =
+  do [refL, refR] <- storeNew p r [ Branch keysL rsL
+                                  , Branch keysR rsR ]
+     let branch = Branch [b] [refL, refR]
+     mapM_ (Cstm.updateTag $ Just r) rs
+     C.store (Just parent) r $! branch
+     return branch
+  where
+    i = order p
+    (keysL, (b : keysR)) = L.splitAt i keys
+    (rsL, rsR) = L.splitAt (i+1) rs
+
+
+
+-- | /O(log n)/. Insert key-value pair into current tree. After this operation
+-- 'lookup' @k@ will yield @Just v@. If the key already exists it is overridden.
+-- If you want the overridden value, or want different behaviour when the key
+-- exists see 'modify'.
+--
+-- 'insert' may leave the tree /unbalanced/, skewed or with underfull nodes.
+-- The tree can be re-balanced by starting a 'rebalanceProcess'.
+--
+-- > execTree p $ insert 42 "foobar"
+insert :: ( MonadIO m, TreeBackend mc k v
+          , Key k, Value v)
+          => k                                    -- ^ key
+          -> v                                    -- ^ value to associate with the key
+          -> TreeResult m mc k v ()
+insert k v = do _ <- modify const k v
+                return ()
+
+
+-- | /O(log n)/. Delete a key from the tree. The deleted value is returned as
+-- @Just v@ if present, otherwise @Nothing@ is returned.
+--
+-- > execTree p $ delete 42
+delete :: ( MonadIO m, TreeBackend mc k v
+          , Key k, Value v)
+          => k                                    -- ^ key
+          -> TreeResult m mc k v (Maybe v)        -- ^ The previous value if present
+delete k = modifyLeaf (findChild k) $ \p parent r ks -> do
+  let (vOld, ks') = M.updateLookupWithKey (\_ _ -> Nothing) k ks
+  C.store (Just parent) r $! Leaf ks'
+  return vOld
+
+
+
+-- | /O(log n)/. Lookup key in current tree.
+--
+-- > execTree p $ do insert 42 "foo"      -- ()
+-- >                 a <- lookup 42       -- Just "foo"
+-- >                 insert 42 "bar"      -- ()
+-- >                 b <- lookup 42       -- Just "bar"
+-- >                 delete 42            -- Just "bar"
+-- >                 c <- lookup 42       -- Nothing
+-- >                 return (a, b, c)     -- (Just "foo", Just "bar", Nothing)
+lookup :: ( MonadIO m, TreeBackend mc k v
+          , Key k, Value v)
+          => k                                    -- ^ key
+          -> TreeResult m mc k v (Maybe v)        -- ^ The value if present
+lookup k = modifyLeaf (findChild k) $ \_ _ _ -> return . M.lookup k
+
+
+
+-- | /O(log n)/. Replace the value of @k@ with @f v v'@, where @v'@ is the
+-- current value. The old value @v'@ is returned after the replacement. If no
+-- current value exist, @v@ is inserted.
+--
+-- The semantics is the same as @'Data.Map.insertLookupWithKey' . const@.
+--
+-- > execTree p $ do delete 42
+-- >                 modify subtract 42 1    -- inserts    (42,  1)
+-- >                 modify subtract 42 1    -- updates to (42,  0)
+-- >                 modify subtract 42 1    -- updates to (42, -1)
+modify :: ( MonadIO m, TreeBackend mc k v
+          , Key k, Value v)
+          => (v -> v -> v)                  -- ^ @f@ computes the new value from old and default.
+          -> k                              -- ^ key
+          -> v                              -- ^ Default value is used when no other is present
+          -> TreeResult m mc k v (Maybe v)  -- ^ The previous value if present
+modify f k v = do
+  -- c  <- asks state
+  -- liftIO $ Cstm.flush c
+  modifyLeaf (findChild k) $ \p parent r ks -> do
+  let (vOld, ks') = M.insertLookupWithKey (const f) k v ks
+      lf' = Leaf ks'
+  if M.size ks' <= 2 * order p
+    then C.store (Just parent) r $! lf'
+    else do Branch [bk] _ <- split p parent r lf'
+            addMarked p bk
+  return vOld
+{-# INLINE modify #-}
+
+
+-- modifyFromChannel ch = do
+--   -- get first set of f k v
+--   task@(_, _, k, _) <- liftIO $ atomically $ readTChan ch
+--   -- lookup parent and child, execute task
+--   (r, ks) <- modifyLeaf (findChild k) $ \p r ks -> do insert' p task r ks
+--                                                       return (r, ks)
+--   -- try to execute next task, too
+--   task'@(_, _, k, _) <- liftIO $ atomically $ readTChan ch
+--   next ch task' r
+--   where
+--     next ch task r = do
+--       suc <- go task r
+--       case suc of
+--         True -> do
+--           task <- liftIO $ atomically $ readTChan ch
+--           next ch task r
+--         False -> do
+--           liftIO $ atomically $ writeTChan ch task
+--           modifyFromChannel ch
+
+--     go task@(_, _, k, _) r = do
+--       p <- ask
+--       liftIO $ C.eval (state p) $ do
+--         n <- C.fetch r
+--         case n of
+--           (Just (Leaf ks))
+--             -- Inside correct leaf
+--             | M.size ks > 0 && (fst $ M.findMin ks) <= k && k <= (fst $ M.findMax ks) ->
+--               do insert' p task r ks
+--                  return True
+
+--             | otherwise -> return False
+--           _ -> return False
+
+--     insert' p (tm, f, k, v) r ks = do
+--       let (vOld, ks') = M.insertLookupWithKey (const f) k v ks
+--           lf' = Leaf ks'
+--       if M.size ks' <= 2 * order p
+--         then do C.store r r lf'
+--         else do b@(Branch [bk] _) <- split p lf'
+--                 C.store r r b
+--                 addMarked p bk
+--       Cstm.liftSTM $ putTMVar tm vOld
+
+
+findChild k (Branch ks rs) =
+  let idx = L.length $ L.takeWhile (<k) ks in rs !! idx
+
+
+-- | Calculate the height of the tree, i.e. the longest node path from root to leaf.
+height :: (MonadIO m, C.Cache m1 p (Ref (Node k v)) (Node k v)) => BTreeM m p k v Int
+height = do p <- ask
+            r <- root' p
+            liftIO $ go p r
+  where
+    go p r = do
+      n <- C.eval (state p) $ C.fetch r
+      case n of
+        Nothing -> error $ "height: invalid tree: " ++ show r
+        Just (Leaf     ks) -> return 1
+        Just (Branch _ rs) -> do h <- foldM (\h r -> do h' <- go p r
+                                                        return $ max h h') 0 rs
+                                 return $ 1 + h
+
+
+-- | Modify a leaf in current tree and return result of modification
+modifyLeaf :: (Ord k, MonadIO m, C.Cache mc p (Ref (Node k v)) (Node k v)) =>
+              (Node k v -> Ref (Node k v)) ->
+              (Param p k v -> Ref (Node k v) -> Ref (Node k v) -> M.Map k v -> mc a) ->
+              BTreeM m p k v a
+modifyLeaf pick f = retry 100 $ do p <- ask
+                                   r <- root' p
+                                   liftIO $ try $ go p r r
+  where
+    retry 0 m = do x <- m
+                   either throw return x
+    retry n m = do x <- m
+                   case x of
+                     Left  (_::ErrorCall) -> retry (n-1) m
+                     Right a -> return a
+
+    go p parent r = do
+      res <- C.eval (state p) transaction
+      either (go p r) return res
+        where
+          transaction =
+            do n <- C.fetch r
+               case n of
+                 Just (Leaf ks) ->
+                   do v <- f p parent r ks
+                      return $! Right $! v
+                 Just n -> return $! Left $! pick n
+                 Nothing ->
+                   error $ "modifyLeaf: invalid tree: " ++ show r
+{-# INLINE modifyLeaf #-}
+
+
+-- | A process for background rebalancing. Start inside its own thread, since
+-- this will run forever. Stop by killing the thread.
+--
+-- > pid <- forkIO $ rebalanceProcess p
+-- > -- Perform safe tree operations
+-- > killThread pid
+rebalanceProcess :: (MonadIO m, TreeBackend m2 k v, Key k, Value v)
+                    => Param (CacheSTMP m2 k v) k v       -- ^ Tree parameter.
+                    -> m (MVar ThreadId)                  -- ^ ThreadId
+rebalanceProcess p = liftIO $ do
+  mv  <- newEmptyMVar
+  pid <- forkIO $ forever $ execTree p $ do
+    p <- ask
+    r <- root' p
+    k <- liftIO $ atomically $ readTChan $ marked p
+    x <- liftIO $ takeMVar mv
+    rebalanceKey p r r k
+    liftIO $ putMVar mv x
+  putMVar mv pid
+  return mv
+
+
+-- | Rebalance until no more rebalancing can take place
+rebalanceAll :: (MonadIO m, Key k, Value v,
+                 C.Cache (CacheSTM m2 k v) (CacheSTMP m2 k v) (Ref (Node k v)) (Node k v),
+                 TreeBackend m2 k v) =>
+                BTreeM m (CacheSTMP m2 k v) k v ()
+rebalanceAll = ifM rebalance rebalanceAll $ return ()
+
+
+-- | Perform rebalancing.
+-- Moves the tree one step closer to rebalancing
+rebalance :: (Key k, Value v, MonadIO m,
+              C.Cache (CacheSTM m2 k v) (CacheSTMP m2 k v) (Ref (Node k v)) (Node k v),
+              TreeBackend m2 k v) =>
+             BTreeM m (CacheSTMP m2 k v) k v Bool
+rebalance = do p <- ask
+               r <- root' p
+               let ch = marked p
+               mk <- liftIO $ atomically $
+                     ifM (isEmptyTChan ch)
+                     (return Nothing)
+                     (Just `fmap` readTChan ch)
+               case mk of
+                 Just k  -> do rebalanceKey p r r k
+                               return True
+                 Nothing -> return False
+
+
+rebalance' :: (Key k, Value v, MonadIO m,
+              C.Cache (CacheSTM m2 k v) (CacheSTMP m2 k v) (Ref (Node k v)) (Node k v),
+              TreeBackend m2 k v) =>
+             BTreeM m (CacheSTMP m2 k v) k v ()
+rebalance' = do p <- ask
+                r <- root' p
+                let ch = marked p
+                k <- liftIO $ atomically $ readTChan ch
+                rebalanceKey p r r k
+
+rebalanceKey p parent r k = do
+  ord <- asks order
+  mr  <- liftIO $ C.eval (state p) $ trans ord
+  case mr of
+    Nothing -> return ()
+    Just r' -> rebalanceKey p r r' k
+  where
+    trans ord = do
+      mn <- C.fetch r
+      case mn of
+        Nothing                 -> error $ "rebalanceKey: invalid tree: " ++ show r
+        Just (Leaf _)           -> return Nothing
+        Just (n@(Branch ks rs)) -> do
+          let cr = findChild k n
+          mcn <- C.fetch cr
+          case mcn of
+            Nothing       -> error $ "rebalanceKey: invalid tree: cr = " ++ show cr
+            Just (Leaf _) -> return Nothing  -- TODO: Handle empty leaf
+            Just (cn@(Branch [k'] [r0, r1])) -> do
+              let ks'        = L.insert k' ks
+                  Just idx   = L.elemIndex k' ks'
+                  (a, _ : b) = L.splitAt idx rs
+                  rs'        = a ++ (r0 : r1 : b)
+                  branch     = Branch ks' rs'
+              if length rs' <= 2 * ord
+                then do C.store (Just parent) r branch
+                        C.remove Nothing cr
+                        -- TODO: why can't we remove cr?
+                else do branch'@(Branch _ frs) <- split p parent r branch
+                        C.store (Just parent) r branch'
+                        C.remove Nothing cr
+                        addMarked p k'
+              if k `equals` k' then return Nothing
+                else return $ Just r
+            Just (Branch cks crs) -> return $ Just cr
+
+
+
+deleteByFst k = L.deleteBy cmpfst (k, undefined)
+  where
+    cmpfst (a, _) (b, _) = a `equals` b
+
+
+size :: (Ord k, MonadIO m, C.Cache mc p (Ref (Node k v)) (Node k v)) =>
+        BTreeM m p k v Int
+size = do p <- ask
+          r <- root' p
+          go p r
+  where
+    go p r = do
+      n <- liftIO $ C.eval (state p) $ fetch' r
+      case n of
+        Leaf ks -> return $ M.size ks
+        Branch ks rs -> do
+          tot <- foldM (\n r ->
+                         do m <- go p r
+                            return $ n + m
+                       ) 0 rs
+          return tot
+
+
+-- | Convert the tree into a list of key-value pairs. This function may crash
+-- if used together with 'rebalanceProcess'.
+toList :: ( MonadIO m, TreeBackend mc k v, Key k, Value v)
+          => TreeResult m mc k v [(k, v)]         -- ^ The list of (key, value) pairs.
+toList = do p <- ask
+            r <- root' p
+            Cstm.withGeneration (state p) $ \n -> go n p r
+  where
+    go gen p r = do
+      n <- liftIO $ C.eval (state p) $ Cstm.fetchGen gen r
+      case n of
+        Nothing             -> error $ "toList: invalid tree: " ++ show r
+        Just (Leaf ks)      -> return $ M.toList ks
+        Just (Branch ks rs) -> do
+          ls <- mapM (go gen p) rs
+          return $ concat ls
+
+
+-- | Save the tree by flushing the underlying cache to the permanent store and
+-- return a ref to the root node.
+save :: ( MonadIO m, TreeBackend mc k v, Key k, Value v)
+        => TreeResult m mc k v (Ref (Node k v))   -- ^ 'Ref' to the root node.
+save = do
+  p <- ask
+  liftIO $ C.sync $ state p
+  root' p
+
+
+-- | Lookup minimum key
+findMin :: (Ord k, MonadIO m, C.Cache mc p (Ref (Node k v)) (Node k v)) =>
+           BTreeM m p k v (k, v)
+findMin = modifyLeaf (\(Branch _ rs) -> head rs) $ \_ _ _ -> return . M.findMin
+
+
+-- | Lookup maximum key
+findMax :: (Ord k, MonadIO m, C.Cache mc p (Ref (Node k v)) (Node k v)) =>
+           BTreeM m p k v (k, v)
+findMax = modifyLeaf (\(Branch _ rs) -> last rs) $ \_ _ _ -> return . M.findMax
+
+
+
+-- | Fold with key in left to right order.
+foldli :: (MonadIO m, TreeBackend mc k v, Key k, Value v) =>
+          (a -> k -> v -> a) -> a -> TreeResult m mc k v a
+foldli f a = do p <- ask
+                r <- root' p
+                go p a r
+  where
+    go p a r = do
+      n <- liftIO $ C.eval (state p) $ fetch' r
+      case n of
+        Leaf   ks    -> return $ M.foldlWithKey f a ks
+        Branch ks rs -> foldM (go p) a rs
+
+
+-- | Fold with key in right to left order.
+foldri :: (MonadIO m, TreeBackend mc k v, Key k, Value v) =>
+          (k -> v -> a -> a) -> a -> TreeResult m mc k v a
+foldri f a = do p <- ask
+                r <- root' p
+                go p a r
+  where
+    go p a r = do
+      n <- liftIO $ C.eval (state p) $ fetch' r
+      case n of
+        Leaf ks      -> return $ M.foldrWithKey f a ks
+        Branch ks rs -> foldM (go p) a $ reverse rs
+
+
+
+
+-- | A generalised way of querying the tree. Given two keys @a <= b@ the
+-- function needs to answer @True@ or @False@ as to whether the interval @[a,
+-- b]@ contains interesting keys. No all keys in the interval need be
+-- interesting. This function will then return all interesting keys in an
+-- efficient way.
+search :: (MonadIO m, TreeBackend mc k v, Key k, Value v)
+          => ((k, k) -> Bool)                     -- ^ @f@ defines interesting intervals
+          -> TreeResult m mc k v [(k, v)]         -- ^ A list of chosen (key, value) pairs
+search f = do p  <- ask
+              r  <- root' p
+              lb <- fst `fmap'` findMin -- lower bound
+              ub <- fst `fmap'` findMax -- upper bound
+              go p r lb ub
+  where
+    fmap' f m = m >>= return . f
+
+    go p r lb ub  = do
+      n <- liftIO $ C.eval (state p) $ fetch' r
+      case n of
+        Leaf   ks -> return $ filter (\(k, _) -> f (k, k)) $ M.toList ks
+        Branch ks rs -> do
+          let ints = findInts 0 (lb:ks ++ [ub])
+          ls <- mapM (\(n, lb, ub) -> go p (rs!!n) lb ub) ints
+          return $ concat ls
+      where
+        findInts (!n) (lb:ub:xs) =
+          if f (lb, ub) then (n, lb, ub) : rest else rest
+          where
+            rest = findInts (n+1) (ub:xs)
+        findInts _ _ = []
+
+
+search_ :: (MonadIO m, TreeBackend mc k v, Key k, Value v)
+          => ((k, k) -> Bool)                     -- ^ @f@ defines interesting intervals
+          -> TreeResult m mc k v ()               -- ^ A list of chosen (key, value) pairs
+search_ f = do p  <- ask
+               r  <- root' p
+               lb <- fst `fmap'` findMin -- lower bound
+               ub <- fst `fmap'` findMax -- upper bound
+               tv <- liftIO $ newEmptyMVar
+               liftIO $ go p r lb ub tv
+               liftIO $ takeMVar tv
+  where
+    fmap' f m = m >>= return . f
+
+    go p r lb ub tv = do
+      n <- C.eval (state p) $ fetch' r
+      case n of
+        Leaf   ks -> putMVar tv ()
+        Branch ks rs -> do
+          let ints = findInts 0 (lb:ks ++ [ub])
+          tv' <- newEmptyMVar
+          mapM_ (\(n, lb, ub) -> forkIO $ go p (rs!!n) lb ub tv') ints
+          replicateM_ (length ints) $ takeMVar tv'
+          putMVar tv ()
+      where
+        findInts (!n) (lb:ub:xs) =
+          if f (lb, ub) then (n, lb, ub) : rest else rest
+          where
+            rest = findInts (n+1) (ub:xs)
+        findInts _ _ = []
diff --git a/Data/BTree/Cache/Class.hs b/Data/BTree/Cache/Class.hs
new file mode 100644
--- /dev/null
+++ b/Data/BTree/Cache/Class.hs
@@ -0,0 +1,20 @@
+{-# LANGUAGE MultiParamTypeClasses
+           , FunctionalDependencies
+           , ExistentialQuantification
+  #-}
+
+module Data.BTree.Cache.Class where
+
+import Control.Concurrent.STM
+
+
+data R b = forall a. Inter (IO a) (a -> STM ())
+         | Final b
+
+
+class Monad m => Cache m p k v | m -> p, p -> k, p -> v, p -> m where
+  store  :: Maybe k -> k -> v -> m ()
+  fetch  ::            k -> m (Maybe v)
+  remove :: Maybe k -> k -> m ()
+  sync   :: p ->        IO ()
+  eval   :: p -> m a -> IO a
diff --git a/Data/BTree/Cache/STM.hs b/Data/BTree/Cache/STM.hs
new file mode 100644
--- /dev/null
+++ b/Data/BTree/Cache/STM.hs
@@ -0,0 +1,348 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving
+           , FlexibleContexts
+           , FlexibleInstances
+           , MultiParamTypeClasses
+           , UndecidableInstances
+           , RankNTypes
+           , ScopedTypeVariables
+  #-}
+
+module Data.BTree.Cache.STM where
+
+import Data.Hashable (Hashable)
+import qualified Data.List  as L
+import qualified Data.Map   as M
+import qualified Data.Graph as G
+
+import qualified Data.BTree.Cache.Class     as C
+import qualified Data.BTree.HashTable.STM   as H
+import qualified Data.Serialize             as S
+
+import qualified Data.BTree.KVBackend.Class as KV
+
+import Control.Concurrent.STM
+import Control.Concurrent
+
+import Control.Monad
+import Control.Monad.Trans
+import Control.Monad.Reader
+
+import qualified Data.ByteString as B
+
+import Data.Either
+import Data.Maybe
+import Data.Time.Clock
+import Debug.Trace
+import System.IO
+
+import Control.Monad.Error
+
+
+data State k v = Read             !(Maybe v)
+               | Write !(Maybe k) !(Maybe v)
+               deriving Eq
+
+instance Show (State k v) where
+  show (Read    a) = "Read:  " ++ mtoS a
+  show (Write k a) = "Write: " ++ mtoS a
+
+mtoS a = if isJust a then "Just" else "Nothing"
+
+type AccessTime = UTCTime
+
+
+data Exist = Exist | NoExist
+           deriving (Eq)
+
+data Ref k v = Ref {
+  refST  :: TVar (Either (State k v)
+                  (State k v, Int, State k v)),  -- Current state
+  refExt :: TVar Exist                           -- Exists in external storage?
+  }
+
+
+data Param m k v = Param {
+    cacheSize :: Int
+  , table     :: H.HashTableSTM k (Ref k (Either B.ByteString v))
+  , toIO      :: forall a. m a -> IO a
+  , flushQ    :: TVar [(k, Ref k v)]
+  , timestamp :: UTCTime
+  , genId     :: TVar Int -- Generation ID
+  , genActive :: TVar Int -- Active users of maintained generation
+  }
+
+trace = id
+
+newtype CacheSTM m k v a = CacheSTM { runCacheSTM :: ReaderT (Param m k v) (ErrorT (IO ()) STM) a }
+                         deriving (Monad, MonadReader (Param m k v), MonadError (IO ()), Functor)
+
+instance Error (IO ())
+
+
+stm m = lift $ lift m
+
+
+evalCacheSTM :: Param m k v -> CacheSTM m k v a -> IO a
+evalCacheSTM p m = do
+  mer <- atomically $ runErrorT $ runReaderT (runCacheSTM m) p
+  case mer of
+    Left  io -> io >> evalCacheSTM p m  -- perform IO and retry
+    Right a  -> return a                -- return final result
+
+
+sizedParam :: Int -> (forall a. m a -> IO a) -> IO (Param m k v)
+sizedParam s f = do
+  ts <- getCurrentTime
+  ht <- H.newSized s
+  mv <- atomically $ newTVar []
+  gn <- atomically $ newTVar 0
+  ga <- atomically $ newTVar 0
+  return $ Param s ht f mv ts gn ga
+
+
+getRef k = do
+  p  <- ask
+  ht <- asks table
+  ev <- asks toIO
+  mr <- stm $ H.lookup ht k
+  case mr of
+    Nothing -> fetchRef p ev ht
+    Just r  -> return r
+  where
+    fetchRef p ev ht = throwError $ (ev $ KV.fetch k) >>= createRef p ht
+    createRef p ht bytes = do
+      atomically $ do
+        l <- H.lookup ht k
+        case l of
+          Just _ -> return ()
+          Nothing -> do
+            tvst <- newTVar $ Left $ Read $ Left `fmap` bytes
+            tvex <- newTVar Exist
+            let ref = Ref tvst tvex
+            H.insert ht k ref
+
+
+newRef t k v = do
+  ht <- asks table
+  r@(Ref tv _) <- getRef k
+  -- maybeQueue False tv (k, r)
+  update tv $! Write t v
+  where
+    update tv x = do
+      gt <- asks genId
+      ga <- asks genActive
+      stm $ do
+        gid <- readTVar gt -- Generation ID
+        act <- readTVar ga -- Active users
+        s   <- readTVar tv -- State of ref
+        case s of
+          Left o | act == 0  -> writeTVar tv $! Left  $! x
+                 | otherwise -> writeTVar tv $! Right $! (x, gid, o)
+          Right (x', n, o)
+            | act == 0  -> writeTVar tv $! Left  $! x
+            | gid /= n  -> writeTVar tv $! Right $! (x, gid, x')
+            | otherwise -> writeTVar tv $! Right $! (x, gid, o )
+
+
+maybeQueue force t x =
+  if force then update
+  else do
+    s <- stm $ readTVar t
+    case s of
+      Left  (Write _ _)       -> return () -- Already in queue
+      Right (Write _ _, _, _) -> return ()
+      _                       -> update
+  where
+    update = do
+      qt <- asks flushQ
+      stm $ do q <- readTVar qt
+               writeTVar qt $! x : q
+
+
+store t k v = CacheSTM $ newRef t k $! Just $! Right v
+
+
+-- fetch :: (Eq k, NFData k, Hashable k, KV.KVBackend IO k v) => k -> CacheSTM m k v (Maybe v)
+fetch k = CacheSTM $ do
+  r@(Ref tv _) <- getRef k
+  s <- stm $ readTVar tv
+  case s of
+    Left x          -> return $! value x
+    Right (x, _, _) -> return $! value x
+
+fetchGen n k = CacheSTM $ do
+  r@(Ref tv _) <- getRef k
+  s <- stm $ readTVar tv
+  return $ value $ getGen n s
+
+
+remove t k = CacheSTM $ newRef t k Nothing
+
+
+updateTag t k = CacheSTM $ do
+  ht <- asks table
+  x  <- stm $ H.lookup ht k
+  case x of
+    Nothing           -> return ()
+    Just (Ref tv _) -> do
+      s <- stm $ readTVar tv
+      case s of
+        Left  (Write _ v)       -> stm $ writeTVar tv $! Left  $! Write t v
+        Right (Write _ v, n, o) -> stm $ writeTVar tv $! Right $! (Write t v, n, o)
+        _ -> return ()
+
+
+keys = CacheSTM $ do
+  ht <- asks table
+  stm $ H.keys ht
+
+
+debug  a = liftIO $ do print a
+                       hFlush stdout
+
+getGen n (Left s) = s
+getGen n (Right (news, m, olds))
+  | n == m    = olds
+  | otherwise = news
+
+flipWrite x (Left  (Write _ x'))       | x == x' = Left  $! (Read x)
+flipWrite x (Right (Write _ x', n, o)) | x == x' = Right $! (Read x', n, o)
+flipWrite x (Right (c, n, Write _ x')) | x == x' = Right $! (c, n, Read x')
+flipWrite _ s = s
+
+
+equals a b = value a == value b
+
+
+value v = case v of
+  Read    x -> either decode id `fmap` x
+  Write _ x -> either decode id `fmap` x
+  where
+    decode = either error id . S.decode
+
+
+withGeneration p f = do
+  -- start generation
+  n <- liftIO $ atomically $ do
+    a <- readTVar $ genActive p
+    n <- readTVar $ genId p
+    writeTVar (genActive p) $! a + 1
+    if a > 0 then return n
+      else do writeTVar (genId p) $! n + 1
+              return $! n + 1
+  -- compute
+  x <- f n
+
+  -- end generation
+  liftIO $ atomically $ do
+    a <- readTVar $ genActive p
+    writeTVar (genActive p) $! a - 1
+
+  -- yield result
+  return x
+
+
+flush p = do
+  nowSize <- atomically $ H.size ht
+  gen     <- atomically $ readTVar $ genId p
+  when (nowSize > maxSize) $ do
+    flush =<< (atomically $ H.toList ht)
+  where
+    ht      = table  p
+    maxSize = cacheSize p
+
+    flush ks = do
+      mapM_ (evalCacheSTM p . flushKey ht) ks
+
+
+flushKey ht (k, r@(Ref tvst tvex)) = CacheSTM $ do
+  tvga <- asks genActive
+  tvgi <- asks genId
+  stm $ do
+    act <- readTVar tvga
+    gen <- readTVar tvgi
+    s   <- readTVar tvst
+    case s of
+      Left  (Read  _) ->
+        H.delete ht k >> return Nothing
+
+      Right (Read    s, n, _) | act == 0 || n /= gen ->
+        H.delete ht k >> return Nothing
+
+      Right (Write t s, n, _) | act == 0 || n /= gen ->
+        (writeTVar tvst $! Left $! Write t s) >> return Nothing
+
+      Left (Write t (Just (Right v))) ->
+        (writeTVar tvst $! Left $! Write t $! Just $! Left $! S.encode v)
+        >> return Nothing
+
+      Right (Write t (Just (Right v)), n, o) ->
+        (writeTVar tvst $! Right $! (Write t $! Just $! Left $! S.encode v, n, o))
+        >> return Nothing
+
+      _ -> return $ Just s
+
+
+sync p = do
+  withGeneration p $ \gen -> do
+    -- sync
+    -- TODO: use flush queue
+    ks <- atomically $ H.toList $ table p
+
+    ls <- forM ks $ \(k, r@(Ref tv _)) -> do
+      s <- atomically $ readTVar tv
+      case getGen gen s of
+        Write (Just t) _ -> return $! Just $! Left  (t, k, r)
+        Write Nothing  _ -> return $! Just $! Right (k, r)
+        _                -> return $! Nothing
+
+    let (lefts, rights) = partitionEithers $ catMaybes ls
+
+    mapM_ (evalCacheSTM p . go gen) $ sortByTag lefts
+    mapM_ (evalCacheSTM p . go gen) $ rights
+  where
+    sortByTag :: Ord k => [(k, k, Ref k v)] -> [(k, Ref k v)]
+    sortByTag ls =
+      let m         = M.fromList $ zip (map (\(_, k, _) -> k) ls) [0..]
+          (g, f, _) = G.graphFromEdges
+                      [((k, r), i, maybe [] return $ M.lookup t m)
+                      | ((t, k, r), i) <- zip ls [0..]]
+      in map (\(p, _, _) -> p) $ map f $ G.topSort g
+
+    go gen (k, (r@(Ref tv tvex))) = CacheSTM $ do
+      s  <- stm $ readTVar tv
+      ex <- stm $ readTVar tvex
+      case getGen gen s of
+        -- TODO: handle exist
+        Write _ Nothing | ex == Exist -> throwError write
+                        | otherwise   -> stm $ update Nothing
+
+        Write _ (Just v) -> throwError write
+        _ -> return ()
+
+      where
+        write = do
+          s <- atomically $ readTVar tv
+          case getGen gen s of
+            Write _ Nothing  -> (toIO p $ KV.remove k  ) >> (atomically $ update Nothing)
+            Write _ (Just v) -> (toIO p $ KV.store  k $ either id S.encode $ v)
+                                >> (atomically $ update (Just v))
+            _              -> return ()
+
+        update v = do
+            s <- readTVar tv
+            writeTVar tv $! flipWrite v s
+
+
+liftSTM  = CacheSTM . stm
+fail     = CacheSTM . throwError
+
+
+instance ( Show k, S.Serialize k, S.Serialize v, Ord k, Eq k, Eq v
+         , Hashable k, KV.KVBackend m k B.ByteString) =>
+         C.Cache (CacheSTM m k v) (Param m k v) k v where
+  store  = store
+  fetch  = fetch
+  remove = remove
+  sync   = sync
+  eval   = evalCacheSTM
diff --git a/Data/BTree/Class.hs b/Data/BTree/Class.hs
new file mode 100644
--- /dev/null
+++ b/Data/BTree/Class.hs
@@ -0,0 +1,63 @@
+{-# LANGUAGE MultiParamTypeClasses
+           , GeneralizedNewtypeDeriving
+           , FunctionalDependencies
+           , FlexibleInstances
+           , FlexibleContexts
+           , UndecidableInstances
+  #-}
+
+module Data.BTree.Class where
+
+import Prelude hiding (lookup)
+import Data.Maybe
+import Data.Serialize()
+
+import Control.Monad.Trans
+import Control.Monad
+
+import Data.BTree.Types
+import qualified Data.BTree.BTree as T()
+import qualified Data.BTree.Cache.Class as C()
+import qualified Data.BTree.Cache.STM   as Cstm
+import qualified Data.BTree.KVBackend.Class as KV()
+
+class (Functor m, MonadIO m) => Tree m k v | m -> v, m -> k where
+  -- lookup k <- case lookup k of
+  --               Nothing -> v
+  --               Just v' -> f v v'
+  -- modify f k v = Just v'       if T(k) = v'
+  --              = Nothing       otherwise
+  modify :: (v -> v -> v) -> k -> v -> m (Maybe v)
+
+  modify_ :: (v -> v -> v) -> k -> v -> m ()
+  modify_ f k = void . modify f k
+
+  modifyMany :: [(v -> v -> v, k, v)] -> m ()
+  modifyMany fks = mapM_ (\(f, k, v)  -> modify_ f k v) fks
+
+  delete  :: k                        -> m (Maybe v)
+  delete_ :: k                        -> m ()
+  delete_ = void . delete
+
+  lookup :: k                         -> m (Maybe v)
+
+  member :: k                         -> m Bool
+  member k = isJust `fmap` lookup k
+
+  search :: ((k, k) -> Bool)          -> m [(k, v)]
+
+  foldli :: (a -> k -> v -> a) -> a -> m a
+
+  toList :: m [(k,v)]
+  toList = reverse `fmap` (foldli (\l k v -> (k,v):l) [])
+
+
+type N k v = Node k v
+type R k v = Ref (N k v)
+
+-- Cache Parameter
+type Cp m k v = Cstm.Param m (R k v) (N k v)
+
+
+type S m k v = Cstm.Param m (R k v) (N k v)
+
diff --git a/Data/BTree/HashTable/STM.hs b/Data/BTree/HashTable/STM.hs
new file mode 100644
--- /dev/null
+++ b/Data/BTree/HashTable/STM.hs
@@ -0,0 +1,113 @@
+{-# LANGUAGE TupleSections
+           , BangPatterns
+  #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Data.BTree.HashTable.STM
+-- A hashtable in STM.
+--
+-----------------------------------------------------------------------------
+
+
+module Data.BTree.HashTable.STM
+       ( HashTableSTM
+       , newSized
+       , insert
+       , lookup
+       , delete
+       , size
+       , keys
+       , toList
+       ) where
+
+import Prelude hiding (lookup)
+
+import Control.Concurrent.STM
+import Control.Monad
+
+import Data.Array
+import Data.Hashable (Hashable(..))
+import Data.Maybe
+
+import qualified Data.List as L
+import qualified Data.Map  as M
+
+
+type Bucket k v = M.Map k v
+
+
+data HashTableSTM k v = HashTableSTM { buckets  :: !Int     -- number of buckets
+                                     , count    :: TVar Int -- current element count
+                                     , getArray :: Array Int (TVar (Bucket k v)) }
+
+
+bucket (HashTableSTM n _ arr) k = arr ! (hash k `mod` n)
+{-# INLINE bucket #-}
+
+-- | Create a new HashTable with fixed size
+newSized :: Int -> IO (HashTableSTM k v)
+newSized n =
+  do co <- newTVarIO 0
+     vs <- mapM (\i -> (i,) `fmap` newTVarIO M.empty) [0..n-1]
+     return $! HashTableSTM n co $! array (0, n-1) vs
+
+
+modifyCount h f = do
+  n <- readTVar $ count h
+  writeTVar (count h) $! f n
+{-# INLINE modifyCount #-}
+
+
+-- | /O(log n)/. Insert a key/value pair into HashTable.
+insert :: (Hashable k, Ord k) => HashTableSTM k v -> k -> v -> STM ()
+insert h !k !v = do
+     m <- readTVar b
+     let m' = M.insert k v m
+     writeTVar b $! m'
+     modifyCount h (+1)
+  where
+    b = bucket h k
+
+
+-- | /O(log n)/. Lookup a key in HashTable.
+lookup :: (Hashable k, Ord k) => HashTableSTM k v -> k -> STM (Maybe v)
+lookup h !k =
+  do lst <- readTVar $ bucket h k
+     return $! M.lookup k lst
+
+
+-- | /O(log n)/. Delete a key from HashTable.
+delete :: (Hashable k, Ord k) => HashTableSTM k v -> k -> STM ()
+delete h !k =
+  do m <- readTVar b
+     let (a, m') = M.updateLookupWithKey (\_ _ -> Nothing) k m
+     when (isJust a) $
+       modifyCount h (subtract 1)
+     M.lookup k m' `seq` writeTVar b m'
+  where
+    b = bucket h k
+
+
+-- | /O(1)/. Grab the size of the hash table.
+size :: HashTableSTM k v -> STM Int
+size h = readTVar c
+  where
+    c = count h
+
+
+-- | /O(n)/. Get a list of key/value pairs.
+toList :: HashTableSTM k v -> STM [(k, v)]
+toList h =
+  do bs <- buckets h
+     return $ concat $ map M.toList bs
+  where
+    buckets (HashTableSTM n _ arr) =
+      mapM readTVar $ elems arr
+
+
+-- | /O(n)/. Get a list of keys.
+keys :: HashTableSTM k v -> STM [k]
+keys h =
+  do l <- toList h
+     return $ map fst l
diff --git a/Data/BTree/KVBackend/Class.hs b/Data/BTree/KVBackend/Class.hs
new file mode 100644
--- /dev/null
+++ b/Data/BTree/KVBackend/Class.hs
@@ -0,0 +1,13 @@
+{-# LANGUAGE MultiParamTypeClasses
+           , FunctionalDependencies
+  #-}
+
+module Data.BTree.KVBackend.Class
+       ( KVBackend(..) )
+       where
+
+
+class Monad m => KVBackend m k v | m -> k, m -> v where
+  store  :: k -> v -> m ()
+  fetch  :: k ->      m (Maybe v)
+  remove :: k ->      m ()
diff --git a/Data/BTree/KVBackend/Files.hs b/Data/BTree/KVBackend/Files.hs
new file mode 100644
--- /dev/null
+++ b/Data/BTree/KVBackend/Files.hs
@@ -0,0 +1,77 @@
+{-# LANGUAGE FlexibleInstances
+           , MultiParamTypeClasses
+           , GeneralizedNewtypeDeriving
+           , UndecidableInstances
+           , ScopedTypeVariables
+  #-}
+
+module Data.BTree.KVBackend.Files where
+
+import Debug.Trace
+
+import Prelude hiding (catch)
+
+import Control.Exception
+import Control.Concurrent
+import Control.Monad.Reader
+
+import System.Random
+import System.FilePath
+import System.Directory (removeFile, renameFile)
+
+import Data.Serialize (Serialize, encode, decode)
+
+import qualified Data.ByteString.Char8  as B
+import qualified Data.ByteString.Base64 as B64
+import qualified Data.ByteString.Lazy   as BL
+import Data.Word
+
+import Data.BTree.KVBackend.Util (atomicFileWrite, safeReadFile, safeWriteFile)
+import qualified Data.BTree.KVBackend.Class as KV
+
+import Codec.Compression.Snappy
+
+type Param = FilePath
+
+newtype FilesKV a = FilesKV { runFilesKV :: ReaderT Param IO a }
+                      deriving (Monad, MonadIO, MonadReader Param)
+
+evalFilesKV :: FilePath -> FilesKV a -> IO a
+evalFilesKV p m =
+  runReaderT (runFilesKV m) p
+
+traceThis a = traceShow a a
+
+filePath :: Serialize k => k -> FilesKV FilePath
+filePath path =
+  do dir <- ask
+     return $ dir </> (B.unpack $ B.map fix $ B64.encode $ encode path)
+  where
+    fix '/' = '-'
+    fix c   = c
+
+
+store k v = do path <- filePath k
+               e <- liftIO $! try $! safeWriteFile path bin
+               case e of
+                 Left (e :: IOError) -> do -- File is probably locked
+                   liftIO $ threadDelay 1
+                   store k v
+                 Right _ -> return ()
+  where
+    bin = compress $ encode v
+
+fetch k = do path <- filePath k
+             liftIO $ do bin <- safeReadFile path
+                         return $! either (const Nothing) Just $ decode $ decompress bin
+               `catch` \(_ :: IOError) -> return Nothing
+
+remove k = do path <- filePath k
+              liftIO $ removeFile path
+                `catch` \(_ :: IOError) -> return ()
+
+
+instance (Show k, Serialize k, Serialize v) => KV.KVBackend FilesKV k v where
+  store  k v = store k v
+  fetch  k   = fetch k
+  remove k   = remove k
diff --git a/Data/BTree/KVBackend/Util.hs b/Data/BTree/KVBackend/Util.hs
new file mode 100644
--- /dev/null
+++ b/Data/BTree/KVBackend/Util.hs
@@ -0,0 +1,37 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Data.BTree.KVBackend.Util
+       ( atomicFileWrite
+       , safeWriteFile
+       , safeReadFile
+       ) where
+
+import Prelude hiding (catch)
+
+import qualified Data.ByteString.Char8 as B
+import Data.ByteString.Char8 (ByteString)
+import qualified Data.ByteString.Base64 as B64
+
+import Data.Serialize (Serialize, encode, decode)
+
+import System.FilePath ((<.>), (</>))
+import System.Directory (renameFile, removeFile)
+
+import Control.Exception
+
+import Data.BTree.UUID
+
+
+atomicFileWrite path bytes = do
+  tmp <- (path <.>) `fmap` show `fmap` uuid
+  write tmp
+  where
+    writeThenMove tmp = do
+      B.writeFile tmp bytes
+      renameFile tmp path
+
+    write tmp = do
+      writeThenMove tmp `finally` (removeFile tmp `catch` \(_::IOError) -> return ())
+
+safeWriteFile path bytes = atomicFileWrite path bytes
+safeReadFile  path       = B.readFile path
diff --git a/Data/BTree/Types.hs b/Data/BTree/Types.hs
new file mode 100644
--- /dev/null
+++ b/Data/BTree/Types.hs
@@ -0,0 +1,68 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving
+           , TypeSynonymInstances
+           , FlexibleInstances
+  #-}
+
+module Data.BTree.Types where
+
+import Data.Hashable (Hashable)
+
+import Data.BTree.Cache.Class
+
+import Data.Word
+
+import Data.Serialize
+import Data.Map as M
+import Data.Hashable
+
+import Control.Concurrent.STM
+import Control.Monad.Reader
+
+import System.Random
+
+
+newtype Ref a = Ref Word64
+              deriving (Show, Ord, Eq, Hashable, Num)
+
+
+instance Serialize (Ref a) where
+  put (Ref a) = put a
+  get = Ref `fmap` get
+
+
+data Node k v = Leaf   (M.Map k v)
+              | Branch [k] [Ref (Node k v)]
+              deriving Eq
+
+
+instance (Ord k, Serialize k, Serialize v) => Serialize (Node k v) where
+  put (Leaf ks) =
+    do put (0 :: Word8)
+       put ks
+
+  put (Branch ks rs) =
+    do put (1 :: Word8)
+       put ks
+       put rs
+
+  get = do tag <- get :: Get Word8
+           case tag of
+             0 -> Leaf `fmap` get
+             1 -> do ks <- get
+                     rs <- get
+                     return $ Branch ks rs
+
+
+data Param st k v = Param {
+    order  :: Int
+  , root   :: TVar (Ref (Node k v))
+  , state  :: st
+  , marked :: TChan k
+  , unused :: TVar [Ref (Node k v)]
+  }
+
+
+newtype BTreeM m st k v a = BTreeM { runBTreeM :: ReaderT (Param st k v) m a }
+                       deriving (Monad, MonadIO, MonadReader (Param st k v), Functor)
+
+
diff --git a/IOTreeTestQC.hs b/IOTreeTestQC.hs
new file mode 100644
--- /dev/null
+++ b/IOTreeTestQC.hs
@@ -0,0 +1,202 @@
+{-# LANGUAGE ScopedTypeVariables
+           , TypeSynonymInstances
+  #-}
+
+import Prelude hiding (lookup)
+
+import Control.Concurrent
+import Control.Monad
+import Control.Monad.Trans
+
+import Data.Word
+
+import qualified Data.ByteString.Char8 as B
+
+import qualified Data.BTree.Types           as Ty
+import qualified Data.BTree.BTree           as T
+import qualified Data.BTree.Cache.Class     as C
+import qualified Data.BTree.Cache.STM       as Cstm
+import qualified Data.BTree.KVBackend.Files as Files
+
+import qualified Data.Map as M
+import Data.Maybe
+
+import Test.QuickCheck
+import Test.QuickCheck.Monadic as QCM
+
+import System.Posix.Directory (createDirectory)
+import Test.Util
+
+
+type Index = Word64
+type Key   = Word32
+type Value = Word16
+
+
+data TreeOps = Insert       Key  Value
+             | InsertMany [(Key, Value)]
+
+             | UpdateIndex Index Value
+
+             | ModifyKey   ModFun Key   Value
+             | ModifyIndex ModFun Index Value
+
+             | ModifyMany [(ModFun, Key, Value)]
+
+             | UpdateNoop  Index
+
+             | DeleteKey   Key
+             | DeleteIndex Index
+             | DeleteMany [Index]
+
+             | DeleteMin
+             | DeleteMax
+             deriving (Show)
+
+
+data ModFun = ModFun (Value -> Value -> Value)
+
+
+instance T.Interval Key where
+  between a b = a + ((b - a) `div` 2)
+
+
+instance Show ModFun where
+  show _ = "ModFun"
+
+instance Arbitrary ModFun where
+  arbitrary = ModFun `fmap` (oneof $ map return [
+                                  (+)
+                                , (*)
+                                , (-)
+                                , const
+                                , flip const
+                                ])
+
+
+smallArbitrary :: Arbitrary a => Gen a
+smallArbitrary = sized $ \s -> resize (floor $ sqrt $ fromIntegral s) arbitrary
+
+instance Arbitrary TreeOps where
+  arbitrary = oneof [
+      liftM2 Insert      arbitrary arbitrary
+    , liftM  InsertMany  smallArbitrary
+
+    , liftM3 ModifyKey   arbitrary arbitrary arbitrary
+    , liftM3 ModifyIndex arbitrary arbitrary arbitrary
+    -- , liftM  ModifyMany  arbitrary
+
+    , liftM2 UpdateIndex arbitrary arbitrary
+    , liftM  UpdateNoop  arbitrary
+
+    , liftM  DeleteIndex arbitrary
+    , liftM  DeleteKey   arbitrary
+
+    -- , return DeleteMin
+    -- , return DeleteMax
+    ]
+
+
+-- behaves_like_map_prop :: String -> Property
+behaves_like_map_prop dir root =
+  QCM.monadicIO $
+  do ops <- pick arbitrary
+     eq  <- QCM.run $ interp ops
+     assert eq
+
+  where
+    interp ops =
+      do c <- Cstm.sizedParam 8 $ Files.evalFilesKV dir
+         r <- readMVar root
+         p <- T.makeParam 8 (Just r) c
+
+         l0 <- T.execTree p $ T.toList
+
+         reb <- T.rebalanceProcess p
+         sid <- safeForkIO $ \mv -> forever $ do
+                                    threadDelay $ 10^5
+                                    withMVar mv $ const $
+                                       modifyMVar root $ \_ -> do
+                                         r <- T.execTree p $ T.save
+                                         return (r, ())
+         fid <- safeForkIO $ \mv -> forever $ do
+                                    threadDelay $ 10^5
+                                    withMVar mv $ const $
+                                       Cstm.flush c
+
+
+         m <- T.execTree p $ foldM go (M.fromList l0) ops
+
+         mapM_ safeKill [reb, sid, fid]
+         l1 <- T.execTree p $ T.toList
+
+         return $ M.toList m == l1
+
+    go m op =
+      case op of
+        Insert k v -> do T.modify const k v
+                         return $ M.insert k v m
+
+        InsertMany ks -> do
+          mapM_ (uncurry $ T.modify const) ks
+          return $ foldl (flip $ uncurry $ M.insert) m ks
+
+
+        ModifyKey (ModFun f) k v -> do
+          T.modify f k v
+          return $ M.insertWith f k v m
+
+        ModifyIndex (ModFun f) idx v -> withKey idx $ \k -> do
+          T.modify f k v
+          return $ M.insertWith f k v m
+
+        ModifyMany fkvs -> do
+          mapM_ (\(ModFun f, k, v) -> T.modify f k v) fkvs
+          return $ foldl (\m (ModFun f, k, v) -> M.insertWith f k v m) m fkvs
+
+        UpdateIndex idx v -> withKey idx $ \k -> do
+          T.modify const k v
+          return $ M.insert k v m
+
+        UpdateNoop idx -> withKey idx $ \k -> do
+          T.modify (flip const) k $ fromIntegral k
+          return m
+
+        DeleteIndex idx -> withKey idx $ \k -> do
+          T.delete k
+          return $ M.delete k m
+
+        DeleteKey k -> do
+          T.delete k
+          return $ M.delete k m
+
+        -- Delete-min and delete-max are not yet safe
+        -- DeleteMin
+        --   | M.null m  -> return m
+        --   | otherwise -> do
+        --     (k, _) <- T.findMin
+        --     T.delete k
+        --     return $ M.deleteMin m
+
+        _ -> return m
+
+      where
+        withKey idx f
+          | M.null m  = return m
+          | otherwise = do
+            f $ fst $ M.elemAt (fromIntegral idx `mod` M.size m) m
+
+
+
+main = do
+  let args = stdArgs {maxSuccess = 30, maxSize = 5000}
+  createDirectory dir 493
+  -- Create an empty tree
+  c <- Cstm.sizedParam 8 $ Files.evalFilesKV dir
+  p <- T.makeParam 8 Nothing c
+  r <- T.execTree p T.save
+  root <- newMVar r
+  quickCheckWithResult args $ behaves_like_map_prop dir root
+  where
+    dir  = "btree-conc-test-tmp"
+
diff --git a/README.md b/README.md
new file mode 100644
--- /dev/null
+++ b/README.md
@@ -0,0 +1,7 @@
+btree-concurrent
+================
+
+A backend agnostic, concurrent BTree written in Haskell.
+
+Although the code does work, it is neither production-ready nor complete. See
+the TODO.org file for more details on missing parts.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,10 @@
+#!/usr/bin/env runhaskell
+
+import Control.Monad
+import Distribution.Simple
+import System.Process
+
+main = defaultMainWithHooks simpleUserHooks { postInst = myPostInst }
+
+
+myPostInst args flags desc info = return ()
diff --git a/TODO.org b/TODO.org
new file mode 100644
--- /dev/null
+++ b/TODO.org
@@ -0,0 +1,25 @@
+* Smaller things:
+** Fix the code to give fewer warnings when compiled with -Wall
+
+   There are tons of small things in the code that spit out warnings in GHC or
+   hlint.  Fixing this would likely improve code quality a bit.
+
+** Update this TODO
+   There is probably more things to do that aren't named in here.
+
+
+* Larger things:
+** Should we only allow bytestring as key to avoid serialize/deserialze?
+
+  This could give lower memory usage, since nodes could remains as packed
+  bytestrings at all times. Some c-functions could be introduced to manipulate
+  these in a safe yet efficient way (copy on change).
+
+** Complete the implementations of findMin and findMax.
+
+  Currently, min and max values can only be located if they reside in an
+  outermost leaf. Due to the nature of eventual-balance and lazy rebalancing
+  this is not always the case. The outermost leaf could be empty.
+
+
+
diff --git a/Test/Util.hs b/Test/Util.hs
new file mode 100644
--- /dev/null
+++ b/Test/Util.hs
@@ -0,0 +1,60 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Test.Util
+       ( byteStringToFileName
+       , fileNameToByteString
+       , clearDirectory
+       , safeForkIO
+       , safeKill
+       , decode'
+       )
+       where
+
+import Prelude hiding (catch)
+
+import qualified Data.ByteString.Char8 as B
+import Data.ByteString.Char8 (ByteString)
+import qualified Data.ByteString.Base64 as B64
+import System.Directory
+import Control.Monad
+
+import Data.Serialize (encode, decode)
+
+import System.FilePath ((<.>))
+import System.Directory (renameFile)
+
+import Control.Concurrent
+import Control.Exception
+
+
+byteStringToFileName k = map fixChars $ B.unpack $ B64.encode k
+  where
+    fixChars '/' = '-'
+    fixChars c   = c
+
+fileNameToByteString f = unRight $ B64.decode $ B.pack $ map unfixChars f
+  where
+    unRight (Right x) = x
+    unfixChars '-' = '/'
+    unfixChars c   = c
+
+clearDirectory path = do
+  metaExists <- doesDirectoryExist path
+  when metaExists $
+    removeDirectoryRecursive path
+  createDirectoryIfMissing True path
+
+
+safeForkIO f = do
+  mv  <- newEmptyMVar
+  pid <- forkIO $ f mv
+  putMVar mv pid
+  return mv
+
+
+safeKill m = do
+  withMVar m killThread
+
+
+decode' errmsg a =
+  either (\msg -> error $ errmsg ++ ": " ++ msg) id $ decode a
diff --git a/btree-concurrent.cabal b/btree-concurrent.cabal
new file mode 100644
--- /dev/null
+++ b/btree-concurrent.cabal
@@ -0,0 +1,103 @@
+name:               btree-concurrent
+version:            0.1.0
+homepage:           https://github.com/brinchj/btree-concurrent
+synopsis:           A backend agnostic, concurrent BTree
+description:        A backend agnostic, concurrent BTree
+category:           Data Structures
+license:            LGPL
+author:             Morten Brøns, Johan Brinch
+maintainer:         brinchj@gmail.com
+data-files:         README.md TODO.org
+cabal-version:      >= 1.8
+build-type:         Custom
+stability:          Experimental
+
+
+
+Test-Suite quickcheck-highlevel
+    type:       exitcode-stdio-1.0
+    main-is:    IOTreeTestQC.hs
+
+    other-modules:
+        Test.Util
+
+    build-depends:
+        base == 4.*, unix == 2.5.*, QuickCheck == 2.4.*
+        ,
+        -- Everything the library depends on :-|
+        base == 4.*
+        ,
+        -- control
+        mtl == 2.*, stm == 2.2.*
+        ,
+        -- util
+        old-time == 1.*, random == 1.*, time == 1.*
+        ,
+        -- data structures
+        array == 0.4.*, containers == 0.4.*, hashable == 1.*
+        ,
+        -- packing
+        snappy == 0.2.*
+        ,
+        -- bytestring
+        bytestring == 0.9.*, base16-bytestring == 0.1.*, base64-bytestring == 0.1.*,
+        cereal == 0.3.*
+        ,
+        -- files
+        directory == 1.*, filepath == 1.*
+        ,
+        -- crypto
+        cprng-aes == 0.2.*, entropy >= 0.2
+
+    ghc-options:
+        -threaded
+        -Wall
+
+
+library
+    exposed-modules:
+        Data.BTree.BTree
+        Data.BTree.Class
+        Data.BTree.Types
+
+        Data.BTree.Cache.Class
+        Data.BTree.Cache.STM
+        Data.BTree.HashTable.STM
+
+        Data.BTree.KVBackend.Class
+        Data.BTree.KVBackend.Files
+        Data.BTree.KVBackend.Util
+
+
+    build-depends:
+        base == 4.*
+        ,
+        -- control
+        mtl == 2.*, stm == 2.2.*
+        ,
+        -- util
+        old-time == 1.*, random == 1.*, time == 1.*
+        ,
+        -- data structures
+        array == 0.4.*, containers == 0.4.*, hashable == 1.*
+        ,
+        -- packing
+        snappy == 0.2.*
+        ,
+        -- bytestring
+        bytestring == 0.9.*, base16-bytestring == 0.1.*, base64-bytestring == 0.1.*,
+        cereal == 0.3.*
+        ,
+        -- files
+        directory == 1.*, filepath == 1.*
+        ,
+        -- crypto
+        cprng-aes == 0.2.*, entropy >= 0.2
+
+
+    ghc-options:
+        -funbox-strict-fields
+        -Wall
+        -fno-warn-hi-shadowing
+        -fno-warn-name-shadowing
+        -fno-warn-missing-signatures -O2