berkeleydb (empty) → 2008.10.31
raw patch · 10 files changed
+1409/−0 lines, 10 filesdep +basedep +binarydep +bytestringsetup-changed
Dependencies added: base, binary, bytestring
Files
- LICENSE +35/−0
- Setup.hs +2/−0
- berkeleydb.cabal +31/−0
- cbits/wrapper.c +59/−0
- cbits/wrapper.h +30/−0
- runHPC.sh +6/−0
- src/Data/BerkeleyDB.hs +614/−0
- src/Data/BerkeleyDB/IO.hs +104/−0
- src/Data/BerkeleyDB/Internal.hsc +303/−0
- src/Tests.hs +225/−0
+ LICENSE view
@@ -0,0 +1,35 @@+Copyright (c) 2008, David Himmelstrup+All rights reserved.++Redistribution and use in source and binary forms,+with or without modification, are permitted provided+that the following conditions are met:++ * Redistributions of source code must retain+ the above copyright notice, this list of+ conditions and the following disclaimer.+ * Redistributions in binary form must reproduce+ the above copyright notice, this list of+ conditions and the following disclaimer in the+ documentation and/or other materials provided+ with the distribution.+ * Neither the name of David Himmelstrup nor the+ names of other contributors may be used to+ endorse or promote products derived from this+ software without specific prior written permission.+++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND+CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES+OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER+OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,+BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS+INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,+WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING+NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE+USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY+OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ berkeleydb.cabal view
@@ -0,0 +1,31 @@+Name: berkeleydb+Version: 2008.10.31+Author: David Himmelstrup <lemmih@gmail.com>+Maintainer: David Himmelstrup <lemmih@gmail.com>+Copyright: 2008 David Himmelstrup <lemmih@gmail.com>+Build-Type: Simple+Build-Depends: base, bytestring, binary+Exposed-Modules: Data.BerkeleyDB+Other-Modules: Data.BerkeleyDB.Internal+ Data.BerkeleyDB.IO+Hs-Source-Dirs: src+Extensions: CPP+Includes: db.h+Extra-libraries: db+Include-dirs: cbits+Extra-source-files: cbits/wrapper.h, runHPC.sh, src/Tests.hs+C-sources: cbits/wrapper.c+License: BSD3+License-file: LICENSE+Tested-with: GHC ==6.8.3+Category: Database+Synopsis: Pretty BerkeleyDB v4 binding.+Description:+ This library attempts to provide a memory efficient alternative to+ Data.Map. The BerkeleyDB system is bound and exposed through an+ interface that mimics Data.Map as much as possible.+ .+ Features include: pure interface with fairly efficient sharing+ and a very small memory footprint.+ .+ Tested with libdb4.6
+ cbits/wrapper.c view
@@ -0,0 +1,59 @@+#include <db.h>+#include <string.h>++#include "wrapper.h"++int hs_open(DB *db, DB_TXN *txnid, const char *file,+ const char *database, DBTYPE type, u_int32_t flags, int mode)+{ return db->open(db,txnid,file,database,type,flags,mode); }++int hs_close(DB *db, u_int32_t flags)+{ return db->close(db, flags); }++void hs_gc_close(DB *db)+{ db->close(db, DB_NOSYNC); }++int hs_put(DB *db,+ DB_TXN *txnid, DBT *key, DBT *data, u_int32_t flags)+{ return db->put(db,txnid,key,data,flags); }++int hs_get(DB *db,+ DB_TXN *txnid, DBT *key, DBT *data, u_int32_t flags)+{ return db->get(db,txnid,key,data,flags); }++void hs_clear_dbt(DBT *dbt)+{ memset(dbt, 0, sizeof(DBT)); }++void hs_multiple_init(void **ptr, DBT *data)+{+ DB_MULTIPLE_INIT(*ptr,data);+}++void hs_multiple_next(void **ptr, DBT *data, void **retdata, size_t *retdlen)+{+ DB_MULTIPLE_NEXT(*ptr,data,*retdata,*retdlen);+}++int hs_set_flags(DB *db, u_int32_t flags)+{ return db->set_flags(db,flags); }++int hs_get_flags(DB *db, u_int32_t *flags)+{ return db->get_flags(db,flags); }+++int hs_cursor(DB *db, DB_TXN *txnid, DBC **cursorp, u_int32_t flags)+{ return db->cursor(db,txnid,cursorp,flags); }+++int hs_cursor_get(DBC *DBcursor,+ DBT *key, DBT *data, u_int32_t flags)+{ return DBcursor->get(DBcursor, key, data, flags); }++int hs_cursor_close(DBC *DBcursor)+{ return DBcursor->close(DBcursor); }+++int hs_env_open(DB_ENV *dbenv, char *db_home, u_int32_t flags, int mode)+ { return dbenv->open(dbenv,db_home,flags,mode); }++
+ cbits/wrapper.h view
@@ -0,0 +1,30 @@+#if !defined(__WRAPPER_H__)+#define __WRAPPER_H__++int hs_open(DB *db, DB_TXN *txnid, const char *file,+ const char *database, DBTYPE type, u_int32_t flags, int mode);++int hs_close(DB *db, u_int32_t flags);+void hs_gc_close(DB *db);++int hs_put(DB *db, DB_TXN *txnid, DBT *key, DBT *data, u_int32_t flags);++int hs_get(DB *db, DB_TXN *txnid, DBT *key, DBT *data, u_int32_t flags);++void hs_clear_dbt(DBT *dbt);+++void hs_multiple_init(void **ptr, DBT *data);++void hs_multiple_next(void **ptr, DBT *data, void **retdata, size_t *retdlen);++int hs_set_flags(DB *db, u_int32_t flags);+int hs_get_flags(DB *db, u_int32_t *flags);++int hs_cursor(DB *db, DB_TXN *txnid, DBC **cursorp, u_int32_t flags);+int hs_cursor_get(DBC *DBcursor, DBT *key, DBT *data, u_int32_t flags);+int hs_cursor_close(DBC *DBcursor);++int hs_env_open(DB_ENV *dbenv, char *db_home, u_int32_t flags, int mode);++#endif
+ runHPC.sh view
@@ -0,0 +1,6 @@+#!/usr/bin/env sh++ghc dist/build/cbits/wrapper.o -ldb -isrc -idist/build --make -O2 -fhpc src/Tests.hs &&+rm -f Tests.tix &&+./src/Tests &&+hpc markup Tests.tix
+ src/Data/BerkeleyDB.hs view
@@ -0,0 +1,614 @@+{-# LANGUAGE DeriveDataTypeable, CPP #-}+-----------------------------------------------------------------------------+-- |+-- Module : Data.BerkeleyDB+-- Copyright : (c) David Himmelstrup 2008+-- License : BSD-style+-- Maintainer : lemmih@gmail.com+-- Stability : experimental+-- Portability : non-portable (requires libDB)+--+-- An efficient implementation of maps from keys to values (dictionaries).+--+-- Since many function names (but not the type name) clash with+-- "Prelude" names, this module is usually imported @qualified@, e.g.+--+-- > import Data.BerkeleyDB (DB)+-- > import qualified Data.BerkeleyDB as DB+--+-- The implementation of 'Db' uses the berkeley db library. See+-- <http://en.wikipedia.org/wiki/Berkeley_DB> and+-- <http://www.oracle.com/technology/products/berkeley-db/index.html> +--+-- Note that this implementation behaves exactly like a @Data.Map.Map ByteString ByteString@,+-- with the key and value encoded by @Data.Binary.encode/Data.Binary.decode@.+-- This means that keys aren't sorted according to Ord. Affected functions are:+-- 'toList', 'assocs', 'elems'.+-----------------------------------------------------------------------------+module Data.BerkeleyDB+ ( -- * Db type+ Db++ -- * Operators+ , (!) --, (\\)++ -- * Query+ , null+ , size+ , member+ , notMember+ , lookup+ , findWithDefault++ -- * Construction+ , empty+ , singleton++ -- ** Insertion+ , insert+ , insertWith+ , insertWithKey++ -- ** Delete\/Update+ , delete+ , adjust+ , adjustWithKey+ , update+ , updateWithKey+ , updateLookupWithKey+ , alter++ -- * Combine+ -- ** Union+ , union+ , unionWith+ , unionWithKey+ , unions+ , unionsWith++ -- ** Difference+{- , difference+ , differenceWith+ , differenceWithKey++ -- ** Intersection+ , intersection+ , intersectionWith+ , intersectionWithKey-}++ -- * Traversal+ -- ** Map+ , map+ , mapWithKey+{- , mapAccum+ , mapAccumWithKey+ , mapKeys+ , mapKeysWith+ , mapKeysMonotonic-}++ -- ** Fold+ , fold+-- , foldWithKey++ -- * Conversion+ , elems+ , keys+-- , keysSet+ , assocs++ -- ** Lists+ , toList+ , fromList+ , fromListWith+ , fromListWithKey++ -- ** Ordered lists+{- , toAscList+ , fromAscList+ , fromAscListWith+ , fromAscListWithKey+ , fromDistinctAscList-}++ -- * Filter+ , filter+ , filterWithKey+{- , partition+ , partitionWithKey-}++{- , mapMaybe+ , mapMaybeWithKey+ , mapEither+ , mapEitherWithKey++ , split+ , splitLookup-}++ -- * Submap+-- , isSubdbOf, isSubdbOfBy+-- , isProperSubdbOf, isProperSubdbOfBy++ -- * Indexed+ -- * Min\/Max+{- , findMin+ , findMax+ , deleteMin+ , deleteMax+ , deleteFindMin+ , deleteFindMax+ , updateMin+ , updateMax+ , updateMinWithKey+ , updateMaxWithKey+ , minView+ , maxView+ , minViewWithKey+ , maxViewWithKey -}+ ) where++import Data.Binary+import Data.Monoid+#if __GLASGOW_HASKELL__+import Data.Generics+import Text.Read hiding (get)+#endif++import qualified Data.BerkeleyDB.IO as IO+import qualified Data.BerkeleyDB.Internal as Internal++import qualified Data.ByteString.Lazy as Lazy+import qualified Data.ByteString as Strict++import Data.IORef+import System.IO.Unsafe+import Data.List (foldl',sort)+import Data.Maybe+import Data.Typeable (Typeable)+import Data.Binary+import Control.Monad (forM_, liftM, replicateM, mplus)+import Control.Concurrent+import Foreign++import Prelude hiding (map,lookup,null,filter)+import qualified Prelude++data Db key value = Empty+ | Db { ioDB :: IO.Db key (Int,Maybe Internal.Object)+ , range :: ![Range]+ , uniqGen :: {- UNPACK -} !(IORef Int)+ , dbSize :: !Int+ }+ deriving (Typeable)+data Range = Range Int Int deriving Show++{--------------------------------------------------------------------+ Instances+--------------------------------------------------------------------}++instance (Show key, Show value, Binary key, Binary value) => Binary (Db key value) where+-- put = put . toList+ put Empty = put (0::Int)+ put (Db db range uniq size)+ = do let lst = unsafePerformIO $+ withVar db $ \(IO.Db db) ->+ withForeignPtr db $ \dbPtr ->+ do cursor <- Internal.newCursor dbPtr+ let loop = unsafeInterleaveIO $+ do mbPair <- Internal.getAtCursor cursor [Internal.Next]+ case mbPair of+ Nothing -> Internal.closeCursor cursor >> touchForeignPtr db >> return []+ Just pair -> liftM (pair:) loop+ loop+ bss :: [(Internal.Object, Internal.Object)]+ bss = flip mapMaybe lst $ \(key,values) ->+ do value <- findValue range (Prelude.map (decode.fromObject) values)+ return (key, value)+ put size+ mapM_ put bss+-- get = fmap fromList get+ get = do n <- get+ bss <- replicateM n get :: Get [(Internal.Object, Internal.Object)]+ unsafePerformIO $+ do db <- IO.new IO.BTree+ let IO.Db dbForeign = db+ withForeignPtr dbForeign $ \dbPtr -> forM_ bss $ \(key,value) -> Internal.put dbPtr key (toObject $ encode $ (0::Int,Just value)) []+ uniq <- newIORef 1+ return $ return $ Db db (addToRange 0 []) uniq n++instance (Binary key, Binary value, Show key, Show value) => Show (Db key value) where+ showsPrec d m = showParen (d > 10) $+ showString "fromList " . shows (toList m)++instance (Binary k, Binary a, Read k, Read a) => Read (Db k a) where+#ifdef __GLASGOW_HASKELL__+ readPrec = parens $ prec 10 $ do+ Ident "fromList" <- lexP+ xs <- readPrec+ return (fromList xs)++ readListPrec = readListPrecDefault+#else+ readsPrec p = readParen (p > 10) $ \ r -> do+ ("fromList",s) <- lex r+ (xs,t) <- reads s+ return (fromList xs,t)+#endif+++instance (Binary key, Binary value, Eq key, Eq value) => Eq (Db key value) where+ db1 == db2 = size db1 == size db2 && toList db1 == toList db2++instance (Binary key, Binary value, Ord key, Ord value) => Ord (Db key value) where+ db1 `compare` db2 = sort (toList db1) `compare` sort (toList db2)++instance (Binary k, Binary a) => Monoid (Db k a) where+ mempty = empty+ mappend = union+ mconcat = unions++#if __GLASGOW_HASKELL__+{--------------------------------------------------------------------+ A Data instance +--------------------------------------------------------------------}++-- This instance preserves data abstraction at the cost of inefficiency.+-- We omit reflection services for the sake of data abstraction.++instance (Data k, Data a, Binary k, Binary a) => Data (Db k a) where+ gfoldl f z map = z fromList `f` (toList map)+ toConstr _ = error "toConstr"+ gunfold _ _ = error "gunfold"+ dataTypeOf _ = mkNorepType "Data.BerkeleyDB.Db"+ dataCast2 f = gcast2 f++#endif++++{--------------------------------------------------------------------+ Methods+--------------------------------------------------------------------}++-- | /O(log n)/. Find the value at a key.+-- Calls 'error' when the element can not be found.+(!) :: (Binary k, Binary v) => Db k v -> k -> v+db ! k = case lookup k db of+ Nothing -> error "Data.BerkeleyDB.!: element not in the database"+ Just x -> x++-- | /O(1)/. The empty database.+empty :: (Binary key, Binary value) => Db key value+empty = Empty++-- | /O(1)/. A map with a single element.+singleton :: (Binary k, Binary a) => k -> a -> Db k a+singleton k a = insert k a empty++-- | /O(log n)/. Insert a new key and value in the database.+-- If the key is already present in the database, the associated value is+-- replaced with the supplied value, i.e. 'insert' is equivalent to+-- @'insertWith' 'const'@.+insert :: (Binary key, Binary value) => key -> value -> Db key value -> Db key value+insert key val db+ = unsafePerformIO $+ withDB db $ \(Db db range uniq size) ->+ do myUniq <- atomicModifyIORef uniq (\a -> (a+1,a))+ withVar db $ \ioDB ->+ do exist <- fmap isJust $ lookupPrim key ioDB range+ IO.insert ioDB key (myUniq, Just $ toObject $ encode val)+ return $ Db db (addToRange myUniq range) uniq (if exist then size else size+1)++-- | /O(log n)/. Insert with a combining function.+-- @'insertWith' f key value db@ +-- will insert the pair (key, value) into @db@ if key does+-- not exist in the database. If the key does exist, the function will+-- insert the pair @(key, f new_value old_value)@.+insertWith :: (Binary k, Binary a) => (a -> a -> a) -> k -> a -> Db k a -> Db k a+insertWith fn key val db+ = insertWithKey (\k x y -> fn x y) key val db++-- | /O(log n)/. Insert with a combining function.+-- @'insertWithKey' f key value db@ +-- will insert the pair (key, value) into @db@ if key does+-- not exist in the database. If the key does exist, the function will+-- insert the pair @(key,f key new_value old_value)@.+-- Note that the key passed to f is the same key passed to 'insertWithKey'.+insertWithKey :: (Binary k, Binary a) => (k -> a -> a -> a) -> k -> a -> Db k a -> Db k a+insertWithKey fn key val db+ = unsafePerformIO $+ withDB db $ \(Db db range uniq size) ->+ do myUniq <- atomicModifyIORef uniq (\a -> (a+1,a))+ withVar db $ \ioDB ->+ do mbOldValue <- lookupPrim key ioDB range+ case mbOldValue of+ Nothing -> do IO.insert ioDB key (myUniq, Just $ toObject $ encode val)+ return $ Db db (addToRange myUniq range) uniq (size+1)+ Just oldValue -> do let newvalue = fn key val (decode (fromObject oldValue))+-- putStrLn $ "oldValue: " ++ show oldValue+ IO.insert ioDB key (myUniq, Just $ toObject $ encode newvalue)+ return $ Db db (addToRange myUniq range) uniq size++++-- | /O(log n)/. Lookup the value at a key in the database.+--+-- The function will+-- @return@ the result in the monad or @fail@ in it the key isn't in the+-- database. Often, the monad to use is 'Maybe', so you get either+-- @('Just' result)@ or @'Nothing'@.+lookup :: (Binary key, Binary value, Monad m) => key -> Db key value -> m value+lookup key Empty = fail "Data.BerkeleyDB.lookup: Key not found"+lookup key (Db db range uniq size)+ = unsafePerformIO $+ do withVar db $ \db -> do mbValue <- lookupPrim key db range+ case mbValue of+ Nothing -> return $ fail "Data.BerkeleyDB.lookup: Key not found"+ Just value -> return $ return (decode (fromObject value))++-- | /O(log n)/. The expression @('findWithDefault' def k db)@ returns+-- the value at key @k@ or returns @def@ when the key is not in the database.+findWithDefault :: (Binary k, Binary a) => a -> k -> Db k a -> a+findWithDefault def k db+ = case lookup k db of+ Nothing -> def+ Just x -> x++-- | /O(log n)/. Is the key a member of the map?+member :: (Binary key, Binary value) => key -> Db key value -> Bool+member key db+ = isJust (lookup key db)++-- | /O(log n)/. Is the key not a member of the map?+notMember :: (Binary key, Binary value) => key -> Db key value -> Bool+notMember k m = not $ member k m+++--lookupPrim :: (Binary key, Binary value) => key -> IO.Db key value -> [Range] -> IO (Maybe value)+lookupPrim key db range+ = do rets <- IO.lookupMany db key+ return $ findValue range rets++-- | /O(log n*m)/.+-- The expression (@'union' t1 t2@) takes the left-biased union of @t1@ and @t2@. +-- It prefers @t1@ when duplicate keys are encountered,+-- i.e. (@'union' == 'unionWith' 'const'@).+union :: (Binary key, Binary value) => Db key value -> Db key value -> Db key value+union t1 t2+ = unionWith const t1 t2++-- | /O(log n*m)/. Union with a combining function.+unionWith :: (Binary key, Binary value) => (value -> value -> value) -> Db key value -> Db key value -> Db key value+unionWith fn t1 t2+ = unionWithKey (\k x y -> fn x y) t1 t2++-- | /O(log n*m))/.+-- Union with a combining function. This function is most efficient on (bigset `union` smallset).+unionWithKey :: (Binary key, Binary value) => (key -> value -> value -> value) -> Db key value -> Db key value -> Db key value+unionWithKey fn t1 t2+ = foldl' (\db (k,v) -> insertWith (flip (fn k)) k v db) t1 (toList t2)++-- | The union of a list of databases:+-- (@'unions' == 'Prelude.foldl' 'union' 'empty'@).+unions :: (Binary k, Binary a) => [Db k a] -> Db k a+unions = foldl' union empty++-- | The union of a list of databases, with a combining operation:+-- (@'unionsWith' f == 'Prelude.foldl' ('unionWith' f) 'empty'@).+unionsWith :: (Binary k, Binary a) => (a -> a -> a) -> [Db k a] -> Db k a+unionsWith fn = foldl' (unionWith fn) empty++-- | /O(n)/. Fold the values in the map, such that+-- @'fold' f z == 'Prelude.foldr' f z . 'elems'@.+-- For example,+--+-- > elems map = fold (:) [] map+--+fold :: (Binary k, Binary a) => (a -> b -> b) -> b -> Db k a -> b+fold f z m+ = Prelude.foldr f z (elems m)++-- | /O(log n)/. Delete a key and its value from the database. When the key is not+-- a member of the database, the original database is returned.+delete :: (Binary key, Binary value) => key -> Db key value -> Db key value+delete key Empty = Empty+delete key (Db db range uniq size)+ = unsafePerformIO $+ do myUniq <- atomicModifyIORef uniq (\a -> (a+1,a))+ withVar db $ \ioDB ->+ do exist <- fmap isJust $ lookupPrim key ioDB range+ IO.insert ioDB key (myUniq, Nothing)+ return $ Db db (addToRange myUniq range) uniq (if exist then size-1 else size)++-- | /O(log n)/. Adjust a value at a specific key. When the key is not+-- a member of the map, the original map is returned.+adjust :: (Binary k, Binary a) => (a -> a) -> k -> Db k a -> Db k a+adjust fn k db = adjustWithKey (\k x -> fn x) k db++-- | /O(log n)/. Adjust a value at a specific key. When the key is not+-- a member of the map, the original map is returned.+adjustWithKey :: (Binary k, Binary a) => (k -> a -> a) -> k -> Db k a -> Db k a+adjustWithKey fn k db = updateWithKey (\k v -> Just (fn k v)) k db++-- | /O(log n)/. The expression (@'update' f k map@) updates the value @x@+-- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is+-- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.+update :: (Binary k, Binary a) => (a -> Maybe a) -> k -> Db k a -> Db k a+update fn k db = updateWithKey (\k x -> fn x) k db++-- | /O(log n)/. The expression (@'updateWithKey' f k db@) updates the+-- value @x@ at @k@ (if it is in the database). If (@f k x@) is 'Nothing',+-- the element is deleted. If it is (@'Just' y@), the key @k@ is bound+-- to the new value @y@.+updateWithKey :: (Binary k, Binary a) => (k -> a -> Maybe a) -> k -> Db k a -> Db k a+updateWithKey fn key db = snd (updateLookupWithKey fn key db)++-- | /O(log n)/. The expression (@'updateWithKey' f k db@) updates the+-- value @x@ at @k@ (if it is in the database). If (@f k x@) is 'Nothing',+-- the element is deleted. If it is (@'Just' y@), the key @k@ is bound+-- to the new value @y@.+updateLookupWithKey :: (Binary k, Binary a) => (k -> a -> Maybe a) -> k -> Db k a -> (Maybe a, Db k a)+updateLookupWithKey _ _ Empty = (Nothing, Empty)+updateLookupWithKey fn key orig@(Db db range uniq size)+ = unsafePerformIO $+ withVar db $ \ioDB ->+ do mbVal <- lookupPrim key ioDB range+ case mbVal of+ Nothing -> return (Nothing, orig)+ Just val -> do myUniq <- atomicModifyIORef uniq (\a -> (a+1,a))+ let oldval = decode (fromObject val)+ newval = fn key oldval+ IO.insert ioDB key (myUniq, fmap (toObject.encode) newval)+ return (newval `mplus` Just oldval, Db db (addToRange myUniq range) uniq (if isJust newval then size else size-1))++-- FIXME: Use a cursor to avoid two lookups.+-- | /O(log n)/. The expression (@'alter' f k db@) alters the value @x@ at @k@, or absence thereof.+-- 'alter' can be used to insert, delete, or update a value in a 'Db'.+-- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@+alter :: (Binary k, Binary a) => (Maybe a -> Maybe a) -> k -> Db k a -> Db k a+alter f k db+ = case f (lookup k db) of+ Nothing -> delete k db+ Just x' -> insert k x' db++-- | /O(n)/. Convert to a list of key\/value pairs.+toList :: (Binary key, Binary value) => Db key value -> [(key, value)]+toList = unsafePerformIO . toListIO++toListIO :: (Binary key, Binary value) => Db key value -> IO [(key, value)]+toListIO Empty = return []+toListIO (Db db range uniq size)+ = do -- putStrLn "Initiating toList"+ assocs <- withVar db $ \db -> IO.getAllObjects db+ let real = [ (key, decode $ fromObject value) | (key, values) <- assocs, Just value <- [findValue range values]]+ --putStrLn $ " Elements: " ++ show (length real)+ return real++-- | /O(n)/. Return all key\/value pairs in the map in ascending key order.+assocs :: (Binary key, Binary value) => Db key value -> [(key,value)]+assocs m+ = toList m+++-- | /O(n*log n)/. Build a database from a list of key\/value pairs. See also 'fromAscList'.+fromList :: (Binary key, Binary value) => [(key, value)] -> Db key value+fromList = fromListWith const+{-+ = unsafePerformIO $+ do db <- IO.new IO.BTree+ forM_ lst $ \(key,value) -> IO.insert db key (0, Just $ toObject $ encode value)+ uniq <- newIORef 1+ var <- newMVar db+ return $ Db var [Range 0 0] uniq+-}++-- | /O(n*log n)/. Build a database from a list of key\/value pairs with a combining function.+fromListWith :: (Binary k, Binary a) => (a -> a -> a) -> [(k,a)] -> Db k a+fromListWith fn = fromListWithKey (\k -> fn)++-- | /O(n*log n)/. Build a database from a list of key\/value pairs with a combining function.+fromListWithKey :: (Binary k, Binary a) => (k -> a -> a -> a) -> [(k,a)] -> Db k a+fromListWithKey fn = foldl' (\db (k,v) -> insertWithKey fn k v db) empty++++-- | /O(n)/.+-- Return all elements of the database in the ascending order of their keys+-- sorted by their binary representation.+elems :: (Binary key, Binary value) => Db key value -> [value]+elems = Prelude.map snd . toList++-- | /O(n)/. Return all keys of the database in ascending order+-- sorted by their binary representation.+keys :: (Binary key, Binary value) => Db key value -> [key]+keys = Prelude.map fst . toList++-- | /O(1)/. Is the map empty?+null :: Db key value -> Bool+null db = size db == 0++-- | /O(1)/. The number of elements in the map.+size :: Db key value -> Int+size Empty = 0+size (Db{dbSize=s}) = s++-- | /O(n)/. Map a function over all values in the database.+map :: (Binary a, Binary b,Binary k) => (a -> b) -> Db k a -> Db k b+map fn db = mapWithKey (\_key val -> fn val) db++-- | /O(n)/. Map a function over all values in the database.+mapWithKey :: (Binary a, Binary b,Binary k) => (k -> a -> b) -> Db k a -> Db k b+mapWithKey fn db+ = unsafePerformIO $+ do let lst = toList db+ newDb <- IO.new IO.BTree+ uniq <- newIORef 1+ forM_ lst $ \(key,value) -> IO.insert newDb key (0, Just $ toObject $ encode $ fn key value)+ return $ Db newDb (addToRange 0 []) uniq (size db)+++-- | /O(n)/. Filter all values that satisfy the predicate.+filter :: (Binary k, Binary a) => (a -> Bool) -> Db k a -> Db k a+filter p m+ = filterWithKey (\k x -> p x) m++-- | /O(n)/. Filter all keys\/values that satisfy the predicate.+filterWithKey :: (Binary k, Binary a) => (k -> a -> Bool) -> Db k a -> Db k a+filterWithKey p Empty = Empty+filterWithKey p orig@(Db db range uniq size)+ = unsafePerformIO $+ do myUniq <- atomicModifyIORef uniq (\a -> (a+1,a))+ let loop n [] = return $ Db db (addToRange myUniq range) uniq (size-n)+ loop n ((key,val):rs)+ | p key val = loop n rs+ | otherwise = do withVar db $ \dbIO -> IO.insert dbIO key (myUniq, Nothing)+ loop (n+1) rs+ loop 0 =<< toListIO orig++++++{--------------------------------------------------------------------+ Utilities+--------------------------------------------------------------------}+++toObject lbs = Strict.concat (Lazy.toChunks lbs)++fromObject bs = Lazy.fromChunks [bs]++withVar var fn = fn var++withDB Empty fn+ = do db <- do db <- IO.new IO.BTree+ ref <- newIORef 0+ return $ Db db [] ref 0+ fn db+withDB db fn = fn db+++findValue range [] = Nothing+findValue range ((uniqId, value):rs)+ | uniqId `isInRange` range = value+ | otherwise = findValue range rs+++isInRange :: Int -> [Range] -> Bool+isInRange i [] = False+isInRange i (Range x y:rs)+ | i > x = False+ | i < y = isInRange i rs+ | otherwise = True++addToRange :: Int -> [Range] -> [Range]+addToRange i [] = [Range i i]+addToRange i (Range x y:rs)+ = merge (Range i i:Range x y:rs)++merge [] = []+merge [x] = [x]+merge (Range x y:Range a b:rs)+ | y == a+1 = merge (Range x b:rs)+ | otherwise = Range x y:merge (Range a b:rs)+++
+ src/Data/BerkeleyDB/IO.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE ForeignFunctionInterface #-}+module Data.BerkeleyDB.IO+ ( new+ , insert+-- , Data.BerkeleyDB.IO.lookup+ , lookupMany+ , getAllObjects+ , serialise+ , Db(..)+ , module Data.BerkeleyDB.Internal+ ) where++import Data.Binary+import qualified Data.ByteString.Lazy as Lazy+import qualified Data.ByteString.Unsafe as Strict+import qualified Data.ByteString as Strict++import qualified Data.BerkeleyDB.Internal as D+import Data.BerkeleyDB.Internal (DbType(..),DbFlag(..))++import Foreign.C+import Foreign (ForeignPtr, Ptr, FunPtr, newForeignPtr, withForeignPtr, castPtr)+import Control.Monad+import System.IO.Unsafe+import Foreign.ForeignPtr++newtype Db key value = Db (ForeignPtr D.DB)++newtype Cursor key value = Cursor (Ptr D.DBC)++new :: (Binary key, Binary value) => DbType -> IO (Db key value)+new dbType+ = do --putStrLn "newdb"+ ptr <- D.open Nothing Nothing dbType [D.Create,D.Thread]+ liftM Db $ newForeignPtr D.closePtr ptr++insert :: (Binary key, Binary value) => Db key value -> key -> value -> IO ()+insert (Db db) key val+ = withForeignPtr db $ \dbPtr ->+ do D.put dbPtr (serialise key) (serialise val) []++{-+{-# INLINE lookup #-}+lookup :: (Binary key, Binary value) => Db key value -> key -> IO (Maybe value)+lookup (Db db) key+ = withForeignPtr db $ \dbPtr ->+ do mbObject <- D.get dbPtr (serialise key) []+ case mbObject of+ Just object -> return $ Just (deserialise object)+ Nothing -> return Nothing+-}++{-# INLINE lookupMany #-}+lookupMany :: (Binary key, Binary value) => Db key value -> key -> IO [value]+lookupMany (Db db) key+ = withForeignPtr db $ \dbPtr ->+ do objects <- D.getMany dbPtr (serialise key) []+ return $ map deserialise objects++{-+setFlags :: Db key value -> [DbFlag] -> IO ()+setFlags (Db db) flags+ = withForeignPtr db $ \dbPtr ->+ D.setFlags dbPtr flags+-}++newCursor :: Db key value -> IO (Cursor key value)+newCursor (Db db)+ = withForeignPtr db $ \dbPtr ->+ do dbc <- D.newCursor dbPtr+ return $ Cursor dbc++getAtCursor :: (Binary key, Binary value) => Cursor key value -> IO (Maybe (key, [value]))+getAtCursor (Cursor ptr)+ = do ret <- D.getAtCursor ptr [Next]+ case ret of+ Nothing -> return Nothing+ Just (key, vals) -> return $ Just (deserialise key, map deserialise vals)++closeCursor :: Cursor key value -> IO ()+closeCursor (Cursor ptr)+ = D.closeCursor ptr++getAllObjects :: (Binary key, Binary value) => Db key value -> IO [(key,[value])]+getAllObjects db@(Db fptr)+ = do cursor <- newCursor db+ let loop = unsafeInterleaveIO $+ do mbPair <- getAtCursor cursor+ case mbPair of+ Nothing -> do closeCursor cursor+ touchForeignPtr fptr+ return []+ Just pair -> liftM (pair:) loop+ loop++serialise :: Binary val => val -> D.Object+serialise val+ = case Lazy.toChunks (encode val) of+ [chunk] -> chunk+ ls -> Strict.concat ls++deserialise :: Binary val => D.Object -> val+deserialise bs+ = decode $ Lazy.fromChunks [bs]
+ src/Data/BerkeleyDB/Internal.hsc view
@@ -0,0 +1,303 @@+{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-}+#include <db.h>+module Data.BerkeleyDB.Internal where++import Foreign.C.Error+import Foreign.C+import Foreign+import System.IO.Unsafe+import Data.Char++import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as Char8+import qualified Data.ByteString.Unsafe as B+import qualified Data.ByteString.Internal as B++data DB+data DBT+data DBC+data ENV++type DBTYPE = #{type DBTYPE}++data Flag+ = AutoCommit+ | Create+ | Excl+ | Multiversion+ | NoMMap+ | ReadOnly+ | ReadUncommitted+ | Thread+ | Truncate+ deriving (Read, Show, Enum, Eq, Ord)++data DbType+ = BTree+ | Hash+ | Recno+ | Queue+ | UnknownType++fromDbType BTree = #{const DB_BTREE}+fromDbType Hash = #{const DB_HASH}+fromDbType Recno = #{const DB_RECNO}+fromDbType Queue = #{const DB_QUEUE}+fromDbType UnknownType = #{const DB_UNKNOWN}++fromFlag AutoCommit = #{const DB_AUTO_COMMIT}+fromFlag Create = #{const DB_CREATE}+fromFlag Excl = #{const DB_EXCL}+fromFlag Multiversion = #{const DB_MULTIVERSION}+fromFlag _ = 0++fromFlags = foldr (.|.) 0 . map fromFlag++data SyncOption = Sync | NoSync++fromSyncOption Sync = 0+fromSyncOption NoSync = #{const DB_NOSYNC}++data PutFlag+ = Append+ | NoDupData+ | NoOverwrite+ deriving (Read, Show, Enum, Eq, Ord)++fromPutFlag Append = #{const DB_APPEND}+fromPutFlag NoDupData = #{const DB_NODUPDATA}+fromPutFlag NoOverwrite = #{const DB_NOOVERWRITE}++fromPutFlags = foldr (.|.) 0 . map fromPutFlag++data DbFlag+ = Consume+ | ConsumeWait+ | Multiple+ | Duplicates+ | SortDuplicates+ | Next++fromDbFlag Consume = #{const DB_CONSUME}+fromDbFlag ConsumeWait = #{const DB_CONSUME_WAIT}+fromDbFlag Multiple = #{const DB_MULTIPLE}+fromDbFlag Duplicates = #{const DB_DUP}+fromDbFlag SortDuplicates = #{const DB_DUPSORT}+fromDbFlag Next = #{const DB_NEXT}++fromDbFlags = foldr (.|.) 0 . map fromDbFlag++type Object = B.ByteString++++--int db_env_create(DB_ENV **dbenvp, u_int32_t flags);+foreign import ccall unsafe db_env_create+ :: Ptr (Ptr ENV) -> CUInt -> IO CInt++createEnv :: IO (Ptr ENV)+createEnv = alloca $ \tmp ->+ do throwErrnoIf (/=0) "db_env_create" $ db_env_create tmp 0+ peek tmp++--int DB_ENV->open(DB_ENV *dbenv, char *db_home, u_int32_t flags, int mode);+foreign import ccall unsafe hs_env_open+ :: Ptr ENV -> CString -> CUInt -> CInt -> IO CInt+++++--int db_create(DB **dbp, DB_ENV *dbenv, u_int32_t flags);+foreign import ccall unsafe "db_create" c_create ::+ Ptr (Ptr DB) -> Ptr ENV -> Word32 -> IO CInt++create :: IO (Ptr DB)+create = alloca $ \tmp ->+ do --env <- createEnv+-- let flags = #{const DB_INIT_CDB} .|. #{const DB_INIT_MPOOL} .|. #{const DB_CREATE} .|. #{const DB_PRIVATE} .|. #{const DB_THREAD}+-- throwErrnoIf (/=0) "env_open" $ hs_env_open env nullPtr flags 0+ throwErrnoIf (/=0) "create" $ c_create tmp nullPtr 0+ peek tmp+++-- int DB->open(DB *db, DB_TXN *txnid, const char *file,+-- const char *database, DBTYPE type, u_int32_t flags, int mode);+foreign import ccall unsafe "hs_open" c_open ::+ Ptr DB -> Ptr () -> CString -> CString -> DBTYPE -> Word32 -> CInt -> IO CInt++open :: Maybe FilePath -> Maybe String -> DbType -> [Flag] -> IO (Ptr DB)+open mbFile mbDatabase dbType flags+ = do ptr <- create+ setFlags ptr [Duplicates]+ maybeWith withCString mbFile $ \cfile ->+ maybeWith withCString mbDatabase $ \cdatabase ->+ throwErrnoIf (/=0) "open" $+ c_open ptr nullPtr cfile cdatabase (fromDbType dbType) (fromFlags flags) 0+ return ptr+++++-- int DB->close(DB *db, u_int32_t flags);+foreign import ccall unsafe "hs_close" c_close :: Ptr DB -> Word32 -> IO CInt++close :: Ptr DB -> SyncOption -> IO ()+close db sync+ = do throwErrnoIf (/=0) "close" $ c_close db (fromSyncOption sync)+ return ()++foreign import ccall unsafe "&hs_gc_close" closePtr :: FunPtr (Ptr DB -> IO ())+++foreign import ccall unsafe "hs_clear_dbt" clear_dbt :: Ptr DBT -> IO ()++withDBT :: Object -> (Ptr DBT -> IO a) -> IO a+withDBT object fn+ = allocaBytes #{size DBT} $ \dbt ->+ do clear_dbt dbt+ B.unsafeUseAsCStringLen object $ \(ptr,len) ->+ do #{poke DBT, data} dbt ptr+ #{poke DBT, size} dbt (fromIntegral len :: CInt)+ fn dbt+++-- int DB->put(DB *db, DB_TXN *txnid, DBT *key, DBT *data, u_int32_t flags);+foreign import ccall unsafe "hs_put" c_put ::+ Ptr DB -> Ptr () -> Ptr DBT -> Ptr DBT -> Word32 -> IO CInt++put :: Ptr DB -> Object -> Object -> [PutFlag] -> IO ()+put db key value flags+ = withDBT key $ \dbtKey ->+ withDBT value $ \dbtValue ->+ do throwErrnoIf (/=0) "put" $+ c_put db nullPtr dbtKey dbtValue (fromPutFlags flags)+ return ()+++-- int DB->get(DB *db, DB_TXN *txnid, DBT *key, DBT *data, u_int32_t flags);+foreign import ccall unsafe "hs_get" c_get ::+ Ptr DB -> Ptr () -> Ptr DBT -> Ptr DBT -> Word32 -> IO CInt++get :: Ptr DB -> Object -> [DbFlag] -> IO (Maybe Object)+get db object flags+ = withDBT object $ \keyDbt ->+ withDBT nullObject $ \dataDbt ->+ do #{poke DBT, flags} keyDbt (#{const DB_DBT_MALLOC} :: Word32)+ ret <- c_get db nullPtr keyDbt dataDbt (fromDbFlags flags)+ case ret of+ #{const DB_NOTFOUND} -> return Nothing+ 0 -> do ptr <- #{peek DBT, data} dataDbt+ size <- #{peek DBT, size} dataDbt :: IO CInt+ bs <- B.unsafePackCStringFinalizer ptr (fromIntegral size) (free ptr)+ return $ Just bs+ _ -> throwErrno "get"+{-+foreign import ccall unsafe hs_multiple_init+ :: Ptr (Ptr a) -> Ptr DBT -> IO ()++foreign import ccall unsafe hs_multiple_next+ :: Ptr (Ptr a) -> Ptr DBT -> Ptr (Ptr b) -> Ptr #{type size_t} -> IO ()+-}+getMany :: Ptr DB -> Object -> [DbFlag] -> IO [Object]+getMany db object flags+ = withDBT object $ \keyDbt ->+ withDBT nullObject $ \dataDbt ->+ dbtGetMany dataDbt (c_get db nullPtr keyDbt dataDbt (fromDbFlags (Multiple:flags)))++dbtGetMany dataDbt fn+ = let loop size =+ do ptr <- mallocBytes size+ #{poke DBT, data} dataDbt ptr+ #{poke DBT, flags} dataDbt (#{const DB_DBT_USERMEM} :: Word32)+ #{poke DBT, ulen} dataDbt (fromIntegral size :: Word32)+ ret <- fn+ case ret of+ #{const DB_NOTFOUND} -> free ptr >> return []+ #{const DB_BUFFER_SMALL} -> free ptr >> loop (size*2)+ 0 -> do ulen <- fmap fromIntegral (#{peek DBT, ulen} dataDbt :: IO Word32)+ fptr <- newForeignPtr finalizerFree ptr+ let intPtr = castPtr ptr+ let walker n ls = do offset <- peekByteOff intPtr (ulen - #{size u_int32_t} * (n+1)) :: IO Word32+ len <- peekByteOff intPtr (ulen - #{size u_int32_t} * (n+2)) :: IO Word32+-- putStrLn $ "walker: " ++ show (ulen, offset, len, ptr)+ if offset == -1 || (offset == 0 && len == 0)+ then return ls+ else let bs = B.fromForeignPtr fptr (fromIntegral offset) (fromIntegral len)+ in walker (n+2) (bs:ls)+ walker 0 []+ _ -> throwErrno "getMany"+ in loop (1024*sizeOf (undefined :: Int))+++--int hs_set_flags(DB *db, u_int32_t flags);+foreign import ccall unsafe hs_set_flags :: Ptr DB -> Word32 -> IO CInt++setFlags :: Ptr DB -> [DbFlag] -> IO ()+setFlags ptr flags+ = do throwErrnoIf (/=0) "setFlags" $ hs_set_flags ptr (fromDbFlags flags)+ return ()++--int hs_get_flags(DB *db, u_int32_t *flags);++foreign import ccall unsafe "hs_cursor"+ hs_cursor :: Ptr DB -> Ptr () -> Ptr (Ptr DBC) -> Word32 -> IO CInt++foreign import ccall unsafe "hs_cursor_get"+ hs_cursor_get :: Ptr DBC -> Ptr DBT -> Ptr DBT -> Word32 -> IO CInt++foreign import ccall unsafe "hs_cursor_close"+ hs_cursor_close :: Ptr DBC -> IO CInt++closeCursor :: Ptr DBC -> IO ()+closeCursor ptr = do throwErrnoIf (/=0) "hs_cursor_close" $ hs_cursor_close ptr+ return ()++newCursor :: Ptr DB -> IO (Ptr DBC)+newCursor db+ = alloca $ \dbcPtr -> do throwErrnoIf (/=0) "hs_cursor" $ hs_cursor db nullPtr dbcPtr 0+ peek dbcPtr++getAtCursor :: Ptr DBC -> [DbFlag] -> IO (Maybe (Object,[Object]))+getAtCursor dbc flags+ = withDBT nullObject $ \keyDbt ->+ withDBT nullObject $ \dataDbt ->+ do clear_dbt keyDbt+ #{poke DBT, flags} keyDbt (#{const DB_DBT_MALLOC} :: Word32)+ objs <- dbtGetMany dataDbt $ hs_cursor_get dbc keyDbt dataDbt (fromDbFlags $ Multiple:flags)+ if null objs then return Nothing else do+ ptr <- #{peek DBT, data} keyDbt+ size <- #{peek DBT, size} keyDbt :: IO CInt+ keyObject <- B.unsafePackCStringFinalizer ptr (fromIntegral size) (free ptr)+ let pp = B.take 40 . Char8.filter isPrint+-- putStrLn $ "Key: " ++ show (pp keyObject) ++ ": " ++ show (map pp objs)+-- putStrLn $ "Key ptr: " ++ show ptr+-- putStrLn $ " Objs: " ++ show (map (B.take 30 . Char8.filter isAlphaNum) objs)+ return (Just (keyObject,objs))++{-+getAllObjects :: Ptr DB -> IO [(Object,[Object])]+getAllObjects ptr+ = do dbc <- alloca $ \dbcPtr -> do throwErrnoIf (/=0) "hs_cursor" $ hs_cursor ptr nullPtr dbcPtr 0+ peek dbcPtr+ let flags = #{const DB_MULTIPLE} .|. #{const DB_NEXT}+ let loop = --unsafeInterleaveIO $+ withDBT nullObject $ \keyDbt ->+ withDBT nullObject $ \dataDbt ->+ do clear_dbt keyDbt+ #{poke DBT, flags} keyDbt (#{const DB_DBT_MALLOC} :: Word32)+ objs <- dbtGetMany dataDbt $ hs_cursor_get dbc keyDbt dataDbt flags+ if null objs then return [] else do+ ptr <- #{peek DBT, data} keyDbt+ size <- #{peek DBT, size} keyDbt :: IO CInt+ keyObject <- B.unsafePackCStringFinalizer ptr (fromIntegral size) (free ptr)+ let pp = B.take 40 . Char8.filter isPrint+-- putStrLn $ "Key: " ++ show (pp keyObject) ++ ": " ++ show (map pp objs)+-- putStrLn $ "Key ptr: " ++ show ptr+-- putStrLn $ " Objs: " ++ show (map (B.take 30 . Char8.filter isAlphaNum) objs)+ rest <- loop+ return ((keyObject,objs):rest)+ loop+-}++nullObject = B.fromForeignPtr B.nullForeignPtr 0 0+
+ src/Tests.hs view
@@ -0,0 +1,225 @@+module Main (main) where++import Data.Binary+import Data.Binary.Get+import Data.List+import Test.QuickCheck+import Test.QuickCheck.Batch++import qualified Data.ByteString as Strict++import qualified Data.BerkeleyDB as Pure+import qualified Data.Map as Map++import Debug.Trace+import System.Mem (performGC)+import Control.Concurrent (yield)+import System.IO++data T = T (Pure.Db Int Int) (Map.Map Int Int)+instance Show T where+ show (T db _) = show (Pure.toList db)++newtype Db = Db { unDb :: Pure.Db Int Int }+instance Show Db where+ show (Db db) = show (Pure.toList db)++instance Arbitrary T where+ arbitrary = do lst <- arbitrary+ snd <- arbitrary+ return $ T (foldr Pure.delete (Pure.fromList lst) snd) (foldr Map.delete (Map.fromList lst) snd)+ coarbitrary = undefined++instance Arbitrary Db where+ arbitrary = do lst <- arbitrary+ snd <- arbitrary+ return $ Db (foldl' (\db k -> Pure.delete k db) (Pure.fromList lst) snd)+ coarbitrary = undefined++instance (Arbitrary key, Arbitrary value,Binary key,Binary value) => Arbitrary (Pure.Db key value) where+ arbitrary = fmap Pure.fromList arbitrary+ coarbitrary = undefined+++eq db m = if sort (Pure.toList db) == sort (Map.toList m) && Pure.size db == Map.size m+ then True+ else False --trace (show $ Pure.toList db) False++++prop_fromList vals = Pure.fromList vals `eq` Map.fromList (vals :: [(Int,Int)])++prop_fromList_fold vals = Pure.fromList vals == foldl' (\db (k,v) -> Pure.insert k v db) Pure.empty (vals::[(Int,Int)])++prop_null (T db m) = Pure.null db == Map.null m+prop_size (T db m) = Pure.size db == Map.size m++prop_insert (T db m) key val = Pure.insert key val db `eq` Map.insert key val m++prop_delete (T db m) key = Pure.delete key db `eq` Map.delete key m++prop_map (T db m) = Pure.map succ db `eq` Map.map succ m++prop_mapWithKey (T db m) = Pure.mapWithKey (+) db `eq` Map.mapWithKey (+) m++prop_insertWith (T db m) key val = Pure.insertWith (+) key val db `eq` Map.insertWith (+) key val m++prop_insertWithKey (T db m) key val = Pure.insertWithKey (\k x y -> k) key val db `eq` Map.insertWithKey (\k x y -> k) key val m++prop_singleton key val = Pure.singleton key val `eq` Map.singleton (key::Int) (val::Int)++prop_lookup (T db m) key = Pure.lookup key db == (Map.lookup key m :: Maybe Int)++prop_find (T db m) key = Pure.member key db ==> (db Pure.! key) == (m Map.! key)++prop_member (T db m) key = Pure.member key db == Map.member key m+prop_notMember (T db m) key = Pure.notMember key db == Map.notMember key m++prop_assocs_self (Db db) = Pure.assocs db == Pure.toList db+prop_assocs (T db m) = sort (Pure.assocs db) == sort (Map.assocs m)++prop_elems (T db m) = sort (Pure.elems db) == sort (Map.elems m)++prop_keys (T db m) = sort (Pure.keys db) == sort (Map.keys m)++-- The result of 'show' should be the same if we have the same key ordering.+prop_show (T db m) = show (Pure.toList db) == show (Map.toList m) ==> show db == show m++prop_diverge (T db m) keys lst+ = foldr Pure.delete db keys `eq` foldr Map.delete m keys &&+ foldr (uncurry Pure.insert) db lst `eq` foldr (uncurry Map.insert) m lst++prop_diverge_insert (T db m) lst1 lst2+ = foldr (uncurry Pure.insert) db lst1 `eq` foldr (uncurry Map.insert) m lst1 &&+ foldr (uncurry Pure.insert) db lst2 `eq` foldr (uncurry Map.insert) m lst2++prop_fold_sum (T db m)+ = Pure.fold (+) 0 db == Map.fold (+) 0 m++prop_union (T db1 m1) (T db2 m2)+ = Pure.union db1 db2 `eq` Map.union m1 m2++prop_unionWith (T db1 m1) (T db2 m2)+ = Pure.unionWith (+) db1 db2 `eq` Map.unionWith (+) m1 m2++prop_unionWithKey (T db1 m1) (T db2 m2)+ = Pure.unionWithKey (\k x y -> k+x+y) db1 db2 `eq` Map.unionWithKey (\k x y -> k+x+y) m1 m2++prop_filter (T db m) cutoff+ = Pure.filter (>cutoff) db `eq` Map.filter (>cutoff) m++-- Mostly false predicate+prop_filterWithKey (T db m)+ = Pure.filterWithKey (\k x -> k==x) db `eq` Map.filterWithKey (\k x -> k==x) m++-- Mostly true predicate+prop_filterWithKey2 (T db m)+ = Pure.filterWithKey (\k x -> k/=x) db `eq` Map.filterWithKey (\k x -> k/=x) m++prop_adjust (T db m) key+ = Pure.adjust succ key db `eq` Map.adjust succ key m++prop_adjustWithKey (T db m) key+ = Pure.adjustWithKey (+) key db `eq` Map.adjustWithKey (+) key m++prop_update (T db m) key+ = Pure.update (const Nothing) key db `eq` Map.update (const Nothing) key m++prop_update_succ (T db m) key+ = Pure.update (Just . succ) key db `eq` Map.update (Just . succ) key m++prop_updateLookup (T db m) key+ = let (v1,db') = Pure.updateLookupWithKey (\k x -> Nothing) key db + (v2,m') = Map.updateLookupWithKey (\k x -> Nothing) key m+ in db' `eq` m' && v1==v2++prop_updateLookup2 (T db m) key+ = let (v1,db') = Pure.updateLookupWithKey (\k x -> Just k) key db + (v2,m') = Map.updateLookupWithKey (\k x -> Just k) key m+ in db' `eq` m' && v1==v2++prop_compare (T db1 m1) (T db2 m2)+ = db1 `compare` db2 == m1 `compare` m2++prop_alter (T db m) key val+ = Pure.alter (fmap (+val)) key db `eq` Map.alter (fmap (+val)) key m++prop_find_def (T db m) key def+ = Pure.findWithDefault def key db == Map.findWithDefault def key m ++prop_fromListWithKey lst+ = Pure.fromListWithKey (\k x y -> k+x+y) lst `eq` Map.fromListWithKey (\k x y -> k+x+y) (lst :: [(Int,Int)])++mapConformity+ = runTests "Data.Map conformity" defOpt+ [ run prop_fromList+ , run prop_fromList_fold+ , run prop_null+ , run prop_size+ , run prop_insert+ , run prop_insertWith+ , run prop_insertWithKey+ , run prop_delete+ , run prop_map+ , run prop_mapWithKey+ , run prop_singleton+ , run prop_lookup+ , run prop_find+ , run prop_member+ , run prop_notMember+ , run prop_assocs_self+ , run prop_assocs+ , run prop_elems+ , run prop_keys+ , run prop_show+ , run prop_diverge+ , run prop_diverge_insert+ , run prop_fold_sum+ , run prop_union+ , run prop_unionWith+ , run prop_unionWithKey+ , run prop_filter+ , run prop_filterWithKey+ , run prop_filterWithKey2+ , run prop_adjust+ , run prop_adjustWithKey+ , run prop_update+ , run prop_update_succ+ , run prop_updateLookup+ , run prop_updateLookup2+ , run prop_compare+ , run prop_alter+ , run prop_find_def+ , run prop_fromListWithKey+ ]++encodings+ = runTests "Encodings" defOpt+ [ run prop_binary_id+ , run prop_binary_use+ , run prop_binary_extra+ , run prop_readShow_id+ , run prop_readShow_use+ , run prop_readShow_extra+ , run prop_readShow_list+ ]++prop_binary_id (Db db) = decode (encode db) == db+prop_binary_use (T db m) key val = Pure.insert key val (decode (encode db)) `eq` Map.insert key val m+prop_binary_extra (Db db) = decode (encode (db,"string")) == (db,"string")++prop_readShow_id (Db db) = read (show db) == db+prop_readShow_use (T db m) key val = Pure.insert key val (read (show db)) `eq` Map.insert key val m+prop_readShow_extra (Db db) = read (show (db,"string")) == (db,"string")+prop_readShow_list dbList = read (show (map unDb dbList)) == map unDb dbList++--gcProp = \_ -> performGC >> yield >> return (TestOk "" 0 [])+--withGC lst = intersperse gcProp lst+++runAllTests = sequence_ [mapConformity, encodings]++main :: IO ()+main = do hSetBuffering stdout NoBuffering+ runAllTests+ --check defaultConfig{configMaxTest=2000} prop_fromList