fixfile (empty) → 0.1.0.0
raw patch · 10 files changed
+1969/−0 lines, 10 filesdep +QuickCheckdep +arraydep +basesetup-changed
Dependencies added: QuickCheck, array, base, binary, bytestring, containers, directory, exceptions, filepath, fixfile, hashable, hashtables, lens, mtl, tasty, tasty-quickcheck, temporary
Files
- LICENSE +165/−0
- Setup.hs +2/−0
- fixfile.cabal +69/−0
- src/Data/FixFile.hs +491/−0
- src/Data/FixFile/BTree.hs +255/−0
- src/Data/FixFile/Fixed.hs +97/−0
- src/Data/FixFile/Set.hs +115/−0
- src/Data/FixFile/Tree23.hs +406/−0
- src/Data/FixFile/Trie.hs +349/−0
- tests/Tests.hs +20/−0
+ LICENSE view
@@ -0,0 +1,165 @@+ GNU LESSER GENERAL PUBLIC LICENSE+ Version 3, 29 June 2007++ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.+++ This version of the GNU Lesser General Public License incorporates+the terms and conditions of version 3 of the GNU General Public+License, supplemented by the additional permissions listed below.++ 0. Additional Definitions.++ As used herein, "this License" refers to version 3 of the GNU Lesser+General Public License, and the "GNU GPL" refers to version 3 of the GNU+General Public License.++ "The Library" refers to a covered work governed by this License,+other than an Application or a Combined Work as defined below.++ An "Application" is any work that makes use of an interface provided+by the Library, but which is not otherwise based on the Library.+Defining a subclass of a class defined by the Library is deemed a mode+of using an interface provided by the Library.++ A "Combined Work" is a work produced by combining or linking an+Application with the Library. The particular version of the Library+with which the Combined Work was made is also called the "Linked+Version".++ The "Minimal Corresponding Source" for a Combined Work means the+Corresponding Source for the Combined Work, excluding any source code+for portions of the Combined Work that, considered in isolation, are+based on the Application, and not on the Linked Version.++ The "Corresponding Application Code" for a Combined Work means the+object code and/or source code for the Application, including any data+and utility programs needed for reproducing the Combined Work from the+Application, but excluding the System Libraries of the Combined Work.++ 1. Exception to Section 3 of the GNU GPL.++ You may convey a covered work under sections 3 and 4 of this License+without being bound by section 3 of the GNU GPL.++ 2. Conveying Modified Versions.++ If you modify a copy of the Library, and, in your modifications, a+facility refers to a function or data to be supplied by an Application+that uses the facility (other than as an argument passed when the+facility is invoked), then you may convey a copy of the modified+version:++ a) under this License, provided that you make a good faith effort to+ ensure that, in the event an Application does not supply the+ function or data, the facility still operates, and performs+ whatever part of its purpose remains meaningful, or++ b) under the GNU GPL, with none of the additional permissions of+ this License applicable to that copy.++ 3. Object Code Incorporating Material from Library Header Files.++ The object code form of an Application may incorporate material from+a header file that is part of the Library. You may convey such object+code under terms of your choice, provided that, if the incorporated+material is not limited to numerical parameters, data structure+layouts and accessors, or small macros, inline functions and templates+(ten or fewer lines in length), you do both of the following:++ a) Give prominent notice with each copy of the object code that the+ Library is used in it and that the Library and its use are+ covered by this License.++ b) Accompany the object code with a copy of the GNU GPL and this license+ document.++ 4. Combined Works.++ You may convey a Combined Work under terms of your choice that,+taken together, effectively do not restrict modification of the+portions of the Library contained in the Combined Work and reverse+engineering for debugging such modifications, if you also do each of+the following:++ a) Give prominent notice with each copy of the Combined Work that+ the Library is used in it and that the Library and its use are+ covered by this License.++ b) Accompany the Combined Work with a copy of the GNU GPL and this license+ document.++ c) For a Combined Work that displays copyright notices during+ execution, include the copyright notice for the Library among+ these notices, as well as a reference directing the user to the+ copies of the GNU GPL and this license document.++ d) Do one of the following:++ 0) Convey the Minimal Corresponding Source under the terms of this+ License, and the Corresponding Application Code in a form+ suitable for, and under terms that permit, the user to+ recombine or relink the Application with a modified version of+ the Linked Version to produce a modified Combined Work, in the+ manner specified by section 6 of the GNU GPL for conveying+ Corresponding Source.++ 1) Use a suitable shared library mechanism for linking with the+ Library. A suitable mechanism is one that (a) uses at run time+ a copy of the Library already present on the user's computer+ system, and (b) will operate properly with a modified version+ of the Library that is interface-compatible with the Linked+ Version.++ e) Provide Installation Information, but only if you would otherwise+ be required to provide such information under section 6 of the+ GNU GPL, and only to the extent that such information is+ necessary to install and execute a modified version of the+ Combined Work produced by recombining or relinking the+ Application with a modified version of the Linked Version. (If+ you use option 4d0, the Installation Information must accompany+ the Minimal Corresponding Source and Corresponding Application+ Code. If you use option 4d1, you must provide the Installation+ Information in the manner specified by section 6 of the GNU GPL+ for conveying Corresponding Source.)++ 5. Combined Libraries.++ You may place library facilities that are a work based on the+Library side by side in a single library together with other library+facilities that are not Applications and are not covered by this+License, and convey such a combined library under terms of your+choice, if you do both of the following:++ a) Accompany the combined library with a copy of the same work based+ on the Library, uncombined with any other library facilities,+ conveyed under the terms of this License.++ b) Give prominent notice with the combined library that part of it+ is a work based on the Library, and explaining where to find the+ accompanying uncombined form of the same work.++ 6. Revised Versions of the GNU Lesser General Public License.++ The Free Software Foundation may publish revised and/or new versions+of the GNU Lesser General Public License from time to time. Such new+versions will be similar in spirit to the present version, but may+differ in detail to address new problems or concerns.++ Each version is given a distinguishing version number. If the+Library as you received it specifies that a certain numbered version+of the GNU Lesser General Public License "or any later version"+applies to it, you have the option of following the terms and+conditions either of that published version or of any later version+published by the Free Software Foundation. If the Library as you+received it does not specify a version number of the GNU Lesser+General Public License, you may choose any version of the GNU Lesser+General Public License ever published by the Free Software Foundation.++ If the Library as you received it specifies that a proxy can decide+whether future versions of the GNU Lesser General Public License shall+apply, that proxy's public statement of acceptance of any version is+permanent authorization for you to choose that version for the+Library.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ fixfile.cabal view
@@ -0,0 +1,69 @@+-- Initial fixfile.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/++name: fixfile+version: 0.1.0.0+synopsis: File-backed recursive data structures.+homepage: https://github.com/revnull/fixfile+license: LGPL-3+license-file: LICENSE+author: Rev. Johnny Healey+maintainer: Rev. Johnny Healey <rev.null@gmail.com>+-- copyright: +category: Data+build-type: Simple+-- extra-source-files: +cabal-version: >=1.10+description:+ This package is a library for datatype-generic disk serialization. It+ provides a file abstraction that uses multi-version concurrency control+ to support transaction-aware isolation for multi-threaded access.++ The base library comes with a collection of datatypes to provide sets and+ key-value stores with different properties.++library+ build-depends: base >=4.8 && < 5+ ,binary+ ,bytestring+ ,mtl+ ,array+ ,directory+ ,filepath+ ,temporary+ ,hashable+ ,hashtables+ ,containers+ ,lens+ hs-source-dirs: src+ default-language: Haskell2010+ exposed-modules: Data.FixFile+ ,Data.FixFile.BTree+ ,Data.FixFile.Set+ ,Data.FixFile.Tree23+ ,Data.FixFile.Trie+ other-modules: Data.FixFile.Fixed+ ghc-options: -Wall++Test-Suite test-fixfile+ hs-source-dirs: tests + Main-is: Tests.hs+ type: exitcode-stdio-1.0+ Build-Depends: base >=4.5+ ,fixfile+ ,binary >= 0.7+ ,bytestring >= 0.10.2+ ,mtl+ ,temporary+ ,directory+ ,QuickCheck+ ,tasty+ ,tasty-quickcheck+ ,exceptions+ ,lens+ default-language: Haskell2010+ ghc-options: -O2 -threaded++source-repository head+ type: git+ location: git@github.com:revnull/fixfile.git
+ src/Data/FixFile.hs view
@@ -0,0 +1,491 @@+{-# LANGUAGE ScopedTypeVariables, RankNTypes, KindSignatures,+ MultiParamTypeClasses, FlexibleInstances, FlexibleContexts,+ FunctionalDependencies, TypeFamilies, UndecidableInstances,+ DeriveDataTypeable, DeriveGeneric #-}++{- |+ + Module : Data.FixFile+ Copyright : (C) 2016 Rev. Johnny Healey+ License : LGPL-3+ Maintainer : Rev. Johnny Healey <rev.null@gmail.com>+ Stability : experimental+ Portability : unknown++ A 'FixFile' is file for storing recursive data. The file supports MVCC+ through an append-only file.++ In order to eliminate distinctions between data structures that are+ file-backed versus in-memory, this library makes heavy use of lazy IO.+ 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+ should be structured such that the fixed point of the data type is+ recursive.++ There is also the concept of the 'Root' data of a 'FixFile'. This can be+ used as a kind of header for a FixFile that can allow several recursive+ data structures to be modified in a single transaction.++ -}++module Data.FixFile (+ -- * Fixed point combinators+ Fixed(..)+ ,Fix(..)+ ,Stored+ -- * F-Algebras+ ,CataAlg+ ,cata+ ,AnaAlg+ ,ana+ ,ParaAlg+ ,para+ ,iso+ -- * Root Data+ ,Root(..)+ ,Ptr+ ,Ref(..)+ ,ref+ -- * FixFiles+ ,FixFile+ ,createFixFile+ ,createFixFileHandle+ ,openFixFile+ ,openFixFileHandle+ ,closeFixFile+ ,vacuum+ -- * Transactions+ ,Transaction+ ,alterT+ ,lookupT+ ,readTransaction+ ,writeTransaction+ ,subTransaction+ ,getFull+ ) where++import Prelude hiding (sequence, mapM, lookup)++import Control.Concurrent.MVar+import Control.Exception+import Control.Lens hiding (iso, para)+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+import Data.Hashable+import Data.HashTable.IO+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+import System.IO+import System.IO.Unsafe++import Data.FixFile.Fixed++type HashTable k v = CuckooHashTable k v++data Cache f = Cache Int (HashTable (Ptr f) (f (Ptr f)))+ (HashTable (Ptr f) (f (Ptr f)))+ deriving (Typeable)++type Caches = M.Map TypeRep Dynamic++createCache :: IO (Cache f)+createCache = Cache 0 <$> new <*> new++cacheInsert :: Ptr f -> f (Ptr f) -> Cache f -> IO (Cache f)+cacheInsert p f (Cache i oc nc) =+ if i >= 50+ then new >>= cacheInsert p f . Cache 0 nc+ else do+ insert nc p f+ return (Cache (i + 1) oc nc)++cacheLookup :: Ptr f -> Cache f -> IO (Cache f, Maybe (f (Ptr f)))+cacheLookup p c@(Cache _ oc nc) = do+ nval <- lookup nc p+ val <- maybe (lookup oc p) (return . Just) nval+ case (nval, val) of+ (Nothing, Just v) -> do+ c' <- cacheInsert p v c+ return (c', val)+ _ -> return (c, val)++getCachedOrStored :: Typeable f => Ptr f -> IO (f (Ptr f)) -> MVar Caches ->+ IO (f (Ptr f))+getCachedOrStored p m cs = do+ mval <- withCache cs (cacheLookup p)+ case mval of+ Just v -> return v+ Nothing -> do+ v <- m+ withCache_ cs (cacheInsert p v)+ return v++withCache :: Typeable c => MVar Caches -> (Cache c -> IO (Cache c, a)) -> IO a+withCache cs f = modifyMVar cs $ \cmap -> do+ let mc = M.lookup mt cmap >>= fromDynamic+ mt = typeOf $ fromJust mc+ c <- maybe createCache return mc+ (c', a) <- f c+ return (M.insert mt (toDyn c') cmap, a)++withCache_ :: Typeable c => MVar Caches -> (Cache c -> IO (Cache c)) -> IO ()+withCache_ cs f = withCache cs $ \c -> f c >>= \c' -> return (c', ())++type Pos = Word64++-- FFH is a FixFile Handle. This is an internal data structure.+data FFH = FFH (MVar Handle) (MVar Caches)++getRawBlock :: Binary 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)++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+ readFromFile = withMVar mh $ flip getRawBlock pos++putRawBlock :: Binary a => a -> FFH -> IO Pos+putRawBlock a (FFH mh _) = putRaw where+ putRaw = withMVar mh $ \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'+ return p++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++{- | + 'Stored' is a fixed-point combinator of 'f' in Transaction 's'.+-}+data Stored s f =+ -- | A memory-only instance of 'a'.+ Memory (f (Stored s f))+ -- | An instance of 'a' that is file-backed.+ | Cached {-# UNPACK #-} !(Ptr f) (f (Stored s f))++instance Fixed (Stored s) where+ inf = Memory+ {-# INLINE inf #-}+ outf (Memory a) = a+ outf (Cached _ a) = a+ {-# INLINE outf #-}++-- | 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 h = commit where+ commit (Memory r) = do+ r' <- mapM commit r+ putBlock r' h+ commit (Cached p _) = return p++{- |+ A 'Ptr' points to a location in a 'FixFile' and has a phantom type for a + 'Functor' 'f'. A 'Root' expects an argument that resembles a 'Fixed',+ but we can pass it a 'Ptr' instead. This is not a well-formed 'Fixed'+ because it can't be unpacked into @'f' ('Ptr' 'f')@.+ + But, it can be serialized, which allows a 'Root' object that takes this+ as an argument to be serialized.+-}+newtype Ptr (f :: * -> *) = Ptr Pos+ deriving (Generic, Eq, Ord, Read, Show)++instance Binary (Ptr f)++instance Hashable (Ptr f) where+ hashWithSalt x (Ptr y) = hashWithSalt x y++{- |+ 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.++-}+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++{- |+ A 'Ref' is a reference to a 'Functor' 'f' in the 'Fixed' instance of 'g'.++ 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 }+ 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)++-- | Lens for accessing the value stored in a Ref+ref :: Lens' (Ref f g) (g f)+ref = lens (\(Ref a) -> a) (\_ b -> Ref b)++{- |+ A 'Transaction' is an isolated execution of a read or update operation+ on the root object stored in a 'FixFile'. 'r' is the 'Root' data that is+ stored by the 'FixFile'. 's' is a phantom type used to isolate 'Stored'+ values to the transaction where they are run.+-}+newtype Transaction r s a = Transaction {+ runRT :: RWS.RWST FFH (Last (r Ptr)) (r (Stored s)) IO a+ }++instance Functor (Transaction f s) where+ fmap f (Transaction t) = Transaction $ fmap f t++instance Applicative (Transaction f s) where+ pure = Transaction . pure+ Transaction a <*> Transaction b = Transaction $ a <*> b++instance Monad (Transaction f s) where+ return = pure+ Transaction t >>= f = Transaction $ RWS.RWST $ \ffh root -> do+ (a, root', w) <- RWS.runRWST t ffh root+ (a', root'', w') <- RWS.runRWST (runRT $ f a) ffh root'+ return (a', root'', w `mappend` w')++instance RWS.MonadState (r (Stored s)) (Transaction r s) where+ get = Transaction $ RWS.get+ put = Transaction . RWS.put+ state = Transaction . RWS.state++{- |+ Perform a 'Transaction' on a part of the root object.+-}+subTransaction :: Lens' (r (Stored s)) (r' (Stored s)) -> Transaction r' s a ->+ Transaction r s a+subTransaction l st = Transaction $ RWS.RWST $ \ffh root -> do+ (a, r, _) <- RWS.runRWST (runRT st) ffh (root^.l)+ return (a, set l r root, mempty)++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 h p = do+ f <- getBlock p h+ let fcons = Cached p+ fcons <$> mapM (unsafeInterleaveIO . readStoredLazy h) f++{- |+ The preferred way to modify the root object of a 'FixFile' is by using+ 'alterT'. It applies a function that takes the root object as a+ @'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))) =>+ (Stored s f -> Stored s f) -> tr ()+alterT f = ref %= f++{- |+ 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))) =>+ (Stored s f -> a) -> tr a+lookupT f = f <$> use ref++{- |+ A 'FixFile' is a handle for accessing a file-backed recursive data+ structure. 'r' is the 'Root' object stored in the 'FixFile'.+-}+data FixFile r = FixFile FilePath (MVar (FFH, r Ptr)) (MVar ())++acquireWriteLock :: FixFile f -> IO ()+acquireWriteLock (FixFile _ _ wl) = do+ void $ takeMVar wl++releaseWriteLock :: FixFile f -> IO ()+releaseWriteLock (FixFile _ _ wl) = do+ putMVar wl ()++withWriteLock :: FixFile f -> IO a -> IO a+withWriteLock ff f = do+ acquireWriteLock ff+ f `finally` releaseWriteLock ff++readHeader :: FFH -> IO (Pos)+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 _) -> + withMVar mh $ \h -> do+ hSeek h AbsoluteSeek 0+ BSL.hPut h (encode p)+ hFlush h++{- |+ 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 initial path =+ openFile path ReadWriteMode >>= createFixFileHandle initial path++{- |+ Create a 'FixFile', using @'Fix' f@ as the initial structure to store+ at the location described by 'FilePath' and using the 'Handle' to the+ file to be created.+-}+createFixFileHandle :: (Root r, Binary (r Ptr), Typeable 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))+ let t = runRT $ do+ dr <- writeRoot $ rootIso initial+ (withHandle $ putRawBlock dr) >>= updateHeader+ Transaction . RWS.tell . Last . Just $ dr+ (_,_,root') <- RWS.runRWST t ffh undefined+ let Just root = getLast root'+ ffhmv <- newMVar (ffh, root)+ FixFile path ffhmv <$> newMVar ()++{- |+ Open a 'FixFile' from the file described by 'FilePath'.+-}+openFixFile :: Binary (r Ptr) => FilePath -> IO (FixFile r)+openFixFile path =+ openFile path ReadWriteMode >>= openFixFileHandle path++{- |+ Open a 'FixFile' from the file described by 'FilePath' and using the+ 'Handle' to the file.+-}+openFixFileHandle :: Binary (r Ptr) => FilePath -> Handle ->+ IO (FixFile r)+openFixFileHandle path h = do+ ffh <- FFH <$> newMVar h <*> newMVar M.empty+ root <- readHeader ffh >>= getRawBlock h + ffhmv <- newMVar (ffh, root)+ FixFile path ffhmv <$> newMVar ()++{- |+ Close a 'FixFile'. This can potentially cause errors on data that is lazily+ being read from a 'Transaction'.+-}+closeFixFile :: FixFile r -> IO ()+closeFixFile (FixFile path tmv _) = do+ (FFH mh _, _) <- takeMVar tmv+ h <- takeMVar mh+ hClose h+ putMVar mh $ error (path ++ " is closed.")+ putMVar tmv $ error (path ++ " is closed.")++{- |+ Perform a read transaction on a 'FixFile'. This transaction cannot+ modify the root object stored in the file. The returned value is lazily+ evaluated, but will always correspond to the root object at the start+ of the transaction.+-}+readTransaction :: Root r => FixFile r ->+ (forall s. Transaction r s a) -> IO a+readTransaction (FixFile _ ffhmv _) t = do+ (ffh, root) <- readMVar ffhmv+ let t' = readRoot root >>= RWS.put >> t+ (a, _) <- RWS.evalRWST (runRT t') ffh undefined+ return a++{- |+ Perform a write transaction on a 'FixFile'. This operation differs from+ 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) => + FixFile r -> (forall s. Transaction r s a)+ -> IO a+writeTransaction ff@(FixFile _ ffhmv _) t = res where+ res = withWriteLock ff runTransaction+ runTransaction = do+ (ffh, root) <- readMVar ffhmv+ let t' = readRoot root >>= RWS.put >> t >>= save+ save a = do+ dr <- RWS.get >>= writeRoot+ (withHandle $ putRawBlock dr) >>= updateHeader+ Transaction . RWS.tell . Last . Just $ dr+ return a+ (a, root') <- RWS.evalRWST (runRT t') ffh undefined+ case getLast root' of+ Nothing -> return ()+ Just root'' -> do+ void $ swapMVar ffhmv (ffh, root'')+ return a++{- |+ Get the full datastructure from the transaction as a @'Fix' f@.+-}+getFull :: Functor f => Transaction (Ref f) s (Fix f)+getFull = uses ref iso++{- |+ Because a 'FixFile' is backed by an append-only file, there is a periodic+ need to 'vacuum' the file to garbage collect data that is no longer+ referenced from the root. This task operates on a temporary file that then+ replaces the file that backs FixFile.++ 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 ff@(FixFile path mv _) = withWriteLock ff runVacuum where+ runVacuum = do+ mval <- takeMVar mv++ readFFHMV <- newMVar mval+ readDB <- FixFile path readFFHMV <$> newMVar ()++ (tp, th) <- openTempFile (takeDirectory path) ".ffile.tmp"+ hClose th++ rootMem <- readTransaction readDB (rootIso <$> RWS.get)+ (FixFile _ newMV _) <- createFixFile rootMem tp++ renameFile tp path++ takeMVar newMV >>= putMVar mv+
+ src/Data/FixFile/BTree.hs view
@@ -0,0 +1,255 @@+{-# LANGUAGE DeriveGeneric, DeriveFunctor, DeriveFoldable, DeriveTraversable,+ DeriveDataTypeable #-}++{- |+ Module : Data.FixFile.BTree+ 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.+-}+module Data.FixFile.BTree (BTree+ ,createBTreeFile+ ,openBTreeFile+ ,empty+ ,insertBTree+ ,insertBTreeT+ ,lookupBTree+ ,lookupBTreeT+ ,filterBTree+ ,filterBTreeT+ ,deleteBTree+ ,deleteBTreeT+ ,toListBTree+ ,fromListBTree+ ) where++import Data.Array+import Data.Binary+import Data.Dynamic+import GHC.Generics++import Data.FixFile++{- |+ A 'Fixed' @('BTree' k v)@ stores a BTree of key/value pairs.+-}+data BTree k v a =+ Empty+ | Value v+ | Node Word32 (Array Int (k, a))+ deriving (Read, Show, Generic, Functor, Foldable, Traversable, Typeable)++instance (Binary k, Binary v, Binary a) => Binary (BTree k v a)++-- | An empty 'BTree' +empty :: Fixed g => g (BTree k v)+empty = inf Empty++value :: Fixed g => v -> g (BTree k v)+value = inf . Value++node :: Fixed g => Word32 -> Array Int (k, g (BTree k v)) -> g (BTree 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 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)))+openBTreeFile = openFixFile++nodeSize :: Integral i => i+nodeSize = 32++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 -> 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++data Insert k v g =+ Inserted k (g (BTree k v))+ | Split Word32 (k, (g (BTree k v))) (k, (g (BTree 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+ 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)++ children xs = [(i, x) | (i, (x, _)) <- xs]++ phi Empty = Inserted k $ node 0 $ array (0,0) [(0, (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++-- | 'Transaction' version of 'insertBTree'.+insertBTreeT :: (Ord k, Binary k, Binary v) => k -> v ->+ Transaction (Ref (BTree 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 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++-- | 'Transaction' version of 'lookupBTree'.+lookupBTreeT :: (Ord k, Binary k, Binary v) => k ->+ Transaction (Ref (BTree k v)) s [v]+lookupBTreeT k = lookupT (lookupBTree k)++data Deleted k v g =+ Deleted k (g (BTree 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)+filterBTree k f t = deleted' . para phi $ t where+ deleted' UnChanged = t+ deleted' AllDeleted = empty+ deleted' (Deleted _ x) = x+ 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++-- | 'Transaction' version of 'filterBTree'.+filterBTreeT :: (Ord k, Binary k, Binary v) => k -> (v -> Bool) ->+ Transaction (Ref (BTree 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 k = filterBTree k (const False)++-- | 'Transaction' version of 'deleteBTree'.+deleteBTreeT :: (Ord k, Binary k, Binary v) => k ->+ Transaction (Ref (BTree k v)) s ()+deleteBTreeT k = alterT (deleteBTree k)++-- | 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 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++-- | 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 = foldr (uncurry insertBTree) empty+
+ src/Data/FixFile/Fixed.hs view
@@ -0,0 +1,97 @@++{- |+ Module : Data.FixFile.Fixed+ Copyright : (C) 2016 Rev. Johnny Healey+ License : LGPL-3+ Maintainer : Rev. Johnny Healey <rev.null@gmail.com>+ Stability : experimental+ Portability : unknown++ This is a data type that can be used with a 'FixFile' to store a set of+ 'Ordered' items as an unbalanced binary tree. This file is not recommended+ for use, but exists for educational purposes. It has a simple+ implementation that is easier to read than some of the more advanced+ balanced data types.+-}+module Data.FixFile.Fixed (+ Fix(..)+ ,Fixed(..)+ ,CataAlg+ ,cata+ ,AnaAlg+ ,ana+ ,ParaAlg+ ,para+ ,iso+ ) where++{-|+ 'Fixed' is a typeclass for representing the fixed point of a 'Functor'.+ A well-behaved instance of 'Fixed' should not change the shape of the+ underlying 'Functor'.++ In other words, the following should always be true:+@+'outf' ('inf' x) == x+@+ -}+class Fixed g where+ inf :: f (g f) -> g f+ outf :: g f -> f (g f)++{-|+ 'Fix' is a type for creating an in-memory representation of the fixed+ point of a 'Functor'.++-}+newtype Fix f = InF { outF :: f (Fix f) }++instance Fixed Fix where+ inf = InF+ {-# INLINE inf #-}+ outf = outF+ {-# INLINE outf #-}++{-|+ 'AnaAlg' is an anamorpism F-Algebra.+-}+type AnaAlg f a = a -> f a++{-|+ 'ana' applies an AnaAlg over an argument to produce a fixed-point+ of a Functor.+-}+ana :: (Functor f, Fixed g) => AnaAlg f a -> a -> g f+ana f = inf . fmap (ana f) . f++{-|+ 'CataAlg' is a catamorphism F-Algebra.+-}+type CataAlg f a = f a -> a++{-|+ 'cata' applies a 'CataAlg' over a fixed point of a 'Functor'.+-}+cata :: (Functor f, Fixed g) => CataAlg f a -> g f -> a+cata f = f . fmap (cata f) . outf++{-|+ 'ParaAlg' is a paramorphism F-Algebra.+-}+type ParaAlg g f a = f (g f, a) -> a++{-|+ '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)++{-|+ 'iso' maps from a fixed point of a 'Functor' to a different fixed+ point of the same 'Functor'. For any two well-behaved instances of+ 'Fixed', the shape of the 'Functor' should remain unchanged.+-}+iso :: (Functor f, Fixed g, Fixed h) => g f -> h f+iso = cata inf+
+ src/Data/FixFile/Set.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE DeriveGeneric, DeriveFunctor, DeriveFoldable, DeriveTraversable,+ DeriveDataTypeable #-}++{- |+ Module : Data.FixFile.Set+ Copyright : (C) 2016 Rev. Johnny Healey+ License : LGPL-3+ Maintainer : Rev. Johnny Healey <rev.null@gmail.com>+ Stability : experimental+ Portability : unknown++ This is a data type that can be used with a 'FixFile' to store a set of+ 'Ordered' items as an unbalanced binary tree. This file is not recommended+ for use, but exists for educational purposes. It has a simple+ implementation that is easier to read than some of the more advanced+ balanced data types.+-}+module Data.FixFile.Set (Set+ ,createSetFile+ ,openSetFile+ ,empty+ ,insertSet+ ,insertSetT+ ,deleteSet+ ,deleteSetT+ ,lookupSet+ ,lookupSetT+ ,toListSet+ ,toListSetT+ ) where++import Prelude hiding (lookup)++import Data.Binary+import Data.Dynamic+import GHC.Generics++import Data.FixFile+{- |+ A 'Fixed' @('Set' i)@ is a set of items represented as a binary tree.+-}+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)++-- | An empty 'Set'.+empty :: Fixed g => g (Set i)+empty = inf Empty++node :: Fixed g => g (Set i) -> i -> g (Set i) -> g (Set i)+node l i r = inf $ Node l i r++-- | Insert an item 'i' into a 'Fixed' recursive @'Set' i@.+insertSet :: (Ord i, Fixed g) => i -> g (Set i) -> g (Set i)+insertSet i s = newHead $ para phi s where+ newHead = maybe s id+ phi Empty = Just $ node empty i empty+ phi (Node (ln, la) j (rn, ra)) = case compare i j of+ EQ -> Nothing+ LT -> la >>= \l -> return $ node l j rn+ GT -> ra >>= \r -> return $ node ln j r++-- | 'Transaction' version of 'insertSet'.+insertSetT :: (Ord i, Binary i) => i -> Transaction (Ref (Set i)) s ()+insertSetT i = alterT (insertSet i)++-- | Delete an item 'i' into a 'Fixed' recursive @'Set' i@.+deleteSet :: (Ord i, Fixed g) => i -> g (Set i) -> g (Set i)+deleteSet i s = newHead $ para phi s Nothing where+ newHead = maybe s id+ phi Empty x = x+ phi (Node (ln, la) j (rn, ra)) Nothing = case compare i j of+ EQ -> la (Just rn)+ LT -> la Nothing >>= \l -> return $ node l j rn+ GT -> ra Nothing >>= \r -> return $ node ln j r+ 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 i = alterT (deleteSet i)++-- | Predicate to lookup an item from a @'Set' i@.+lookupSet :: (Ord i, Fixed g) => i -> g (Set i) -> Bool+lookupSet i = cata phi where+ phi Empty = False+ phi (Node la j ra) = case compare i j of+ EQ -> True+ LT -> la+ GT -> ra++-- | 'FTransaction' version of 'lookupSet'.+lookupSetT :: (Ord i, Binary i) => i -> Transaction (Ref (Set i)) s Bool+lookupSetT i = lookupT (lookupSet i)++-- | Create a @'FixFile' ('Set' i)@.+createSetFile :: (Binary 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) =>+ FilePath -> IO (FixFile (Ref (Set i)))+openSetFile = openFixFile++-- | Turn a 'Fixed' recurive structure of @'Set' i@ into a list.+toListSet :: Fixed g => g (Set i) -> [i]+toListSet s = cata phi s [] where+ phi Empty l = l+ phi (Node la i ra) l = (la . (i:) . ra) l++-- | 'Transaction' version of 'toListSet'.+toListSetT :: Binary i => Transaction (Ref (Set i)) s [i]+toListSetT = lookupT toListSet+
+ src/Data/FixFile/Tree23.hs view
@@ -0,0 +1,406 @@+{-# LANGUAGE DeriveGeneric, DeriveFunctor, DeriveFoldable, DeriveTraversable,+ KindSignatures, TypeFamilies, FlexibleInstances, FlexibleContexts,+ DeriveDataTypeable #-}++{- |+ Module : Data.FixFile.Tree23+ Copyright : (C) 2016 Rev. Johnny Healey+ License : LGPL-3+ Maintainer : Rev. Johnny Healey <rev.null@gmail.com>+ Stability : experimental+ Portability : unknown++ This is an implementation of a Two-Three Tree data structure that can be+ used with 'FixFile'. It has two interfaces that are+-}+module Data.FixFile.Tree23 (Tree23+ ,TreeD+ ,empty+ ,null+ ,size+ -- | * Set+ ,Set+ ,createSetFile+ ,openSetFile+ ,insertSet+ ,lookupSet+ ,deleteSet+ ,toListSet+ ,fromListSet+ ,insertSetT+ ,lookupSetT+ ,deleteSetT+ -- | * Map+ ,Map+ ,createMapFile+ ,openMapFile+ ,insertMap+ ,lookupMap+ ,deleteMap+ ,alterMap+ ,mapMap+ ,toListMap+ ,fromListMap+ ,insertMapT+ ,lookupMapT+ ,deleteMapT+ ,alterMapT+ ,keysMap+ ,valuesMap+ ) where++import Prelude hiding (null)++import Data.Dynamic+import Data.Binary+import Data.Maybe+import GHC.Generics+ +import Data.FixFile++data Tree23F k v a = + Empty+ | Leaf k v+ | Two a k a+ | Three a k a k a+ deriving (Read, Show, Eq, Ord, Generic, Functor, Foldable, Traversable,+ Typeable)++{- |+ 'Fixed' @('TreeD' 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)++data family TreeKey d++data family TreeValue d++instance (Binary a, Binary (TreeKey d), Binary (TreeValue d)) =>+ Binary (Tree23F (TreeKey d) (TreeValue d) a)++-- | An empty 'Fixed' 'Tree23'.+empty :: Fixed g => Tree23 g d+empty = inf Empty++leaf :: Fixed g => TreeKey d -> TreeValue d -> Tree23 g d+leaf k v = inf $ Leaf k v++two :: Fixed g => Tree23 g d -> TreeKey d ->+ Tree23 g d -> Tree23 g 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 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 = null' . outf where+ null' Empty = True+ null' _ = False++-- | Number of entries in @('Tree23' g d)@.+size :: Fixed g => Tree23 g 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++-- | A 'Set' of 'k' represented as a Two-Three Tree.+data Set k++newtype instance TreeKey (Set k) = SK k+ deriving (Read, Show, Eq, Ord, Generic, Typeable)++data instance TreeValue (Set k) = SV+ deriving (Read, Show, Eq, Ord, Generic, Typeable)++instance Binary k => Binary (TreeKey (Set k))++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 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 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 k = alterTree23 (SK k) (const $ Just Nothing)++-- | Convert a set into a list of items.+toListSet :: (Fixed g, Ord k) => Tree23 g (Set k) -> [k]+toListSet = ($ []) . cata phi where+ phi Empty xs = xs+ phi (Leaf (SK k) _) xs = k:xs+ phi (Two la _ ra) xs = la . ra $ xs+ 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 = 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 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 fp = openFixFile fp++-- | 'Transaction' version of 'insertSet'.+insertSetT :: (Binary k, Ord k) =>+ k -> Transaction (Ref (TreeD (Set k))) s ()+insertSetT k = alterT (insertSet k) ++-- | 'FTransaction' version of 'lookupSet'.+lookupSetT :: (Binary k, Ord k) =>+ k -> Transaction (Ref (TreeD (Set k))) s Bool+lookupSetT k = lookupT (lookupSet k)++-- | 'FTransaction' version of 'deleteSet'.+deleteSetT :: (Binary k, Ord k) =>+ k -> Transaction (Ref (TreeD (Set k))) s ()+deleteSetT k = alterT (deleteSet k)++-- | A 'Map' of keys 'k' to values 'v' represented as a Two-Three Tree.+data Map k v++newtype instance TreeKey (Map k v) = MK k+ deriving (Read, Show, Eq, Ord, Generic, Typeable)++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 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 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 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 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 k f = alterTree23 (MK k) (Just . fmap MV . f . fmap fromMV)++-- | Convert a map into a list of key-value tuples.+toListMap :: (Fixed g, Ord k) => Tree23 g (Map k v) -> [(k,v)]+toListMap = ($ []) . cata phi where+ phi Empty xs = xs+ phi (Leaf (MK k) (MV v)) xs = (k,v):xs+ phi (Two la _ ra) xs = la . ra $ xs+ 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 = 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 = fmap fst . toListMap++-- | Return a list of values in a map.+valuesMap :: (Fixed g, Ord k) => Tree23 g (Map k v) -> [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 f = cata phi where+ phi Empty = empty+ phi (Leaf (MK k) (MV a)) = leaf (MK k) (MV (f a))+ phi (Two l (MK k) r) = two l (MK k) r+ 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 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 fp = openFixFile fp++-- | 'Transaction' version of 'insertMap'.+insertMapT :: (Binary k, Binary v, Ord k) =>+ k -> v -> Transaction (Ref (TreeD (Map k v))) 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 k = lookupT (lookupMap k)++-- | 'Transaction' version of 'deleteMap'.+deleteMapT :: (Binary k, Binary v, Ord k) => k ->+ Transaction (Ref (TreeD (Map k v))) s ()+deleteMapT k = alterT (deleteMap 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 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)+lookupTree23 k = cata phi where+ phi Empty = Nothing+ phi (Leaf k' v)+ | k == k' = Just v+ | otherwise = Nothing+ phi (Two la k' ra) =+ case compare k k' of+ LT -> la+ _ -> ra+ phi (Three la k1 ma k2 ra) =+ case (compare k k1, compare k k2) of+ (LT, _) -> la+ (_, LT) -> ma+ (_, _) -> ra++data Change g d =+ NoChange+ | Changed (Maybe (TreeKey d)) (Tree23 g d)+ | Unbalanced (Maybe (TreeKey d)) (Tree23 g d)+ | Hole+ | Split (Tree23 g d) (TreeKey d) (Tree23 g 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.+--+-- The (TreeKey d) is the key where the modification should take place.+-- The function takes one argument which is Maybe the value stored in the+-- tree for the given key.+-- The function returns Nothing if no change is made to the tree, Just Nothing+-- if the value should be deleted from the tree, and Just v for the new value]+-- 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+alterTree23 k f t = processHead $ para phi t t where+ processHead NoChange = t+ processHead (Changed _ t') = t'+ processHead Hole = empty+ processHead (Unbalanced _ t') = t'+ processHead (Split lt d rt) = two lt d rt++ phi Empty _ = case f Nothing of+ Just (Just v) -> Changed Nothing $ leaf k v+ _ -> NoChange++ phi (Leaf k' v') n+ | k == k' = case f (Just v') of+ Nothing -> NoChange+ Just Nothing -> Hole+ Just (Just v) -> Changed Nothing $ leaf k' v+ | otherwise = case f Nothing of+ Nothing -> NoChange+ Just Nothing -> NoChange+ Just (Just v) -> if k < k'+ then Split (leaf k v) k' n+ else Split n k (leaf k v)++ phi (Two (ln, la) k' (rn, ra)) _+ | k < k' = case la ln of+ NoChange -> NoChange+ Changed nk la' ->+ Changed nk $ two la' k' rn+ Split la' k'' ma'->+ Changed Nothing $ three la' k'' ma' k' rn+ Hole -> Unbalanced (Just k') rn+ Unbalanced uk un -> case outf rn of+ Three ln' k1 mn' k2 rn' -> Changed uk $+ two (two un k' ln') k1 (two mn' k2 rn')+ Two ln' k1 rn' -> Unbalanced uk $+ three un k' ln' k1 rn'+ _ -> error "Invalid Tree23"+ | otherwise = case ra rn of+ NoChange -> NoChange+ Hole -> Unbalanced Nothing ln+ Changed dk dn -> Changed Nothing $+ two ln (maybe k' id dk) dn+ Split ma' k'' ra' -> Changed Nothing $+ three ln k' ma' k'' ra'+ Unbalanced uk un -> case outf ln of+ Three ln' k1 mn' k2 rn' -> Changed Nothing $+ two (two ln' k1 mn') k2 (two rn' (maybe k' id uk) un)+ Two ln' k1 rn' -> Unbalanced Nothing $+ three ln' k1 rn' (maybe k' id uk) un+ _ -> error "Invalid Tree23"++ phi (Three (ln, la) k1 (mn, ma) k2 (rn, ra)) _ + | k < k1 = case la ln of+ NoChange -> NoChange+ Hole -> Changed (Just k1) $ two mn k2 rn+ Changed dk dn -> Changed dk $+ three dn k1 mn k2 rn+ Split ln' k' rn' -> Split+ (two ln' k' rn') k1 (two mn k2 rn)+ Unbalanced uk un -> case outf mn of+ Three ln' k1' mn' k2' rn' -> Changed uk $+ three (two un k1 ln') k1' (two mn' k2' rn') k2 rn+ Two ln' k1' rn' -> Changed uk $+ two (three un k1 ln' k1' rn') k2 rn+ _ -> error "Invalid Tree23"++ | k < k2 = case ma mn of+ NoChange -> NoChange+ Hole -> Changed Nothing $ two ln k2 rn+ Changed dk dn -> Changed Nothing $+ three ln (maybe k1 id dk) dn k2 rn+ Split mn' k' rn' -> Split+ (two ln k1 mn') k' (two rn' k2 rn)+ Unbalanced uk un -> case outf rn of+ Three ln' k1' mn' k2' rn' -> Changed Nothing $+ three ln (maybe k1 id uk) (two un k2 ln')+ k1' (two mn' k2' rn')+ Two ln' k1' rn' -> Changed Nothing $+ two ln (maybe k1 id uk) (three un k2 ln' k1' rn')+ _ -> error "Invalid Tree23"++ | otherwise = case ra rn of+ NoChange -> NoChange+ Hole -> Changed Nothing $ two ln k1 mn+ Changed dk dn -> Changed Nothing $+ three ln k1 mn (maybe k2 id dk) dn+ Split mn' k' rn' -> Split+ (two ln k1 mn) k2 (two mn' k' rn')+ Unbalanced uk un -> case outf mn of+ Three ln' k1' mn' k2' rn' -> Changed Nothing $+ three ln k1 (two ln' k1' mn') k2'+ (two rn' (maybe k2 id uk) un)+ Two ln' k1' rn' -> Changed Nothing $ two ln k1+ (three ln' k1' rn' (maybe k2 id uk) un)+ _ -> error "Invalid Tree23"+
+ src/Data/FixFile/Trie.hs view
@@ -0,0 +1,349 @@+{-# LANGUAGE DeriveGeneric, DeriveFunctor, DeriveFoldable, DeriveTraversable,+ TypeFamilies, DeriveDataTypeable #-}++{- |+ 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 (Trie+ ,empty+ ,freeze+ ,createTrieFile+ ,openTrieFile+ ,lookupTrie+ ,lookupTrieT+ ,insertTrie+ ,insertTrieT+ ,deleteTrie+ ,deleteTrieT+ ,iterateTrie+ ,iterateTrieT+ ,trieMap+ ) 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 GHC.Generics++import Data.FixFile++-- | 'Fixed' @('Trie' v)@ is a trie mapping lazy 'ByteString's to values of+-- type v.+data Trie v a =+ Value v+ | Tail (Maybe a)+ | String (Maybe a) BS.ByteString a+ | Small (Maybe a) [(Word8, a)]+ | Big (Maybe a) (Array Word8 (Maybe a))+ | Mutable (Maybe a) (M.Map Word8 a)+ deriving (Read, Show, Generic, Functor, Foldable, Traversable, Typeable)++instance (Binary v, Binary a) => Binary (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+ 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 0 = Value <$> get+ 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"++value :: Fixed g => v -> g (Trie v)+value = inf . Value++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)+string v k t = inf $ String v k t++fill :: Fixed g => BS.ByteString -> Maybe (g (Trie 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 (g (Trie v)) -> [(Word8, g (Trie v))]+ -> g (Trie v)+small v l = inf $ Small v l++big :: Fixed g => Maybe (g (Trie v)) ->+ Array Word8 (Maybe (g (Trie v)))+ -> g (Trie v)+big v l = inf $ Big v l++mut :: Fixed g => Maybe (g (Trie 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 >>= ($ 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++-- | '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)+ (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)++-- | 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+ valTail = tail val+ phi (Value _) _ = error "Badly formed Trie"+ phi (Tail vm) k = fill k (fmap fst 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+ vm' = fmap fst vm+ 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 (fmap fst 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 (Value _) _ = error "Invalid Trie"+ 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 =+ let (_, lt, rt) = splitKey k s+ ta' = ta lt+ vm' = fmap fst vm+ in 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'+ vm' = fmap fst vm+ 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'+ vm' = fmap fst vm+ 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+ phi (Value v) _ k' l = (k',v):l+ phi (Tail vm) k k' l = maybe l (\va -> va k k' l) (guard (BS.null k) >> vm)+ phi (String vm s ta) k k' l =+ let (_, lt, rt) = splitKey k s+ f l' = maybe l' (\va -> va k k' l') (guard (BS.null k) >> vm)+ in if BS.null lt || BS.null rt+ then f $ ta lt (BS.append k' s) l + else f l+ phi (Small vm ts) k k' l = + let f l' = maybe l' (\va -> va k k' l') (guard (BS.null k) >> vm)+ in case BS.uncons k of+ 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+ Nothing -> l+ Just r -> r k'' (BS.snoc k' i) l+ phi (Big vm ts) k k' l = + let f l' = maybe l' (\va -> va k k' l') (guard (BS.null k) >> vm)+ in case BS.uncons k of+ 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+ Nothing -> l+ Just r -> r k'' (BS.snoc k' i) l+ phi (Mutable vm ts) k k' l = + let f l' = maybe l' (\va -> va k k' l') (guard (BS.null k) >> vm)+ in case BS.uncons k of+ Nothing -> ($ l) . (f .) . Prelude.foldr (.) id $ do+ (i, r) <- M.toList ts+ return $ r BS.empty (BS.snoc k' i)+ Just (i, k'') -> case M.lookup i ts of+ Nothing -> l+ Just r -> r k'' (BS.snoc k' i) l++-- | 'Transaction' version of 'iterateTrie'.+iterateTrieT :: Binary v => BS.ByteString ->+ Transaction (Ref (Trie v)) s [(BS.ByteString, v)]+iterateTrieT k = lookupT (iterateTrie k)++-- | Map a function over a 'Fixed' 'Trie'. Because of the data types used,+-- this can't be implemented as a 'Functor'.+trieMap :: (Fixed h, Fixed i) => (v -> v') -> h (Trie v) -> i (Trie v')+trieMap f = cata phi where+ phi (Value v) = value (f v)+ phi (Tail v) = tail v+ phi (String v b t) = string v b t+ phi (Small v ts) = small v ts+ phi (Big v ts) = big v ts+ phi (Mutable v ts) = mut v ts+
+ tests/Tests.hs view
@@ -0,0 +1,20 @@++import Test.Tasty++import TestSet+import TestTree23+import TestTrie+import TestBTree+import TestFixFile++main :: IO ()+main = defaultMain $+ testGroup "FixFile"+ [+ test23+ ,testSet+ ,testTrie+ ,testBTree+ ,testFixFile+ ]+