diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/berkeleydb.cabal b/berkeleydb.cabal new file mode 100644 --- /dev/null +++ b/berkeleydb.cabal @@ -0,0 +1,31 @@ +Name: berkeleydb +Version: 2008.10.31 +Author: David Himmelstrup +Maintainer: David Himmelstrup +Copyright: 2008 David Himmelstrup +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 diff --git a/cbits/wrapper.c b/cbits/wrapper.c new file mode 100644 --- /dev/null +++ b/cbits/wrapper.c @@ -0,0 +1,59 @@ +#include +#include + +#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); } + + diff --git a/cbits/wrapper.h b/cbits/wrapper.h new file mode 100644 --- /dev/null +++ b/cbits/wrapper.h @@ -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 diff --git a/runHPC.sh b/runHPC.sh new file mode 100644 --- /dev/null +++ b/runHPC.sh @@ -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 diff --git a/src/Data/BerkeleyDB.hs b/src/Data/BerkeleyDB.hs new file mode 100644 --- /dev/null +++ b/src/Data/BerkeleyDB.hs @@ -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 +-- and +-- +-- +-- 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) + + + diff --git a/src/Data/BerkeleyDB/IO.hs b/src/Data/BerkeleyDB/IO.hs new file mode 100644 --- /dev/null +++ b/src/Data/BerkeleyDB/IO.hs @@ -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] diff --git a/src/Data/BerkeleyDB/Internal.hsc b/src/Data/BerkeleyDB/Internal.hsc new file mode 100644 --- /dev/null +++ b/src/Data/BerkeleyDB/Internal.hsc @@ -0,0 +1,303 @@ +{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-} +#include +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 + diff --git a/src/Tests.hs b/src/Tests.hs new file mode 100644 --- /dev/null +++ b/src/Tests.hs @@ -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