fixfile 0.6.0.0 → 0.7.0.0

raw patch · 10 files changed

+278/−205 lines, 10 filesdep +cerealdep −binaryPVP ok

version bump matches the API change (PVP)

Dependencies added: cereal

Dependencies removed: binary

API changes (from Hackage documentation)

Files

• fixfile.cabal +4/−3
• src/Data/FixFile.hs +54/−44
• src/Data/FixFile/BTree.hs +10/−9
• src/Data/FixFile/BTree/Light.hs +10/−9
• src/Data/FixFile/Fixed.hs +10/−8
• src/Data/FixFile/Set.hs +9/−9
• src/Data/FixFile/Tree23.hs +25/−25
• src/Data/FixFile/Trie.hs +66/−53
• src/Data/FixFile/Trie/Light.hs +60/−45
• src/Data/FixFile/Trie/Shared.hs +30/−0

@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/  name:                   fixfile-version:                0.6.0.0+version:                0.7.0.0 synopsis:               File-backed recursive data structures. homepage:               https://github.com/revnull/fixfile license:                LGPL-3@@ -24,7 +24,7 @@  library   build-depends:        base >=4.8 && < 5-                       ,binary+                       ,cereal                        ,bytestring                        ,mtl                        ,array@@ -47,6 +47,7 @@                        ,Data.FixFile.Trie.Light   other-modules:        Data.FixFile.Fixed                        ,Data.FixFile.Null+                       ,Data.FixFile.Trie.Shared   ghc-options:          -Wall  Test-Suite test-fixfile@@ -55,7 +56,7 @@   type:                 exitcode-stdio-1.0   Build-Depends:        base >=4.5                        ,fixfile-                       ,binary >= 0.7+                       ,cereal                        ,bytestring >= 0.10.2                        ,mtl                        ,temporary

@@ -1,7 +1,8 @@ {-# LANGUAGE ScopedTypeVariables, RankNTypes, KindSignatures,     MultiParamTypeClasses, FlexibleInstances, FlexibleContexts,     FunctionalDependencies, TypeFamilies, UndecidableInstances,-    DeriveDataTypeable, DeriveGeneric, ConstraintKinds #-}+    DeriveDataTypeable, DeriveGeneric, ConstraintKinds,+    DefaultSignatures #-}  {- |     @@ -20,7 +21,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 'Typeable', 'Traversable', and 'Binary' and+    but should have instances of 'Typeable', 'Traversable', and 'Serialize' and     should be structured such that the fixed point of the data type is     recursive. @@ -99,9 +100,8 @@ import Control.Lens hiding (iso, para) import Control.Monad.Except hiding (mapM_) import qualified Control.Monad.RWS as RWS hiding (mapM_)-import Data.Binary+import Data.Serialize 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 hiding (mapM_)@@ -109,6 +109,7 @@ import qualified Data.Map as M import Data.Maybe import Data.Monoid+import Data.Word import GHC.Generics import System.FilePath import System.Directory@@ -183,50 +184,58 @@     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+writeWB :: Serialize a => a -> WriteBuffer -> (WriteBuffer, Pos, Bool)+writeWB a (WB bsf st end) = wb where     wb = (WB bsf' st end', end, end' - st > bufferFlushSize)     enc = encode a-    len = fromIntegral $ BSL.length enc+    len = fromIntegral $ BS.length enc     len' = encode (len :: Word32)-    sbs = BSL.toStrict (len' <> enc)     end' = end + 4 + fromIntegral len-    bsf' = bsf . (sbs:)+    bsf' = bsf . (len':) . (enc:) -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 [])+flushBuffer :: WriteBuffer -> MVar Handle -> IO WriteBuffer+flushBuffer (WB bsf st en) mh = do+    let bs = BS.concat (bsf [])+    seq bs $ withMVar mh $ \h -> do+        hSeek h SeekFromEnd 0+        p <- fromIntegral <$> hTell h+        when (p /= st) $ fail "WriteBuffer position failure."+        BS.hPut h (BS.concat $ bsf [])     return (WB id en en)  -- FFH is a FixFile Handle. This is an internal data structure. data FFH = FFH (MVar Handle) (IORef WriteBuffer) (MVar Caches) -getRawBlock :: Binary a => Handle -> Pos -> IO a+getRawBlock :: Serialize a => Handle -> Pos -> IO a getRawBlock h p = do     hSeek h AbsoluteSeek (fromIntegral p)-    (sb :: Word32) <- decode <$> (BSL.hGet h 4)-    decode <$> BSL.hGet h (fromIntegral sb)+    Right (sb :: Word32) <- decode <$> (BS.hGet h 4)+    Right a <- decode <$> BS.hGet h (fromIntegral sb)+    return a -getBlock :: Fixable f => Ptr f -> FFH -> IO (f (Ptr f))-getBlock p@(Ptr pos) (FFH mh _ mc) = getCachedOrStored p readFromFile mc where+getBlock :: Fixable f => FFH -> Ptr f -> IO (f (Ptr f))+getBlock (FFH mh _ mc) p@(Ptr pos) = getCachedOrStored p readFromFile mc where     readFromFile = withMVar mh $ flip getRawBlock pos -putRawBlock :: Binary a => Bool -> a -> FFH -> IO Pos+-- Bypassing the cache+getBlock' :: Fixable f => FFH -> Ptr f -> IO (f (Ptr f))+getBlock' _ (Ptr 0) = return empty1+getBlock' (FFH mh _ _) (Ptr pos) = readFromFile where+    readFromFile = withMVar mh $ flip getRawBlock pos++putRawBlock :: Serialize 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'')+            wb''' <- flushBuffer wb'' mh             writeIORef wb wb'''         else writeIORef wb wb''     return p -putBlock :: Fixable f => f (Ptr f) -> FFH -> IO (Ptr f)-putBlock a h@(FFH _ _ mc) +putBlock :: Fixable f => FFH -> f (Ptr f) -> IO (Ptr f)+putBlock h@(FFH _ _ mc) a     | null a = return (Ptr 0)     | otherwise = putRawBlock False a h >>= cacheBlock . Ptr where         cacheBlock p = do@@ -253,9 +262,10 @@ --   matches what is in memory. sync :: (Fixable f) => FFH -> Stored s f -> IO (Ptr f) sync h = commit where+    pb = putBlock h     commit (Memory r) = do         r' <- mapM commit r-        putBlock r' h+        pb r'     commit (Cached p _) = return p  {- |@@ -270,13 +280,13 @@ newtype Ptr (f :: * -> *) = Ptr Pos     deriving (Generic, Eq, Ord, Read, Show) -instance Binary (Ptr f)+instance Serialize (Ptr f)  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, Null1 f)+type Fixable f = (Traversable f, Serialize (f (Ptr f)), Typeable f, Null1 f)  {- |     'FixTraverse' is a class based on 'Traverse' but taking an argument of kind@@ -291,11 +301,11 @@  {- |      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'+    'Serialize'. This acts as a sort of "header" for the file where the 'Root'     may have several 'Ref's under it to different 'Functors'. -} -type Root r = (FixTraverse r, Binary (r Ptr))+type Root r = (FixTraverse r, Serialize (r Ptr))  readRoot :: Root r => r Ptr -> Transaction r' s (r (Stored s)) readRoot = traverseFix readPtr where@@ -317,7 +327,7 @@ newtype Ref (f :: * -> *) (g :: (* -> *) -> *) = Ref { deRef :: g f }     deriving (Generic) -instance Binary (Ref f Ptr)+instance Serialize (Ref f Ptr)  instance Fixable f => FixTraverse (Ref f) where     traverseFix isoT (Ref a) = Ref <$> isoT a@@ -368,10 +378,9 @@ withHandle f = Transaction $ RWS.ask >>= liftIO . f  readStoredLazy :: Fixable f => FFH -> Ptr f -> IO (Stored s f)-readStoredLazy h p = do-    f <- getBlock p h-    let fcons = Cached p-    fcons <$> mapM (unsafeInterleaveIO . readStoredLazy h) f+readStoredLazy h = anaMP where +    gb = getBlock h+    anaMP p = Cached p <$> unsafeInterleaveIO (gb p >>= mapM anaMP)  {- |     The preferred way to modify the root object of a 'FixFile' is by using@@ -379,7 +388,7 @@     @'Stored' 's' 'f'@ and returns the new desired head of the     same type. -}-alterT :: (tr ~ Transaction (Ref f) s, Traversable f, Binary (f (Ptr f))) =>+alterT :: (tr ~ Transaction (Ref f) s, Traversable f, Serialize (f (Ptr f))) =>     (Stored s f -> Stored s f) -> tr () alterT f = ref %= f @@ -387,7 +396,7 @@     The preferred way to read from a 'FixFile' is to use 'lookupT'. It     applies a function that takes a @'Stored' s f@ and returns a value. -}-lookupT :: (tr ~ Transaction (Ref f) s, Traversable f, Binary (f (Ptr f))) =>+lookupT :: (tr ~ Transaction (Ref f) s, Traversable f, Serialize (f (Ptr f))) =>     (Stored s f -> a) -> tr a lookupT f = f <$> use ref @@ -417,14 +426,15 @@ readHeader :: FFH -> IO (Pos) readHeader (FFH mh _ _) = withMVar mh $ \h -> do     hSeek h AbsoluteSeek 0-    decode <$> BSL.hGet h 8+    Right p <- decode <$> BS.hGet h 8+    return p  updateHeader :: Pos -> Transaction r s () updateHeader p = do     withHandle $ \(FFH mh _ _) ->          withMVar mh $ \h -> do             hSeek h AbsoluteSeek 0-            BSL.hPut h (encode p)+            BS.hPut h (encode p)             hFlush h  {- |@@ -443,7 +453,7 @@ createFixFileHandle :: Root r =>     r Fix -> FilePath -> Handle -> IO (FixFile r) createFixFileHandle initial path h = do-    BSL.hPut h (encode (0 :: Pos))+    BS.hPut h (encode (0 :: Pos))     wb <- initWB h     ffh <- FFH <$> newMVar h <*> newIORef wb <*> newMVar M.empty     let t = runRT $ do@@ -458,7 +468,7 @@ {- |     Open a 'FixFile' from the file described by 'FilePath'. -}-openFixFile :: Binary (r Ptr) => FilePath -> IO (FixFile r)+openFixFile :: Serialize (r Ptr) => FilePath -> IO (FixFile r) openFixFile path =     openBinaryFile path ReadWriteMode >>= openFixFileHandle path @@ -466,7 +476,7 @@     Open a 'FixFile' from the file described by 'FilePath' and using the     'Handle' to the file. -}-openFixFileHandle :: Binary (r Ptr) => FilePath -> Handle ->+openFixFileHandle :: Serialize (r Ptr) => FilePath -> Handle ->     IO (FixFile r) openFixFileHandle path h = do     wb <- initWB h@@ -577,7 +587,7 @@     runClone = do         mv'@(ffh, root) <- takeMVar mv -        BSL.hPut dh (encode (Ptr 0))+        BS.hPut dh (encode (Ptr 0))          wb <- initWB dh         wb' <- newIORef wb@@ -588,12 +598,12 @@         r' <- putRawBlock True root' dffh           hSeek dh AbsoluteSeek 0-        BSL.hPut dh (encode r')+        BS.hPut dh (encode r')          putMVar mv mv'      copyPtr ffh h = hyloM-        (flip getBlock ffh)+        (getBlock' ffh)         ((Ptr <$>) . flip (putRawBlock False) h)  {- |

@@ -1,6 +1,6 @@ {-# LANGUAGE DeriveGeneric, DeriveFunctor, DeriveFoldable, DeriveTraversable,     DeriveDataTypeable, DataKinds, KindSignatures, TypeFamilies,-    TupleSections #-}+    TupleSections, DefaultSignatures #-}  {- |     Module      :  Data.FixFile.BTree@@ -32,9 +32,10 @@                           ) where  import Control.Monad.Writer-import Data.Binary+import Data.Serialize import Data.Dynamic import qualified Data.Vector as V+import Data.Word import GHC.Generics import GHC.TypeLits @@ -56,7 +57,7 @@     null1 Empty = True     null1 _ = False -instance (Binary k, Binary v, Binary a) => Binary (BTree n k v a) where+instance (Serialize k, Serialize v, Serialize a) => Serialize (BTree n k v a) where     put Empty = putWord8 0x45     put (Value v) = putWord8 0x56 >> put v     put (Node d vec) = do@@ -85,12 +86,12 @@  -- | Create a 'FixFile' storing a @('BTree' k v)@. --   The initial value is 'empty'.-createBTreeFile :: (Typeable n, Binary k, Typeable k, Binary v, Typeable v) =>+createBTreeFile :: (Typeable n, Serialize k, Typeable k, Serialize 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) =>+openBTreeFile :: (Serialize k, Typeable k, Serialize v, Typeable v) =>     FilePath -> IO (FixFile (Ref (BTree n k v))) openBTreeFile = openFixFile @@ -164,7 +165,7 @@                 newNode d (currSize + 1) (csf $ V.fromList [ls, rs])  -- | 'Transaction' version of 'insertBTree'.-insertBTreeT :: (KnownNat n, Ord k, Binary k, Binary v) => k -> v ->+insertBTreeT :: (KnownNat n, Ord k, Serialize k, Serialize v) => k -> v ->     Transaction (Ref (BTree n k v)) s () insertBTreeT k v = alterT (insertBTree k v) @@ -182,7 +183,7 @@         in V.foldr (($) . snd) l eq  -- | 'Transaction' version of 'lookupBTree'.-lookupBTreeT :: (Ord k, Binary k, Binary v) => k ->+lookupBTreeT :: (Ord k, Serialize k, Serialize v) => k ->     Transaction (Ref (BTree n k v)) s [v] lookupBTreeT k = lookupT (lookupBTree k) @@ -247,7 +248,7 @@             _ -> Deleted mink $ node d vec'  -- | 'Transaction' version of 'filterBTree'.-filterBTreeT :: (Ord k, Binary k, Binary v) => k -> (v -> Bool) ->+filterBTreeT :: (Ord k, Serialize k, Serialize v) => k -> (v -> Bool) ->     Transaction (Ref (BTree n k v)) s () filterBTreeT k f = alterT (filterBTree k f) @@ -256,7 +257,7 @@ deleteBTree k = filterBTree k (const False)  -- | 'Transaction' version of 'deleteBTree'.-deleteBTreeT :: (Ord k, Binary k, Binary v) => k ->+deleteBTreeT :: (Ord k, Serialize k, Serialize v) => k ->     Transaction (Ref (BTree n k v)) s () deleteBTreeT k = alterT (deleteBTree k) 

@@ -1,6 +1,6 @@ {-# LANGUAGE DeriveGeneric, DeriveFunctor, DeriveFoldable, DeriveTraversable,     DeriveDataTypeable, DataKinds, KindSignatures, TypeFamilies,-    TupleSections #-}+    TupleSections, DefaultSignatures #-}  {- |     Module      :  Data.FixFile.BTree.Light@@ -34,8 +34,9 @@                                 ) where  import Control.Monad.Writer-import Data.Binary+import Data.Serialize import Data.Dynamic+import Data.Word import qualified Data.Vector as V import GHC.Generics import GHC.TypeLits@@ -57,7 +58,7 @@     null1 Empty = True     null1 _ = False -instance (Binary k, Binary v, Binary a) => Binary (BTree n k v a) where+instance (Serialize k, Serialize v, Serialize a) => Serialize (BTree n k v a) where     put Empty = putWord8 0x45     put (Node _ (Left vec)) = do         putWord8 0x4c@@ -90,12 +91,12 @@  -- | Create a 'FixFile' storing a @('BTree' k v)@. --   The initial value is 'empty'.-createBTreeFile :: (Typeable n, Binary k, Typeable k, Binary v, Typeable v) =>+createBTreeFile :: (Typeable n, Serialize k, Typeable k, Serialize 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) =>+openBTreeFile :: (Serialize k, Typeable k, Serialize v, Typeable v) =>     FilePath -> IO (FixFile (Ref (BTree n k v))) openBTreeFile = openFixFile @@ -180,7 +181,7 @@                 newNode d (currSize + 1) (csf $ V.fromList [ls, rs])  -- | 'Transaction' version of 'insertBTree'.-insertBTreeT :: (KnownNat n, Ord k, Binary k, Binary v) => k -> v ->+insertBTreeT :: (KnownNat n, Ord k, Serialize k, Serialize v) => k -> v ->     Transaction (Ref (BTree n k v)) s () insertBTreeT k v = alterT (insertBTree k v) @@ -200,7 +201,7 @@         in V.foldr (($) . snd) l eq  -- | 'Transaction' version of 'lookupBTree'.-lookupBTreeT :: (Ord k, Binary k, Binary v) => k ->+lookupBTreeT :: (Ord k, Serialize k, Serialize v) => k ->     Transaction (Ref (BTree n k v)) s [v] lookupBTreeT k = lookupT (lookupBTree k) @@ -257,7 +258,7 @@             _ -> Deleted mink $ node d vec'  -- | 'Transaction' version of 'filterBTree'.-filterBTreeT :: (Ord k, Binary k, Binary v) => k -> (v -> Bool) ->+filterBTreeT :: (Ord k, Serialize k, Serialize v) => k -> (v -> Bool) ->     Transaction (Ref (BTree n k v)) s () filterBTreeT k f = alterT (filterBTree k f) @@ -266,7 +267,7 @@ deleteBTree k = filterBTree k (const False)  -- | 'Transaction' version of 'deleteBTree'.-deleteBTreeT :: (Ord k, Binary k, Binary v) => k ->+deleteBTreeT :: (Ord k, Serialize k, Serialize v) => k ->     Transaction (Ref (BTree n k v)) s () deleteBTreeT k = alterT (deleteBTree k) 

@@ -85,14 +85,14 @@     of a Functor. -} ana :: (Functor f, Fixed g) => AnaAlg f a -> a -> g f-ana f = inf . fmap (ana f) . f+ana f = af where af = inf . fmap af . f  {-|     'anaM' is a monadic anamorphism. -} anaM :: (Traversable f, Fixed g, Monad m) =>     AnaMAlg m f a -> a -> m (g f)-anaM f = fmap inf . (traverse (anaM f) =<<) . f+anaM f = af where af = fmap inf . (traverse af =<<) . f  {-|     'CataAlg' is a catamorphism F-Algebra.@@ -109,14 +109,14 @@ -} cata :: (Functor f, Fixed g) => CataAlg f a -> g f -> a {-# INLINE[1] cata #-}-cata f = f . fmap (cata f) . outf+cata f = cf where cf = f . fmap cf . outf  {-|     'cataM' is a monadic catamorphism. -} cataM :: (Traversable f, Fixed g, Monad m) =>     CataMAlg m f a -> g f -> m a-cataM f = (>>= f) . (traverse (cataM f)) . outf+cataM f = cf where cf = (>>= f) . traverse cf . outf  {-|     'ParaAlg' is a paramorphism F-Algebra.@@ -132,17 +132,19 @@     'para' applies a 'ParaAlg' over a fixed point of a 'Functor'. -} para :: (Functor f, Fixed g) => ParaAlg g f a -> g f -> a-para f = f . fmap para' . outf where-    para' x = (x, para f x)+para f = pf where+    pf = f . fmap para' . outf+    para' x = (x, pf x)  {-|     'paraM' is a monadic paramorphism. -} paraM :: (Traversable f, Fixed g, Monad m) =>     ParaMAlg m g f a -> g f -> m a-paraM f = (>>= f) . mapM para' . outf where+paraM f = pf where+    pf = (>>= f) . mapM para' . outf where     para' x = do-        x' <- paraM f x+        x' <- pf x         return (x, x')  {-|

@@ -1,5 +1,5 @@ {-# LANGUAGE DeriveGeneric, DeriveFunctor, DeriveFoldable, DeriveTraversable,-    DeriveDataTypeable, TypeFamilies #-}+    DeriveDataTypeable, TypeFamilies, DefaultSignatures #-}  {- |     Module      :  Data.FixFile.Set@@ -31,7 +31,7 @@  import Prelude hiding (lookup) -import Data.Binary+import Data.Serialize import Data.Dynamic import Data.Monoid import GHC.Generics@@ -45,7 +45,7 @@ data Set i a = Empty | Node a i a     deriving (Read, Show, Generic, Functor, Foldable, Traversable, Typeable) -instance (Binary i, Binary a) => Binary (Set i a)+instance (Serialize i, Serialize a) => Serialize (Set i a)  instance Null1 (Set i) where     empty1 = Empty@@ -66,7 +66,7 @@         GT -> ra >>= \r -> return $ node ln j r  -- | 'Transaction' version of 'insertSet'.-insertSetT :: (Ord i, Binary i) => i -> Transaction (Ref (Set i)) s ()+insertSetT :: (Ord i, Serialize i) => i -> Transaction (Ref (Set i)) s () insertSetT i = alterT (insertSet i)  -- | Delete an item 'i' into a 'Fixed' recursive @'Set' i@.@@ -81,7 +81,7 @@     phi (Node (ln, _) j (_, ra)) x = node ln j <$> ra x  -- | 'Transaction' version of 'deleteSet'.-deleteSetT :: (Ord i, Binary i) => i -> Transaction (Ref (Set i)) s ()+deleteSetT :: (Ord i, Serialize i) => i -> Transaction (Ref (Set i)) s () deleteSetT i = alterT (deleteSet i)  -- | Predicate to lookup an item from a @'Set' i@.@@ -94,16 +94,16 @@         GT -> ra  -- | 'FTransaction' version of 'lookupSet'.-lookupSetT :: (Ord i, Binary i) => i -> Transaction (Ref (Set i)) s Bool+lookupSetT :: (Ord i, Serialize i) => i -> Transaction (Ref (Set i)) s Bool lookupSetT i = lookupT (lookupSet i)  -- | Create a @'FixFile' ('Set' i)@.-createSetFile :: (Binary i, Typeable i) =>+createSetFile :: (Serialize i, Typeable i) =>     FilePath -> IO (FixFile (Ref (Set i))) createSetFile fp = createFixFile (Ref empty) fp  -- | Open a @'FixFile' ('Set' i)@.-openSetFile :: (Binary i, Typeable i) =>+openSetFile :: (Serialize i, Typeable i) =>     FilePath -> IO (FixFile (Ref (Set i))) openSetFile = openFixFile @@ -114,7 +114,7 @@     phi (Node la i ra) l = (la . (i:) . ra) l  -- | 'Transaction' version of 'toListSet'.-toListSetT :: Binary i => Transaction (Ref (Set i)) s [i]+toListSetT :: Serialize i => Transaction (Ref (Set i)) s [i] toListSetT = lookupT toListSet  instance FixedAlg (Set i) where

@@ -1,6 +1,6 @@ {-# LANGUAGE DeriveGeneric, DeriveFunctor, DeriveFoldable, DeriveTraversable,     KindSignatures, TypeFamilies, FlexibleInstances, FlexibleContexts,-    DeriveDataTypeable #-}+    DeriveDataTypeable, DefaultSignatures #-}  {- |     Module      :  Data.FixFile.Tree23@@ -61,7 +61,7 @@ import Prelude hiding (null)  import Data.Dynamic-import Data.Binary+import Data.Serialize import Data.Maybe import Data.Monoid import GHC.Generics (Generic)@@ -94,8 +94,8 @@  data family TreeValue d -instance (Binary a, Binary (TreeKey d), Binary (TreeValue d)) =>-    Binary (Tree23F (TreeKey d) (TreeValue d) a)+instance (Serialize a, Serialize (TreeKey d), Serialize (TreeValue d)) =>+    Serialize (Tree23F (TreeKey d) (TreeValue d) a)  leaf :: Fixed g => TreeKey d -> TreeValue d -> g (Tree23 d) leaf k v = inf $ Leaf k v@@ -134,9 +134,9 @@ data instance TreeValue (Set k) = SV     deriving (Read, Show, Eq, Ord, Generic, Typeable) -instance Binary k => Binary (TreeKey (Set k))+instance Serialize k => Serialize (TreeKey (Set k)) -instance Binary (TreeValue (Set k))+instance Serialize (TreeValue (Set k))  -- | Insert an item into a set. insertSet :: (Fixed g, Ord k, f ~ Tree23 (Set k)) => k -> g f -> g f@@ -179,42 +179,42 @@ fromListSet = Prelude.foldr insertSet empty  -- | Create a 'FixFile' for storing a set of items.-createSetFile :: (Binary k, Typeable k, f ~ Tree23 (Set k)) =>+createSetFile :: (Serialize 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, f ~ Tree23 (Set k)) =>+openSetFile :: (Serialize 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, f ~ Tree23 (Set k)) =>+insertSetT :: (Serialize 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, f ~ Tree23 (Set k)) =>+lookupSetT :: (Serialize 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, f ~ Tree23 (Set k)) =>+deleteSetT :: (Serialize 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 ->+partitionSetT :: (Serialize k, Ord k, f ~ Tree23 (Set k)) => k ->     Transaction (Ref f) s (Stored s f, Stored s f) partitionSetT k = lookupT (partitionSet k)  -- | 'FTransaction' version of 'minSet'.-minSetT :: (Binary k, Ord k, f ~ Tree23 (Set k)) =>+minSetT :: (Serialize k, Ord k, f ~ Tree23 (Set k)) =>     Transaction (Ref f) s (Maybe k) minSetT = lookupT minSet  -- | 'FTransaction' version of 'minSet'.-maxSetT :: (Binary k, Ord k, f ~ Tree23 (Set k)) =>+maxSetT :: (Serialize k, Ord k, f ~ Tree23 (Set k)) =>     Transaction (Ref f) s (Maybe k) maxSetT = lookupT maxSet @@ -237,9 +237,9 @@ newtype instance TreeValue (Map k v) = MV { fromMV :: v }     deriving (Read, Show, Eq, Ord, Generic, Typeable) -instance Binary k => Binary (TreeKey (Map k v))+instance Serialize k => Serialize (TreeKey (Map k v)) -instance Binary v => Binary (TreeValue (Map k v))+instance Serialize v => Serialize (TreeValue (Map k v))  -- | Insert value 'v' into a map for key 'k'. Any existing value is replaced. insertMap :: (Fixed g, Ord k, f ~ Tree23 (Map k v)) => k -> v -> g f -> g f@@ -299,49 +299,49 @@     return (k, v)  -- | Create a 'FixFile' of a Map.-createMapFile :: (Binary k, Typeable k, Binary v, Typeable v,+createMapFile :: (Serialize k, Typeable k, Serialize 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,+openMapFile :: (Serialize k, Typeable k, Serialize 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, f ~ Tree23 (Map k v)) =>+insertMapT :: (Serialize k, Serialize 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, f ~ Tree23 (Map k v)) =>+lookupMapT :: (Serialize k, Serialize 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, f ~ Tree23 (Map k v)) =>+deleteMapT :: (Serialize k, Serialize 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)) =>+partitionMapT :: (Serialize k, Ord k, Serialize 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, f ~ Tree23 (Map k v)) =>+alterMapT :: (Serialize k, Serialize v, Ord k, f ~ Tree23 (Map k v)) =>     k -> (Maybe v -> Maybe v) -> Transaction (Ref f) s () alterMapT k f = alterT (alterMap k f)  -- | 'FTransaction' version of 'minMap'.-minMapT :: (Binary k, Binary v, Ord k, f ~ Tree23 (Map k v)) =>+minMapT :: (Serialize k, Serialize v, Ord k, f ~ Tree23 (Map k v)) =>     Transaction (Ref f) s (Maybe (k, v)) minMapT = lookupT minMap  -- | 'FTransaction' version of 'minMap'.-maxMapT :: (Binary k, Binary v, Ord k, f ~ Tree23 (Map k v)) =>+maxMapT :: (Serialize k, Serialize v, Ord k, f ~ Tree23 (Map k v)) =>     Transaction (Ref f) s (Maybe (k, v)) maxMapT = lookupT maxMap 

@@ -1,5 +1,5 @@ {-# LANGUAGE DeriveGeneric, DeriveFunctor, DeriveFoldable, DeriveTraversable,-    TypeFamilies, DeriveDataTypeable, TupleSections #-}+    TypeFamilies, DeriveDataTypeable, TupleSections, DefaultSignatures #-}  {- |     Module      :  Data.FixFile.Trie@@ -13,11 +13,14 @@     as a key-value store where the key is a 'ByteString' of arbitrary size. -} module Data.FixFile.Trie (Trie+                         ,value                          ,freeze                          ,createTrieFile                          ,openTrieFile                          ,lookupTrie                          ,lookupTrieT+                         ,descendTrie+                         ,descendTrieT                          ,insertTrie                          ,insertTrieT                          ,deleteTrie@@ -31,15 +34,17 @@ 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 Data.Serialize+import Data.Word import GHC.Generics  import Data.FixFile+import Data.FixFile.Trie.Shared  -- | 'Fixed' @('Trie' v)@ is a trie mapping lazy 'ByteString's to values of --   type v.@@ -57,7 +62,7 @@     null1 (Tail Nothing) = True     null1 _ = False -instance (Binary v, Binary a) => Binary (Trie v a) where+instance (Serialize v, Serialize a) => Serialize (Trie v a) where     put (Value v) = putWord8 0 >> put v     put (Tail a) = putWord8 1 >> put a     put (String m b a) = putWord8 2 >> put m >> put b >> put a@@ -72,8 +77,8 @@         getTrie 4 = Big <$> get <*> get         getTrie _ = error "Invalid Serialized Trie" -value :: Fixed g => v -> g (Trie v)-value = inf . Value+valueNode :: Fixed g => v -> g (Trie v)+valueNode = inf . Value  tail :: Fixed g => Maybe (g (Trie v)) -> g (Trie v) tail = inf . Tail where@@ -101,8 +106,14 @@     g (Trie v) mut v l = inf $ Mutable v l -bigThreshold :: Int-bigThreshold = 20+value :: Fixed g => g (Trie v) -> Maybe v+value = cata phi where+    phi (Value v') = Just v'+    phi (Tail v) = join v+    phi (String v _ _) = join v+    phi (Small v _) = join v+    phi (Big v _) = join v+    phi (Mutable v _) = join v  -- | '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@@ -113,11 +124,14 @@  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)+    then+        let Just ((minb,_),_) = M.minViewWithKey b+            Just ((maxb,_),_) = M.maxViewWithKey b+        in Big a $ array (minb, maxb) $ do+            i <- [minb..maxb]+            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 @@ -129,58 +143,57 @@ thaw m = m  -- | Create a 'FixFile' of @('Trie' v)@ data.-createTrieFile :: (Binary v, Typeable v) =>+createTrieFile :: (Serialize 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) =>+openTrieFile :: (Serialize 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 >>= ($ k)-    phi (Value v) _ = return 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+lookupTrie a b = descendTrie a b >>= value  -- | 'Transaction' version of 'lookupTrie'.-lookupTrieT :: Binary v =>+lookupTrieT :: Serialize 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)-    (Nothing, Just _) -> (BS.empty, x, y)-    (Just _, Nothing) -> (BS.empty, x, y)-    (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)+descendTrie :: Fixed g => BS.ByteString -> g (Trie v) -> Maybe (g (Trie v))+descendTrie a b = para phi b b a where+    term t k = guard (BS.null k) >> return t+    phi t t' k = term t' k <|> phi' t k+    phi' (String _ s (t', t)) k = do+        let (_, lt, rt) = splitKey s k+        case (BS.null lt, BS.null rt) of+            (True, _) -> t t' rt+            (False, False) -> Nothing+            _ -> return . inf $ (String Nothing lt t')+    phi' (Small _ l) k = do+        (c, r) <- BS.uncons k+        (t', t) <- lookupAscending c l+        t t' r+    phi' (Big _ l) k = do+        (c, r) <- BS.uncons k+        guard (inRange (bounds l) c)+        (t', t) <- l ! c+        t t' r+    phi' (Mutable _ l) k = do+        (c, r) <- BS.uncons k+        (t', t) <- M.lookup c l+        t t' r+    phi' _ _ = Nothing +descendTrieT :: Serialize v => BS.ByteString ->+    Transaction (Ref (Trie v)) s (Maybe (Stored s (Trie v)))+descendTrieT a = lookupT (descendTrie a)+ -- | 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 $ value b+    val = Just $ valueNode b     valTail = tail val     phi (Value _) _ = error "Badly formed Trie"     phi (Tail vm) k = fill k (fmap fst vm) valTail@@ -213,7 +226,7 @@             Just (_, ta) -> M.insert kh (ta kt) $ fmap fst m  -- | 'Transaction' version of 'insertTrie'.-insertTrieT :: Binary v =>+insertTrieT :: Serialize v =>     BS.ByteString -> v -> Transaction (Ref (Trie v)) s () insertTrieT k v = alterT (insertTrie k v)  @@ -287,7 +300,7 @@                 _ -> NoDelete  -- | 'Transaction' version of 'deleteTrie'.-deleteTrieT :: Binary v =>+deleteTrieT :: Serialize v =>     BS.ByteString -> Transaction (Ref (Trie v)) s () deleteTrieT k = alterT (deleteTrie k) @@ -309,7 +322,7 @@             Nothing -> ($ l) . (f .) . Prelude.foldr (.) id $ do                 (i, r) <- ts                 return $ r BS.empty (BS.snoc k' i)-            Just (i, k'') -> case lookup i ts of+            Just (i, k'') -> case lookupAscending i ts of                 Nothing -> l                 Just r -> r k'' (BS.snoc k' i) l     phi (Big vm ts) k k' l  = @@ -318,7 +331,7 @@             Nothing -> ($ l) . (f .) . Prelude.foldr (.) id $ do                 (i, Just r) <- assocs ts                 return $ r BS.empty (BS.snoc k' i)-            Just (i, k'') -> case ts ! i of+            Just (i, k'') -> case guard (inRange (bounds ts) i) >> ts ! i of                 Nothing -> l                 Just r -> r k'' (BS.snoc k' i) l     phi (Mutable vm ts) k k' l  = @@ -332,7 +345,7 @@                 Just r -> r k'' (BS.snoc k' i) l  -- | 'Transaction' version of 'iterateTrie'.-iterateTrieT :: Binary v => BS.ByteString ->+iterateTrieT :: Serialize v => BS.ByteString ->     Transaction (Ref (Trie v)) s [(BS.ByteString, v)] iterateTrieT k = lookupT (iterateTrie k) @@ -344,7 +357,7 @@  instance FixedFunctor (Trie v) where     fmapF f = cata phi where-        phi (Value v) = value (f v)+        phi (Value v) = valueNode (f v)         phi (Tail v) = tail v         phi (String v b t) = string v b t         phi (Small v ts) = small v ts@@ -364,7 +377,7 @@     traverseF f = cata phi where         mapply Nothing = pure Nothing         mapply (Just v) = Just <$> v-        phi (Value v) = value <$> f v+        phi (Value v) = valueNode <$> 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 <*>

@@ -13,11 +13,14 @@     as a key-value store where the key is a 'ByteString' of arbitrary size. -} module Data.FixFile.Trie.Light (Trie+                               ,value                                ,freeze                                ,createTrieFile                                ,openTrieFile                                ,lookupTrie                                ,lookupTrieT+                               ,descendTrie+                               ,descendTrieT                                ,insertTrie                                ,insertTrieT                                ,deleteTrie@@ -31,15 +34,17 @@ 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 Data.Serialize+import Data.Word import GHC.Generics  import Data.FixFile+import Data.FixFile.Trie.Shared  -- | 'Fixed' @('Trie' v)@ is a trie mapping lazy 'ByteString's to values of --   type v.@@ -56,7 +61,7 @@     null1 (Tail Nothing) = True     null1 _ = False -instance (Binary v, Binary a) => Binary (Trie v a) where+instance (Serialize v, Serialize a) => Serialize (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@@ -90,8 +95,13 @@ 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+value :: Fixed g => g (Trie v) -> Maybe v+value = phi . outf where+    phi (Tail v) = v+    phi (String v _ _) = v+    phi (Small v _) = v+    phi (Big v _) = v+    phi (Mutable v _) = v  -- | '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@@ -102,11 +112,14 @@  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)+    then +        let Just ((minb,_),_) = M.minViewWithKey b+            Just ((maxb,_),_) = M.maxViewWithKey b+        in Big a $ array (minb, maxb) $ do+            i <- [minb..maxb]+            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 @@ -118,52 +131,54 @@ thaw m = m  -- | Create a 'FixFile' of @('Trie' v)@ data.-createTrieFile :: (Binary v, Typeable v) =>+createTrieFile :: (Serialize 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) =>+openTrieFile :: (Serialize 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+lookupTrie a b = descendTrie a b >>= value  -- | 'Transaction' version of 'lookupTrie'.-lookupTrieT :: Binary v =>+lookupTrieT :: Serialize 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)+-- | Lookup a possible value stored in a trie for a given 'ByteString' key.+descendTrie :: Fixed g => BS.ByteString -> g (Trie v) -> Maybe (g (Trie v))+descendTrie a b = para phi b b a where+    term t k = guard (BS.null k) >> return t+    phi t t' k = term t' k <|> phi' t k+    phi' (Tail _) _ = Nothing+    phi' (String _ s (t', t)) k = do+        let (_, lt, rt) = splitKey s k+        case (BS.null lt, BS.null rt) of+            (True, _) -> t t' rt+            (False, False) -> Nothing+            _ -> return . inf $ (String Nothing lt t')+    phi' (Small _ l) k = do+        (c, r) <- BS.uncons k+        (t', t) <- lookupAscending c l+        t t' r+    phi' (Big _ l) k = do+        (c, r) <- BS.uncons k+        guard (inRange (bounds l) c)+        (t', t) <- l ! c+        t t' r+    phi' (Mutable _ l) k = do+        (c, r) <- BS.uncons k+        (t', t) <- M.lookup c l+        t t' r +descendTrieT :: Serialize v => BS.ByteString ->+    Transaction (Ref (Trie v)) s (Maybe (Stored s (Trie v)))+descendTrieT a = lookupT (descendTrie a)+ -- | 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@@ -198,7 +213,7 @@             Just (_, ta) -> M.insert kh (ta kt) $ fmap fst m  -- | 'Transaction' version of 'insertTrie'.-insertTrieT :: Binary v =>+insertTrieT :: Serialize v =>     BS.ByteString -> v -> Transaction (Ref (Trie v)) s () insertTrieT k v = alterT (insertTrie k v)  @@ -267,7 +282,7 @@                 _ -> NoDelete  -- | 'Transaction' version of 'deleteTrie'.-deleteTrieT :: Binary v =>+deleteTrieT :: Serialize v =>     BS.ByteString -> Transaction (Ref (Trie v)) s () deleteTrieT k = alterT (deleteTrie k) @@ -288,7 +303,7 @@         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+            Just (i, k'') -> case lookupAscending 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@@ -296,7 +311,7 @@         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+            Just (i, k'') -> case guard (inRange (bounds ts) i) >> 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@@ -308,7 +323,7 @@                 Just r -> r k'' (BS.snoc k' i)  -- | 'Transaction' version of 'iterateTrie'.-iterateTrieT :: Binary v => BS.ByteString ->+iterateTrieT :: Serialize v => BS.ByteString ->     Transaction (Ref (Trie v)) s [(BS.ByteString, v)] iterateTrieT k = lookupT (iterateTrie k) 

@@ -0,0 +1,30 @@++module Data.FixFile.Trie.Shared (+                                 bigThreshold+                                ,lookupAscending+                                ,splitKey+                                ) where++import Data.ByteString.Lazy as BS++bigThreshold :: Int+bigThreshold = 20++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)+    (Nothing, Just _) -> (BS.empty, x, y)+    (Just _, Nothing) -> (BS.empty, x, y)+    (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)++lookupAscending :: Ord a => a -> [(a, b)] -> Maybe b+lookupAscending _ [] = Nothing+lookupAscending k ((x,y):xs) = case compare x k of+    LT -> lookupAscending k xs+    EQ -> Just y+    _ -> Nothing+