fixfile 0.5.0.0 → 0.6.0.0

raw patch · 11 files changed

+885/−83 lines, 11 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• fixfile.cabal +4/−1
• src/Data/FixFile.hs +92/−52
• src/Data/FixFile/BTree.hs +9/−9
• src/Data/FixFile/BTree/Light.hs +364/−0
• src/Data/FixFile/Fixed.hs +5/−0
• src/Data/FixFile/Null.hs +42/−0
• src/Data/FixFile/Set.hs +4/−4
• src/Data/FixFile/Tree23.hs +5/−12
• src/Data/FixFile/Trie.hs +5/−5
• src/Data/FixFile/Trie/Light.hs +351/−0
• tests/Tests.hs +4/−0

@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/  name:                   fixfile-version:                0.5.0.0+version:                0.6.0.0 synopsis:               File-backed recursive data structures. homepage:               https://github.com/revnull/fixfile license:                LGPL-3@@ -40,10 +40,13 @@   default-language:     Haskell2010   exposed-modules:      Data.FixFile                        ,Data.FixFile.BTree+                       ,Data.FixFile.BTree.Light                        ,Data.FixFile.Set                        ,Data.FixFile.Tree23                        ,Data.FixFile.Trie+                       ,Data.FixFile.Trie.Light   other-modules:        Data.FixFile.Fixed+                       ,Data.FixFile.Null   ghc-options:          -Wall  Test-Suite test-fixfile

@@ -31,10 +31,13 @@  -}  module Data.FixFile (-                      -- * Fixed point combinators+                     -- * Fixed point combinators                       Fixed(..)                      ,Fix(..)                      ,Stored+                     -- * Null typeclasses+                     ,Null(..)+                     ,Null1(..)                      -- * F-Algebras                      ,CataAlg                      ,CataMAlg@@ -89,18 +92,20 @@                      ,getFull                      ) where -import Prelude hiding (sequence, mapM, lookup)+import Prelude hiding (sequence, mapM, lookup, null)  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.Except hiding (mapM_)+import qualified Control.Monad.RWS as RWS hiding (mapM_) import Data.Binary-import Data.ByteString.Lazy as BSL+import Data.ByteString as BS hiding (null, empty)+import Data.ByteString.Lazy as BSL hiding (null, empty) import Data.Dynamic import Data.Hashable-import Data.HashTable.IO+import Data.HashTable.IO hiding (mapM_)+import Data.IORef import qualified Data.Map as M import Data.Maybe import Data.Monoid@@ -111,6 +116,7 @@ import System.IO.Unsafe  import Data.FixFile.Fixed+import Data.FixFile.Null  type HashTable k v = CuckooHashTable k v @@ -141,8 +147,9 @@             return (c', val)         _ -> return (c, val) -getCachedOrStored :: Typeable f => Ptr f -> IO (f (Ptr f)) -> MVar Caches ->-    IO (f (Ptr f))+getCachedOrStored :: (Null1 f, Typeable f) => Ptr f -> IO (f (Ptr f)) ->+    MVar Caches -> IO (f (Ptr f))+getCachedOrStored (Ptr 0) _ _ = return empty1 getCachedOrStored p m cs = do     mval <- withCache cs (cacheLookup p)     case mval of@@ -165,8 +172,37 @@  type Pos = Word64 +data WriteBuffer = WB ([BS.ByteString] -> [BS.ByteString]) Pos Pos++bufferFlushSize :: Word64+bufferFlushSize = 10485760 -- 10 MB++initWB :: Handle -> IO WriteBuffer+initWB h = do+    hSeek h SeekFromEnd 0+    p <- fromIntegral <$> hTell h+    return $ WB id p p++writeWB :: Binary a => a -> WriteBuffer -> (WriteBuffer, Pos, Bool)+writeWB a (WB bsf st end) = sbs `seq` wb where+    wb = (WB bsf' st end', end, end' - st > bufferFlushSize)+    enc = encode a+    len = fromIntegral $ BSL.length enc+    len' = encode (len :: Word32)+    sbs = BSL.toStrict (len' <> enc)+    end' = end + 4 + fromIntegral len+    bsf' = bsf . (sbs:)++flushBuffer :: WriteBuffer -> Handle -> IO WriteBuffer+flushBuffer (WB bsf st en) h = do+    hSeek h SeekFromEnd 0+    p <- fromIntegral <$> hTell h+    when (p /= st) $ fail "WriteBuffer position failure."+    mapM_ (BS.hPut h) (bsf [])+    return (WB id en en)+ -- FFH is a FixFile Handle. This is an internal data structure.-data FFH = FFH (MVar Handle) (MVar Caches)+data FFH = FFH (MVar Handle) (IORef WriteBuffer) (MVar Caches)  getRawBlock :: Binary a => Handle -> Pos -> IO a getRawBlock h p = do@@ -174,30 +210,28 @@     (sb :: Word32) <- decode <$> (BSL.hGet h 4)     decode <$> BSL.hGet h (fromIntegral sb) -getBlock :: (Typeable f, Binary (f (Ptr f))) => Ptr f -> FFH -> IO (f (Ptr f))-getBlock p@(Ptr pos) (FFH mh mc) = getCachedOrStored p readFromFile mc where+getBlock :: Fixable f => Ptr f -> FFH -> IO (f (Ptr f))+getBlock p@(Ptr pos) (FFH mh _ mc) = getCachedOrStored p readFromFile mc where     readFromFile = withMVar mh $ flip getRawBlock pos -putRawBlock' :: Binary a => a -> Handle -> IO Pos-putRawBlock' a h = do-    hSeek h SeekFromEnd 0-    p <- fromIntegral <$> hTell h-    let enc  = encode a-        len  = fromIntegral $ BSL.length enc-        len' = encode (len :: Word32)-        enc' = mappend len' enc-    BSL.hPut h enc'+putRawBlock :: Binary a => Bool -> a -> FFH -> IO Pos+putRawBlock fl a (FFH mh wb _) = do+    wb' <- readIORef wb+    let (wb'', p, fl') = writeWB a wb'+    if (fl' || fl)+        then do+            wb''' <- withMVar mh (flushBuffer wb'')+            writeIORef wb wb'''+        else writeIORef wb wb''     return p -putRawBlock :: Binary a => a -> FFH -> IO Pos-putRawBlock a (FFH mh _) = withMVar mh $ putRawBlock' a--putBlock :: (Typeable f, Binary (f (Ptr f))) => (f (Ptr f)) -> FFH ->-    IO (Ptr f)-putBlock a h@(FFH _ mc) = putRawBlock a h >>= cacheBlock . Ptr where-    cacheBlock p = do-        withCache_ mc (cacheInsert p a)-        return p+putBlock :: Fixable f => f (Ptr f) -> FFH -> IO (Ptr f)+putBlock a h@(FFH _ _ mc) +    | null a = return (Ptr 0)+    | otherwise = putRawBlock False a h >>= cacheBlock . Ptr where+        cacheBlock p = do+            withCache_ mc (cacheInsert p a)+            return p  {- |      'Stored' is a fixed-point combinator of 'f' in Transaction 's'.@@ -217,8 +251,7 @@  -- | Write the stored data to disk so that the on-disk representation  --   matches what is in memory.-sync :: (Traversable f, Binary (f (Ptr f)), Typeable f) =>-    FFH -> Stored s f -> IO (Ptr f)+sync :: (Fixable f) => FFH -> Stored s f -> IO (Ptr f) sync h = commit where     commit (Memory r) = do         r' <- mapM commit r@@ -243,7 +276,7 @@     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)+type Fixable f = (Traversable f, Binary (f (Ptr f)), Typeable f, Null1 f)  {- |     'FixTraverse' is a class based on 'Traverse' but taking an argument of kind@@ -253,7 +286,7 @@     -- | 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 =>+    traverseFix :: Applicative f =>         (forall g. Fixable g => a g -> f (b g)) -> t a -> f (t b)  {- | @@ -265,15 +298,15 @@ type Root r = (FixTraverse r, Binary (r Ptr))  readRoot :: Root r => r Ptr -> Transaction r' s (r (Stored s))-readRoot = sequenceAFix readPtr where+readRoot = traverseFix readPtr where     readPtr p = withHandle $ flip readStoredLazy p  writeRoot :: Root r => r (Stored s) -> Transaction r' s (r Ptr)-writeRoot = sequenceAFix writeStored where+writeRoot = traverseFix writeStored where     writeStored s = withHandle $ flip sync s  rootIso :: (Root r, Fixed g, Fixed h) => r g -> r h-rootIso = runIdentity . sequenceAFix (Identity . iso)+rootIso = runIdentity . traverseFix (Identity . iso)  {- |     A 'Ref' is a reference to a 'Functor' 'f' in the 'Fixed' instance of 'g'.@@ -281,13 +314,13 @@     This is an instance of 'Root' and acts to bridge between the 'Root' and     the recursively defined data structure that is @('g' 'f')@. -}-data Ref (f :: * -> *) (g :: (* -> *) -> *) = Ref { deRef :: g f }+newtype Ref (f :: * -> *) (g :: (* -> *) -> *) = Ref { deRef :: g f }     deriving (Generic)  instance Binary (Ref f Ptr)  instance Fixable f => FixTraverse (Ref f) where-    sequenceAFix isoT (Ref a) = Ref <$> isoT a+    traverseFix isoT (Ref a) = Ref <$> isoT a  -- | Lens for accessing the value stored in a Ref ref :: Lens' (Ref f g) (g f)@@ -334,8 +367,7 @@ withHandle :: (FFH -> IO a) -> Transaction r s a withHandle f = Transaction $ RWS.ask >>= liftIO . f -readStoredLazy :: (Traversable f, Binary (f (Ptr f)), Typeable f) =>-    FFH -> Ptr f -> IO (Stored s f)+readStoredLazy :: Fixable f => FFH -> Ptr f -> IO (Stored s f) readStoredLazy h p = do     f <- getBlock p h     let fcons = Cached p@@ -383,13 +415,13 @@     f `finally` releaseWriteLock ff  readHeader :: FFH -> IO (Pos)-readHeader (FFH mh _) = withMVar mh $ \h -> do+readHeader (FFH mh _ _) = withMVar mh $ \h -> do     hSeek h AbsoluteSeek 0     decode <$> BSL.hGet h 8  updateHeader :: Pos -> Transaction r s () updateHeader p = do-    withHandle $ \(FFH mh _) -> +    withHandle $ \(FFH mh _ _) ->          withMVar mh $ \h -> do             hSeek h AbsoluteSeek 0             BSL.hPut h (encode p)@@ -411,11 +443,12 @@ createFixFileHandle :: Root r =>     r Fix -> FilePath -> Handle -> IO (FixFile r) createFixFileHandle initial path h = do-    ffh <- FFH <$> newMVar h <*> newMVar M.empty     BSL.hPut h (encode (0 :: Pos))+    wb <- initWB h+    ffh <- FFH <$> newMVar h <*> newIORef wb <*> newMVar M.empty     let t = runRT $ do             dr <- writeRoot $ rootIso initial-            (withHandle $ putRawBlock dr) >>= updateHeader+            (withHandle $ putRawBlock True dr) >>= updateHeader             Transaction . RWS.tell . Last . Just $ dr     (_,_,root') <- RWS.runRWST t ffh undefined     let Just root = getLast root'@@ -436,7 +469,8 @@ openFixFileHandle :: Binary (r Ptr) => FilePath -> Handle ->     IO (FixFile r) openFixFileHandle path h = do-    ffh <- FFH <$> newMVar h <*> newMVar M.empty+    wb <- initWB h+    ffh <- FFH <$> newMVar h <*> newIORef wb <*> newMVar M.empty     root <- readHeader ffh >>= getRawBlock h      ffhmv <- newMVar (ffh, root)     FixFile path ffhmv <$> newMVar ()@@ -447,7 +481,7 @@ -} closeFixFile :: FixFile r -> IO () closeFixFile (FixFile path tmv _) = do-    (FFH mh _, _) <- takeMVar tmv+    (FFH mh _ _, _) <- takeMVar tmv     h <- takeMVar mh     hClose h     putMVar mh $ error (path ++ " is closed.")@@ -482,7 +516,7 @@         let t' = readRoot root >>= RWS.put >> t >>= save             save a = do                 dr <- RWS.get >>= writeRoot-                (withHandle $ putRawBlock dr) >>= updateHeader+                (withHandle $ putRawBlock True dr) >>= updateHeader                 Transaction . RWS.tell . Last . Just $ dr                 return a         (a, root') <- RWS.evalRWST (runRT t') ffh undefined@@ -511,7 +545,7 @@             save l@(Left _) = return l             save r@(Right _) = do                 dr <- RWS.get >>= writeRoot-                (withHandle $ putRawBlock dr) >>= updateHeader+                (withHandle $ putRawBlock True dr) >>= updateHeader                 Transaction . RWS.tell . Last . Just $ dr                 return r         (a, root') <- RWS.evalRWST (runRT t') ffh undefined@@ -545,16 +579,22 @@          BSL.hPut dh (encode (Ptr 0)) -        root' <- sequenceAFix (copyPtr ffh dh) root+        wb <- initWB dh+        wb' <- newIORef wb+        dffh <- FFH <$> newMVar dh <*> return wb' <*> newMVar M.empty -        r' <- putRawBlock' root' dh -        +        root' <- traverseFix (copyPtr ffh dffh) root++        r' <- putRawBlock True root' dffh +         hSeek dh AbsoluteSeek 0         BSL.hPut dh (encode r')          putMVar mv mv' -    copyPtr ffh h = hyloM (flip getBlock ffh) ((Ptr <$>) . flip putRawBlock' h)+    copyPtr ffh h = hyloM+        (flip getBlock ffh)+        ((Ptr <$>) . flip (putRawBlock False) h)  {- |     It's potentially useful to copy the contents of a 'FixFile' to a new

@@ -17,7 +17,6 @@ module Data.FixFile.BTree (BTree                           ,createBTreeFile                           ,openBTreeFile-                          ,empty                           ,depth                           ,insertBTree                           ,insertBTreeT@@ -52,6 +51,11 @@   | Node Word32 (V.Vector (k, a))     deriving (Read, Show, Generic, Functor, Foldable, Traversable, Typeable) +instance Null1 (BTree n k v) where+    empty1 = Empty+    null1 Empty = True+    null1 _ = False+ 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@@ -68,14 +72,10 @@  -- | 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 n k v)-empty = inf Empty+depth = dep . outf where+    dep Empty = 0+    dep (Value _) = 1+    dep (Node d _) = fromIntegral d  value :: Fixed g => v -> g (BTree n k v) value = inf . Value

@@ -0,0 +1,364 @@+{-# LANGUAGE DeriveGeneric, DeriveFunctor, DeriveFoldable, DeriveTraversable,+    DeriveDataTypeable, DataKinds, KindSignatures, TypeFamilies,+    TupleSections #-}++{- |+    Module      :  Data.FixFile.BTree.Light+    Copyright   :  (C) 2016 Rev. Johnny Healey+    License     :  LGPL-3+    Maintainer  :  Rev. Johnny Healey <rev.null@gmail.com>+    Stability   :  experimental+    Portability :  unknown++    This is a BTree data type that can be used with 'FixFile'. It can be used+    as a key-value store where the same key can correspond to multiple values.+    It supports logarithmic insert, lookup, and delete operations. This BTree+    embeds values in the leaf nodes instead of providing them with distinct+    leaf nodes. It is not recommended for use with large values.+-}+module Data.FixFile.BTree.Light (BTree+                                ,createBTreeFile+                                ,openBTreeFile+                                ,depth+                                ,insertBTree+                                ,insertBTreeT+                                ,lookupBTree+                                ,lookupBTreeT+                                ,filterBTree+                                ,filterBTreeT+                                ,deleteBTree+                                ,deleteBTreeT+                                ,partitionBTree+                                ,toListBTree+                                ,fromListBTree+                                ) where++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' 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 (n :: Nat) k v a =+    Empty+  | Node Word32 (Either (V.Vector (k, v)) (V.Vector (k, a)))+    deriving (Read, Show, Generic, Functor, Foldable, Traversable, Typeable)++instance Null1 (BTree n k v) where+    empty1 = Empty+    null1 Empty = True+    null1 _ = False++instance (Binary k, Binary v, Binary a) => Binary (BTree n k v a) where+    put Empty = putWord8 0x45+    put (Node _ (Left vec)) = do+        putWord8 0x4c+        put (V.length vec)+        mapM_ put vec+    put (Node d (Right vec)) = do+        putWord8 0x52+        put d+        put (V.length vec)+        mapM_ put vec+    get = getWord8 >>= getBTree where+        getBTree 0x45 = return Empty+        getBTree 0x4c = (Node 1 . Left) <$>+            (get >>= \n -> V.replicateM n get)+        getBTree 0x52 = Node <$> get <*>+            (get >>= \n -> Right <$> 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 = dep . outf where+    dep Empty = 0+    dep (Node d _) = fromIntegral d++node :: Fixed g => Word32 -> V.Vector (k, g (BTree n k v)) -> g (BTree n k v)+node d = inf . Node d . Right++leaf :: Fixed g => V.Vector (k, v) -> g (BTree n k v)+leaf = inf . Node 1 . Left++-- | Create a 'FixFile' storing a @('BTree' k v)@.+--   The initial value is 'empty'.+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 n k v)))+openBTreeFile = openFixFile++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++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++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 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 :: (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) $ V.fromList [lt, rt]+    nodeSize = fromIntegral $ treeNodeSize t++    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)++    newLeaf 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 1 (mini l, leaf l') (mini r, leaf r')+        | otherwise =+            Inserted (fst $ V.head cs) (leaf cs)+            +    nodes = fmap (\(a,(b,_)) -> (a, b))++    phi Empty = Inserted k $ leaf $ V.singleton (k, v)++    phi (Node 1 (Left vec)) =+        let (lt, eq, gt) = split3 (splitRange k vec) vec+            newSize = 1 + V.length vec+        in newLeaf newSize (V.concat [lt, eq, V.singleton (k, v), gt])+    phi (Node _ (Left _)) = error "Malformed Leaf"++    phi (Node d (Right 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 :: (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 n k v) -> [v]+lookupBTree k = ($ []) . cata phi where+    phi Empty l = l++    phi (Node 1 (Left vec)) l =+        let (_, eq, _) = split3 (splitRange k vec) vec+        in V.foldr ((:) . snd) l eq+    phi (Node _ (Left _)) _ = error "Malformed Leaf"++    phi (Node _ (Right 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 n k v)) s [v]+lookupBTreeT k = lookupT (lookupBTree k)++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 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 (Node 1 (Left vec)) =+        let (lt, eq, gt) = split3 (splitRange k vec) vec+            eq' = V.filter (f . snd) eq+            vec' = V.concat [lt, eq', gt]+            mink = fst (V.head vec')+        in case (V.null vec', V.length eq /= V.length eq') of+            (True, _) -> AllDeleted+            (_, False) -> UnChanged+            _ -> Deleted mink $ leaf vec'+    phi (Node _ (Left _)) = error "Malformed Leaf"++    phi (Node d (Right 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 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 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 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 (Node 1 (Left 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, leaf lt) (minkr, leaf gte)+    phi (Node _ (Left _)) = error "Malformed Leaf"++    phi (Node d (Right 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 n k v) -> [(k,v)]+toListBTree t = cata phi t [] where+    phi Empty = id++    phi (Node 1 (Left vec)) = foldMap (:) vec+    phi (Node _ (Left _)) = error "Malformed Leaf"++    phi (Node _ (Right vec)) = foldMap snd vec++-- | Turn a list of key value tuples into a 'Fixed' @('BTree' k v)@.+fromListBTree :: (KnownNat n, Ord k, Fixed g) => [(k,v)] -> g (BTree n k v)+fromListBTree = foldr (uncurry insertBTree) empty++instance FixedAlg (BTree n k v) where+    type Alg (BTree n k v) = v++instance FixedSub (BTree n k v) where+    type Sub (BTree n k v) v v' = BTree n k v'++instance FixedFunctor (BTree n k v) where+    fmapF f = cata phi where+        phi Empty = empty+        phi (Node 1 (Left vec)) = leaf $ fmap (fmap f) vec+        phi (Node _ (Left _)) = error "Malformed Leaf"+        phi (Node c (Right vec)) = node c vec++instance FixedFoldable (BTree n k v) where+    foldMapF f = cata phi where+        phi Empty = mempty+        phi (Node 1 (Left vec)) = foldMap (f . snd) vec+        phi (Node _ (Left _)) = error "Malformed Leaf"+        phi (Node _ (Right vec)) = foldMap snd vec++instance FixedTraversable (BTree n k v) where+    traverseF f = cata phi where+        phi Empty = pure empty+        phi (Node 1 (Left vec)) = leaf <$> traverse (\(w, a) -> (w,) <$> f a) vec +        phi (Node _ (Left _)) = error "Malformed Leaf"+        phi (Node c (Right vec)) = node c <$> traverse (\(w, a) -> (w,) <$> a) vec +

@@ -108,6 +108,7 @@     'cata' applies a 'CataAlg' over a fixed point of a 'Functor'. -} cata :: (Functor f, Fixed g) => CataAlg f a -> g f -> a+{-# INLINE[1] cata #-} cata f = f . fmap (cata f) . outf  {-|@@ -158,6 +159,8 @@ hylo :: Functor f => AnaAlg f a -> CataAlg f b -> a -> b hylo f g = hylo' where hylo' = g . fmap hylo' . f +{-# RULES "hylo" forall f g a. cata g (ana f a) = hylo f g a #-}+ {-|     'hyloM' is a monadic hylomorphism. -}@@ -165,6 +168,8 @@ hyloM :: (Traversable f, Monad m) =>     AnaMAlg m f a -> CataMAlg m f b -> a -> m b hyloM f g = hylo' where hylo' = g <=< mapM hylo' <=< f++{-# RULES "hyloM" forall f g a. anaM f a >>= cataM g = hyloM f g a #-}  {-|     'FixedAlg' is a typeclass for describing the relationship between a

@@ -0,0 +1,42 @@+{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}++module Data.FixFile.Null (+                          Null1(..)+                         ,Null(..)+                         ) where++import Data.FixFile.Fixed++{-|+    'Null' is a typeclass for representing data that can be 'empty' as well as+    the 'null' predicate that can determine if a piece of data is 'empty'.+ -}+class Null f where+    empty :: f+    null :: f -> Bool++{-|+    'Null1' is for expressing null types of kind @(* -> *)@.+ -}+class Null1 f where+    empty1 :: f a+    null1 :: f a -> Bool++instance Null1 f => Null (f a) where+    empty = empty1+    null = null1++instance Null1 Maybe where+    empty1 = Nothing+    null1 Nothing = True+    null1 _ = False++instance Null1 [] where+    empty1 = []+    null1 [] = True+    null1 _ = False++instance (Fixed g, Null1 f) => Null (g f) where+    empty = inf empty1+    null = null1 . outf+

@@ -18,7 +18,6 @@ module Data.FixFile.Set (Set                          ,createSetFile                          ,openSetFile-                         ,empty                          ,insertSet                          ,insertSetT                          ,deleteSet@@ -48,9 +47,10 @@  instance (Binary i, Binary a) => Binary (Set i a) --- | An empty 'Set'.-empty :: Fixed g => g (Set i)-empty = inf Empty+instance Null1 (Set i) where+    empty1 = Empty+    null1 Empty = True+    null1 _ = False  node :: Fixed g => g (Set i) -> i -> g (Set i) -> g (Set i) node l i r = inf $ Node l i r

@@ -14,8 +14,6 @@     used with 'FixFile'. It has two interfaces that are -} module Data.FixFile.Tree23 (Tree23-                           ,empty-                           ,null                            ,size                            ,depth                            -- | * Set@@ -79,6 +77,11 @@   deriving (Read, Show, Eq, Ord, Generic, Functor, Foldable, Traversable,             Typeable) +instance Null1 (Tree23F k v) where+    empty1 = Empty+    null1 Empty = True+    null1 _ = False+ {- |     '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@@ -94,10 +97,6 @@ instance (Binary a, Binary (TreeKey d), Binary (TreeValue d)) =>     Binary (Tree23F (TreeKey d) (TreeValue d) a) --- | An empty 'Fixed' 'Tree23'.-empty :: Fixed g => g (Tree23 d)-empty = inf Empty- leaf :: Fixed g => TreeKey d -> TreeValue d -> g (Tree23 d) leaf k v = inf $ Leaf k v @@ -109,12 +108,6 @@     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 => g (Tree23 d) -> Bool-null = null' . outf where-    null' Empty = True-    null' _ = False  -- | Number of entries in @('Tree23' g d)@. size :: Fixed g => g (Tree23 d) -> Int

@@ -13,7 +13,6 @@     as a key-value store where the key is a 'ByteString' of arbitrary size. -} module Data.FixFile.Trie (Trie-                         ,empty                          ,freeze                          ,createTrieFile                          ,openTrieFile@@ -53,6 +52,11 @@   | Mutable (Maybe a) (M.Map Word8 a)   deriving (Read, Show, Generic, Functor, Foldable, Traversable, Typeable) +instance Null1 (Trie v) where+    empty1 = Tail Nothing+    null1 (Tail Nothing) = True+    null1 _ = False+ instance (Binary v, Binary a) => Binary (Trie v a) where     put (Value v) = putWord8 0 >> put v     put (Tail a) = putWord8 1 >> put a@@ -73,10 +77,6 @@  tail :: Fixed g => Maybe (g (Trie v)) -> g (Trie v) tail = inf . Tail where---- | An empty 'Trie'-empty :: Fixed g => g (Trie v)-empty = inf $ Tail Nothing  string :: Fixed g => Maybe (g (Trie v)) -> BS.ByteString ->     g (Trie v) -> g (Trie v)

@@ -0,0 +1,351 @@+{-# LANGUAGE DeriveGeneric, DeriveFunctor, DeriveFoldable, DeriveTraversable,+    TypeFamilies, DeriveDataTypeable, TupleSections #-}++{- |+    Module      :  Data.FixFile.Trie+    Copyright   :  (C) 2016 Rev. Johnny Healey+    License     :  LGPL-3+    Maintainer  :  Rev. Johnny Healey <rev.null@gmail.com>+    Stability   :  experimental+    Portability :  unknown++    This is a Trie data type that can be used with 'FixFile'. It can be used+    as a key-value store where the key is a 'ByteString' of arbitrary size.+-}+module Data.FixFile.Trie.Light (Trie+                               ,freeze+                               ,createTrieFile+                               ,openTrieFile+                               ,lookupTrie+                               ,lookupTrieT+                               ,insertTrie+                               ,insertTrieT+                               ,deleteTrie+                               ,deleteTrieT+                               ,iterateTrie+                               ,iterateTrieT+                               ) where++import Prelude hiding (tail)++import Control.Applicative hiding (empty)+import Control.Monad+import Data.Array+import Data.Binary+import qualified Data.ByteString.Lazy as BS+import Data.Dynamic+import qualified Data.Map as M+import Data.Maybe+import Data.Monoid+import GHC.Generics++import Data.FixFile++-- | 'Fixed' @('Trie' v)@ is a trie mapping lazy 'ByteString's to values of+--   type v.+data Trie v a =+    Tail (Maybe v)+  | String (Maybe v) BS.ByteString a+  | Small (Maybe v) [(Word8, a)]+  | Big (Maybe v) (Array Word8 (Maybe a))+  | Mutable (Maybe v) (M.Map Word8 a)+  deriving (Read, Show, Generic, Functor, Foldable, Traversable, Typeable)++instance Null1 (Trie v) where+    empty1 = Tail Nothing+    null1 (Tail Nothing) = True+    null1 _ = False++instance (Binary v, Binary a) => Binary (Trie v a) where+    put (Tail a) = putWord8 1 >> put a+    put (String m b a) = putWord8 2 >> put m >> put b >> put a+    put (Small m l) = putWord8 3 >> put m >> put l+    put (Big m a) = putWord8 4 >> put m >> put a+    put m = put $ freeze' m+    get = getWord8 >>= getTrie where+        getTrie 1 = Tail <$> get+        getTrie 2 = String <$> get <*> get <*> get+        getTrie 3 = Small <$> get <*> get+        getTrie 4 = Big <$> get <*> get+        getTrie _ = error "Invalid Serialized Trie"++tail :: Fixed g => Maybe v -> g (Trie v)+tail = inf . Tail where++string :: Fixed g => Maybe v -> BS.ByteString ->+    g (Trie v) -> g (Trie v)+string v k t = inf $ String v k t++fill :: Fixed g => BS.ByteString -> Maybe v -> g (Trie v) -> g (Trie v)+fill k x t = if BS.null k+    then t+    else string x k t++small :: Fixed g => Maybe v -> [(Word8, g (Trie v))] -> g (Trie v)+small v l = inf $ Small v l++big :: Fixed g => Maybe v -> Array Word8 (Maybe (g (Trie v))) -> g (Trie v)+big v l = inf $ Big v l++mut :: Fixed g => Maybe v -> M.Map Word8 (g (Trie v)) -> g (Trie v)+mut v l = inf $ Mutable v l++bigThreshold :: Int+bigThreshold = 20++-- | 'freeze' takes a 'Trie' that has been mutated and creates a copy of it+-- that allows for faster lookups. This happens automatically for 'Trie's that+-- are serialized to a 'FixFile'. A 'Trie' will be automatically thawed on+-- any node that is modified.+freeze :: Fixed g => g (Trie v) -> g (Trie v)+freeze = cata (inf . freeze') where++freeze' :: Trie v a -> Trie v a+freeze' (Mutable a b) = if M.size b > bigThreshold+    then Big a $ array (minBound, maxBound) $ do+        i <- [minBound..maxBound]+        case M.lookup i b of+            Nothing -> return (i, Nothing)+            Just t -> return (i, Just t)+    else Small a $ M.toList b+freeze' m = m++thaw :: Trie v a -> Trie v a+thaw (Big a b) = Mutable a . M.fromList $ do+    (i, Just v) <- assocs b+    return (i, v)+thaw (Small a b) = Mutable a $ M.fromList b+thaw m = m++-- | Create a 'FixFile' of @('Trie' v)@ data.+createTrieFile :: (Binary v, Typeable v) =>+    FilePath -> IO (FixFile (Ref (Trie v)))+createTrieFile fp = createFixFile (Ref empty) fp++-- | Open a 'FixFile' of @('Trie' v)@ data.+openTrieFile :: (Binary v, Typeable v) =>+    FilePath -> IO (FixFile (Ref (Trie v)))+openTrieFile = openFixFile++-- | Lookup a possible value stored in a trie for a given 'ByteString' key.+lookupTrie :: Fixed g => BS.ByteString -> g (Trie v) -> Maybe v+lookupTrie a b = cata phi b a where+    term v k = guard (BS.null k) >> v+    phi (Tail v) k = term v k+    phi (String v s t) k = term v k <|> do+        let (_, lt, rt) = splitKey s k+        guard (BS.null lt)+        t rt+    phi (Small v l) k = term v k <|> do+        (c, r) <- BS.uncons k+        t <- lookup c l+        t r+    phi (Big v l) k = term v k <|> do+        (c, r) <- BS.uncons k+        t <- l ! c+        t r+    phi (Mutable v l) k = term v k <|> do+        (c, r) <- BS.uncons k+        t <- M.lookup c l+        t r++-- | 'Transaction' version of 'lookupTrie'.+lookupTrieT :: Binary v =>+    BS.ByteString -> Transaction (Ref (Trie v)) s (Maybe v)+lookupTrieT k = lookupT (lookupTrie k)++splitKey :: BS.ByteString -> BS.ByteString ->+    (BS.ByteString, BS.ByteString, BS.ByteString)+splitKey x y = case (BS.uncons x, BS.uncons y) of+    (Nothing, Nothing) -> (BS.empty, BS.empty, BS.empty)+    (Just (xc, xs), Just (yc, ys)) -> if xc == yc+        then let (shared, xt, yt) = splitKey xs ys+            in (BS.cons xc shared, xt, yt)+        else (BS.empty, x, y)+    _ -> (BS.empty, x, y)++-- | Insert a value into a trie for the given 'ByteString' key.+insertTrie :: Fixed g => BS.ByteString -> v -> g (Trie v) -> g (Trie v)+insertTrie a b c = para phi c a where+    val = Just b+    valTail = tail val+    phi (Tail vm) k = fill k vm valTail+    phi (String vm s (tn, ta)) k+        | BS.null k = string val s tn+        | otherwise =+            let (sh, lt, rt) = splitKey k s+                Just (lh, ls) = BS.uncons lt+                Just (rh, rs) = BS.uncons rt+            in case (BS.null sh, BS.null lt, BS.null rt) of+                (True, False, False) -> mut vm $ M.fromList+                    [(lh, fill ls Nothing valTail), (rh, fill rs Nothing tn)]+                (True, _, _) -> error "Invalid Key Split"+                (_, False, False) -> string vm sh $ mut Nothing $ M.fromList+                    [(lh, fill ls Nothing valTail), (rh, fill rs Nothing tn)]+                (_, True, False) -> string vm sh $ string val rt tn+                (_, False, True) -> string vm sh $ ta lt+                (_, True, True) -> string vm s $ ta lt+    phi x@(Big _ t) k+        | BS.null k = big val (fmap (fmap fst) t)+        | otherwise = phi (thaw x) k+    phi x@(Small _ t) k+        | BS.null k = small val (fmap (fmap fst) t)+        | otherwise = phi (thaw x) k+    phi (Mutable vm m) k = case BS.uncons k of+        Nothing -> mut val (fmap fst m)+        Just (kh, kt) -> mut vm $ case M.lookup kh m of+            Nothing -> M.insert kh (fill kt Nothing valTail) $ fmap fst m+            Just (_, ta) -> M.insert kh (ta kt) $ fmap fst m++-- | 'Transaction' version of 'insertTrie'.+insertTrieT :: Binary v =>+    BS.ByteString -> v -> Transaction (Ref (Trie v)) s ()+insertTrieT k v = alterT (insertTrie k v)+ +data Deleted g v = +    NoDelete+  | Deleted Bool (g (Trie v)) (Maybe (BS.ByteString, g (Trie v)))++-- | Delete a value from a trie for a given 'ByteString' key.+deleteTrie :: Fixed g => BS.ByteString -> g (Trie v) -> g (Trie v)+deleteTrie a b = newHead $ para phi b a where+    newHead NoDelete = b+    newHead (Deleted True _ _) = empty+    newHead (Deleted _ h _) = h+    phi (Tail _) k = if BS.null k+        then Deleted True empty Nothing+        else NoDelete+    phi (String vm s (tn, ta)) k+        | BS.null k = if isJust vm+            then Deleted False (string Nothing s tn) (Just (s, tn))+            else NoDelete+        | otherwise = del where+            (_, lt, rt) = splitKey k s+            ta' = ta lt+            del = if BS.null rt+                then case ta' of+                    NoDelete -> NoDelete+                    Deleted True _ _ -> if isNothing vm+                        then Deleted True empty Nothing+                        else Deleted False (tail vm) Nothing+                    Deleted False tn' (Just (b', tn'')) ->+                        Deleted False (string vm s tn') $+                            Just (BS.append s b', tn'')+                    Deleted False tn' Nothing ->+                        Deleted False (string vm s tn') Nothing+                else NoDelete+    phi x@(Small vm ts) k+        | BS.null k = case vm of+            Nothing -> NoDelete+            _ -> Deleted False (small Nothing (fmap (fmap fst) ts)) Nothing+        | otherwise = phi (thaw x) k+    phi x@(Big vm ts) k+        | BS.null k = case vm of+            Nothing -> NoDelete+            _ -> Deleted False (big Nothing (fmap (fmap fst) ts)) Nothing+        | otherwise = phi (thaw x) k+    phi (Mutable vm ts) k+        | BS.null k = case vm of+            Nothing -> NoDelete+            _ -> Deleted False (mut Nothing (fmap fst ts)) Nothing+        | otherwise = fromJust . (<|> Just NoDelete) $ do+            (kh, kt) <- BS.uncons k+            (_, ta) <- M.lookup kh ts+            return $ case ta kt of+                Deleted True _ _ ->+                    let ts' = fmap fst $ M.delete kh $ ts+                        mut' = mut vm ts'+                    in case M.size ts' of+                        0 -> if isNothing vm+                            then Deleted True empty Nothing+                            else Deleted False (tail vm) Nothing+                        _ -> Deleted False mut' Nothing+                Deleted False dt _ ->+                    let ts' = M.insert kh dt $ fmap fst ts+                        mut' = mut vm ts'+                    in Deleted False mut' Nothing+                _ -> NoDelete++-- | 'Transaction' version of 'deleteTrie'.+deleteTrieT :: Binary v =>+    BS.ByteString -> Transaction (Ref (Trie v)) s ()+deleteTrieT k = alterT (deleteTrie k)++-- | Iterate over a Trie for all of the 'ByteString' and value tuples for a+-- given 'ByteString' prefix.+iterateTrie :: Fixed g => BS.ByteString -> g (Trie v) -> [(BS.ByteString, v)]+iterateTrie a b = cata phi b a BS.empty [] where+    kvlist _ _ Nothing = id+    kvlist k k' (Just v) = if BS.null k+        then ((k', v):) else id+    phi (Tail vm) k k' = kvlist k k' vm+    phi (String vm s ta) k k' = kvlist k k' vm <> ta' where+        (_, lt, rt) = splitKey k s+        ta' = if BS.null lt || BS.null rt+            then ta lt (BS.append k' s)+            else mempty+    phi (Small vm ts) k k' = kvlist k k' vm <> ts' where+        mapKeys (xk, xv) = xv k (BS.snoc k' xk)+        ts' = case BS.uncons k of+            Nothing -> foldMap mapKeys ts+            Just (i, k'') -> case lookup i ts of+                Nothing -> mempty+                Just xv -> xv k'' (BS.snoc k' i)+    phi (Big vm ts) k k' = kvlist k k' vm <> ts' where+        mapKeys (_, Nothing) = mempty+        mapKeys (xk, Just xv) = xv k (BS.snoc k' xk)+        ts' = case BS.uncons k of+            Nothing -> foldMap mapKeys (assocs ts)+            Just (i, k'') -> case ts ! i of+                Nothing -> mempty+                Just r -> r k'' (BS.snoc k' i) +    phi (Mutable vm ts) k k' = kvlist k k' vm <> ts' where+        mapKeys (xk, xv) = xv k (BS.snoc k' xk)+        ts' = case BS.uncons k of+            Nothing -> foldMap mapKeys (M.assocs ts)+            Just (i, k'') -> case M.lookup i ts of+                Nothing -> mempty+                Just r -> r k'' (BS.snoc k' i)++-- | 'Transaction' version of 'iterateTrie'.+iterateTrieT :: Binary v => BS.ByteString ->+    Transaction (Ref (Trie v)) s [(BS.ByteString, v)]+iterateTrieT k = lookupT (iterateTrie k)++instance FixedAlg (Trie v) where+    type Alg (Trie v) = v++instance FixedSub (Trie v) where+    type Sub (Trie v) v v' = Trie v'++instance FixedFunctor (Trie v) where+    fmapF f = cata phi where+        phi (Tail v) = tail (fmap f v)+        phi (String v b t) = string (fmap f v) b t+        phi (Small v ts) = small (fmap f v) ts+        phi (Big v ts) = big (fmap f v) ts+        phi (Mutable v ts) = mut (fmap f v) ts++instance FixedFoldable (Trie v) where+    foldMapF f = cata phi where+        mapply Nothing = mempty+        mapply (Just v) = f v+        phi (Tail v) = mapply v+        phi (String v _ t) = mapply v <> t+        phi (Small v l) = mapply v <> mconcat (snd <$> l)+        phi (Big v a) = mapply v <> foldMap (maybe mempty id) a+        phi (Mutable v m) = mapply v <> foldMap id m++instance FixedTraversable (Trie v) where+    traverseF f = cata phi where+        mapply Nothing = pure Nothing+        mapply (Just v) = Just <$> f v+        phi (Tail v) = tail <$> mapply v+        phi (String v b a) = string <$> mapply v <*> pure b <*> a+        phi (Small v l) = small <$> mapply v <*>+            traverse (\(w, a) -> (w,) <$> a) l+        phi (Big v a) = big <$> mapply v <*> traverse tapply a where+            tapply Nothing = pure Nothing+            tapply (Just t) = Just <$> t+        phi (Mutable v m) = mut <$> mapply v <*> traverse id m+

@@ -4,7 +4,9 @@ import TestSet import TestTree23 import TestTrie+import TestLightTrie import TestBTree+import TestLightBTree import TestFixFile  main :: IO ()@@ -14,7 +16,9 @@         test23        ,testSet        ,testTrie+       ,testLightTrie        ,testBTree+       ,testLightBTree        ,testFixFile     ]