tokyocabinet-haskell (empty) → 0.0.1
raw patch · 18 files changed
+2770/−0 lines, 18 filesdep +basedep +bytestringdep +mtlsetup-changed
Dependencies added: base, bytestring, mtl
Files
- Database/TokyoCabinet.hs +367/−0
- Database/TokyoCabinet/BDB.hs +319/−0
- Database/TokyoCabinet/BDB/C.hsc +211/−0
- Database/TokyoCabinet/BDB/Cursor.hs +86/−0
- Database/TokyoCabinet/BDB/Cursor/C.hsc +79/−0
- Database/TokyoCabinet/Error.hsc +112/−0
- Database/TokyoCabinet/FDB.hs +266/−0
- Database/TokyoCabinet/FDB/C.hsc +199/−0
- Database/TokyoCabinet/FDB/Key.hs +59/−0
- Database/TokyoCabinet/HDB.hs +257/−0
- Database/TokyoCabinet/HDB/C.hsc +167/−0
- Database/TokyoCabinet/Internal.hs +115/−0
- Database/TokyoCabinet/List.hs +159/−0
- Database/TokyoCabinet/List/C.hs +95/−0
- Database/TokyoCabinet/Storable.hs +187/−0
- LICENSE +29/−0
- Setup.hs +14/−0
- tokyocabinet-haskell.cabal +49/−0
+ Database/TokyoCabinet.hs view
@@ -0,0 +1,367 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Database.TokyoCabinet+ (+ -- $doc+ TCM+ , runTCM+ , OpenMode(..)+ , TCDB(..)+ , H.HDB+ , F.FDB+ , BDB+ -- * Error Code+ , E.ECODE(..)+ , E.errmsg+ ) where++import Control.Monad.Trans (MonadIO)++import Database.TokyoCabinet.Storable+import Database.TokyoCabinet.FDB.Key (ID, toID)+import qualified Database.TokyoCabinet.HDB as H+import qualified Database.TokyoCabinet.FDB as F+import qualified Database.TokyoCabinet.BDB as B+import qualified Database.TokyoCabinet.BDB.Cursor as C+import qualified Database.TokyoCabinet.Error as E++import Data.Int++-- $doc+-- Basic Usage (sample code)+--+-- @+-- import Database.TokyoCabinet+-- import Data.ByteString.Char8+-- @+--+-- @+-- putsample :: String -> [(ByteString, ByteString)] -> TCM Bool+-- putsample file kv =+-- do tc <- new :: TCM HDB -- alternatively you can use BDB or FDB+-- open tc file [OWRITER, OCREAT]+-- mapM (uncurry $ put tc) kv+-- close tc+-- @+--+-- @+-- getsample :: String -> ByteString -> TCM (Maybe ByteString)+-- getsample file key =+-- do tc <- new :: TCM HDB -- alternatively you can use BDB or FDB+-- open tc file [OREADER]+-- val <- get tc key+-- close tc+-- return val+-- @+--+-- @+-- main = runTCM (do putsample \"foo.tch\" [(pack \"foo\", pack \"bar\")]+-- getsample \"foo.tch\" (pack \"foo\")) >>=+-- maybe (return ()) (putStrLn . show)+-- @+--++-- | Tokyo Cabinet related computation. Wrap of IO.+newtype TCM a =+ TCM { -- | Unwrap TCM.+ runTCM :: IO a+ } deriving (Monad, MonadIO)++-- | Represent open mode for `open' function.+data OpenMode = OREADER |+ OWRITER |+ OCREAT |+ OTRUNC |+ ONOLCK |+ OLCKNB+ deriving (Eq, Ord, Show)++-- | Type class that abstract Tokyo Cabinet database.+class TCDB a where+ -- | Create a database object.+ new :: TCM a++ -- | Free object resource forcibly.+ delete :: a -> TCM ()++ -- | Open a database file.+ open :: a -- ^ database object+ -> String -- ^ path to database file+ -> [OpenMode] -- ^ open mode+ -> TCM Bool -- ^ if successful, the return value is True++ -- | Close the database file. If successful, the return value is True+ close :: a -> TCM Bool++ -- | Store a record.+ put :: (Storable k, Storable v) =>+ a -- ^ database object+ -> k -- ^ key+ -> v -- ^ value+ -> TCM Bool -- ^ if successful, the return value is True++ -- | Store a new recoed. If a record with the same key exists+ -- in the database, this function has no effect.+ putkeep :: (Storable k, Storable v) =>+ a -- ^ database object+ -> k -- ^ key+ -> v -- ^ value+ -> TCM Bool -- ^ if successful, the return value is True++ -- | Concatenate a value at the end of the existing record.+ putcat :: (Storable k, Storable v) =>+ a -- ^ database object+ -> k -- ^ key+ -> v -- ^ value+ -> TCM Bool -- ^ if successful, the return value is True++ -- | Retrieve a record.+ get :: (Storable k, Storable v) =>+ a -- ^ database object+ -> k -- ^ key+ -> TCM (Maybe v) -- ^ If successful, the return value is the+ -- value of the corresponding record wrapped+ -- by `Just', else, Nothing is returned.++ -- | Remove a record.+ out :: (Storable k) =>+ a -- ^ database object+ -> k -- ^ key+ -> TCM Bool -- ^ if successful, the return value is True++ -- | Get the size of the value of a record.+ vsiz :: (Storable k) =>+ a -- ^ database object+ -> k -- ^ key+ -> TCM (Maybe Int) -- ^ If successful, the return value+ -- is the size of the value of the+ -- corresponding record wrapped by+ -- `Just', else, it is Nothing.++ -- | Initialize the iterator. If successful, the return value is True.+ iterinit :: a -> TCM Bool++ -- | Get the next key of the iterator. If successful, the return+ -- value is the next key wrapped by `Just', else, it is Nothing.+ iternext :: (Storable v) => a -> TCM (Maybe v)++ -- | Get forward matching keys.+ fwmkeys :: (Storable k, Storable v) =>+ a -- ^ database object+ -> k -- ^ search string+ -> Int -- ^ the maximum number of keys to be fetched+ -> TCM [v] -- ^ result keys++ -- | Add an integer to a record.+ addint :: (Storable k) =>+ a -- ^ database object+ -> k -- ^ key+ -> Int -- ^ the addtional value+ -> TCM (Maybe Int) -- ^ If the corresponding record+ -- exists, the value is treated as an+ -- integer and is added to. If no+ -- record corresponds, a new record+ -- of the additional value is stored.++ -- | Add a real number to a record.+ adddouble :: (Storable k) =>+ a -- ^ database object+ -> k -- ^ key+ -> Double -- ^ the additional value+ -> TCM (Maybe Double) -- ^ If the corresponding record+ -- exists, the value is treated as+ -- a real number and is added+ -- to. If no record corresponds, a+ -- new record of the additional+ -- value is stored.++ -- | Synchronize updated contents with the file and the device.+ -- If successful, the return value is True.+ sync :: a -> TCM Bool++ -- | Remove all records. If successful, the return value is True.+ vanish :: a -> TCM Bool++ -- | Copy the database file.+ copy :: a -- ^ database object+ -> String -- ^ path of the destination file+ -> TCM Bool -- ^ If successful, the return value is True.++ -- | Get the path of the database file.+ path :: a -> TCM (Maybe String)++ -- | Get the number of records.+ rnum :: a -> TCM Int64++ -- | Get the size of the database file.+ size :: a -> TCM Int64++ -- | Get the last happened error code.+ ecode :: a -> TCM E.ECODE++ -- | Get the default extension for specified database object.+ defaultExtension :: a -> String++openModeToHOpenMode :: OpenMode -> H.OpenMode+openModeToHOpenMode OREADER = H.OREADER+openModeToHOpenMode OWRITER = H.OWRITER+openModeToHOpenMode OCREAT = H.OCREAT+openModeToHOpenMode OTRUNC = H.OTRUNC+openModeToHOpenMode ONOLCK = H.ONOLCK+openModeToHOpenMode OLCKNB = H.OLCKNB++lift :: (a -> IO b) -> a -> TCM b+lift = (TCM .)++lift2 :: (a -> b -> IO c) -> a -> b -> TCM c+lift2 f x y = TCM $ f x y++lift3 :: (a -> b -> c -> IO d) -> a -> b -> c -> TCM d+lift3 f x y z = TCM $ f x y z++instance TCDB H.HDB where+ new = TCM H.new+ delete = lift H.delete+ open tc name mode = TCM $ H.open tc name (map openModeToHOpenMode mode)+ close = lift H.close+ put = lift3 H.put+ putkeep = lift3 H.putkeep+ putcat = lift3 H.putcat+ get = lift2 H.get+ out = lift2 H.out+ vsiz = lift2 H.vsiz+ iterinit = lift H.iterinit+ iternext = lift H.iternext+ fwmkeys = lift3 H.fwmkeys+ addint = lift3 H.addint+ adddouble = lift3 H.adddouble+ sync = lift H.sync+ vanish = lift H.vanish+ copy = lift2 H.copy+ path = lift H.path+ rnum = lift H.rnum+ size = lift H.fsiz+ ecode = lift H.ecode+ defaultExtension = const ".tch"++openModeToBOpenMode :: OpenMode -> B.OpenMode+openModeToBOpenMode OREADER = B.OREADER+openModeToBOpenMode OWRITER = B.OWRITER+openModeToBOpenMode OCREAT = B.OCREAT+openModeToBOpenMode OTRUNC = B.OTRUNC+openModeToBOpenMode ONOLCK = B.ONOLCK+openModeToBOpenMode OLCKNB = B.OLCKNB++data BDB = BDB { unTCBDB :: B.BDB+ , unTCBDBCUR :: C.BDBCUR }++liftB :: (B.BDB -> IO a) -> BDB -> TCM a+liftB f x = TCM $ f (unTCBDB x)++liftB2 :: (B.BDB -> a -> IO b) -> BDB -> a -> TCM b+liftB2 f x y = TCM $ f (unTCBDB x) y++liftB3 :: (B.BDB -> a -> b -> IO c) -> BDB -> a -> b -> TCM c+liftB3 f x y z = TCM $ f (unTCBDB x) y z++instance TCDB BDB where+ new = TCM $ do bdb <- B.new+ cur <- C.new bdb+ return $ BDB bdb cur+ delete = liftB B.delete+ open tc name mode = TCM $ B.open (unTCBDB tc) name+ (map openModeToBOpenMode mode)+ close = liftB B.close+ put = liftB3 B.put+ putkeep = liftB3 B.putkeep+ putcat = liftB3 B.putcat+ get = liftB2 B.get+ out = liftB2 B.out+ vsiz = liftB2 B.vsiz+ iterinit bdb = TCM $ C.first (unTCBDBCUR bdb)+ iternext bdb = TCM $ do k <- C.key (unTCBDBCUR bdb)+ C.next (unTCBDBCUR bdb)+ return k+ fwmkeys = liftB3 B.fwmkeys+ addint = liftB3 B.addint+ adddouble = liftB3 B.adddouble+ sync = liftB B.sync+ vanish = liftB B.vanish+ copy = liftB2 B.copy+ path = liftB B.path+ rnum = liftB B.rnum+ size = liftB B.fsiz+ ecode = liftB B.ecode+ defaultExtension = const ".tcb"++instance TCDB B.BDB where+ new = TCM B.new+ delete = lift B.delete+ open tc name mode = TCM $ B.open tc name (map openModeToBOpenMode mode)+ close = lift B.close+ put = lift3 B.put+ putkeep = lift3 B.putkeep+ putcat = lift3 B.putcat+ get = lift2 B.get+ out = lift2 B.out+ vsiz = lift2 B.vsiz+ iterinit = undefined+ iternext = undefined+ fwmkeys = lift3 B.fwmkeys+ addint = lift3 B.addint+ adddouble = lift3 B.adddouble+ sync = lift B.sync+ vanish = lift B.vanish+ copy = lift2 B.copy+ path = lift B.path+ rnum = lift B.rnum+ size = lift B.fsiz+ ecode = lift B.ecode+ defaultExtension = const ".tcb"++openModeToFOpenMode :: OpenMode -> F.OpenMode+openModeToFOpenMode OREADER = F.OREADER+openModeToFOpenMode OWRITER = F.OWRITER+openModeToFOpenMode OCREAT = F.OCREAT+openModeToFOpenMode OTRUNC = F.OTRUNC+openModeToFOpenMode ONOLCK = F.ONOLCK+openModeToFOpenMode OLCKNB = F.OLCKNB++storableToKey :: (Storable a) => a -> ID+storableToKey = toID . toInt64++liftF2 :: (Storable b) => (a -> ID -> IO c) -> a -> b -> TCM c+liftF2 f x y = TCM $ f x (storableToKey y)++liftF3 :: (Storable b) => (a -> ID -> c -> IO d) -> a -> b -> c -> TCM d+liftF3 f x y z = TCM $ f x (storableToKey y) z++keyToStorable :: (Storable a) => String -> a+keyToStorable = fromString++instance TCDB F.FDB where+ new = TCM F.new+ delete = lift F.delete+ open tc name mode = TCM $ F.open tc name (map openModeToFOpenMode mode)+ close = lift F.close+ put = liftF3 F.put+ putkeep = liftF3 F.putkeep+ putcat = liftF3 F.putcat+ get = liftF2 F.get+ out = liftF2 F.out+ vsiz = liftF2 F.vsiz+ iterinit = lift F.iterinit+ iternext tc = TCM $ do key <- F.iternext tc+ case key of+ Nothing -> return Nothing+ Just x -> return $ Just (keyToStorable x)+ fwmkeys = lift3 F.fwmkeys+ addint = liftF3 F.addint+ adddouble = liftF3 F.adddouble+ sync = lift F.sync+ vanish = lift F.vanish+ copy = lift2 F.copy+ path = lift F.path+ rnum = lift F.rnum+ size = lift F.fsiz+ ecode = lift F.ecode+ defaultExtension = const ".tcf"
+ Database/TokyoCabinet/BDB.hs view
@@ -0,0 +1,319 @@+-- | Interface to B+ tree based DBM. See also,+-- <http://tokyocabinet.sourceforge.net/spex-en.html#tcbdbapi> for details+module Database.TokyoCabinet.BDB+ (+ -- $doc+ -- * Constructors+ BDB+ , ECODE(..)+ , OpenMode(..)+ , TuningOption(..)+ -- * Basic API (tokyocabinet.idl compliant)+ , new+ , delete+ , ecode+ , errmsg+ , tune+ , setcache+ , setxmsiz+ , open+ , close+ , put+ , putkeep+ , putcat+ , putdup+ , putlist+ , out+ , outlist+ , get+ , getlist+ , vnum+ , vsiz+ , range+ , fwmkeys+ , addint+ , adddouble+ , sync+ , optimize+ , vanish+ , copy+ , tranbegin+ , trancommit+ , tranabort+ , path+ , rnum+ , fsiz+ ) where++import Data.Int++import Foreign.Ptr+import Foreign.ForeignPtr++import Database.TokyoCabinet.Error+import Database.TokyoCabinet.BDB.C+import Database.TokyoCabinet.Internal+import qualified Database.TokyoCabinet.Storable as S++-- $doc+-- Example+--+-- @+-- import Control.Monad+-- import Database.TokyoCabinet.BDB+-- import qualified Database.TokyoCabinet.BDB.Cursor as C+-- @+--+-- @ +-- main :: IO ()+-- main =+-- do bdb <- new+-- -- open the database+-- open bdb \"casket.tcb\" [OWRITER, OCREAT] >>= err bdb+-- -- store records+-- puts bdb [ (\"foo\", \"hop\"), (\"bar\", \"step\"), (\"baz\", \"jump\") ] >>=+-- err bdb . (all id)+-- -- retrieve records+-- get bdb \"foo\" >>= maybe (error \"something goes wrong\") putStrLn+-- -- traverse records+-- cur <- C.new bdb+-- C.first cur >>= err bdb+-- iter cur >>= putStrLn . show+-- -- close the database+-- close bdb >>= err bdb+-- where+-- puts :: BDB -> [(String, String)] -> IO [Bool]+-- puts bdb = mapM (uncurry $ put bdb)+-- @+--+-- @+-- err :: BDB -> Bool -> IO ()+-- err bdb = flip unless $ ecode bdb >>= error . show+-- @+--+-- @ +-- iter :: C.BDBCUR -> IO [(String, String)]+-- iter cur = do+-- [key, value] <- sequence [C.key cur, C.val cur]+-- case (key, value) of+-- (Just k, Just v) -> C.next cur >> iter cur >>= return . ((k,v):)+-- _ -> return []+-- @+--++-- | Create a B+ tree database object. +new :: IO BDB+new = BDB `fmap` (c_tcbdbnew >>= newForeignPtr tcbdbFinalizer)++-- | Free BDB resource forcibly. +-- BDB is kept by ForeignPtr, so Haskell runtime GC cleans up memory for+-- almost situation. Most always, you don't need to call this. +-- After call this, you must not touch BDB object. Its behavior is undefined.+delete :: BDB -> IO ()+delete bdb = finalizeForeignPtr (unTCBDB bdb)++-- | Return the last happened error code.+ecode :: BDB -> IO ECODE+ecode bdb = cintToError `fmap` withForeignPtr (unTCBDB bdb) c_tcbdbecode++-- | Set the tuning parameters.+tune :: BDB -- ^ BDB object+ -> Int32 -- ^ the number of members in each leaf page.+ -> Int32 -- ^ the number of members in each non-leaf page.+ -> Int64 -- ^ the number of elements of the bucket array. + -> Int8 -- ^ the size of record alignment by power of 2.+ -> Int8 -- ^ the maximum number of elements of the free block+ -- pool by power of 2.+ -> [TuningOption] -- ^ tuning options+ -> IO Bool -- ^ if successful, the return value is True.+tune bdb lmemb nmemb bnum apow fpow opts =+ withForeignPtr (unTCBDB bdb) $ \bdb' ->+ c_tcbdbtune bdb' lmemb nmemb bnum apow fpow (combineTuningOption opts)++-- | Set the caching parameters.+setcache :: BDB -- ^ BDB object+ -> Int32 -- ^ the maximum number of leaf nodes to be cached.+ -> Int32 -- ^ the maximum number of non-leaf nodes to be cached.+ -> IO Bool -- ^ if successful, the return value is True.+setcache bdb lcnum ncnum =+ withForeignPtr (unTCBDB bdb) $ \bdb' -> c_tcbdbsetcache bdb' lcnum ncnum++-- | Set the size of extra mapped memory.+setxmsiz :: BDB -> Int64 -> IO Bool+setxmsiz bdb xmsiz =+ withForeignPtr (unTCBDB bdb) $ \bdb' -> c_tcbdbsetxmsiz bdb' xmsiz++-- | Open BDB database file.+open :: BDB -> String -> [OpenMode] -> IO Bool+open = openHelper c_tcbdbopen unTCBDB combineOpenMode++-- | Close the database file.+close :: BDB -> IO Bool+close bdb = withForeignPtr (unTCBDB bdb) c_tcbdbclose++-- | Stora a record (key-value pair) on BDB. Key and value type must+-- be instance of Storable class. Usually, we can use `String',+-- `ByteString' for key, `String', `ByteString', `Int', `Double' for+-- value.+put :: (S.Storable k, S.Storable v) => BDB -> k -> v -> IO Bool+put = putHelper c_tcbdbput unTCBDB++-- | Store a new record. If a record with the same key exists in the+-- database, this function has no effect.+putkeep :: (S.Storable k, S.Storable v) => BDB -> k -> v -> IO Bool+putkeep = putHelper c_tcbdbputkeep unTCBDB++-- | Concatenate a value at the end of the existing record.+putcat :: (S.Storable k, S.Storable v) => BDB -> k -> v -> IO Bool+putcat = putHelper c_tcbdbputcat unTCBDB++-- | Store a record with allowing duplication of keys. +putdup :: (S.Storable k, S.Storable v) => BDB -> k -> v -> IO Bool+putdup = putHelper c_tcbdbputdup unTCBDB++-- | Store records with allowing duplication of keys. +putlist :: (S.Storable k, S.Storable v) => BDB -> k -> [v] -> IO Bool+putlist bdb key vals = do+ and `fmap` mapM (putdup bdb key) vals++-- | Delete a record. If the key of duplicated records is specified,+-- the first one is deleted. +out :: (S.Storable k) => BDB -> k -> IO Bool+out = outHelper c_tcbdbout unTCBDB++-- | Delete records. If the key of duplicated records is specified,+-- all of them are deleted.+outlist :: (S.Storable k) => BDB -> k -> IO Bool+outlist = outHelper c_tcbdbout3 unTCBDB++-- | Return the value of record. If the key of duplicated records is+-- specified, the first one is returned.+get :: (S.Storable k, S.Storable v) => BDB -> k -> IO (Maybe v)+get = getHelper c_tcbdbget unTCBDB++-- | Retrieve records. +getlist :: (S.Storable k, S.Storable v) => BDB -> k -> IO [v]+getlist bdb key =+ withForeignPtr (unTCBDB bdb) $ \bdb' ->+ S.withPtrLen key $ \(kbuf, ksize) -> do+ ptr <- c_tcbdbget4 bdb' kbuf ksize+ if ptr == nullPtr+ then return []+ else peekTCListAndFree ptr++-- | Return the number of records corresponding to a key. +vnum :: (S.Storable k) => BDB -> k -> IO (Maybe Int)+vnum bdb key =+ withForeignPtr (unTCBDB bdb) $ \bdb' ->+ S.withPtrLen key $ \(kbuf, ksize) -> do+ res <- c_tcbdbvnum bdb' kbuf ksize+ return $ if res == 0+ then Nothing+ else Just $ fromIntegral res++-- | Return the size of the value of a record. If the key of duplicated+-- records is specified, the first one is selected.+vsiz :: (S.Storable k) => BDB -> k -> IO (Maybe Int)+vsiz = vsizHelper c_tcbdbvsiz unTCBDB++-- | Return list of keys in the specified range.+range :: (S.Storable k) =>+ BDB -- ^ BDB object+ -> Maybe k -- ^ the key of the beginning border. If it is+ -- Nothing, the first record in the database is+ -- specified.+ -> Bool -- ^ whether the beginning border is inclusive or not. + -> Maybe k -- ^ the key of the ending border. If it is Nothing,+ -- the last record is specified.+ -> Bool -- ^ whether the ending border is inclusive or not.+ -> Int -- ^ the maximum number of keys to be fetched. If it+ -- is negative value, no limit is specified.+ -> IO [k] -- ^ keys in the specified range.+range bdb bkey binc ekey einc maxn =+ withForeignPtr (unTCBDB bdb) $ \bdb' ->+ withPtrLen' bkey $ \(bkbuf, bksiz) ->+ withPtrLen' ekey $ \(ekbuf, eksiz) ->+ c_tcbdbrange bdb' bkbuf bksiz binc ekbuf eksiz einc+ (fromIntegral maxn) >>= peekTCListAndFree+ where+ withPtrLen' (Just key) action = S.withPtrLen key action+ withPtrLen' Nothing action = action (nullPtr, 0)++-- | Return list of forward matched keys.+fwmkeys :: (S.Storable k1, S.Storable k2) =>+ BDB -- ^ BDB object+ -> k1 -- ^ search string+ -> Int -- ^ the maximum number of keys to be fetched. If it+ -- is negative value, no limit is specified.+ -> IO [k2] -- ^ keys matches specified string (in forward matching).+fwmkeys = fwmHelper c_tcbdbfwmkeys unTCBDB++-- | Increment the corresponding value. (The value specified by a key+-- is treated as integer.)+addint :: (S.Storable k) =>+ BDB -- ^ BDB object.+ -> k -- ^ Key.+ -> Int -- ^ Amount of increment.+ -> IO (Maybe Int) -- ^ If successful, a new value is returned.+addint = addHelper c_tcbdbaddint unTCBDB fromIntegral fromIntegral (== cINT_MIN)++-- | Increment the corresponding value. (The value specified by a key+-- is treated as double.)+adddouble :: (S.Storable k) =>+ BDB -- ^ BDB object.+ -> k -- ^ Key.+ -> Double -- ^ Amount of increment.+ -> IO (Maybe Double) -- ^ If successful, a new value is returned.+adddouble = addHelper c_tcbdbadddouble unTCBDB realToFrac realToFrac isNaN++-- | Synchronize updated contents of a database object with the file+-- and the device.+sync :: BDB -> IO Bool+sync bdb = withForeignPtr (unTCBDB bdb) c_tcbdbsync++-- | Optimize the file of a B+ tree database object.+optimize :: BDB+ -> Int32 -- ^ the number of members in each leaf page.+ -> Int32 -- ^ the number of members in each non-leaf page.+ -> Int64 -- ^ the number of elements of the bucket array. + -> Int8 -- ^ the size of record alignment by power of 2.+ -> Int8 -- ^ the maximum number of elements of the free block+ -- pool by power of 2.+ -> [TuningOption] -- ^ tuning options+ -> IO Bool -- ^ if successful, the return value is True.+optimize bdb lmemb nmemb bnum apow fpow opts =+ withForeignPtr (unTCBDB bdb) $ \bdb' ->+ c_tcbdboptimize bdb' lmemb nmemb bnum apow fpow+ (combineTuningOption opts)++-- | Delete all records.+vanish :: BDB -> IO Bool+vanish bdb = withForeignPtr (unTCBDB bdb) c_tcbdbvanish++-- | Copy the database file.+copy :: BDB -> String -> IO Bool+copy = copyHelper c_tcbdbcopy unTCBDB++-- | Begin the transaction.+tranbegin :: BDB -> IO Bool+tranbegin bdb = withForeignPtr (unTCBDB bdb) c_tcbdbtranbegin++-- | Commit the transaction.+trancommit :: BDB -> IO Bool+trancommit bdb = withForeignPtr (unTCBDB bdb) c_tcbdbtrancommit++-- | Abort the transaction.+tranabort :: BDB -> IO Bool+tranabort bdb = withForeignPtr (unTCBDB bdb) c_tcbdbtranabort++-- | Return the file path of currentry opened database.+path :: BDB -> IO (Maybe String)+path = pathHelper c_tcbdbpath unTCBDB++-- | Return the number of records in the database.+rnum :: BDB -> IO Int64+rnum bdb = withForeignPtr (unTCBDB bdb) c_tcbdbrnum++-- | Return the size of the database file.+fsiz :: BDB -> IO Int64+fsiz bdb = withForeignPtr (unTCBDB bdb) c_tcbdbfsiz
+ Database/TokyoCabinet/BDB/C.hsc view
@@ -0,0 +1,211 @@+{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-}+module Database.TokyoCabinet.BDB.C where++#include <tcbdb.h>++import Foreign.Ptr+import Foreign.ForeignPtr++import Foreign.C.Types+import Foreign.C.String++import Data.Int+import Data.Word+import Data.Bits++import Database.TokyoCabinet.List.C (LIST)++data BDB = BDB { unTCBDB :: !(ForeignPtr BDB') }++data OpenMode =+ OREADER |+ OWRITER |+ OCREAT |+ OTRUNC |+ ONOLCK |+ OLCKNB |+ OTSYNC+ deriving (Eq, Ord, Show)++openModeToCInt :: OpenMode -> CInt+openModeToCInt OREADER = #const BDBOREADER+openModeToCInt OWRITER = #const BDBOWRITER+openModeToCInt OCREAT = #const BDBOCREAT+openModeToCInt OTRUNC = #const BDBOTRUNC+openModeToCInt ONOLCK = #const BDBONOLCK+openModeToCInt OLCKNB = #const BDBOLCKNB+openModeToCInt OTSYNC = #const BDBOTSYNC++combineOpenMode :: [OpenMode] -> CInt+combineOpenMode = foldr ((.|.) . openModeToCInt) 0++data TuningOption =+ TLARGE |+ TDEFLATE |+ TBZIP |+ TTCBS |+ TEXCODEC+ deriving (Eq, Ord, Show)++tuningOptionToWord8 :: TuningOption -> Word8+tuningOptionToWord8 TLARGE = #const BDBTLARGE+tuningOptionToWord8 TDEFLATE = #const BDBTDEFLATE+tuningOptionToWord8 TBZIP = #const BDBTBZIP+tuningOptionToWord8 TTCBS = #const BDBTTCBS+tuningOptionToWord8 TEXCODEC = #const BDBTEXCODEC++combineTuningOption :: [TuningOption] -> Word8+combineTuningOption = foldr ((.|.) . tuningOptionToWord8) 0++type TCCMP = Ptr CChar -> CInt -> Ptr CChar -> CInt -> Ptr Word8 -> CInt++data BDB'++foreign import ccall safe "tcbdbnew"+ c_tcbdbnew :: IO (Ptr BDB')++foreign import ccall safe "tcbdbdel"+ c_tcbdbdel :: Ptr BDB' -> IO ()++foreign import ccall safe "&tcbdbdel"+ tcbdbFinalizer :: FunPtr (Ptr BDB' -> IO ())++foreign import ccall safe "tcbdbecode"+ c_tcbdbecode :: Ptr BDB' -> IO CInt++foreign import ccall safe "tcbdbsetmutex"+ c_tcbdbsetmutex :: Ptr BDB' -> IO Bool++foreign import ccall safe "tcbdbsetcmpfunc"+ c_tcbdbsetcmpfunc :: Ptr BDB' -> FunPtr TCCMP -> IO Bool++foreign import ccall safe "tcbdbtune"+ c_tcbdbtune ::+ Ptr BDB' -> Int32 -> Int32 -> Int64 -> Int8 -> Int8 -> Word8 -> IO Bool++foreign import ccall safe "tcbdbsetcache"+ c_tcbdbsetcache :: Ptr BDB' -> Int32 -> Int32 -> IO Bool++foreign import ccall safe "tcbdbsetxmsiz"+ c_tcbdbsetxmsiz :: Ptr BDB' -> Int64 -> IO Bool++foreign import ccall safe "tcbdbopen"+ c_tcbdbopen :: Ptr BDB' -> CString -> CInt -> IO Bool++foreign import ccall safe "tcbdbclose"+ c_tcbdbclose :: Ptr BDB' -> IO Bool++foreign import ccall safe "tcbdbput"+ c_tcbdbput :: Ptr BDB' -> Ptr Word8 -> CInt -> Ptr Word8 -> CInt -> IO Bool++foreign import ccall safe "tcbdbput2"+ c_tcbdbput2 :: Ptr BDB' -> CString -> CString -> IO Bool++foreign import ccall safe "tcbdbputkeep"+ c_tcbdbputkeep ::+ Ptr BDB' -> Ptr Word8 -> CInt -> Ptr Word8 -> CInt -> IO Bool++foreign import ccall safe "tcbdbputkeep2"+ c_tcbdbputkeep2 :: Ptr BDB' -> CString -> CString -> IO Bool++foreign import ccall safe "tcbdbputcat"+ c_tcbdbputcat ::+ Ptr BDB' -> Ptr Word8 -> CInt -> Ptr Word8 -> CInt -> IO Bool++foreign import ccall safe "tcbdbputcat2"+ c_tcbdbputcat2 :: Ptr BDB' -> CString -> CString -> IO Bool++foreign import ccall safe "tcbdbputdup"+ c_tcbdbputdup ::+ Ptr BDB' -> Ptr Word8 -> CInt -> Ptr Word8 -> CInt -> IO Bool++foreign import ccall safe "tcbdbputdup2"+ c_tcbdbputdup2 :: Ptr BDB' -> CString -> CString -> IO Bool++foreign import ccall safe "tcbdbputdup3"+ c_tcbdbputdup3 :: Ptr BDB' -> Ptr Word8 -> CInt -> Ptr LIST -> IO Bool++foreign import ccall safe "tcbdbout"+ c_tcbdbout :: Ptr BDB' -> Ptr Word8 -> CInt -> IO Bool++foreign import ccall safe "tcbdbout2"+ c_tcbdbout2 :: Ptr BDB' -> CString -> IO Bool++foreign import ccall safe "tcbdbout3"+ c_tcbdbout3 :: Ptr BDB' -> Ptr Word8 -> CInt -> IO Bool++foreign import ccall safe "tcbdbget"+ c_tcbdbget :: Ptr BDB' -> Ptr Word8 -> CInt -> Ptr CInt -> IO (Ptr Word8)++foreign import ccall safe "tcbdbget2"+ c_tcbdbget2 :: Ptr BDB' -> CString -> IO CString++foreign import ccall safe "tcbdbget3"+ c_tcbdbget3 :: Ptr BDB' -> Ptr Word8 -> CInt -> Ptr CInt -> IO (Ptr Word8)++foreign import ccall safe "tcbdbget4"+ c_tcbdbget4 :: Ptr BDB' -> Ptr Word8 -> CInt -> IO (Ptr LIST)++foreign import ccall safe "tcbdbvnum"+ c_tcbdbvnum :: Ptr BDB' -> Ptr Word8 -> CInt -> IO CInt++foreign import ccall safe "tcbdbvnum2"+ c_tcbdbvnum2 :: Ptr BDB' -> CString -> IO CInt++foreign import ccall safe "tcbdbvsiz"+ c_tcbdbvsiz :: Ptr BDB' -> Ptr Word8 -> CInt -> IO CInt++foreign import ccall safe "tcbdbvsiz2"+ c_tcbdbvsiz2 :: Ptr BDB' -> CString -> IO CInt++foreign import ccall safe "tcbdbrange"+ c_tcbdbrange ::+ Ptr BDB' -> Ptr Word8 -> CInt -> Bool+ -> Ptr Word8 -> CInt -> Bool -> CInt -> IO (Ptr LIST)++foreign import ccall safe "tcbdbrange2"+ c_tcbdbrange2 ::+ Ptr BDB' -> CString -> Bool -> CString -> Bool -> CInt -> IO (Ptr LIST)++foreign import ccall safe "tcbdbfwmkeys"+ c_tcbdbfwmkeys :: Ptr BDB' -> Ptr Word8 -> CInt -> CInt -> IO (Ptr LIST)++foreign import ccall safe "tcbdbfwmkeys2"+ c_tcbdbfwmkeys2 :: Ptr BDB' -> CString -> CInt -> IO (Ptr LIST)++foreign import ccall safe "tcbdbaddint"+ c_tcbdbaddint :: Ptr BDB' -> Ptr Word8 -> CInt -> CInt -> IO CInt++foreign import ccall safe "tcbdbadddouble"+ c_tcbdbadddouble :: Ptr BDB' -> Ptr Word8 -> CInt -> CDouble -> IO CDouble++foreign import ccall safe "tcbdbsync"+ c_tcbdbsync :: Ptr BDB' -> IO Bool++foreign import ccall safe "tcbdboptimize"+ c_tcbdboptimize ::+ Ptr BDB' -> Int32 -> Int32 -> Int64 -> Int8 -> Int8 -> Word8 -> IO Bool++foreign import ccall safe "tcbdbvanish"+ c_tcbdbvanish :: Ptr BDB' -> IO Bool++foreign import ccall safe "tcbdbcopy"+ c_tcbdbcopy :: Ptr BDB' -> CString -> IO Bool++foreign import ccall safe "tcbdbtranbegin"+ c_tcbdbtranbegin :: Ptr BDB' -> IO Bool++foreign import ccall safe "tcbdbtrancommit"+ c_tcbdbtrancommit :: Ptr BDB' -> IO Bool++foreign import ccall safe "tcbdbtranabort"+ c_tcbdbtranabort :: Ptr BDB' -> IO Bool++foreign import ccall safe "tcbdbpath"+ c_tcbdbpath :: Ptr BDB' -> IO CString++foreign import ccall safe "tcbdbrnum"+ c_tcbdbrnum :: Ptr BDB' -> IO Int64++foreign import ccall safe "tcbdbfsiz"+ c_tcbdbfsiz :: Ptr BDB' -> IO Int64
+ Database/TokyoCabinet/BDB/Cursor.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-}+module Database.TokyoCabinet.BDB.Cursor+ (+ CursorPutMode(..)+ , new+ , delete+ , first+ , last+ , jump+ , prev+ , next+ , put+ , out+ , key+ , val+ , BDBCUR+ ) where++import Prelude hiding (last)++import Database.TokyoCabinet.BDB.C+import Database.TokyoCabinet.BDB.Cursor.C+import qualified Database.TokyoCabinet.Storable as S++import Foreign.ForeignPtr++import Foreign.Marshal (alloca)+import Foreign.Storable (peek)+import Foreign.Marshal.Utils (maybePeek)++data BDBCUR = BDBCUR !(ForeignPtr CUR) BDB++unTCBDBCUR :: BDBCUR -> ForeignPtr CUR+unTCBDBCUR (BDBCUR cur _) = cur++new :: BDB -> IO BDBCUR+new bdb =+ withForeignPtr (unTCBDB bdb) $ \bdb' -> do+ cur <- c_tcbdbcurnew bdb'+ flip BDBCUR bdb `fmap` newForeignPtr tcbdbcurFinalizer cur++delete :: BDBCUR -> IO ()+delete cur = finalizeForeignPtr (unTCBDBCUR cur)++first :: BDBCUR -> IO Bool+first cur = withForeignPtr (unTCBDBCUR cur) c_tcbdbcurfirst++last :: BDBCUR -> IO Bool+last cur = withForeignPtr (unTCBDBCUR cur) c_tcbdbcurlast++jump :: (S.Storable k) => BDBCUR -> k -> IO Bool+jump cur k =+ withForeignPtr (unTCBDBCUR cur) $ \cur' ->+ S.withPtrLen k $ \(kbuf, ksiz) ->+ c_tcbdbcurjump cur' kbuf ksiz++prev :: BDBCUR -> IO Bool+prev cur = withForeignPtr (unTCBDBCUR cur) c_tcbdbcurprev++next :: BDBCUR -> IO Bool+next cur = withForeignPtr (unTCBDBCUR cur) c_tcbdbcurnext++put :: (S.Storable v) => BDBCUR -> v -> CursorPutMode -> IO Bool+put cur v mode =+ withForeignPtr (unTCBDBCUR cur) $ \cur' ->+ S.withPtrLen v $ \(vbuf, vsiz) ->+ c_tcbdbcurput cur' vbuf vsiz (cpToCInt mode)++out :: BDBCUR -> IO Bool+out cur = withForeignPtr (unTCBDBCUR cur) c_tcbdbcurout++key :: (S.Storable k) => BDBCUR -> IO (Maybe k)+key cur =+ withForeignPtr (unTCBDBCUR cur) $ \cur' ->+ alloca $ \sizbuf -> do+ vbuf <- c_tcbdbcurkey cur' sizbuf+ vsiz <- fromIntegral `fmap` peek sizbuf+ flip maybePeek vbuf $ \vbuf' -> S.peekPtrLen (vbuf', vsiz) ++val :: (S.Storable v) => BDBCUR -> IO (Maybe v)+val cur =+ withForeignPtr (unTCBDBCUR cur) $ \cur' ->+ alloca $ \sizbuf -> do+ vbuf <- c_tcbdbcurval cur' sizbuf+ vsiz <- fromIntegral `fmap` peek sizbuf+ flip maybePeek vbuf $ \vbuf' -> S.peekPtrLen (vbuf', vsiz)
+ Database/TokyoCabinet/BDB/Cursor/C.hsc view
@@ -0,0 +1,79 @@+{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-}+module Database.TokyoCabinet.BDB.Cursor.C where++import Database.TokyoCabinet.BDB.C++import Foreign.Ptr++import Foreign.C.Types+import Foreign.C.String++import Data.Word++#include <tcbdb.h>++data CursorPutMode = CPCURRENT |+ CPBEFORE |+ CPAFTER+ deriving (Eq, Ord, Show)++cpToCInt :: CursorPutMode -> CInt+cpToCInt CPCURRENT = #const BDBCPCURRENT+cpToCInt CPBEFORE = #const BDBCPBEFORE+cpToCInt CPAFTER = #const BDBCPAFTER++data CUR++foreign import ccall safe "tcbdbcurnew"+ c_tcbdbcurnew :: Ptr BDB' -> IO (Ptr CUR)++foreign import ccall safe "tcbdbcurdel"+ c_tcbdbcurdel :: Ptr CUR -> IO ()++foreign import ccall safe "&tcbdbcurdel"+ tcbdbcurFinalizer :: FunPtr (Ptr CUR -> IO ())++foreign import ccall safe "tcbdbcurfirst"+ c_tcbdbcurfirst :: Ptr CUR -> IO Bool++foreign import ccall safe "tcbdbcurlast"+ c_tcbdbcurlast :: Ptr CUR -> IO Bool++foreign import ccall safe "tcbdbcurjump"+ c_tcbdbcurjump :: Ptr CUR -> Ptr Word8 -> CInt -> IO Bool++foreign import ccall safe "tcbdbcurjump2"+ c_tcbdbcurjump2 :: Ptr CUR -> CString -> IO Bool++foreign import ccall safe "tcbdbcurprev"+ c_tcbdbcurprev :: Ptr CUR -> IO Bool++foreign import ccall safe "tcbdbcurnext"+ c_tcbdbcurnext :: Ptr CUR -> IO Bool++foreign import ccall safe "tcbdbcurput"+ c_tcbdbcurput :: Ptr CUR -> Ptr Word8 -> CInt -> CInt -> IO Bool++foreign import ccall safe "tcbdbcurput2"+ c_tcbdbcurput2 :: Ptr CUR -> CString -> CInt -> IO Bool++foreign import ccall safe "tcbdbcurout"+ c_tcbdbcurout :: Ptr CUR -> IO Bool++foreign import ccall safe "tcbdbcurkey"+ c_tcbdbcurkey :: Ptr CUR -> Ptr CInt -> IO (Ptr Word8)++foreign import ccall safe "tcbdbcurkey2"+ c_tcbdbcurkey2 :: Ptr CUR -> IO CString++foreign import ccall safe "tcbdbcurkey3"+ c_tcbdbcurkey3 :: Ptr CUR -> Ptr CInt -> IO (Ptr Word8)++foreign import ccall safe "tcbdbcurval"+ c_tcbdbcurval :: Ptr CUR -> Ptr CInt -> IO (Ptr Word8)++foreign import ccall safe "tcbdbcurval2"+ c_tcbdbcurval2 :: Ptr CUR -> IO CString++foreign import ccall safe "tcbdbcurval3"+ c_tcbdbcurval3 :: Ptr CUR -> Ptr CInt -> IO (Ptr Word8)
+ Database/TokyoCabinet/Error.hsc view
@@ -0,0 +1,112 @@+{-# LANGUAGE CPP, ForeignFunctionInterface #-}+module Database.TokyoCabinet.Error+ (+ -- * Error code+ ECODE(..)+ -- * Utility function+ , errmsg+ , cintToError+ , errorToCInt+ -- * Other constants+ , cINT_MIN+ ) where++import Foreign+import Foreign.C.Types+import Foreign.C.String++#include <tcutil.h>++-- | Represents error+data ECODE =+ ESUCCESS | -- ^ success + ETHREAD | -- ^ threading error + EINVALID | -- ^ invalid operation + ENOFILE | -- ^ file not found + ENOPERM | -- ^ no permission + EMETA | -- ^ invalid meta data + ERHEAD | -- ^ invalid record header + EOPEN | -- ^ open error + ECLOSE | -- ^ close error + ETRUNC | -- ^ trunc error + ESYNC | -- ^ sync error + ESTAT | -- ^ stat error + ESEEK | -- ^ seek error + EREAD | -- ^ read error + EWRITE | -- ^ write error + EMMAP | -- ^ mmap error + ELOCK | -- ^ lock error + EUNLINK | -- ^ unlink error + ERENAME | -- ^ rename error + EMKDIR | -- ^ mkdir error + ERMDIR | -- ^ rmdir error + EKEEP | -- ^ existing record + ENOREC | -- ^ no record found + EMISC -- ^ miscellaneous error+ deriving (Eq, Ord)++instance Show ECODE where+ show e = errmsg e ++ " (code:" ++ show (errorToCInt e) ++ ")"++errorToCInt :: ECODE -> CInt+errorToCInt ESUCCESS = #const TCESUCCESS+errorToCInt ETHREAD = #const TCETHREAD+errorToCInt EINVALID = #const TCEINVALID+errorToCInt ENOFILE = #const TCENOFILE+errorToCInt ENOPERM = #const TCENOPERM+errorToCInt EMETA = #const TCEMETA+errorToCInt ERHEAD = #const TCERHEAD+errorToCInt EOPEN = #const TCEOPEN+errorToCInt ECLOSE = #const TCECLOSE+errorToCInt ETRUNC = #const TCETRUNC+errorToCInt ESYNC = #const TCESYNC+errorToCInt ESTAT = #const TCESTAT+errorToCInt ESEEK = #const TCESEEK+errorToCInt EREAD = #const TCEREAD+errorToCInt EWRITE = #const TCEWRITE+errorToCInt EMMAP = #const TCEMMAP+errorToCInt ELOCK = #const TCELOCK+errorToCInt EUNLINK = #const TCEUNLINK+errorToCInt ERENAME = #const TCERENAME+errorToCInt EMKDIR = #const TCEMKDIR+errorToCInt ERMDIR = #const TCERMDIR+errorToCInt EKEEP = #const TCEKEEP+errorToCInt ENOREC = #const TCENOREC+errorToCInt EMISC = #const TCEMISC++cintToError :: CInt -> ECODE+cintToError #{const TCESUCCESS} = ESUCCESS+cintToError #{const TCETHREAD} = ETHREAD+cintToError #{const TCEINVALID} = EINVALID+cintToError #{const TCENOFILE} = ENOFILE+cintToError #{const TCENOPERM} = ENOPERM+cintToError #{const TCEMETA} = EMETA+cintToError #{const TCERHEAD} = ERHEAD+cintToError #{const TCEOPEN} = EOPEN+cintToError #{const TCECLOSE} = ECLOSE+cintToError #{const TCETRUNC} = ETRUNC+cintToError #{const TCESYNC} = ESYNC+cintToError #{const TCESTAT} = ESTAT+cintToError #{const TCESEEK} = ESEEK+cintToError #{const TCEREAD} = EREAD+cintToError #{const TCEWRITE} = EWRITE+cintToError #{const TCEMMAP} = EMMAP+cintToError #{const TCELOCK} = ELOCK+cintToError #{const TCEUNLINK} = EUNLINK+cintToError #{const TCERENAME} = ERENAME+cintToError #{const TCEMKDIR} = EMKDIR+cintToError #{const TCERMDIR} = ERMDIR+cintToError #{const TCEKEEP} = EKEEP+cintToError #{const TCENOREC} = ENOREC+cintToError #{const TCEMISC} = EMISC+cintToError _ = error "unknown error code"++cINT_MIN :: CInt+cINT_MIN = #const INT_MIN++-- | Convert error code to message string.+errmsg :: ECODE -> String+errmsg = unsafePerformIO . peekCString . c_tcerrmsg . errorToCInt++foreign import ccall "tcerrmsg"+ c_tcerrmsg :: CInt -> CString
+ Database/TokyoCabinet/FDB.hs view
@@ -0,0 +1,266 @@+-- | Interface to Fixed-length DBM. See also,+-- <http://tokyocabinet.sourceforge.net/spex-en.html#tcfdbapi> for details+module Database.TokyoCabinet.FDB+ (+ -- $doc+ -- * Constructors+ FDB+ , ECODE(..)+ , OpenMode(..)+ , ID(..)+ -- * Basic API (tokyocabinet.idl compliant)+ , new+ , delete+ , ecode+ , errmsg+ , tune+ , open+ , close+ , put+ , putkeep+ , putcat+ , out+ , get+ , vsiz+ , iterinit+ , iternext+ , range+ , fwmkeys+ , addint+ , adddouble+ , sync+ , optimize+ , vanish+ , copy+ , path+ , rnum+ , fsiz+ ) where++import Database.TokyoCabinet.Error+import Database.TokyoCabinet.FDB.C+import Database.TokyoCabinet.FDB.Key+import Database.TokyoCabinet.Internal+import qualified Database.TokyoCabinet.Storable as S++import Foreign.Ptr+import Foreign.ForeignPtr+import Foreign.C.Types+import Foreign.Storable (peek)+import Foreign.Marshal (alloca, free)+import Foreign.Marshal.Array (peekArray)+import Foreign.Marshal.Utils (maybePeek)++import Data.Int+import Data.Word++import Control.Exception++-- $doc+-- Example+--+-- @+-- import Control.Monad+-- import Database.TokyoCabinet.FDB+-- @+--+-- @ +-- main = do fdb <- new+-- -- open the database+-- open fdb \"casket.tcf\" [OWRITER, OCREAT] >>= err fdb+-- -- store records+-- puts fdb [(1, \"one\"), (12, \"twelve\"), (144, \"one forty four\")] >>=+-- err fdb . (all id)+-- -- retrieve records+-- get fdb (1 :: Int) >>= maybe (error \"something goes wrong\") putStrLn+-- -- close the database+-- close fdb >>= err fdb+-- where+-- puts :: FDB -> [(Int, String)] -> IO [Bool]+-- puts fdb = mapM (uncurry $ put fdb)+-- @+--+-- @ +-- err :: FDB -> Bool -> IO ()+-- err fdb = flip unless $ ecode fdb >>= error . show+-- @+--+++data FDB = FDB { unTCFDB :: !(ForeignPtr FDB') }++-- | Create a Fixed-length database object. +new :: IO FDB+new = FDB `fmap` (c_tcfdbnew >>= newForeignPtr tcfdbFinalizer)++-- | Free FDB resource forcibly.+-- FDB is kept by ForeignPtr, so Haskell runtime GC cleans up memory for+-- almost situation. Most always, you don't need to call this. +-- After call this, you must not touch FDB object. Its behavior is undefined.+delete :: FDB -> IO ()+delete fdb = finalizeForeignPtr $ unTCFDB fdb++-- | Return the last happened error code.+ecode :: FDB -> IO ECODE+ecode fdb =+ withForeignPtr (unTCFDB fdb) $ \fdb' ->+ cintToError `fmap` c_tcfdbecode fdb'++-- | Set the tuning parameters.+tune :: FDB -- ^ FDB object.+ -> Int32 -- ^ the width of the value of each record.+ -> Int64 -- ^ the limit size of the database file.+ -> IO Bool -- ^ if successful, the return value is True.+tune fdb width limsiz =+ withForeignPtr (unTCFDB fdb) $ \fdb' -> c_tcfdbtune fdb' width limsiz++-- | Open FDB database file.+open :: FDB -> String -> [OpenMode] -> IO Bool+open = openHelper c_tcfdbopen unTCFDB combineOpenMode++-- | Close the database file.+close :: FDB -> IO Bool+close fdb = withForeignPtr (unTCFDB fdb) c_tcfdbclose++type FunPut' = Ptr FDB' -> Int64 -> Ptr Word8 -> CInt -> IO Bool+putHelper' :: (Key k, S.Storable v) => FunPut' -> FDB -> k -> v -> IO Bool+putHelper' func fdb key val =+ withForeignPtr (unTCFDB fdb) $ \fdb' ->+ S.withPtrLen val $ \(vbuf, vsize) -> do+ key' <- keyToInt key+ func fdb' key' vbuf vsize++-- | Stora a record (key-value pair) on FDB. Key type must be+-- instance of Key class. Value type must be instance of Storable.+put :: (Key k, S.Storable v) => FDB -> k -> v -> IO Bool+put = putHelper' c_tcfdbput++-- | Store a new record. If a record with the same key exists in the+-- database, this function has no effect.+putkeep :: (Key k, S.Storable v) => FDB -> k -> v -> IO Bool+putkeep = putHelper' c_tcfdbputkeep++-- | Concatenate a value at the end of the existing record.+putcat :: (Key k, S.Storable v) => FDB -> k -> v -> IO Bool+putcat = putHelper' c_tcfdbputcat++-- | Delete a record. +out :: (Key k) => FDB -> k -> IO Bool+out fdb key =+ withForeignPtr (unTCFDB fdb) $ \fdb' ->+ c_tcfdbout fdb' =<< keyToInt key++-- | Return the value of record. +get :: (Key k, S.Storable v) => FDB -> k -> IO (Maybe v)+get fdb key =+ withForeignPtr (unTCFDB fdb) $ \fdb' ->+ alloca $ \sizbuf -> do+ key' <- keyToInt key+ vbuf <- c_tcfdbget fdb' key' sizbuf+ vsize <- peek sizbuf+ flip maybePeek vbuf $ \vbuf' -> S.peekPtrLen (vbuf', vsize)++-- | Return the byte size of value in a record.+vsiz :: (Key k) => FDB -> k -> IO (Maybe Int)+vsiz fdb key =+ withForeignPtr (unTCFDB fdb) $ \fdb' -> do+ vsize <- c_tcfdbvsiz fdb' =<< keyToInt key+ return $ if vsize == (-1)+ then Nothing+ else Just (fromIntegral vsize)++-- | Initialize the iterator of a FDB object.+iterinit :: FDB -> IO Bool+iterinit fdb = withForeignPtr (unTCFDB fdb) c_tcfdbiterinit++-- | Return the next key of the iterator of a FDB object.+iternext :: (Key k) => FDB -> IO (Maybe k)+iternext fdb = + withForeignPtr (unTCFDB fdb) $ \fdb' -> do+ i <- c_tcfdbiternext fdb'+ return $ if i == 0+ then Nothing+ else Just (fromID $ ID i)++-- | Return list of keys in the specified range.+range :: (Key k1, Key k2) =>+ FDB -- ^ FDB object+ -> k1 -- ^ the lower limit of the range.+ -> k1 -- ^ the upper limit of the range.+ -> Int -- ^ the maximum number of keys to be fetched.+ -> IO [k2] -- ^ keys in the specified range.+range fdb lower upper maxn =+ withForeignPtr (unTCFDB fdb) $ \fdb' ->+ alloca $ \sizbuf -> do+ [l, u] <- mapM keyToInt [lower, upper]+ rp <- c_tcfdbrange fdb' l u (fromIntegral maxn) sizbuf+ size <- fromIntegral `fmap` peek sizbuf+ keys <- peekArray size rp+ free rp+ return $ map (fromID . ID) keys++-- | Return list of forward matched keys.+fwmkeys :: (S.Storable k1, S.Storable k2) => FDB -> k1 -> Int -> IO [k2]+fwmkeys fdb k maxn = map S.fromString `fmap` fwmkeys' fdb k maxn+ where fwmkeys' = fwmHelper c_tcfdbrange4 unTCFDB++-- | Increment the corresponding value. (The value specified by a key+-- is treated as integer.)+addint :: (Key k) => FDB -> k -> Int -> IO (Maybe Int)+addint fdb key num =+ withForeignPtr (unTCFDB fdb) $ \fdb' -> do+ key' <- keyToInt key+ sumval <- c_tcfdbaddint fdb' key' (fromIntegral num)+ return $ if sumval == cINT_MIN+ then Nothing+ else Just $ fromIntegral sumval++-- | Increment the corresponding value. (The value specified by a key+-- is treated as double.)+adddouble :: (Key k) => FDB -> k -> Double -> IO (Maybe Double)+adddouble fdb key num =+ withForeignPtr (unTCFDB fdb) $ \fdb' -> do+ key' <- keyToInt key+ sumval <- c_tcfdbadddouble fdb' key' (realToFrac num)+ return $ if isNaN sumval+ then Nothing+ else Just $ realToFrac sumval++-- | Synchronize updated contents of a database object with the file+-- and the device.+sync :: FDB -> IO Bool+sync fdb = withForeignPtr (unTCFDB fdb) c_tcfdbsync++-- | Optimize the file of a Hash database object.+optimize :: FDB -> Int32 -> Int64 -> IO Bool+optimize fdb width limsiz =+ withForeignPtr (unTCFDB fdb) $ \fdb' -> c_tcfdboptimize fdb' width limsiz++-- | Delete all records.+vanish :: FDB -> IO Bool+vanish fdb = withForeignPtr (unTCFDB fdb) c_tcfdbvanish++-- | Copy the database file.+copy :: FDB -> String -> IO Bool+copy = copyHelper c_tcfdbcopy unTCFDB++-- | Return the file path of currentry opened database.+path :: FDB -> IO (Maybe String)+path = pathHelper c_tcfdbpath unTCFDB++-- | Return the number of records in the database.+rnum :: FDB -> IO Int64+rnum fdb = withForeignPtr (unTCFDB fdb) c_tcfdbrnum++-- | Return the size of the database file.+fsiz :: FDB -> IO Int64+fsiz fdb = withForeignPtr (unTCFDB fdb) c_tcfdbfsiz++keyToInt :: (Key k) => k -> IO Int64+keyToInt i = catchJust selector (evaluate (unID . toID $ i)) handler+ where+ selector :: ErrorCall -> Maybe ()+ selector e = if show e == "Prelude.read: no parse"+ then Just ()+ else Nothing+ handler _ = error "Database.TokyoCabinet.FDB: invalid key"
+ Database/TokyoCabinet/FDB/C.hsc view
@@ -0,0 +1,199 @@+{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-}+module Database.TokyoCabinet.FDB.C where++import Foreign.Ptr+import Foreign.C.Types+import Foreign.C.String++import Data.Int+import Data.Word+import Data.Bits++import Database.TokyoCabinet.List.C (LIST)++#include <tcfdb.h>++data OpenMode =+ OREADER |+ OWRITER |+ OCREAT |+ OTRUNC |+ ONOLCK |+ OLCKNB+ deriving (Eq, Ord, Show)++openModeToCInt :: OpenMode -> CInt+openModeToCInt OREADER = #const FDBOREADER+openModeToCInt OWRITER = #const FDBOWRITER+openModeToCInt OCREAT = #const FDBOCREAT+openModeToCInt OTRUNC = #const FDBOTRUNC+openModeToCInt ONOLCK = #const FDBONOLCK+openModeToCInt OLCKNB = #const FDBOLCKNB++combineOpenMode :: [OpenMode] -> CInt+combineOpenMode = foldr ((.|.) . openModeToCInt) 0++data ID =+ IDMIN |+ IDPREV |+ IDMAX |+ IDNEXT |+ ID Int64+ deriving (Eq, Ord)++instance Show ID where+ show IDMIN = "min"+ show IDPREV = "prev"+ show IDMAX = "max"+ show IDNEXT = "next"+ show (ID i) = show i++unID :: ID -> Int64+unID IDMIN = #const FDBIDMIN+unID IDPREV = #const FDBIDPREV+unID IDMAX = #const FDBIDMAX+unID IDNEXT = #const FDBIDNEXT+unID (ID int) = int++data FDB'++foreign import ccall safe "tcfdberrmsg"+ c_tcfdberrmsg :: CInt -> CString++foreign import ccall safe "tcfdbnew"+ c_tcfdbnew :: IO (Ptr FDB')++foreign import ccall safe "tcfdbdel"+ c_tcfdbdel :: Ptr FDB' -> IO ()++foreign import ccall safe "&tcfdbdel"+ tcfdbFinalizer :: FunPtr (Ptr FDB' -> IO ())++foreign import ccall safe "tcfdbecode"+ c_tcfdbecode :: Ptr FDB' -> IO CInt++foreign import ccall safe "tcfdbsetmutex"+ c_tcfdbsetmutex :: Ptr FDB' -> IO Bool++foreign import ccall safe "tcfdbtune"+ c_tcfdbtune :: Ptr FDB' -> Int32 -> Int64 -> IO Bool++foreign import ccall safe "tcfdbopen"+ c_tcfdbopen :: Ptr FDB' -> CString -> CInt -> IO Bool++foreign import ccall safe "tcfdbclose"+ c_tcfdbclose :: Ptr FDB' -> IO Bool++foreign import ccall safe "tcfdbput"+ c_tcfdbput :: Ptr FDB' -> Int64 -> Ptr Word8 -> CInt -> IO Bool++foreign import ccall safe "tcfdbput2"+ c_tcfdbput2 :: Ptr FDB' -> Ptr Word8 -> CInt -> Ptr Word8 -> CInt -> IO Bool++foreign import ccall safe "tcfdbput3"+ c_tcfdbput3 :: Ptr FDB' -> CString -> CString -> IO Bool++foreign import ccall safe "tcfdbputkeep"+ c_tcfdbputkeep :: Ptr FDB' -> Int64 -> Ptr Word8 -> CInt -> IO Bool++foreign import ccall safe "tcfdbputkeep2"+ c_tcfdbputkeep2 ::+ Ptr FDB' -> Ptr Word8 -> CInt -> Ptr Word8 -> CInt -> IO Bool++foreign import ccall safe "tcfdbputkeep3"+ c_tcfdbputkeep3 :: Ptr FDB' -> CString -> CString -> IO Bool++foreign import ccall safe "tcfdbputcat"+ c_tcfdbputcat :: Ptr FDB' -> Int64 -> Ptr Word8 -> CInt -> IO Bool++foreign import ccall safe "tcfdbputcat2"+ c_tcfdbputcat2 :: Ptr FDB' -> Ptr Word8 -> CInt -> Ptr Word8 -> CInt -> IO Bool++foreign import ccall safe "tcfdbputcat3"+ c_tcfdbputcat3 :: Ptr FDB' -> CString -> CString -> IO Bool++foreign import ccall safe "tcfdbout"+ c_tcfdbout :: Ptr FDB' -> Int64 -> IO Bool++foreign import ccall safe "tcfdbout2"+ c_tcfdbout2 :: Ptr FDB' -> Ptr Word8 -> CInt -> IO Bool++foreign import ccall safe "tcfdbout3"+ c_tcfdbout3 :: Ptr FDB' -> CString -> IO Bool++foreign import ccall safe "tcfdbget"+ c_tcfdbget :: Ptr FDB' -> Int64 -> Ptr CInt -> IO (Ptr Word8)++foreign import ccall safe "tcfdbget2"+ c_tcfdbget2 :: Ptr FDB' -> Ptr Word8 -> CInt -> Ptr CInt -> IO (Ptr Word8)++foreign import ccall safe "tcfdbget3"+ c_tcfdbget3 :: Ptr FDB' -> CString -> IO CString++foreign import ccall safe "tcfdbget4"+ c_tcfdbget4 :: Ptr FDB' -> Int64 -> Ptr Word8 -> CInt -> IO CInt++foreign import ccall safe "tcfdbvsiz"+ c_tcfdbvsiz :: Ptr FDB' -> Int64 -> IO CInt++foreign import ccall safe "tcfdbvsiz2"+ c_tcfdbvsiz2 :: Ptr FDB' -> Ptr Word8 -> CInt -> IO CInt++foreign import ccall safe "tcfdbvsiz3"+ c_tcfdbvsiz3 :: Ptr FDB' -> CString -> IO CInt++foreign import ccall safe "tcfdbiterinit"+ c_tcfdbiterinit :: Ptr FDB' -> IO Bool++foreign import ccall safe "tcfdbiternext"+ c_tcfdbiternext :: Ptr FDB' -> IO Int64++foreign import ccall safe "tcfdbiternext2"+ c_tcfdbiternext2 :: Ptr FDB' -> Ptr CInt -> IO (Ptr Word8)++foreign import ccall safe "tcfdbiternext3"+ c_tcfdbiternext3 :: Ptr FDB' -> IO CString++foreign import ccall safe "tcfdbrange"+ c_tcfdbrange ::+ Ptr FDB' -> Int64 -> Int64 -> CInt -> Ptr CInt -> IO (Ptr Int64)++foreign import ccall safe "tcfdbrange2"+ c_tcfdbrange2 ::+ Ptr FDB' -> Ptr Word8 -> CInt -> Ptr Word8 -> CInt -> CInt -> IO (Ptr LIST)++foreign import ccall safe "tcfdbrange3"+ c_tcfdbrange3 :: Ptr FDB' -> CString -> CString -> CInt -> IO (Ptr LIST)++foreign import ccall safe "tcfdbrange4"+ c_tcfdbrange4 :: Ptr FDB' -> Ptr Word8 -> CInt -> CInt -> IO (Ptr LIST)++foreign import ccall safe "tcfdbrange5"+ c_tcfdbrange5 :: Ptr FDB' -> Ptr Word8 -> CInt -> IO (Ptr LIST)++foreign import ccall safe "tcfdbaddint"+ c_tcfdbaddint :: Ptr FDB' -> Int64 -> CInt -> IO CInt++foreign import ccall safe "tcfdbadddouble"+ c_tcfdbadddouble :: Ptr FDB' -> Int64 -> CDouble -> IO CDouble++foreign import ccall safe "tcfdbsync"+ c_tcfdbsync :: Ptr FDB' -> IO Bool++foreign import ccall safe "tcfdboptimize"+ c_tcfdboptimize :: Ptr FDB' -> Int32 -> Int64 -> IO Bool++foreign import ccall safe "tcfdbvanish"+ c_tcfdbvanish :: Ptr FDB' -> IO Bool++foreign import ccall safe "tcfdbcopy"+ c_tcfdbcopy :: Ptr FDB' -> CString -> IO Bool++foreign import ccall safe "tcfdbpath"+ c_tcfdbpath :: Ptr FDB' -> IO CString++foreign import ccall safe "tcfdbrnum"+ c_tcfdbrnum :: Ptr FDB' -> IO Int64++foreign import ccall safe "tcfdbfsiz"+ c_tcfdbfsiz :: Ptr FDB' -> IO Int64
+ Database/TokyoCabinet/FDB/Key.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE TypeSynonymInstances #-}+module Database.TokyoCabinet.FDB.Key (Key(..), ID(..)) where++import Database.TokyoCabinet.FDB.C (ID(..), unID)++import Data.Int+import Data.Word++class Key a where+ toID :: a -> ID+ fromID :: ID -> a++instance Key Int where+ toID = ID . fromIntegral+ fromID = fromIntegral . unID++instance Key Int8 where+ toID = ID . fromIntegral+ fromID = fromIntegral . unID++instance Key Int16 where+ toID = ID . fromIntegral+ fromID = fromIntegral . unID++instance Key Int32 where+ toID = ID . fromIntegral+ fromID = fromIntegral . unID++instance Key Int64 where+ toID = ID+ fromID = fromIntegral . unID++instance Key Word8 where+ toID = ID . fromIntegral+ fromID = fromIntegral . unID++instance Key Word16 where+ toID = ID . fromIntegral+ fromID = fromIntegral . unID++instance Key Word32 where+ toID = ID . fromIntegral+ fromID = fromIntegral . unID++instance Key Word64 where+ toID = ID . fromIntegral+ fromID = fromIntegral . unID++instance Key ID where+ toID = id+ fromID = id++instance Key String where+ toID "min" = IDMIN+ toID "max" = IDMAX+ toID "prev" = IDPREV+ toID "next" = IDNEXT+ toID idstr = ID (read idstr)+ fromID = show . unID
+ Database/TokyoCabinet/HDB.hs view
@@ -0,0 +1,257 @@+-- | Interface to Hash based DBM. See also,+-- <http://tokyocabinet.sourceforge.net/spex-en.html#tchdbapi> for details+module Database.TokyoCabinet.HDB+ (+ -- $doc+ -- * Constructors+ HDB+ , ECODE(..)+ , OpenMode(..)+ , TuningOption(..)+ -- * Basic API (tokyocabinet.idl compliant)+ , new+ , delete+ , ecode+ , errmsg+ , tune+ , setcache+ , setxmsiz+ , open+ , close+ , put+ , putkeep+ , putcat+ , putasync+ , out+ , get+ , vsiz+ , iterinit+ , iternext+ , fwmkeys+ , addint+ , adddouble+ , sync+ , optimize+ , vanish+ , copy+ , tranbegin+ , trancommit+ , tranabort+ , path+ , rnum+ , fsiz+ )+ where++import Foreign.Storable (peek)+import Foreign.ForeignPtr+import Foreign.Marshal (alloca)+import Foreign.Marshal.Utils (maybePeek)++import Data.Int++import Database.TokyoCabinet.HDB.C+import Database.TokyoCabinet.Error+import Database.TokyoCabinet.Internal+import qualified Database.TokyoCabinet.Storable as S++-- $doc+-- Example+--+-- @+-- import Control.Monad+-- import Database.TokyoCabinet.HDB+-- @+--+-- @+-- main = do hdb <- new+-- -- open the database+-- open hdb \"casket.tch\" [OWRITER, OCREAT] >>= err hdb+-- -- store records+-- puts hdb [(\"foo\", \"hop\"), (\"bar\", \"step\"), (\"baz\", \"jump\")] >>=+-- err hdb . (all id)+-- -- retrieve records+-- get_print hdb \"foo\"+-- -- traverse records+-- iterinit hdb+-- iter hdb >>= mapM_ (\k -> putStr (k++\":\") >> get_print hdb k)+-- -- close the database+-- close hdb >>= err hdb+-- where+-- puts :: HDB -> [(String, String)] -> IO [Bool]+-- puts hdb = mapM (uncurry $ put hdb)+-- @+--+-- @+-- get_print :: HDB -> String -> IO ()+-- get_print hdb key = get hdb key >>=+-- maybe (error \"something goes wrong\") putStrLn+-- @+--+-- @ +-- err :: HDB -> Bool -> IO ()+-- err hdb = flip unless $ ecode hdb >>= error . show+-- @+--+-- @ +-- iter :: HDB -> IO [String]+-- iter hdb = iternext hdb >>=+-- maybe (return []) (\x -> return . (x:) =<< iter hdb)+-- @+--++data HDB = HDB { unTCHDB :: !(ForeignPtr HDB') }++-- | Create a Hash database object. +new :: IO HDB+new = HDB `fmap` (c_tchdbnew >>= newForeignPtr tchdbFinalizer)++-- | Free HDB resource forcibly. +-- HDB is kept by ForeignPtr, so Haskell runtime GC cleans up memory for+-- almost situation. Most always, you don't need to call this. +-- After call this, you must not touch HDB object. Its behavior is undefined.+delete :: HDB -> IO ()+delete hdb = finalizeForeignPtr (unTCHDB hdb)++-- | Return the last happened error code.+ecode :: HDB -> IO ECODE+ecode hdb = cintToError `fmap` withForeignPtr (unTCHDB hdb) c_tchdbecode++-- | Set the tuning parameters.+tune :: HDB -- ^ HDB object+ -> Int64 -- ^ the number of elements of the bucket array.+ -> Int8 -- ^ the size of record alignment by power of 2. + -> Int8 -- ^ the maximum number of elements of the free block+ -- pool by power of 2.+ -> [TuningOption] -- ^ tuning options.+ -> IO Bool -- ^ if successful, the return value is True.+tune hdb bnum apow fpow options =+ withForeignPtr (unTCHDB hdb) $ \p ->+ c_tchdbtune p bnum apow fpow (combineTuningOption options)++-- | Set the caching parameters.+setcache :: HDB -- ^ HDB object.+ -> Int32 -- ^ the maximum number of records to be cached.+ -> IO Bool -- ^ if successful, the return value is True.+setcache hdb rcnum = withForeignPtr (unTCHDB hdb) (flip c_tchdbsetcache rcnum)++-- | Set the size of extra mapped memory.+setxmsiz :: HDB -> Int64 -> IO Bool+setxmsiz hdb xmsiz = withForeignPtr (unTCHDB hdb) (flip c_tchdbsetxmsiz xmsiz)++-- | Open a database file.+open :: HDB -> String -> [OpenMode] -> IO Bool+open = openHelper c_tchdbopen unTCHDB combineOpenMode++-- | Close the database file.+close :: HDB -> IO Bool+close hdb = withForeignPtr (unTCHDB hdb) c_tchdbclose++-- | Stora a record (key-value pair) on HDB. Key and value type must+-- be instance of Storable class. Usually, we can use `String',+-- `ByteString' for key, `String', `ByteString', `Int', `Double' for+-- value.+put :: (S.Storable k, S.Storable v) => HDB -> k -> v -> IO Bool+put = putHelper c_tchdbput unTCHDB++-- | Store a new record. If a record with the same key exists in the+-- database, this function has no effect.+putkeep :: (S.Storable k, S.Storable v) => HDB -> k -> v -> IO Bool+putkeep = putHelper c_tchdbputkeep unTCHDB++-- | Concatenate a value at the end of the existing record.+putcat :: (S.Storable k, S.Storable v) => HDB -> k -> v -> IO Bool+putcat = putHelper c_tchdbputcat unTCHDB++-- | Store a record into a hash database object in asynchronous fashion.+putasync :: (S.Storable k, S.Storable v) => HDB -> k -> v -> IO Bool+putasync = putHelper c_tchdbputasync unTCHDB++-- | Delete a record.+out :: (S.Storable k) => HDB -> k -> IO Bool+out = outHelper c_tchdbout unTCHDB++-- | Return the value of record. +get :: (S.Storable k, S.Storable v) => HDB -> k -> IO (Maybe v)+get = getHelper c_tchdbget unTCHDB++-- | Return the byte size of value in a record.+vsiz :: (S.Storable k) => HDB -> k -> IO (Maybe Int)+vsiz = vsizHelper c_tchdbvsiz unTCHDB++-- | Initialize the iterator of a HDB object.+iterinit :: HDB -> IO Bool+iterinit hdb = withForeignPtr (unTCHDB hdb) c_tchdbiterinit++-- | Return the next key of the iterator of a HDB object.+iternext :: (S.Storable k) => HDB -> IO (Maybe k)+iternext hdb =+ withForeignPtr (unTCHDB hdb) $ \p ->+ alloca $ \sizbuf -> do+ vbuf <- c_tchdbiternext p sizbuf+ flip maybePeek vbuf $ \vp ->+ do siz <- peek sizbuf+ S.peekPtrLen (vp, siz)++-- | Return list of forward matched keys.+fwmkeys :: (S.Storable k1, S.Storable k2) => HDB -> k1 -> Int -> IO [k2]+fwmkeys = fwmHelper c_tchdbfwmkeys unTCHDB++-- | Increment the corresponding value. (The value specified by a key+-- is treated as integer.)+addint :: (S.Storable k) => HDB -> k -> Int -> IO (Maybe Int)+addint = addHelper c_tchdbaddint unTCHDB fromIntegral fromIntegral (== cINT_MIN)++-- | Increment the corresponding value. (The value specified by a key+-- is treated as double.)+adddouble :: (S.Storable k) => HDB -> k -> Double -> IO (Maybe Double)+adddouble = addHelper c_tchdbadddouble unTCHDB realToFrac realToFrac isNaN++-- | Synchronize updated contents of a database object with the file+-- and the device.+sync :: HDB -> IO Bool+sync hdb = withForeignPtr (unTCHDB hdb) c_tchdbsync++-- | Optimize the file of a Hash database object.+optimize :: HDB -- ^ HDB object+ -> Int64 -- ^ the number of elements of the bucket array.+ -> Int8 -- ^ the size of record alignment by power of 2. + -> Int8 -- ^ the maximum number of elements of the free block+ -- pool by power of 2.+ -> [TuningOption] -- ^ tuning options.+ -> IO Bool -- ^ if successful, the return value is True.+optimize hdb bnum apow fpow options = + withForeignPtr (unTCHDB hdb) $ \p ->+ c_tchdboptimize p bnum apow fpow (combineTuningOption options)++-- | Delete all records.+vanish :: HDB -> IO Bool+vanish hdb = withForeignPtr (unTCHDB hdb) c_tchdbvanish++-- | Copy the database file.+copy :: HDB -> String -> IO Bool+copy = copyHelper c_tchdbcopy unTCHDB++-- | Begin the transaction.+tranbegin :: HDB -> IO Bool+tranbegin hdb = withForeignPtr (unTCHDB hdb) c_tchdbtranbegin++-- | Commit the transaction.+trancommit :: HDB -> IO Bool+trancommit hdb = withForeignPtr (unTCHDB hdb) c_tchdbtrancommit++-- | Abort the transaction.+tranabort :: HDB -> IO Bool+tranabort hdb = withForeignPtr (unTCHDB hdb) c_tchdbtranabort++-- | Return the file path of currentry opened database.+path :: HDB -> IO (Maybe String)+path = pathHelper c_tchdbpath unTCHDB++-- | Return the number of records in the database.+rnum :: HDB -> IO Int64+rnum hdb = withForeignPtr (unTCHDB hdb) c_tchdbrnum++-- | Return the size of the database file.+fsiz :: HDB -> IO Int64+fsiz hdb = withForeignPtr (unTCHDB hdb) c_tchdbfsiz
+ Database/TokyoCabinet/HDB/C.hsc view
@@ -0,0 +1,167 @@+{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-}+module Database.TokyoCabinet.HDB.C where++import Foreign.Ptr+import Foreign.C.Types+import Foreign.C.String++import Data.Int+import Data.Word+import Data.Bits++import Database.TokyoCabinet.List.C (LIST)++#include <tchdb.h>++data OpenMode =+ OREADER |+ OWRITER |+ OCREAT |+ OTRUNC |+ ONOLCK |+ OLCKNB |+ OTSYNC+ deriving (Eq, Ord, Show)++openModeToCInt :: OpenMode -> CInt+openModeToCInt OREADER = #const HDBOREADER+openModeToCInt OWRITER = #const HDBOWRITER+openModeToCInt OCREAT = #const HDBOCREAT+openModeToCInt OTRUNC = #const HDBOTRUNC+openModeToCInt ONOLCK = #const HDBONOLCK+openModeToCInt OLCKNB = #const HDBOLCKNB+openModeToCInt OTSYNC = #const HDBOTSYNC++combineOpenMode :: [OpenMode] -> CInt+combineOpenMode = foldr ((.|.) . openModeToCInt) 0++data TuningOption =+ TLARGE |+ TDEFLATE |+ TBZIP |+ TTCBS |+ TEXCODEC+ deriving (Eq, Ord, Show)++tuningOptionToWord8 :: TuningOption -> Word8+tuningOptionToWord8 TLARGE = #const HDBTLARGE+tuningOptionToWord8 TDEFLATE = #const HDBTDEFLATE+tuningOptionToWord8 TBZIP = #const HDBTBZIP+tuningOptionToWord8 TTCBS = #const HDBTTCBS+tuningOptionToWord8 TEXCODEC = #const HDBTEXCODEC++combineTuningOption :: [TuningOption] -> Word8+combineTuningOption = foldr ((.|.) . tuningOptionToWord8) 0++data HDB'++foreign import ccall "&tchdbdel"+ tchdbFinalizer :: FunPtr (Ptr HDB' -> IO ())++foreign import ccall safe "tchdbnew"+ c_tchdbnew :: IO (Ptr HDB')++foreign import ccall safe "tchdbdel"+ c_tchdbdel :: Ptr HDB' -> IO ()++foreign import ccall safe "tchdbecode"+ c_tchdbecode :: Ptr HDB' -> IO CInt++foreign import ccall safe "tchdbtune"+ c_tchdbtune :: Ptr HDB' -> Int64 -> Int8 -> Int8 -> Word8 -> IO Bool++foreign import ccall safe "tchdbsetcache"+ c_tchdbsetcache :: Ptr HDB' -> Int32 -> IO Bool++foreign import ccall safe "tchdbsetxmsiz"+ c_tchdbsetxmsiz :: Ptr HDB' -> Int64 -> IO Bool++foreign import ccall safe "tchdbopen"+ c_tchdbopen :: Ptr HDB' -> CString -> CInt -> IO Bool++foreign import ccall safe "tchdbclose"+ c_tchdbclose :: Ptr HDB' -> IO Bool++foreign import ccall safe "tchdbput"+ c_tchdbput :: Ptr HDB' -> Ptr Word8 -> CInt -> Ptr Word8 -> CInt -> IO Bool++foreign import ccall safe "tchdbput2"+ c_tchdbput2 :: Ptr HDB' -> CString -> CString -> IO Bool++foreign import ccall safe "tchdbputkeep"+ c_tchdbputkeep :: Ptr HDB' -> Ptr Word8 -> CInt -> Ptr Word8 -> CInt -> IO Bool++foreign import ccall safe "tchdbputkeep2"+ c_tchdbputkeep2 :: Ptr HDB' -> CString -> CString -> IO Bool++foreign import ccall safe "tchdbputcat"+ c_tchdbputcat :: Ptr HDB' -> Ptr Word8 -> CInt -> Ptr Word8 -> CInt -> IO Bool++foreign import ccall safe "tchdbputcat2"+ c_tchdbputcat2 :: Ptr HDB' -> CString -> CString -> IO Bool++foreign import ccall safe "tchdbputasync"+ c_tchdbputasync :: Ptr HDB' -> Ptr Word8 -> CInt -> Ptr Word8 -> CInt -> IO Bool++foreign import ccall safe "tchdbout"+ c_tchdbout :: Ptr HDB' -> Ptr Word8 -> CInt -> IO Bool++foreign import ccall safe "tchdbout2"+ c_tchdbout2 :: Ptr HDB' -> CString -> IO Bool++foreign import ccall safe "tchdbget"+ c_tchdbget :: Ptr HDB' -> Ptr Word8 -> CInt -> Ptr CInt -> IO (Ptr Word8)++foreign import ccall safe "tchdbget2"+ c_tchdbget2 :: Ptr HDB' -> CString -> IO CString++foreign import ccall safe "tchdbvsiz"+ c_tchdbvsiz :: Ptr HDB' -> Ptr Word8 -> CInt -> IO CInt++foreign import ccall safe "tchdbiterinit"+ c_tchdbiterinit :: Ptr HDB' -> IO Bool++foreign import ccall safe "tchdbiternext"+ c_tchdbiternext :: Ptr HDB' -> Ptr CInt -> IO (Ptr Word8)++foreign import ccall safe "tchdbiternext2"+ c_tchdbiternext2 :: Ptr HDB' -> IO CString++foreign import ccall safe "tchdbfwmkeys"+ c_tchdbfwmkeys :: Ptr HDB' -> Ptr Word8 -> CInt -> CInt -> IO (Ptr LIST)++foreign import ccall safe "tchdbaddint"+ c_tchdbaddint :: Ptr HDB' -> Ptr Word8 -> CInt -> CInt -> IO CInt++foreign import ccall safe "tchdbadddouble"+ c_tchdbadddouble :: Ptr HDB' -> Ptr Word8 -> CInt -> CDouble -> IO CDouble++foreign import ccall safe "tchdbsync"+ c_tchdbsync :: Ptr HDB' -> IO Bool++foreign import ccall safe "tchdboptimize"+ c_tchdboptimize :: Ptr HDB' -> Int64 -> Int8 -> Int8 -> Word8 -> IO Bool++foreign import ccall safe "tchdbvanish"+ c_tchdbvanish :: Ptr HDB' -> IO Bool++foreign import ccall safe "tchdbcopy"+ c_tchdbcopy :: Ptr HDB' -> CString -> IO Bool++foreign import ccall safe "tchdbtranbegin"+ c_tchdbtranbegin :: Ptr HDB' -> IO Bool++foreign import ccall safe "tchdbtrancommit"+ c_tchdbtrancommit :: Ptr HDB' -> IO Bool++foreign import ccall safe "tchdbtranabort"+ c_tchdbtranabort :: Ptr HDB' -> IO Bool++foreign import ccall safe "tchdbpath"+ c_tchdbpath :: Ptr HDB' -> IO CString++foreign import ccall safe "tchdbrnum"+ c_tchdbrnum :: Ptr HDB' -> IO Int64++foreign import ccall safe "tchdbfsiz"+ c_tchdbfsiz :: Ptr HDB' -> IO Int64
+ Database/TokyoCabinet/Internal.hs view
@@ -0,0 +1,115 @@+module Database.TokyoCabinet.Internal where++import Database.TokyoCabinet.List.C+import Database.TokyoCabinet.Storable++import Foreign.Ptr+import Foreign.ForeignPtr+import Foreign.C.Types+import Foreign.C.String+import Foreign.Storable (peek)+import Foreign.Marshal (alloca)+import Foreign.Marshal.Utils (maybePeek)++import Data.Word++peekTCListAndFree :: (Storable a) => Ptr LIST -> IO [a]+peekTCListAndFree list = do+ vals <- peekTCList' list []+ c_tclistdel list+ return vals+ where+ peekTCList' tclist acc = + alloca $ \sizbuf ->+ do val <- c_tclistpop tclist sizbuf+ siz <- peek sizbuf+ if val == nullPtr+ then return acc+ else do elm <- peekPtrLen (val, siz)+ peekTCList' tclist (elm:acc)++type Lifter ptr tcdb = Ptr ptr -> tcdb+type UnLifter tcdb fptr = tcdb -> ForeignPtr fptr+type Combiner mode c_mode = [mode] -> c_mode+type Caster a b = a -> b+type Checker a = a -> Bool++type FunOpen p c_mode = Ptr p -> CString -> c_mode -> IO Bool+type FunPath p = Ptr p -> IO CString+type FunCopy p = Ptr p -> CString -> IO Bool+type FunPut p = Ptr p -> Ptr Word8 -> CInt -> Ptr Word8 -> CInt -> IO Bool+type FunGet p = Ptr p -> Ptr Word8 -> CInt -> Ptr CInt -> IO (Ptr Word8)+type FunOut p = Ptr p -> Ptr Word8 -> CInt -> IO Bool+type FunAdd p n = Ptr p -> Ptr Word8 -> CInt -> n -> IO n+type FunFwm p = Ptr p -> Ptr Word8 -> CInt -> CInt -> IO (Ptr LIST)+type FunVsiz p = Ptr p -> Ptr Word8 -> CInt -> IO CInt++openHelper :: FunOpen p c_mode -> UnLifter tcdb p+ -> Combiner mode c_mode -> tcdb -> String -> [mode] -> IO Bool+openHelper opener unlifter combiner tcdb name modes =+ withForeignPtr (unlifter tcdb) $ \db ->+ withCString name $ \c_name ->+ opener db c_name (combiner modes)++pathHelper :: FunPath p -> UnLifter tcdb p -> tcdb -> IO (Maybe String)+pathHelper c_path unlifter tcdb =+ withForeignPtr (unlifter tcdb) $ \db ->+ c_path db >>= (maybePeek peekCString)++copyHelper :: FunCopy p -> UnLifter tcdb p -> tcdb -> String -> IO Bool+copyHelper c_copy unlifter tcdb fpath =+ withForeignPtr (unlifter tcdb) $ \db -> withCString fpath (c_copy db)++putHelper :: (Storable a, Storable b) =>+ FunPut p -> UnLifter tcdb p -> tcdb -> a -> b -> IO Bool+putHelper c_put unlifter tcdb key val =+ withForeignPtr (unlifter tcdb) $ \db ->+ withPtrLen key $ \(kbuf, ksize) ->+ withPtrLen val $ \(vbuf, vsize) -> c_put db kbuf ksize vbuf vsize++getHelper :: (Storable a, Storable b) =>+ FunGet p -> UnLifter tcdb p -> tcdb -> a -> IO (Maybe b)+getHelper c_get unlifter tcdb key =+ withForeignPtr (unlifter tcdb) $ \db ->+ withPtrLen key $ \(kbuf, ksiz) ->+ alloca $ \sizbuf -> do+ vbuf <- c_get db kbuf ksiz sizbuf+ flip maybePeek vbuf $ \vp ->+ do siz <- peek sizbuf+ peekPtrLen (vp, siz)++outHelper :: (Storable a) =>+ FunOut p -> UnLifter tcdb p -> tcdb -> a -> IO Bool+outHelper c_out unlifter tcdb key =+ withForeignPtr (unlifter tcdb) $ \db ->+ withPtrLen key $ \(kbuf, ksize) -> c_out db kbuf ksize++addHelper :: (Storable a) =>+ FunAdd p n -> UnLifter tcdb p+ -> Caster hv n -> Caster n hv -> Checker n+ -> tcdb -> a -> hv -> IO (Maybe hv)+addHelper c_add unlifter cast_in cast_out check tcdb key num =+ withForeignPtr (unlifter tcdb) $ \db ->+ withPtrLen key $ \(kbuf, ksiz) -> do+ sumval <- c_add db kbuf ksiz (cast_in num)+ return $ if check sumval+ then Nothing+ else Just $ cast_out sumval+++fwmHelper :: (Storable a, Storable b) =>+ FunFwm p -> UnLifter tcdb p -> tcdb -> a -> Int -> IO [b]+fwmHelper c_fwm unlifter tcdb key maxn = + withForeignPtr (unlifter tcdb) $ \db ->+ withPtrLen key $ \(kbuf, ksiz) ->+ c_fwm db kbuf ksiz (fromIntegral maxn) >>= peekTCListAndFree++vsizHelper :: (Storable a) =>+ FunVsiz p -> UnLifter tcdb p -> tcdb -> a -> IO (Maybe Int)+vsizHelper c_vsiz unlifter tcdb key =+ withForeignPtr (unlifter tcdb) $ \db ->+ withPtrLen key $ \(kbuf, ksiz) -> do+ vsize <- c_vsiz db kbuf ksiz+ return $ if vsize == -1+ then Nothing+ else Just (fromIntegral vsize)
+ Database/TokyoCabinet/List.hs view
@@ -0,0 +1,159 @@+module Database.TokyoCabinet.List+ (+ new+ , new2+ , copy+ , delete+ , len+ , get+ , push+ , pop+ , unshift+ , shift+ , insert+ , remove+ , over+ , sort+ , lsearch+ , bsearch+ , clear+ , dump+ , load+ , TCList+ ) where++import Foreign.Ptr+import Foreign.ForeignPtr+import Foreign.Storable (peek)+import Foreign.Marshal (alloca, free, mallocBytes)+import Foreign.Marshal.Utils (maybePeek, copyBytes)++import Database.TokyoCabinet.List.C+import qualified Database.TokyoCabinet.Storable as S++import Data.ByteString.Unsafe+import qualified Data.ByteString as B++data TCList = TCList { unTCList :: !(ForeignPtr LIST) }++new :: IO TCList+new = c_tclistnew >>= newForeignPtr tclistFinalizer >>= return . TCList++new2 :: Int -> IO TCList+new2 n = do+ l <- c_tclistnew2 (fromIntegral n)+ p <- newForeignPtr tclistFinalizer l+ return $ TCList p++copy :: TCList -> IO TCList+copy tcls =+ withForeignPtr (unTCList tcls) $ \p -> do+ l <- c_tclistdup p+ TCList `fmap` newForeignPtr tclistFinalizer l++delete :: TCList -> IO ()+delete tcls = finalizeForeignPtr (unTCList tcls)++len :: TCList -> IO Int+len tcls =+ withForeignPtr (unTCList tcls) $ \p -> do+ n <- c_tclistnum p+ return $ fromIntegral n++get :: (S.Storable a) => TCList -> Int -> IO (Maybe a)+get tcls index =+ withForeignPtr (unTCList tcls) $ \p ->+ alloca $ \sizbuf -> do+ vbuf <- c_tclistval p (fromIntegral index) sizbuf+ flip maybePeek vbuf $ \vp ->+ do siz <- peek sizbuf+ buf <- mallocBytes (fromIntegral siz)+ copyBytes buf vp (fromIntegral siz)+ S.peekPtrLen (buf, fromIntegral siz)++push :: (S.Storable a) => TCList -> a -> IO ()+push tcls val =+ withForeignPtr (unTCList tcls) $ \p ->+ S.withPtrLen val $ \(vbuf, vsiz) ->+ c_tclistpush p (castPtr vbuf) (fromIntegral vsiz)++pop :: (S.Storable a) => TCList -> IO (Maybe a)+pop tcls =+ withForeignPtr (unTCList tcls) $ \p ->+ alloca $ \sizbuf -> do+ vbuf <- c_tclistpop p sizbuf+ flip maybePeek vbuf $ \vp ->+ do siz <- peek sizbuf+ S.peekPtrLen (vp, fromIntegral siz)++unshift :: (S.Storable a) => TCList -> a -> IO ()+unshift tcls val =+ withForeignPtr (unTCList tcls) $ \p ->+ S.withPtrLen val $ \(vbuf, vsiz) ->+ c_tclistunshift p (castPtr vbuf) (fromIntegral vsiz)++shift :: (S.Storable a) => TCList -> IO (Maybe a)+shift tcls =+ withForeignPtr (unTCList tcls) $ \p ->+ alloca $ \sizbuf -> do+ vbuf <- c_tclistshift p sizbuf+ flip maybePeek vbuf $ \vp ->+ do siz <- peek sizbuf+ S.peekPtrLen (vp, fromIntegral siz)++insert :: (S.Storable a) => TCList -> Int -> a -> IO ()+insert tcls index val =+ withForeignPtr (unTCList tcls) $ \p ->+ S.withPtrLen val $ \(vbuf, vsiz) ->+ c_tclistinsert p (fromIntegral index) (castPtr vbuf)+ (fromIntegral vsiz)++remove :: (S.Storable a) => TCList -> Int -> IO (Maybe a)+remove tcls index =+ withForeignPtr (unTCList tcls) $ \p ->+ alloca $ \sizbuf -> do+ vbuf <- c_tclistremove p (fromIntegral index) sizbuf+ flip maybePeek vbuf $ \vp ->+ do siz <- peek sizbuf+ S.peekPtrLen (vp, fromIntegral siz)++over :: (S.Storable a) => TCList -> Int -> a -> IO ()+over tcls index val =+ withForeignPtr (unTCList tcls) $ \p ->+ S.withPtrLen val $ \(vbuf, vsiz) ->+ c_tclistover p (fromIntegral index) (castPtr vbuf)+ (fromIntegral vsiz)++sort :: TCList -> IO ()+sort tcls = withForeignPtr (unTCList tcls) c_tclistsort++lsearch :: (S.Storable a) => TCList -> a -> IO Int+lsearch tcls key =+ withForeignPtr (unTCList tcls) $ \p ->+ S.withPtrLen key $ \(kbuf, ksiz) ->+ fmap fromIntegral $+ c_tclistlsearch p (castPtr kbuf) (fromIntegral ksiz)++bsearch :: (S.Storable a) => TCList -> a -> IO Int+bsearch tcls key =+ withForeignPtr (unTCList tcls) $ \p ->+ S.withPtrLen key $ \(kbuf, ksiz) ->+ fmap fromIntegral $+ c_tclistbsearch p (castPtr kbuf) (fromIntegral ksiz)++clear :: TCList -> IO ()+clear tcls = withForeignPtr (unTCList tcls) c_tclistclear++dump :: TCList -> IO B.ByteString+dump tcls =+ withForeignPtr (unTCList tcls) $ \p ->+ alloca $ \sizbuf -> do+ c_str <- c_tclistdump p sizbuf+ size <- fromIntegral `fmap` peek sizbuf+ unsafePackCStringFinalizer (castPtr c_str) size (free c_str)++load :: B.ByteString -> IO TCList+load bytes =+ unsafeUseAsCStringLen bytes $ \(buf, siz) -> do+ tclis <- c_tclistload (castPtr buf) (fromIntegral siz)+ TCList `fmap` newForeignPtr tclistFinalizer tclis
+ Database/TokyoCabinet/List/C.hs view
@@ -0,0 +1,95 @@+{-# INCLUDE <tcutil.h> #-}+{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-}+module Database.TokyoCabinet.List.C where++import Data.Word++import Foreign.Ptr+import Foreign.C.Types+import Foreign.C.String++data LIST++foreign import ccall safe "tclistnew"+ c_tclistnew :: IO (Ptr LIST)++foreign import ccall safe "tclistnew2"+ c_tclistnew2 :: CInt -> IO (Ptr LIST)++foreign import ccall safe "tclistdup"+ c_tclistdup :: Ptr LIST -> IO (Ptr LIST)++foreign import ccall safe "tclistdel"+ c_tclistdel :: Ptr LIST -> IO ()++foreign import ccall "&tclistdel"+ tclistFinalizer :: FunPtr (Ptr LIST -> IO ())++foreign import ccall safe "tclistnum"+ c_tclistnum :: Ptr LIST -> IO CInt++foreign import ccall safe "tclistval"+ c_tclistval :: Ptr LIST -> CInt -> Ptr CInt -> IO (Ptr Word8)++foreign import ccall safe "tclistval2"+ c_tclistval2 :: Ptr LIST -> CInt -> IO CString++foreign import ccall safe "tclistpush"+ c_tclistpush :: Ptr LIST -> Ptr Word8 -> CInt -> IO ()++foreign import ccall safe "tclistpush2"+ c_tclistpush2 :: Ptr LIST -> CString -> IO ()++foreign import ccall safe "tclistpop"+ c_tclistpop :: Ptr LIST -> Ptr CInt -> IO (Ptr Word8)++foreign import ccall safe "tclistpop2"+ c_tclistpop2 :: Ptr LIST -> IO CString++foreign import ccall safe "tclistunshift"+ c_tclistunshift :: Ptr LIST -> Ptr Word8 -> CInt -> IO ()++foreign import ccall safe "tclistunshift2"+ c_tclistunshift2 :: Ptr LIST -> Ptr Word8 -> IO ()++foreign import ccall safe "tclistshift"+ c_tclistshift :: Ptr LIST -> Ptr CInt -> IO (Ptr Word8)++foreign import ccall safe "tclistshift2"+ c_tclistshift2 :: Ptr LIST -> IO CString++foreign import ccall safe "tclistinsert"+ c_tclistinsert :: Ptr LIST -> CInt -> Ptr Word8 -> CInt -> IO ()++foreign import ccall safe "tclistinsert2"+ c_tclistinsert2 :: Ptr LIST -> CInt -> Ptr Word8 -> IO ()++foreign import ccall safe "tclistremove"+ c_tclistremove :: Ptr LIST -> CInt -> Ptr CInt -> IO (Ptr Word8)++foreign import ccall safe "tclistremove2"+ c_tclistremove2 :: Ptr LIST -> CInt -> IO CString++foreign import ccall safe "tclistover"+ c_tclistover :: Ptr LIST -> CInt -> Ptr Word8 -> CInt -> IO ()++foreign import ccall safe "tclistover2"+ c_tclistover2 :: Ptr LIST -> CInt -> CString -> IO ()++foreign import ccall safe "tclistsort"+ c_tclistsort :: Ptr LIST -> IO ()++foreign import ccall safe "tclistlsearch"+ c_tclistlsearch :: Ptr LIST -> Ptr Word8 -> CInt -> IO CInt++foreign import ccall safe "tclistbsearch"+ c_tclistbsearch :: Ptr LIST -> Ptr Word8 -> CInt -> IO CInt++foreign import ccall safe "tclistclear"+ c_tclistclear :: Ptr LIST -> IO ()++foreign import ccall safe "tclistdump"+ c_tclistdump :: Ptr LIST -> Ptr CInt -> IO (Ptr Word8)++foreign import ccall safe "tclistload"+ c_tclistload :: Ptr Word8 -> CInt -> IO (Ptr LIST)
+ Database/TokyoCabinet/Storable.hs view
@@ -0,0 +1,187 @@+module Database.TokyoCabinet.Storable where++import Data.Int+import Data.Char+import Data.Word++import Foreign.Ptr+import Foreign.C.Types+import Foreign.C.String+import Foreign.Marshal (peekArray, free)+import Foreign.Marshal.Array (withArray)+import Data.ByteString.Unsafe++import qualified Foreign.Storable as F+import qualified Data.ByteString.Char8 as C+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Lazy.Char8 as LC+import qualified Foreign.Marshal.Utils as U++type PtrLen = (Ptr Word8, CInt)++liftPL :: (a -> (CStringLen -> IO b) -> IO b) -> a -> (PtrLen -> IO b) -> IO b+liftPL f val action =+ f val $ \(buf, siz) ->+ action (castPtr buf, fromIntegral siz)++class (Show a, Read a) => Storable a where+ withPtrLen :: a -> (PtrLen -> IO b) -> IO b+ withPtrLenL :: [a] -> (PtrLen -> IO b) -> IO b++ peekPtrLenL :: PtrLen -> a -> IO [a]+ peekPtrLen :: PtrLen -> IO a++ toInt64 :: a -> Int64+ toInt64L :: [a] -> Int64++ fromString :: String -> a+ fromStringL :: String -> [a]++ toInt64 = read . show+ toInt64L = read . concatMap show++ fromString = read+ fromStringL = (:[]) . fromString++ withPtrLenL = undefined+ peekPtrLenL = undefined++instance Storable C.ByteString where+ withPtrLen = liftPL unsafeUseAsCStringLen+ peekPtrLen (p, len) =+ unsafePackCStringFinalizer p (fromIntegral len) (free p)+ toInt64 = read . C.unpack+ fromString = C.pack++instance Storable L.ByteString where+ withPtrLen = liftPL unsafeUseAsCStringLen . C.concat . L.toChunks+ peekPtrLen (p, len) = do xs <- peekArray (fromIntegral len) p+ free p+ return $ L.pack xs+ toInt64 = read . LC.unpack+ fromString = LC.pack++withPtrLenForFStorable :: (F.Storable a) => a -> (PtrLen -> IO b) -> IO b+withPtrLenForFStorable n f =+ U.with n $ \p -> f (castPtr p, fromIntegral $ F.sizeOf n)++peekPtrLenForFStorable :: (F.Storable a) => PtrLen -> IO a+peekPtrLenForFStorable (p, _) = do val <- F.peek (castPtr p)+ free p+ return val++withPtrLenLForFStorable :: (F.Storable a) => [a] -> (PtrLen -> IO b) -> IO b+withPtrLenLForFStorable xs f =+ withArray xs $ \p ->+ f (castPtr p, fromIntegral $ (F.sizeOf $ head xs) * length xs)++peekPtrLenLForFStorable :: (F.Storable a) => PtrLen -> a -> IO [a]+peekPtrLenLForFStorable (p, size) x = do+ peekArray (fromIntegral size `div` (F.sizeOf x)) (castPtr p)++instance Storable Char where+ withPtrLen = withPtrLenForFStorable+ peekPtrLen = peekPtrLenForFStorable+ withPtrLenL = liftPL withCStringLen+ peekPtrLenL (buf, siz) _ =+ do val <- peekCStringLen (castPtr buf, fromIntegral siz)+ free buf+ return val++ toInt64 c | isDigit c = fromIntegral $ digitToInt c+ toInt64 c | otherwise = fromIntegral $ ord c++ toInt64L cs = read cs++ fromString str = read ('\'':str ++ "'")+ fromStringL = id++instance Storable CInt where+ withPtrLen = withPtrLenForFStorable+ peekPtrLen = peekPtrLenForFStorable+ withPtrLenL = withPtrLenLForFStorable+ peekPtrLenL = peekPtrLenLForFStorable++instance Storable Int where+ withPtrLen = withPtrLenForFStorable+ peekPtrLen = peekPtrLenForFStorable+ withPtrLenL = withPtrLenLForFStorable+ peekPtrLenL = peekPtrLenLForFStorable++instance Storable CDouble where+ withPtrLen = withPtrLenForFStorable+ peekPtrLen = peekPtrLenForFStorable+ withPtrLenL = withPtrLenLForFStorable+ peekPtrLenL = peekPtrLenLForFStorable++instance Storable Double where+ withPtrLen = withPtrLenForFStorable+ peekPtrLen = peekPtrLenForFStorable+ withPtrLenL = withPtrLenLForFStorable+ peekPtrLenL = peekPtrLenLForFStorable++instance Storable CFloat where+ withPtrLen = withPtrLenForFStorable+ peekPtrLen = peekPtrLenForFStorable+ withPtrLenL = withPtrLenLForFStorable+ peekPtrLenL = peekPtrLenLForFStorable++instance Storable Float where+ withPtrLen = withPtrLenForFStorable+ peekPtrLen = peekPtrLenForFStorable+ withPtrLenL = withPtrLenLForFStorable+ peekPtrLenL = peekPtrLenLForFStorable++instance Storable Int8 where+ withPtrLen = withPtrLenForFStorable+ peekPtrLen = peekPtrLenForFStorable+ withPtrLenL = withPtrLenLForFStorable+ peekPtrLenL = peekPtrLenLForFStorable++instance Storable Int16 where+ withPtrLen = withPtrLenForFStorable+ peekPtrLen = peekPtrLenForFStorable+ withPtrLenL = withPtrLenLForFStorable+ peekPtrLenL = peekPtrLenLForFStorable++instance Storable Int32 where+ withPtrLen = withPtrLenForFStorable+ peekPtrLen = peekPtrLenForFStorable+ withPtrLenL = withPtrLenLForFStorable+ peekPtrLenL = peekPtrLenLForFStorable++instance Storable Int64 where+ withPtrLen = withPtrLenForFStorable+ peekPtrLen = peekPtrLenForFStorable+ withPtrLenL = withPtrLenLForFStorable+ peekPtrLenL = peekPtrLenLForFStorable++instance Storable Word8 where+ withPtrLen = withPtrLenForFStorable+ peekPtrLen = peekPtrLenForFStorable+ withPtrLenL = withPtrLenLForFStorable+ peekPtrLenL = peekPtrLenLForFStorable++instance Storable Word16 where+ withPtrLen = withPtrLenForFStorable+ peekPtrLen = peekPtrLenForFStorable+ withPtrLenL = withPtrLenLForFStorable+ peekPtrLenL = peekPtrLenLForFStorable++instance Storable Word32 where+ withPtrLen = withPtrLenForFStorable+ peekPtrLen = peekPtrLenForFStorable+ withPtrLenL = withPtrLenLForFStorable+ peekPtrLenL = peekPtrLenLForFStorable++instance Storable Word64 where+ withPtrLen = withPtrLenForFStorable+ peekPtrLen = peekPtrLenForFStorable+ withPtrLenL = withPtrLenLForFStorable+ peekPtrLenL = peekPtrLenLForFStorable++instance (F.Storable a, Storable a) => Storable [a] where+ withPtrLen = withPtrLenL+ peekPtrLen xs = peekPtrLenL xs undefined+ toInt64 = toInt64L+ fromString = fromStringL
+ LICENSE view
@@ -0,0 +1,29 @@+Copyright (c) 2009, Tom Tsuruhara+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. ++ * The names of contributors may not 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,14 @@+import Distribution.Simple+import Distribution.PackageDescription+import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..))++import System.Cmd (system)+import System.FilePath++main = defaultMainWithHooks $ simpleUserHooks { runTests = myTestRunner }++myTestRunner :: Args -> Bool -> PackageDescription -> LocalBuildInfo -> IO ()+myTestRunner _ _ pkg_descr lbi = mapM_ (system . path) $ executables pkg_descr+ where+ path exec = let name = (dropExtension . exeName) exec+ in (buildDir lbi) </> name </> name
+ tokyocabinet-haskell.cabal view
@@ -0,0 +1,49 @@+Name: tokyocabinet-haskell+Version: 0.0.1+Cabal-Version: >= 1.6.0.2+License: BSD3+License-File: LICENSE+Author: Tom Tsuruhara+Maintainer: tom.lpsd@gmail.com+Stability: experimental+Category: Database+Synopsis: Haskell binding of Tokyo Cabinet+Description:+ Bindings to Tokyo Cabinet library.+ Tokyo Cabinet is a modern implementation of DBM.+ For more about Tokyo Cabinet, see <http://tokyocabinet.sourceforge.net/index.html>.++ This package provides `tokyocabinet.idl compliant' naive interfaces. + See, <http://tokyocabinet.sourceforge.net/tokyocabinet.idl>.+ + Map interface and TDB have not supported yet.++Tested-With: GHC+Build-Type: Simple++Library+ Build-Depends: base >= 4.0, bytestring >= 0.9, mtl >= 1.1+ Exposed-modules:+ Database.TokyoCabinet,+ Database.TokyoCabinet.HDB+ Database.TokyoCabinet.HDB.C+ Database.TokyoCabinet.BDB+ Database.TokyoCabinet.BDB.C+ Database.TokyoCabinet.BDB.Cursor+ Database.TokyoCabinet.BDB.Cursor.C+ Database.TokyoCabinet.FDB+ Database.TokyoCabinet.FDB.C+ Database.TokyoCabinet.FDB.Key+ Database.TokyoCabinet.Error+ Database.TokyoCabinet.List+ Database.TokyoCabinet.List.C+ Database.TokyoCabinet.Storable+ other-modules:+ Database.TokyoCabinet.Internal+ Extensions: CPP, ForeignFunctionInterface,+ EmptyDataDecls, TypeSynonymInstances,+ GeneralizedNewtypeDeriving+ Extra-libraries: tokyocabinet+ Extra-lib-dirs: /usr/local/lib+ Include-dirs: /usr/local/include+ GHC-Options: -Wall