fixfile 0.1.0.0 → 0.2.0.0

raw patch · 5 files changed

+461/−232 lines, 5 filesdep +vectorPVP ok

version bump matches the API change (PVP)

Dependencies added: vector

API changes (from Hackage documentation)

Files

• fixfile.cabal +2/−1
• src/Data/FixFile.hs +79/−32
• src/Data/FixFile/BTree.hs +207/−140
• src/Data/FixFile/Set.hs +3/−0
• src/Data/FixFile/Tree23.hs +170/−59

@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/  name:                   fixfile-version:                0.1.0.0+version:                0.2.0.0 synopsis:               File-backed recursive data structures. homepage:               https://github.com/revnull/fixfile license:                LGPL-3@@ -35,6 +35,7 @@                        ,hashtables                        ,containers                        ,lens+                       ,vector   hs-source-dirs:       src   default-language:     Haskell2010   exposed-modules:      Data.FixFile

@@ -1,7 +1,7 @@ {-# LANGUAGE ScopedTypeVariables, RankNTypes, KindSignatures,     MultiParamTypeClasses, FlexibleInstances, FlexibleContexts,     FunctionalDependencies, TypeFamilies, UndecidableInstances,-    DeriveDataTypeable, DeriveGeneric #-}+    DeriveDataTypeable, DeriveGeneric, ConstraintKinds #-}  {- |     @@ -20,7 +20,7 @@     Transactions are used to ensure safety of the unsafe IO.      The data structures used by a 'FixFile' should not be recursive directly,-    but should have instances of 'Foldable', 'Traversable', and 'Binary' and+    but should have instances of 'Typeable', 'Traversable', and 'Binary' and     should be structured such that the fixed point of the data type is     recursive. @@ -44,7 +44,9 @@                      ,para                      ,iso                      -- * Root Data-                     ,Root(..)+                     ,Fixable+                     ,FixTraverse(..)+                     ,Root                      ,Ptr                      ,Ref(..)                      ,ref@@ -62,7 +64,9 @@                      ,lookupT                      ,readTransaction                      ,writeTransaction+                     ,writeExceptTransaction                      ,subTransaction+                     ,getRoot                      ,getFull                      ) where @@ -71,9 +75,8 @@ import Control.Concurrent.MVar import Control.Exception import Control.Lens hiding (iso, para)+import Control.Monad.Except import qualified Control.Monad.RWS as RWS-import Control.Monad.Identity hiding (mapM)-import Control.Monad.Trans import Data.Binary import Data.ByteString.Lazy as BSL import Data.Dynamic@@ -82,7 +85,6 @@ import qualified Data.Map as M import Data.Maybe import Data.Monoid-import Data.Traversable (mapM) import GHC.Generics import System.FilePath import System.Directory@@ -219,26 +221,39 @@ instance Hashable (Ptr f) where     hashWithSalt x (Ptr y) = hashWithSalt x y +-- | A Constraint for data that can be used with a 'Ref'+type Fixable f = (Traversable f, Binary (f (Ptr f)), Typeable f)+ {- |-    A 'Root' datastructure acts as a kind of header that can contain one or-    more 'Ref's to different recursive structures. It takes one argument,-    which has the kind of @((* -> *) -> *)@. This argument should be either an-    instance of 'Fixed' or a 'Ptr'. If it is an instance of 'Fixed', then-    the 'Root' can contain recursive data structures. If it is passed 'Ptr'-    as an argument, then the 'Root' will contain a non-recursive structure,-    but can be serialized.+    'FixTraverse' is a class based on 'Traverse' but taking an argument of kind+    @(* -> *) -> *)@ instead of @*@.+-}+class FixTraverse (t :: ((* -> *) -> *) -> *) where+    -- | Given a function that maps from @a@ to @b@ over @'Fixable' g@ in the+    --   'Applicative' @f@, traverse over @t@ changing the fixed-point+    --   combinator from @a@ to @b@.+    sequenceAFix :: Applicative f =>+        (forall g. Fixable g => a g -> f (b g)) -> t a -> f (t b) +{- | +    A 'Root' is a datastructure that is an instance of 'FixTraverse' and+    'Binary'. This acts as a sort of "header" for the file where the 'Root'+    may have several 'Ref's under it to different 'Functors'. -}-class Root (r :: (((* -> *) -> *) -> *)) where-    -- | Deserialize @'r' 'Ptr'@ inside a 'Transaction'.-    readRoot :: r Ptr -> Transaction r' s (r (Stored s))-    -- | Serialize @'r' 'Ptr'@ inside a 'Transaction'. This will result in-    -- | changes to any recursive structures to be written as well.-    writeRoot :: r (Stored s) -> Transaction r' s (r Ptr) -    -- | 'iso', but applied to an instance of 'Root'.-    rootIso :: (Fixed g, Fixed h) => r g -> r h+type Root r = (FixTraverse r, Binary (r Ptr)) +readRoot :: Root r => r Ptr -> Transaction r' s (r (Stored s))+readRoot = sequenceAFix readPtr where+    readPtr p = withHandle $ flip readStoredLazy p++writeRoot :: Root r => r (Stored s) -> Transaction r' s (r Ptr)+writeRoot = sequenceAFix writeStored where+    writeStored s = withHandle $ flip sync s++rootIso :: (Root r, Fixed g, Fixed h) => r g -> r h+rootIso = runIdentity . sequenceAFix (Identity . iso)+ {- |     A 'Ref' is a reference to a 'Functor' 'f' in the 'Fixed' instance of 'g'. @@ -248,13 +263,11 @@ data Ref (f :: * -> *) (g :: (* -> *) -> *) = Ref { deRef :: g f }     deriving (Generic) -instance (Typeable f, Binary (f (Ptr f)), Traversable f) => Root (Ref f) where-    readRoot (Ref p) = Ref <$> (withHandle $ flip readStoredLazy p)-    writeRoot (Ref a) = Ref <$> (withHandle $ flip sync a)-    rootIso = Ref . iso . deRef- instance Binary (Ref f Ptr) +instance Fixable f => FixTraverse (Ref f) where+    sequenceAFix isoT (Ref a) = Ref <$> isoT a+ -- | Lens for accessing the value stored in a Ref ref :: Lens' (Ref f g) (g f) ref = lens (\(Ref a) -> a) (\_ b -> Ref b)@@ -361,8 +374,7 @@     Create a 'FixFile', using @'Fix' f@ as the initial structure to store     at the location described by 'FilePath'. -}-createFixFile :: (Root r, Binary (r Ptr), Typeable r) =>-    r Fix -> FilePath -> IO (FixFile r)+createFixFile :: Root r => r Fix -> FilePath -> IO (FixFile r) createFixFile initial path =     openFile path ReadWriteMode >>= createFixFileHandle initial path @@ -371,7 +383,7 @@     at the location described by 'FilePath' and using the 'Handle' to the     file to be created. -}-createFixFileHandle :: (Root r, Binary (r Ptr), Typeable r) =>+createFixFileHandle :: Root r =>     r Fix -> FilePath -> Handle -> IO (FixFile r) createFixFileHandle initial path h = do     ffh <- FFH <$> newMVar h <*> newMVar M.empty@@ -435,7 +447,7 @@     the readTransaction in that the root object stored in the file can     potentially be updated by this 'Transaction'. -}-writeTransaction :: (Root r, Binary (r Ptr), Typeable r) => +writeTransaction :: Root r =>      FixFile r -> (forall s. Transaction r s a)     -> IO a writeTransaction ff@(FixFile _ ffhmv _) t = res where@@ -456,6 +468,42 @@         return a  {- |+    The 'writeExceptTransaction' function behaves like 'writeTransaction', but+    applies to a 'Transaction' wrapped in 'ExceptT'. In the event that an+    exception propagates through the 'Transaction', the updates are not+    committed to disk.++    This is meant to provide a mechanism for aborting 'Transaction's.+-}+writeExceptTransaction :: Root r => +    FixFile r -> (forall s. ExceptT e (Transaction r s) a)+    -> IO (Either e a)+writeExceptTransaction ff@(FixFile _ ffhmv _) t = res where+    res = withWriteLock ff runTransaction+    runTransaction = do+        (ffh, root) <- readMVar ffhmv+        let t' = readRoot root >>= RWS.put >> runExceptT t >>= save+            save l@(Left _) = return l+            save r@(Right _) = do+                dr <- RWS.get >>= writeRoot+                (withHandle $ putRawBlock dr) >>= updateHeader+                Transaction . RWS.tell . Last . Just $ dr+                return r+        (a, root') <- RWS.evalRWST (runRT t') ffh undefined+        case (a, getLast root') of+            (Right _, Just root'') -> do+                void $ swapMVar ffhmv (ffh, root'')+            _ -> return ()+        return a+++{- |+    Get the root datastructure from the transaction as @r 'Fix'@.+-}+getRoot :: Root r => Transaction r s (r Fix)+getRoot = rootIso <$> RWS.get++{- |     Get the full datastructure from the transaction as a @'Fix' f@. -} getFull :: Functor f => Transaction (Ref f) s (Fix f)@@ -470,8 +518,7 @@     The memory usage of this operation scales with the recursive depth of the     structure stored in the file. -}-vacuum :: (Root r, Binary (r Ptr), Typeable r) =>-    FixFile r -> IO ()+vacuum :: Root r => FixFile r -> IO () vacuum ff@(FixFile path mv _) = withWriteLock ff runVacuum where     runVacuum = do         mval <- takeMVar mv

@@ -1,5 +1,5 @@ {-# LANGUAGE DeriveGeneric, DeriveFunctor, DeriveFoldable, DeriveTraversable,-    DeriveDataTypeable #-}+    DeriveDataTypeable, DataKinds, KindSignatures #-}  {- |     Module      :  Data.FixFile.BTree@@ -17,6 +17,7 @@                           ,createBTreeFile                           ,openBTreeFile                           ,empty+                          ,depth                           ,insertBTree                           ,insertBTreeT                           ,lookupBTree@@ -25,231 +26,297 @@                           ,filterBTreeT                           ,deleteBTree                           ,deleteBTreeT+                          ,partitionBTree                           ,toListBTree                           ,fromListBTree                           ) where -import Data.Array+import Control.Monad.Writer import Data.Binary import Data.Dynamic+import qualified Data.Vector as V import GHC.Generics+import GHC.TypeLits  import Data.FixFile  {- |-    A 'Fixed' @('BTree' k v)@ stores a BTree of key/value pairs.+    A 'Fixed' @('BTree' n k v)@ stores a BTree of key/value pairs.+    'n' should be a 'Nat' and will be the maximum number of elements in each+    branch of the 'BTree'. -}-data BTree k v a =+data BTree (n :: Nat) k v a =     Empty   | Value v-  | Node Word32 (Array Int (k, a))+  | Node Word32 (V.Vector (k, a))     deriving (Read, Show, Generic, Functor, Foldable, Traversable, Typeable) -instance (Binary k, Binary v, Binary a) => Binary (BTree k v a)+instance (Binary k, Binary v, Binary a) => Binary (BTree n k v a) where+    put Empty = putWord8 0x45+    put (Value v) = putWord8 0x56 >> put v+    put (Node d vec) = do+        putWord8 0x4e+        put d+        put (V.length vec)+        mapM_ put vec+    get = getWord8 >>= getBTree where+        getBTree 0x45 = return Empty+        getBTree 0x56 = Value <$> get+        getBTree 0x4e = Node <$> get <*> (get >>= \n -> V.replicateM n get)+        getBTree _ = error "Can't decode into BTree" +-- | Compute the depth of a 'BTree' +depth :: Fixed g => g (BTree n k v) -> Int+depth = cata phi where+    phi Empty = 0+    phi (Value _) = 1+    phi (Node d _) = fromIntegral $ 1 + d+ -- | An empty 'BTree' -empty :: Fixed g => g (BTree k v)+empty :: Fixed g => g (BTree n k v) empty = inf Empty -value :: Fixed g => v -> g (BTree k v)+value :: Fixed g => v -> g (BTree n k v) value = inf . Value -node :: Fixed g => Word32 -> Array Int (k, g (BTree k v)) -> g (BTree k v)+node :: Fixed g => Word32 -> V.Vector (k, g (BTree n k v)) -> g (BTree n k v) node d = inf . Node d  -- | Create a 'FixFile' storing a @('BTree' k v)@. --   The initial value is 'empty'.-createBTreeFile :: (Binary k, Typeable k, Binary v, Typeable v) =>-    FilePath -> IO (FixFile (Ref (BTree k v)))+createBTreeFile :: (Typeable n, Binary k, Typeable k, Binary v, Typeable v) =>+    FilePath -> IO (FixFile (Ref (BTree n k v))) createBTreeFile fp = createFixFile (Ref empty) fp  -- | Open a 'FixFile' storing a @('BTree' k v)@. openBTreeFile :: (Binary k, Typeable k, Binary v, Typeable v) =>-    FilePath -> IO (FixFile (Ref (BTree k v)))+    FilePath -> IO (FixFile (Ref (BTree n k v))) openBTreeFile = openFixFile -nodeSize :: Integral i => i-nodeSize = 32+treeNodeSize :: KnownNat n => g (BTree n k v) -> Integer+treeNodeSize = validate . natVal . p where+    p :: g (BTree n k v) -> Proxy n+    p _ = Proxy+    validate n = if n < 2+        then error "BTree branch size must be > 1."+        else n -lookupPos :: (Ord k) => Bool -> k -> Array Int (k, v) ->-    (Int, [(k, v)], (k, v), [(k, v)])-lookupPos ff k arr = result . findFirst . uncurry binary $ bounds arr where-    result i =-        let (a, b:c) = splitAt i $ elems arr-        in (i, a, b, c)-    lookupi = fst . (arr !)-    findFirst = if ff then findFirst' else id-    findFirst' 0 = 0-    findFirst' i = if lookupi (i - 1) == k-        then findFirst' (i - 1)-        else i-    binary mini maxi = -        let avg = (maxi + mini) `div` 2-            avgi = lookupi avg-        in case (maxi - mini <= 1, compare k avgi) of -            (True, _) -> if lookupi maxi <= k then maxi else mini-            (_, EQ) -> avg-            (_, LT) -> binary mini (avg - 1)-            (_, _) -> binary avg maxi+splitRange :: Ord k => k -> V.Vector (k, v) -> (Int, Int)+splitRange k vec = V.foldl' rangeSum (0,0) vec where+    rangeSum t@(i1, i2) (k', _)+        | k' < k = (i1 `seq` i1 + 1, i2 `seq` i2 + 1)+        | k == k' = (i1, i2 `seq` i2 + 1)+        | otherwise = t -splitRange :: (Ord k) => k -> Array Int (k, v) ->-    ([(k,v)], [(k,v)], [(k,v)])-splitRange k = uncurry splitMax . splitMin id Nothing . elems where-    splitMin f Nothing [] = (f [], [])-    splitMin f (Just t) [] = (f [], [t])-    splitMin f Nothing xl@(xt@(xk,_):xs) = case compare xk k of-        LT -> splitMin f (Just xt) xs-        _ -> (f [], xl)-    splitMin f (Just t) xl@(xt@(xk,_):xs) = case compare xk k of-        LT -> splitMin (f . (t:)) (Just xt) xs-        _ -> (f [], t:xl)-    splitMax p xs = -        let (c, n) = splitMax' id xs-        in (p, c, n)-    splitMax' f [] = (f [], [])-    splitMax' f xl@(xt@(xk,_):xs) = case compare xk k of-        GT -> (f [], xl)-        _ -> splitMax' (f . (xt:)) xs+split3 :: (Int, Int) -> V.Vector a -> (V.Vector a, V.Vector a, V.Vector a)+split3 (s1, s2) vec = (vl, vm, vr) where+    (vm',vr) = V.splitAt s2 vec+    (vl, vm) = V.splitAt s1 vm' -data Insert k v g =-    Inserted k (g (BTree k v))-  | Split Word32 (k, (g (BTree k v))) (k, (g (BTree k v)))+data Insert n k v g =+    Inserted k (g (BTree n k v))+  | Split Word32 (k, (g (BTree n k v))) (k, (g (BTree n k v)))  -- | Insert the value 'v' with the key 'k' into a 'Fixed' @('BTree' k v)@.-insertBTree :: (Ord k, Fixed g) => k -> v -> g (BTree k v) -> g (BTree k v)-insertBTree k v = merge . para phi where+insertBTree :: (KnownNat n, Ord k, Fixed g) => k -> v -> g (BTree n k v) ->+    g (BTree n k v)+insertBTree k v t = merge . para phi $ t where     merge (Inserted _ x) = x-    merge (Split d lt rt) = node (d + 1) $ array (0, 1)-        [(0, lt), (1, rt)]-    -    newNode d c ls = if c > nodeSize-        then-            let (l, r) = splitAt half ls-                half = nodeSize `div` 2-                half' = c - half-                mini = fst . head-            in Split d (mini l, node d $ array (0, half - 1) $ zip [0..] l)-                (mini r, node d $ array (0, half' - 1) $ zip [0..] r)-        else Inserted (fst $ head ls) (node d $ array (0, c-1) $ zip [0..] ls)+    merge (Split d lt rt) = node (d + 1) $ V.fromList [lt, rt]+    nodeSize = fromIntegral $ treeNodeSize t -    children xs = [(i, x) | (i, (x, _)) <- xs]+    newNode d c cs+        | c > nodeSize =+            let (l, r) = V.splitAt (nodeSize `div` 2) cs+                l' = V.force l+                r' = V.force r+                mini = fst . V.head+            in Split d (mini l, node d l') (mini r, node d r')+        | otherwise = +            Inserted (fst $ V.head cs) (node d cs) -    phi Empty = Inserted k $ node 0 $ array (0,0) [(0, (k, value v))]+    nodes = fmap (\(a,(b,_)) -> (a, b))++    phi Empty = Inserted k $ node 0 $ V.singleton (k, value v)     phi (Value _) = error "insertBTree phi Value error"-    phi (Node 0 a) =-        let (_, p, (kc, (km, _)), n) = lookupPos False k a-            newSize = (2+) . snd . bounds $ a-        in if kc <= k-            then newNode 0 newSize $-                children p ++ [(kc, km), (k, value v)] ++ children n-            else newNode 0 newSize $-                children p ++ [(k, value v), (kc, km)] ++ children n-    phi (Node d a) =-        let (_, p, (_, (_, ka)), n) = lookupPos False k a-            newSize = 1 + currSize-            currSize = (1+) . snd . bounds $ a-        in case ka of-            Inserted k' n' -> newNode d currSize $-                children p ++ (k', n'):children n-            Split _ lt rt -> newNode d newSize $-                children p ++ [lt, rt] ++ children n +    phi (Node 0 vec) =+        let (lt, eq, gt) = split3 (splitRange k vec) (nodes vec)+            newSize = 1 + V.length vec+        in newNode 0 newSize (V.concat [lt, eq, V.singleton (k, value v), gt])+    phi (Node d vec) = +        let (lt, eq, gt) = split3 (splitRange k vec) vec+            lt' = nodes lt+            eq' = nodes eq+            gt' = nodes gt+            currSize = V.length vec+            (c, csf) = case (V.null eq, V.null lt) of+                (False, _) ->+                    (V.last eq, \n -> V.concat [lt', V.init eq', n, gt'])+                (_, False) ->+                    (V.last lt, \n -> V.concat [V.init lt', n, gt'])+                _ -> (V.head gt, \n -> V.concat [n, V.tail gt'])+        in case snd (snd c) of+            Inserted k' n' ->+                newNode d currSize (csf $ V.singleton (k', n'))+            Split _ ls rs ->+                newNode d (currSize + 1) (csf $ V.fromList [ls, rs])+ -- | 'Transaction' version of 'insertBTree'.-insertBTreeT :: (Ord k, Binary k, Binary v) => k -> v ->-    Transaction (Ref (BTree k v)) s ()+insertBTreeT :: (KnownNat n, Ord k, Binary k, Binary v) => k -> v ->+    Transaction (Ref (BTree n k v)) s () insertBTreeT k v = alterT (insertBTree k v)  -- | Lookup the values stored for the key 'k' in a 'Fixed' @('BTree' k v)@.-lookupBTree :: (Ord k, Fixed g) => k -> g (BTree k v) -> [v]+lookupBTree :: (Ord k, Fixed g) => k -> g (BTree n k v) -> [v] lookupBTree k = ($ []) . cata phi where     phi Empty l = l     phi (Value v) l = v:l-    phi (Node 0 a) l = foldr ($) l . fmap snd . filter ((k ==) . fst) . elems-        $ a-    phi (Node _ a) l =-        let (_, c, _) = splitRange k a-        in foldr ($) l $ fmap snd c+    phi (Node 0 vec) l =+        let (_, eq, _) = split3 (splitRange k vec) vec+        in V.foldr (($) . snd) l eq+    phi (Node _ vec) l =+        let (_, eq, _) = split3 (s1 - 1, s2) vec+            (s1, s2) = splitRange k vec+        in V.foldr (($) . snd) l eq  -- | 'Transaction' version of 'lookupBTree'. lookupBTreeT :: (Ord k, Binary k, Binary v) => k ->-    Transaction (Ref (BTree k v)) s [v]+    Transaction (Ref (BTree n k v)) s [v] lookupBTreeT k = lookupT (lookupBTree k) -data Deleted k v g =-    Deleted k (g (BTree k v))+data Deleted n k v g =+    Deleted k (g (BTree n k v))   | AllDeleted   | UnChanged  -- | Filter items from a 'Fixed' @('BTree' k v)@ for a key 'k' that match --   the predicate. filterBTree :: (Ord k, Fixed g) => k -> (v -> Bool) ->-    g (BTree k v) -> g (BTree k v)+    g (BTree n k v) -> g (BTree n k v) filterBTree k f t = deleted' . para phi $ t where     deleted' UnChanged = t     deleted' AllDeleted = empty     deleted' (Deleted _ x) = x++    nodes = fmap (\(a, (b, _)) -> (a, b))+     phi Empty = UnChanged     phi (Value v) = if f v         then UnChanged         else AllDeleted-    phi (Node 0 a) =-        let al = do-                (nk, (nn, nv)) <- elems a-                case (nk == k, nv) of-                    (False, _) -> return (False, ((nk, nn):))-                    (_, UnChanged) -> return (False, ((nk, nn):))-                    _ -> return (True, id)-            alb = foldr ((||) . fst) False al-            al' = foldr (($) . snd) [] al-            mink = fst . head $ al'-        in case (alb, null al') of-            (True, True) -> AllDeleted-            (True, False) -> Deleted mink $ node 0 $-                array (0, length al' - 1) $ zip [0..] al'-            (False, _) -> UnChanged-    phi (Node d a) = -        let (p, c, n) = splitRange k a-            p' = [(nk, nv) | (nk, (nv, _)) <- p]-            c'' = do-                (nk, (nn, nv)) <- c-                case nv of-                    UnChanged -> return (False, ((nk, nn):))-                    AllDeleted -> return (True, id)-                    Deleted k' v' -> return (True, ((k', v'):))-            c' = foldr (($) . snd) [] c''-            cb = foldr ((||) . fst) False c''-            n' = [(nk, nv) | (nk, (nv, _)) <- n]-            al = p' ++ c' ++ n'-            mink = fst . head $ al-        in case (cb, null al) of-            (False, _) -> UnChanged-            (True, True) -> AllDeleted-            (True, False) -> Deleted mink $ node d $-                array (0, length al - 1) $ zip [0..] al +    phi (Node 0 vec) =+        let (lt, eq, gt) = split3 (splitRange k vec) vec+            lt' = nodes lt+            gt' = nodes gt+            (eq',del) = runWriter $ do+                res <- flip V.filterM eq $ \(_, (_, a)) ->+                    case a of+                        UnChanged -> return True+                        _ -> tell (Any True) >> return False+                return $ nodes res+            vec' = V.concat [lt', eq', gt']+            mink = fst (V.head vec')+        in case (V.null vec', getAny del) of+            (True, _) -> AllDeleted+            (_, False) -> UnChanged+            _ -> Deleted mink $ node 0 vec'+    phi (Node d vec) =+        let (lt, eq, gt) = split3 (s1 - 1, s2) vec+            (s1, s2) = splitRange k vec+            lt' = nodes lt+            gt' = nodes gt+            (eq',del) = runWriter $ do+                res <- flip V.filterM eq $ \(_, (_, a)) ->+                    case a of+                        UnChanged -> return True+                        Deleted _ _ -> tell (Any True) >> return True+                        AllDeleted -> tell (Any True) >> return False+                forM res $ \(nk, (n, a)) -> do+                    case a of+                        UnChanged -> return (nk, n)+                        Deleted nk' a' -> return (nk', a')+                        AllDeleted -> error "AllDeleted?" -- should be unreachable+            vec' = V.concat [lt', eq', gt']+            mink = fst (V.head vec')+        in case (V.null vec', getAny del) of+            (True, _) -> AllDeleted+            (_, False) -> UnChanged+            _ -> Deleted mink $ node d vec'+ -- | 'Transaction' version of 'filterBTree'. filterBTreeT :: (Ord k, Binary k, Binary v) => k -> (v -> Bool) ->-    Transaction (Ref (BTree k v)) s ()+    Transaction (Ref (BTree n k v)) s () filterBTreeT k f = alterT (filterBTree k f)  -- | Delete all items for key 'k' from the 'Fixed' @('BTree' k v)@.-deleteBTree :: (Ord k, Fixed g) => k -> g (BTree k v) -> g (BTree k v)+deleteBTree :: (Ord k, Fixed g) => k -> g (BTree n k v) -> g (BTree n k v) deleteBTree k = filterBTree k (const False)  -- | 'Transaction' version of 'deleteBTree'. deleteBTreeT :: (Ord k, Binary k, Binary v) => k ->-    Transaction (Ref (BTree k v)) s ()+    Transaction (Ref (BTree n k v)) s () deleteBTreeT k = alterT (deleteBTree k) +data SkewDir = L | R++data Parted n k v g =+    NoPart SkewDir+  | Parted (k, (g (BTree n k v))) (k, (g (BTree n k v)))++-- | Split a 'BTree' into two two 'BTree's with keys < 'k' and keys > 'k'.+partitionBTree :: (Ord k, Fixed g) => k -> g (BTree n k v) ->+    (g (BTree n k v), g (BTree n k v))+partitionBTree k t = parted . para phi $ t where+    parted (NoPart L) = (t, empty)+    parted (NoPart R) = (empty, t)+    parted (Parted (_, l) (_, r)) = (l, r)++    nodes = fmap (\(a, (b, _)) -> (a, b))++    phi Empty = NoPart L+    phi (Value _) = error "Unbalanced BTree"+    phi (Node 0 vec) =+        let (lt, gte) = V.splitAt s1 vec+            (s1, _) = splitRange k vec+            minkl = fst (V.head lt)+            minkr = fst (V.head gte)+        in case (V.null lt, V.null gte) of+            (True, _) -> NoPart R+            (_, True) -> NoPart L+            _ -> Parted (minkl, node 0 (nodes lt)) (minkr, node 0 (nodes gte))+    phi (Node d vec) = +        let (lt, eq, gt) = split3 (s1 - 1, s1) vec+            (s1, _) = splitRange k vec+            lt' = nodes lt+            eq' = nodes eq+            gt' = nodes gt+            minkl = if V.null lt then fst (V.head eq) else fst (V.head lt)+            (_,(_,eqa)) = V.head eq+        in case (V.null eq, V.null gt, eqa) of+            (True, _, _) -> NoPart R+            (_, True, NoPart L) -> NoPart L+            (_, _, NoPart R) -> error "Malformed BTree"+            (_, _, NoPart L) ->+                let minkr = fst (V.head gt')+                    ln = node d (V.concat [lt', eq'])+                    rn = node d (V.force gt')+                in Parted (minkl, ln) (minkr, rn)+            (_, _, Parted tl tr@(prk, _)) ->+                let ln = node d (V.concat [lt', V.singleton tl])+                    rn = node d (V.concat [V.singleton tr, gt'])+                in Parted (minkl, ln) (prk, rn)+ -- | Turn a 'Fixed' @('BTree' k v)@ into a list of key value tuples.-toListBTree :: (Ord k, Fixed g) => g (BTree k v) -> [(k,v)]+toListBTree :: (Ord k, Fixed g) => g (BTree n k v) -> [(k,v)] toListBTree t = cata phi t Nothing [] where     phi Empty _ l = l     phi (Value v) (Just k) l = (k, v):l     phi (Value _) _ _ = error "Value with no Key"-    phi (Node _ a) _ l = foldr (\(k,v) -> ((v (Just k)) .)) id (elems a) l+    phi (Node _ vec) _ l = V.foldr (\(k,v) -> ((v (Just k)) .)) id vec l  -- | Turn a list of key value tuples into a 'Fixed' @('BTree' k v)@.-fromListBTree :: (Ord k, Fixed g) => [(k,v)] -> g (BTree k v)+fromListBTree :: (KnownNat n, Ord k, Fixed g) => [(k,v)] -> g (BTree n k v) fromListBTree = foldr (uncurry insertBTree) empty 

@@ -29,6 +29,7 @@                          ,toListSetT                          ) where + import Prelude hiding (lookup)  import Data.Binary@@ -39,6 +40,8 @@ {- |     A 'Fixed' @('Set' i)@ is a set of items represented as a binary tree. -}+{-# WARNING Set "Set is unbalanced and not recommended." #-}+ data Set i a = Empty | Node a i a     deriving (Read, Show, Generic, Functor, Foldable, Traversable, Typeable) 

@@ -14,10 +14,10 @@     used with 'FixFile'. It has two interfaces that are -} module Data.FixFile.Tree23 (Tree23-                           ,TreeD                            ,empty                            ,null                            ,size+                           ,depth                            -- | * Set                            ,Set                            ,createSetFile@@ -25,11 +25,13 @@                            ,insertSet                            ,lookupSet                            ,deleteSet+                           ,partitionSet                            ,toListSet                            ,fromListSet                            ,insertSetT                            ,lookupSetT                            ,deleteSetT+                           ,partitionSetT                            -- | * Map                            ,Map                            ,createMapFile@@ -37,6 +39,7 @@                            ,insertMap                            ,lookupMap                            ,deleteMap+                           ,partitionMap                            ,alterMap                            ,mapMap                            ,toListMap@@ -44,9 +47,11 @@                            ,insertMapT                            ,lookupMapT                            ,deleteMapT+                           ,partitionMapT                            ,alterMapT                            ,keysMap                            ,valuesMap+                           ,partitionTree23                            ) where  import Prelude hiding (null)@@ -67,15 +72,12 @@             Typeable)  {- |-    'Fixed' @('TreeD' d)@ represents a Two-Three tree. The data type 'd' should+    'Fixed' @('Tree23' d)@ represents a Two-Three tree. The data type 'd' should     have data families for it's key and value. These data families are not     exported from the module. As a result, the only valid types for 'd' are     @('Set' k)@ as defined here or @('Map' k v)@, also defined here. -}-type TreeD d = Tree23F (TreeKey d) (TreeValue d)---- | Type synonym for the 'Fixed' representation of a Two-Three Tree.-type Tree23 g d = g (TreeD d)+type Tree23 d = Tree23F (TreeKey d) (TreeValue d)  data family TreeKey d @@ -85,35 +87,43 @@     Binary (Tree23F (TreeKey d) (TreeValue d) a)  -- | An empty 'Fixed' 'Tree23'.-empty :: Fixed g => Tree23 g d+empty :: Fixed g => g (Tree23 d) empty = inf Empty -leaf :: Fixed g => TreeKey d -> TreeValue d -> Tree23 g d+leaf :: Fixed g => TreeKey d -> TreeValue d -> g (Tree23 d) leaf k v = inf $ Leaf k v -two :: Fixed g => Tree23 g d -> TreeKey d ->-    Tree23 g d -> Tree23 g d+two :: Fixed g => g (Tree23 d) -> TreeKey d ->+    g (Tree23 d) -> g (Tree23 d) two l v r = inf $ Two l v r -three :: Fixed g => Tree23 g d -> TreeKey d -> Tree23 g d ->-    TreeKey d -> Tree23 g d -> Tree23 g d+three :: Fixed g => g (Tree23 d) -> TreeKey d -> g (Tree23 d) ->+    TreeKey d -> g (Tree23 d) -> g (Tree23 d) three l t1 m t2 r =     inf $ Three l t1 m t2 r  -- | Predicate that returns true if there are no items in the 'Tree23'.-null :: Fixed g => Tree23 g d -> Bool+null :: Fixed g => g (Tree23 d) -> Bool null = null' . outf where     null' Empty = True     null' _ = False  -- | Number of entries in @('Tree23' g d)@.-size :: Fixed g => Tree23 g d -> Int+size :: Fixed g => g (Tree23 d) -> Int size = cata phi where     phi Empty = 0     phi (Leaf _ _) = 1     phi (Two l _ r) = l + r     phi (Three l _ m _ r) = l + m + r +-- | The depth of @('Tree23' g d)@. @0@ represents en empty Tree.+depth :: Fixed g => g (Tree23 d) -> Int+depth = cata phi where+    phi Empty = 0+    phi (Leaf _ _) = 1+    phi (Two l _ _) = l + 1+    phi (Three l _ _ _ _) = l + 1+ -- | A 'Set' of 'k' represented as a Two-Three Tree. data Set k @@ -128,19 +138,23 @@ instance Binary (TreeValue (Set k))  -- | Insert an item into a set.-insertSet :: (Fixed g, Ord k) => k -> Tree23 g (Set k) -> Tree23 g (Set k)+insertSet :: (Fixed g, Ord k, f ~ Tree23 (Set k)) => k -> g f -> g f insertSet k = alterTree23 (SK k) (maybe (Just $ Just SV) (const Nothing))  -- | Lookup an item in a set.-lookupSet :: (Fixed g, Ord k) => k -> Tree23 g (Set k) -> Bool+lookupSet :: (Fixed g, Ord k, f ~ Tree23 (Set k)) => k -> g f -> Bool lookupSet k = isJust . lookupTree23 (SK k)  -- | Delete an item from a set.-deleteSet :: (Fixed g, Ord k) => k -> Tree23 g (Set k) -> Tree23 g (Set k)+deleteSet :: (Fixed g, Ord k, f ~ Tree23 (Set k)) => k -> g f -> g f deleteSet k = alterTree23 (SK k) (const $ Just Nothing) +-- | Split a set into sets of items < k and >= k+partitionSet :: (Fixed g, Ord k, f ~ Tree23 (Set k)) => k -> g f -> (g f, g f)+partitionSet k = partitionTree23 (SK k)+ -- | Convert a set into a list of items.-toListSet :: (Fixed g, Ord k) => Tree23 g (Set k) -> [k]+toListSet :: (Fixed g, Ord k, f ~ Tree23 (Set k)) => g f -> [k] toListSet = ($ []) . cata phi where     phi Empty xs = xs     phi (Leaf (SK k) _) xs = k:xs@@ -148,34 +162,39 @@     phi (Three la _ ma _ ra) xs = la . ma . ra $ xs  -- | Convert a list of items into a set.-fromListSet :: (Fixed g, Ord k) => [k] -> Tree23 g (Set k)+fromListSet :: (Fixed g, Ord k, f ~ Tree23 (Set k)) => [k] -> g f fromListSet = Prelude.foldr insertSet empty  -- | Create a 'FixFile' for storing a set of items.-createSetFile :: (Binary k, Typeable k) =>-    FilePath -> IO (FixFile (Ref (TreeD (Set k))))+createSetFile :: (Binary k, Typeable k, f ~ Tree23 (Set k)) =>+    FilePath -> IO (FixFile (Ref f)) createSetFile fp = createFixFile (Ref empty) fp  -- | Open a 'FixFile' for storing a set of items.-openSetFile :: (Binary k, Typeable k) =>-    FilePath ->IO (FixFile (Ref (TreeD (Set k))))+openSetFile :: (Binary k, Typeable k, f ~ Tree23 (Set k)) =>+    FilePath ->IO (FixFile (Ref f)) openSetFile fp = openFixFile fp  -- | 'Transaction' version of 'insertSet'.-insertSetT :: (Binary k, Ord k) =>-    k -> Transaction (Ref (TreeD (Set k))) s ()+insertSetT :: (Binary k, Ord k, f ~ Tree23 (Set k)) =>+    k -> Transaction (Ref f) s () insertSetT k = alterT (insertSet k)   -- | 'FTransaction' version of 'lookupSet'.-lookupSetT :: (Binary k, Ord k) =>-    k -> Transaction (Ref (TreeD (Set k))) s Bool+lookupSetT :: (Binary k, Ord k, f ~ Tree23 (Set k)) =>+    k -> Transaction (Ref f) s Bool lookupSetT k = lookupT (lookupSet k)  -- | 'FTransaction' version of 'deleteSet'.-deleteSetT :: (Binary k, Ord k) =>-    k -> Transaction (Ref (TreeD (Set k))) s ()+deleteSetT :: (Binary k, Ord k, f ~ Tree23 (Set k)) =>+    k -> Transaction (Ref f) s () deleteSetT k = alterT (deleteSet k) +-- | 'Transaction' version of 'partitionSet'.+partitionSetT :: (Binary k, Ord k, f ~ Tree23 (Set k)) => k ->+    Transaction (Ref f) s (Stored s f, Stored s f)+partitionSetT k = lookupT (partitionSet k)+ -- | A 'Map' of keys 'k' to values 'v' represented as a Two-Three Tree. data Map k v @@ -190,28 +209,32 @@ instance Binary v => Binary (TreeValue (Map k v))  -- | Insert value 'v' into a map for key 'k'. Any existing value is replaced.-insertMap :: (Fixed g, Ord k) => k -> v -> Tree23 g (Map k v) ->-    Tree23 g (Map k v)+insertMap :: (Fixed g, Ord k, f ~ Tree23 (Map k v)) => k -> v -> g f -> g f insertMap k v = alterTree23 (MK k) (const . Just . Just $ MV v)  -- | Lookup an item in a map corresponding to key 'k'.-lookupMap :: (Fixed g, Ord k) => k -> Tree23 g (Map k v) -> Maybe v+lookupMap :: (Fixed g, Ord k, f ~ Tree23 (Map k v)) => k -> g f -> Maybe v lookupMap k = fmap toV . lookupTree23 (MK k) where     toV (MV v) = v  -- | Delete an item from a map at key 'k'.-deleteMap :: (Fixed g, Ord k) => k -> Tree23 g (Map k v) -> Tree23 g (Map k v)+deleteMap :: (Fixed g, Ord k, f ~ Tree23 (Map k v)) => k -> g f -> g f deleteMap k = alterTree23 (MK k) (const . Just $ Nothing)  -- | Apply a function to alter a Map at key 'k'. The function takes --   @('Maybe' v)@ as an argument for any possible exiting value and returns --   @Nothing@ to delete a value or @Just v@ to set a new value.-alterMap :: (Fixed g, Ord k) => k -> (Maybe v -> Maybe v) ->-    Tree23 g (Map k v) -> Tree23 g (Map k v)+alterMap :: (Fixed g, Ord k, f ~ Tree23 (Map k v)) =>+    k -> (Maybe v -> Maybe v) -> g f -> g f alterMap k f = alterTree23 (MK k) (Just . fmap MV . f . fmap fromMV) +-- | Split a set into maps for keys < k and >= k+partitionMap :: (Fixed g, Ord k, f ~ Tree23 (Map k v)) =>+    k -> g f -> (g f, g f)+partitionMap k = partitionTree23 (MK k)+ -- | Convert a map into a list of key-value tuples.-toListMap :: (Fixed g, Ord k) => Tree23 g (Map k v) -> [(k,v)]+toListMap :: (Fixed g, Ord k, f ~ Tree23 (Map k v)) => g f -> [(k,v)] toListMap = ($ []) . cata phi where     phi Empty xs = xs     phi (Leaf (MK k) (MV v)) xs = (k,v):xs@@ -219,21 +242,21 @@     phi (Three la _ ma _ ra) xs = la . ma . ra $ xs  -- | Convert a lst of key-value tuples into a map.-fromListMap :: (Fixed g, Ord k) => [(k,v)] -> Tree23 g (Map k v)+fromListMap :: (Fixed g, Ord k, f ~ Tree23 (Map k v)) => [(k,v)] -> g f fromListMap = Prelude.foldr (uncurry insertMap) empty  -- | Return the list of keys in a map.-keysMap :: (Fixed g, Ord k) => Tree23 g (Map k v) -> [k]+keysMap :: (Fixed g, Ord k, f ~ Tree23 (Map k v)) => g f -> [k] keysMap = fmap fst . toListMap  -- | Return a list of values in a map.-valuesMap :: (Fixed g, Ord k) => Tree23 g (Map k v) -> [v]+valuesMap :: (Fixed g, Ord k, f ~ Tree23 (Map k v)) => g f -> [v] valuesMap = fmap snd . toListMap  -- | Map a function over a map. Because of the way Tree23 is implemented, it is --   not possible to create a Functor instance to achieve this.-mapMap :: (Fixed g, Fixed h, Ord k) => (a -> b) -> Tree23 g (Map k a) ->-    Tree23 h (Map k b)+mapMap :: (Fixed g, Fixed h, Ord k) => (a -> b) -> g (Tree23 (Map k a)) ->+    h (Tree23 (Map k b)) mapMap f = cata phi where     phi Empty = empty     phi (Leaf (MK k) (MV a)) = leaf (MK k) (MV (f a))@@ -241,39 +264,45 @@     phi (Three l (MK k1) m (MK k2) r) = three l (MK k1) m (MK k2) r  -- | Create a 'FixFile' of a Map.-createMapFile :: (Binary k, Typeable k, Binary v, Typeable v) =>-    FilePath -> IO (FixFile (Ref (TreeD (Map k v))))+createMapFile :: (Binary k, Typeable k, Binary v, Typeable v,+        f ~ Tree23 (Map k v)) =>+    FilePath -> IO (FixFile (Ref f)) createMapFile fp = createFixFile (Ref empty) fp  -- | Open a 'FixFile' of a Map.-openMapFile :: (Binary k, Typeable k, Binary v, Typeable v) =>-    FilePath -> IO (FixFile (Ref (TreeD (Map k v))))+openMapFile :: (Binary k, Typeable k, Binary v, Typeable v,+        f ~ Tree23 (Map k v)) =>+    FilePath -> IO (FixFile (Ref f)) openMapFile fp = openFixFile fp  -- | 'Transaction' version of 'insertMap'.-insertMapT :: (Binary k, Binary v, Ord k) =>-    k -> v -> Transaction (Ref (TreeD (Map k v))) s ()+insertMapT :: (Binary k, Binary v, Ord k, f ~ Tree23 (Map k v)) =>+    k -> v -> Transaction (Ref f) s () insertMapT k v = alterT (insertMap k v)   -- | 'Transaction' version of 'lookupMap'.-lookupMapT :: (Binary k, Binary v, Ord k) =>-    k -> Transaction (Ref (TreeD (Map k v))) s (Maybe v)+lookupMapT :: (Binary k, Binary v, Ord k, f ~ Tree23 (Map k v)) =>+    k -> Transaction (Ref f) s (Maybe v) lookupMapT k = lookupT (lookupMap k)  -- | 'Transaction' version of 'deleteMap'.-deleteMapT :: (Binary k, Binary v, Ord k) => k ->-    Transaction (Ref (TreeD (Map k v))) s ()+deleteMapT :: (Binary k, Binary v, Ord k, f ~ Tree23 (Map k v)) =>+    k -> Transaction (Ref f) s () deleteMapT k = alterT (deleteMap k) +-- | 'Transaction' version of 'partitionMap'.+partitionMapT :: (Binary k, Ord k, Binary v, f ~ Tree23 (Map k v)) =>+    k -> Transaction (Ref f) s (Stored s f, Stored s f)+partitionMapT k = lookupT (partitionMap k)+ -- | 'FTransaction' version of 'alterMap'.-alterMapT :: (Binary k, Binary v, Ord k) => k ->-    (Maybe v -> Maybe v) -> -    Transaction (Ref (TreeD (Map k v))) s ()+alterMapT :: (Binary k, Binary v, Ord k, f ~ Tree23 (Map k v)) =>+    k -> (Maybe v -> Maybe v) -> Transaction (Ref f) s () alterMapT k f = alterT (alterMap k f)  -- lookup the value (if it exists) from a Fixed Tree23 for a given key. lookupTree23 :: (Fixed g, Ord (TreeKey d)) => TreeKey d ->-    Tree23 g d -> Maybe (TreeValue d)+    g (Tree23 d) -> Maybe (TreeValue d) lookupTree23 k = cata phi where     phi Empty = Nothing     phi (Leaf k' v)@@ -291,10 +320,10 @@  data Change g d =     NoChange-  | Changed (Maybe (TreeKey d)) (Tree23 g d)-  | Unbalanced (Maybe (TreeKey d)) (Tree23 g d)+  | Changed (Maybe (TreeKey d)) (g (Tree23 d))+  | Unbalanced (Maybe (TreeKey d)) (g (Tree23 d))   | Hole-  | Split (Tree23 g d) (TreeKey d) (Tree23 g d)+  | Split (g (Tree23 d)) (TreeKey d) (g (Tree23 d))  -- So, this function is a bit overwhelming, but it does everything that to -- handle all of the operations that modify a 2-3 tree.@@ -307,7 +336,7 @@ -- to be written to the tree. alterTree23 :: (Fixed g, Ord (TreeKey d)) => TreeKey d ->     (Maybe (TreeValue d) -> Maybe (Maybe (TreeValue d))) ->-    Tree23 g d -> Tree23 g d+    g (Tree23 d) -> g (Tree23 d) alterTree23 k f t = processHead $ para phi t t where     processHead NoChange = t     processHead (Changed _ t') = t'@@ -403,4 +432,86 @@                 Two ln' k1' rn' -> Changed Nothing $ two ln k1                     (three ln' k1' rn' (maybe k2 id uk) un)                 _ -> error "Invalid Tree23"+++data SkewDir = L | R++data Partition g d =+    NoPartition+  | Skew SkewDir+  | Split2 (Int, g (Tree23 d)) (Int, g (Tree23 d))++merge :: (Fixed g, Ord (TreeKey d)) => Int -> g (Tree23 d) -> TreeKey d ->+    Int -> g (Tree23 d) -> (Int, g (Tree23 d))+merge ld ln k rd rn+    | ld == rd = (ld + 1, two ln k rn)+    | ld < rd = case (rd - ld, outf rn) of+        (1, Two rln rk rrn) -> (rd, three ln k rln rk rrn)+        (1, Three rln rk1 rmn rk2 rrn) ->+            (rd + 1, two (two ln k rln) rk1 (two rmn rk2 rrn))+        (_, Two rln rk rrn) ->+            let (ld', rln') = merge ld ln k (rd - 1) rln+            in merge ld' rln' rk (rd - 1) rrn+        (_, Three rln rk1 rmn rk2 rrn) ->+            let (ld', rln') = merge ld ln k (rd - 1) rln+            in merge ld' rln' rk1 (rd - 1) (two rmn rk2 rrn)+        _ -> error "Malformed Tree23"+    | otherwise = case (ld - rd, outf ln) of+        (1, Two lln lk lrn) -> (ld, three lln lk lrn k rn)+        (1, Three lln lk1 lmn lk2 lrn) ->+            (ld + 1, two (two lln lk1 lmn) lk2 (two lrn k rn))+        (_, Two lln lk lrn) ->+            let (rd', lrn') = merge (ld - 1) lrn k rd rn+            in merge (ld - 1) lln lk rd' lrn'+        (_, Three lln lk1 lmn lk2 lrn) ->+            let (rd', lrn') = merge (ld - 1) lrn k rd rn+            in merge (ld - 1) (two lln lk1 lmn) lk2 rd' lrn'+        _ -> error "Malformed Tree23"++partitionTree23 :: (Fixed g, Ord (TreeKey d)) => TreeKey d ->+    g (Tree23 d) -> (g (Tree23 d), g (Tree23 d))+partitionTree23 k t = resp $ para phi t where+    resp NoPartition = (t, t)+    resp (Skew L) = (t, empty)+    resp (Skew R) = (empty, t)+    resp (Split2 (_, l) (_, r)) = (l, r)+    phi Empty = NoPartition+    phi (Leaf k' _) +        | k' < k = Skew L+        | otherwise = Skew R+    phi (Two (ln, la) k' (rn, ra))+        | k' == k = Split2 (-1, ln) (-1, rn)+        | k' < k = case ra of+            Skew L -> Skew L+            Skew R -> Split2 (-1, ln) (-1, rn)+            Split2 (lbal, lv) (rbal, rv) ->+                Split2 (merge (-1) ln k' lbal lv) (rbal - 1, rv)+            _ -> error "Malformed Tree23"+        | otherwise = case la of+            Skew L -> Split2 (-1, ln) (-1, rn)+            Skew R -> Skew R+            Split2 (lbal, lv) (rbal, rv) ->+                Split2 (lbal - 1, lv) (merge rbal rv k' (-1) rn)+            _ -> error "Malformed Tree23"+    phi (Three (ln, la) k1 (mn, ma) k2 (rn, ra))+        | k1 == k = Split2 (-1, ln) (0, two mn k2 rn)+        | k2 == k = Split2 (0, two ln k1 mn) (-1, rn)+        | k2 < k = case ra of+            Skew L -> Skew L+            Skew R -> Split2 (0, two ln k1 mn) (-1, rn)+            Split2 (lbal, lv) (rbal, rv) ->+                Split2 (merge 0 (two ln k1 mn) k2 lbal lv) (rbal - 1, rv)+            _ -> error "Malformed Tree23"+        | k1 < k = case ma of+            Skew L -> Split2 (0, two ln k1 mn) (-1, rn)+            Skew R -> Split2 (-1, ln) (0, two mn k2 rn)+            Split2 (lbal, lv) (rbal, rv) ->+                Split2 (merge (-1) ln k1 lbal lv) (merge rbal rv k2 (-1) rn)+            _ -> error "Malformed Tree23"+        | otherwise = case la of+            Skew R -> Skew R+            Skew L -> Split2 (-1, ln) (0, two mn k2 rn)+            Split2 (lbal, lv) (rbal, rv) ->+                Split2 (lbal -1, lv) (merge rbal rv k2 0 (two mn k2 rn))+            _ -> error "Malformed Tree23"