packages feed

tokyocabinet-haskell 0.0.3 → 0.0.4

raw patch · 20 files changed

+1493/−18 lines, 20 files

Files

Database/TokyoCabinet.hs view
@@ -8,6 +8,7 @@     , TCDB(..)     , H.HDB     , F.FDB+    , T.TDB     , BDB     -- * Error Code     , E.ECODE(..)@@ -21,6 +22,7 @@ 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.TDB as T import qualified Database.TokyoCabinet.BDB as B import qualified Database.TokyoCabinet.BDB.Cursor as C import qualified Database.TokyoCabinet.Error as E@@ -367,3 +369,36 @@     size              = lift   F.fsiz     ecode             = lift   F.ecode     defaultExtension  = const ".tcf"++openModeToTOpenMode :: OpenMode -> T.OpenMode+openModeToTOpenMode OREADER = T.OREADER+openModeToTOpenMode OWRITER = T.OWRITER+openModeToTOpenMode OCREAT  = T.OCREAT+openModeToTOpenMode OTRUNC  = T.OTRUNC+openModeToTOpenMode ONOLCK  = T.ONOLCK+openModeToTOpenMode OLCKNB  = T.OLCKNB++instance TCDB T.TDB where+    new               = TCM   T.new+    delete            = lift  T.delete+    open tc name mode = TCM $ T.open tc name (map openModeToTOpenMode mode)+    close             = lift  T.close+    put               = lift3 T.put'+    putkeep           = lift3 T.putkeep'+    putcat            = lift3 T.putcat'+    get               = lift2 T.get'+    out               = lift2 T.out+    vsiz              = lift2 T.vsiz+    iterinit          = lift  T.iterinit+    iternext          = lift  T.iternext+    fwmkeys           = lift3 T.fwmkeys+    addint            = lift3 T.addint+    adddouble         = lift3 T.adddouble+    sync              = lift  T.sync+    vanish            = lift  T.vanish+    copy              = lift2 T.copy+    path              = lift  T.path+    rnum              = lift  T.rnum+    size              = lift  T.fsiz+    ecode             = lift  T.ecode+    defaultExtension  = const ".tct"
+ Database/TokyoCabinet/Associative.hs view
@@ -0,0 +1,40 @@+module Database.TokyoCabinet.Associative where++import Data.Maybe++import Foreign.Ptr+import Foreign.ForeignPtr++import Database.TokyoCabinet.Map+import Database.TokyoCabinet.Map.C+import Database.TokyoCabinet.Storable++class Associative a where+    withMap  :: (Storable k, Storable v) => a k v -> (Ptr MAP -> IO b) -> IO b+    peekMap' :: (Storable k, Storable v) => Ptr MAP -> IO (a k v)++newtype AssocList k v =+    AssocList { unAssocList :: [(k, v)] } deriving (Eq, Ord, Show)++instance Associative AssocList where+    withMap (AssocList alist) action =+        do m <- new+           mapM_ (uncurry $ put m) alist+           result <- withForeignPtr (unMap m) action+           delete m+           return result+    peekMap' ptr | ptr == nullPtr = return (AssocList [])+    peekMap' ptr = do m <- Map `fmap` newForeignPtr tcmapFinalizer ptr+                      iterinit m+                      AssocList `fmap` accumulate m []+        where+          accumulate m acc = do val <- iternext m+                                case val of+                                  Just k -> do (Just v) <- get m k+                                               ((k, v):) `fmap` accumulate m acc+                                  _ -> return acc++instance Associative Map where+    withMap m action = withForeignPtr (unMap m) action+    peekMap' ptr | ptr == nullPtr = new+    peekMap' ptr = Map `fmap` newForeignPtr tcmapFinalizer ptr
Database/TokyoCabinet/HDB.hs view
@@ -43,10 +43,8 @@     )     where -import Foreign.Storable (peek)+ import Foreign.ForeignPtr-import Foreign.Marshal (alloca)-import Foreign.Marshal.Utils (maybePeek)  import Data.Int import Data.Word@@ -187,13 +185,7 @@  -- | Return the next key of the iterator of a HDB object. iternext :: (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-                   peekPtrLen (vp, siz)+iternext = iternextHelper c_tchdbiternext unTCHDB  -- | Return list of forward matched keys. fwmkeys :: (Storable k1, Storable k2, Sequence q) =>
Database/TokyoCabinet/Internal.hs view
@@ -9,7 +9,7 @@ import Foreign.C.Types import Foreign.C.String import Foreign.Storable (peek)-import Foreign.Marshal (alloca)+import Foreign.Marshal (alloca, copyBytes, mallocBytes) import Foreign.Marshal.Utils (maybePeek)  import Data.Word@@ -23,12 +23,13 @@ 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 FunPut  p r = Ptr p -> Ptr Word8 -> CInt -> Ptr Word8 -> CInt -> IO r 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+type FunIterNext p = Ptr p -> Ptr CInt -> IO (Ptr Word8)  openHelper :: FunOpen p c_mode -> UnLifter tcdb p            -> Combiner mode c_mode -> tcdb -> String -> [mode] -> IO Bool@@ -47,7 +48,7 @@     withForeignPtr (unlifter tcdb) $ \db -> withCString fpath (c_copy db)  putHelper :: (Storable a, Storable b) =>-             FunPut p -> UnLifter tcdb p -> tcdb -> a -> b -> IO Bool+             FunPut p r -> UnLifter tcdb p -> tcdb -> a -> b -> IO r putHelper c_put unlifter tcdb key val =     withForeignPtr (unlifter tcdb) $ \db ->         withPtrLen key $ \(kbuf, ksize) ->@@ -64,6 +65,19 @@                   do siz <- peek sizbuf                      peekPtrLen (vp, siz) +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+                     buf <- mallocBytes (fromIntegral siz)+                     copyBytes buf vp (fromIntegral siz)+                     peekPtrLen (buf, siz)+ outHelper :: (Storable a) =>              FunOut p -> UnLifter tcdb p -> tcdb -> a -> IO Bool outHelper c_out unlifter tcdb key =@@ -99,3 +113,13 @@           return $ if vsize == -1                      then Nothing                      else Just (fromIntegral vsize)++iternextHelper :: (Storable k) =>+                  FunIterNext p -> UnLifter tcdb p -> tcdb -> IO (Maybe k)+iternextHelper c_iternext unlifter tcdb =+    withForeignPtr (unlifter tcdb) $ \p ->+        alloca $ \sizbuf -> do+            vbuf <- c_iternext p sizbuf+            flip maybePeek vbuf $ \vp ->+                do siz <- peek sizbuf+                   peekPtrLen (vp, siz)
+ Database/TokyoCabinet/Map.hs view
@@ -0,0 +1,134 @@+module Database.TokyoCabinet.Map+    (+      new+    , new2+    , dup+    , delete+    , put+    , putkeep+    , putcat+    , out+    , get+    , move+    , iterinit+    , iternext+    , rnum+    , msiz+    , keys+    , vals+    , addint+    , adddouble+    , clear+    , cutfront+    , dump+    , load+    , Map+    ) where++import Database.TokyoCabinet.Map.C+import Database.TokyoCabinet.Storable+import Database.TokyoCabinet.Sequence+import Database.TokyoCabinet.Internal+import Database.TokyoCabinet.Error (cINT_MIN)++import Data.Word++import Foreign.Ptr+import Foreign.ForeignPtr+import Foreign.Storable (peek)+import Foreign.Marshal (alloca, mallocBytes, free)+import Foreign.Marshal.Utils (maybePeek, copyBytes)++import Data.ByteString (ByteString)+import Data.ByteString.Unsafe+    (+      unsafeUseAsCStringLen+    , unsafePackCStringFinalizer+    )++new :: IO (Map k v)+new = Map `fmap` (c_tcmapnew >>= newForeignPtr tcmapFinalizer)++new2 :: Word32 -> IO (Map k v)+new2 num = Map `fmap` (c_tcmapnew2 num >>= newForeignPtr tcmapFinalizer)++dup :: Map k v -> IO (Map k v)+dup m =+    withForeignPtr (unMap m) $ \m' ->+        Map `fmap` (c_tcmapdup m' >>= newForeignPtr tcmapFinalizer)++delete :: Map k v -> IO ()+delete m = finalizeForeignPtr (unMap m)++put :: (Storable k, Storable v) => Map k v -> k -> v -> IO ()+put = putHelper c_tcmapput unMap++putkeep :: (Storable k, Storable v) => Map k v -> k -> v -> IO Bool+putkeep = putHelper c_tcmapputkeep unMap++putcat :: (Storable k, Storable v) => Map k v -> k -> v -> IO ()+putcat = putHelper c_tcmapputcat unMap++out :: (Storable k) => Map k v -> k -> IO Bool+out = outHelper c_tcmapout unMap++get :: (Storable k, Storable v) => Map k v -> k -> IO (Maybe v)+get = getHelper' c_tcmapget unMap++move :: (Storable k) => Map k v -> k -> Bool -> IO Bool+move m key hd =+    withForeignPtr (unMap m) $ \m' ->+        withPtrLen key $ \(kbuf, ksiz) ->+            c_tcmapmove m' kbuf ksiz hd++iterinit :: Map k v -> IO ()+iterinit m = withForeignPtr (unMap m) c_tcmapiterinit++iternext :: (Storable k) => Map k v -> IO (Maybe k)+iternext m =+    withForeignPtr (unMap m) $ \p ->+        alloca $ \sizbuf -> do+            vbuf <- c_tcmapiternext p sizbuf+            flip maybePeek vbuf $ \vp ->+                do siz <- peek sizbuf+                   buf <- mallocBytes (fromIntegral siz)+                   copyBytes buf vp (fromIntegral siz)+                   peekPtrLen (buf, siz)++rnum :: Map k v -> IO Word64+rnum m = withForeignPtr (unMap m) c_tcmaprnum++msiz :: Map k v -> IO Word64+msiz m = withForeignPtr (unMap m) c_tcmapmsiz++keys :: (Storable k) => Map k v -> IO [k]+keys m = withForeignPtr (unMap m) $ (>>= peekList') . c_tcmapkeys++vals :: (Storable v) => Map k v -> IO [v]+vals m = withForeignPtr (unMap m) $ (>>= peekList') . c_tcmapvals++addint :: (Storable k) => Map k v -> k -> Int -> IO (Maybe Int)+addint = addHelper c_tcmapaddint unMap fromIntegral fromIntegral (== cINT_MIN)++adddouble :: (Storable k) => Map k v -> k -> Double -> IO (Maybe Double)+adddouble = addHelper c_tcmapadddouble unMap realToFrac realToFrac isNaN++clear :: Map k v -> IO ()+clear m = withForeignPtr (unMap m) c_tcmapclear++cutfront :: Map k v -> Int -> IO ()+cutfront m num = withForeignPtr (unMap m) $ flip c_tcmapcutfront (fromIntegral num)++dump :: Map k v -> IO ByteString+dump m =+    withForeignPtr (unMap m) $ \m' ->+        alloca $ \sizbuf -> do+            buf <- c_tcmapdump m' sizbuf+            size <- fromIntegral `fmap` peek sizbuf+            unsafePackCStringFinalizer (castPtr buf) size (free buf)++load :: ByteString -> IO (Map k v)+load bytes =+    unsafeUseAsCStringLen bytes $ \(buf, siz) -> do+      m <- c_tcmapload (castPtr buf) (fromIntegral siz)+      Map `fmap` newForeignPtr tcmapFinalizer m
+ Database/TokyoCabinet/Map/C.hs view
@@ -0,0 +1,106 @@+{-# INCLUDE <tcutil.h> #-}+{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-}+module Database.TokyoCabinet.Map.C where++import Data.Word++import Foreign.Ptr+import Foreign.C.Types+import Foreign.C.String+import Foreign.ForeignPtr++import Database.TokyoCabinet.List.C++data Map k v = Map { unMap :: !(ForeignPtr MAP) }++data MAP++foreign import ccall safe "tcmapnew"+  c_tcmapnew :: IO (Ptr MAP)++foreign import ccall safe "tcmapnew2"+  c_tcmapnew2 :: Word32 -> IO (Ptr MAP)++foreign import ccall safe "tcmapdup"+  c_tcmapdup :: Ptr MAP -> IO (Ptr MAP)++foreign import ccall safe "tcmapdel"+  c_tcmapdel :: Ptr MAP -> IO ()++foreign import ccall safe "&tcmapdel"+  tcmapFinalizer :: FunPtr (Ptr MAP -> IO ())++foreign import ccall safe "tcmapput"+  c_tcmapput :: Ptr MAP -> Ptr Word8 -> CInt -> Ptr Word8 -> CInt -> IO ()++foreign import ccall safe "tcmapput2"+  c_tcmapput2 :: Ptr MAP -> CString -> CString -> IO ()++foreign import ccall safe "tcmapputkeep"+  c_tcmapputkeep :: Ptr MAP -> Ptr Word8 -> CInt -> Ptr Word8 -> CInt -> IO Bool++foreign import ccall safe "tcmapputkeep2"+  c_tcmapputkeep2 :: Ptr MAP -> CString -> CString -> IO Bool++foreign import ccall safe "tcmapputcat"+  c_tcmapputcat :: Ptr MAP -> Ptr Word8 -> CInt -> Ptr Word8 -> CInt -> IO ()++foreign import ccall safe "tcmapputcat2"+  c_tcmapputcat2 :: Ptr MAP -> CString -> CString -> IO ()++foreign import ccall safe "tcmapout"+  c_tcmapout :: Ptr MAP -> Ptr Word8 -> CInt -> IO Bool++foreign import ccall safe "tcmapout2"+  c_tcmapout2 :: Ptr MAP -> CString -> IO Bool++foreign import ccall safe "tcmapget"+  c_tcmapget :: Ptr MAP -> Ptr Word8 -> CInt -> Ptr CInt -> IO (Ptr Word8)++foreign import ccall safe "tcmapget2"+  c_tcmapget2 :: Ptr MAP -> CString -> IO CString++foreign import ccall safe "tcmapmove"+  c_tcmapmove :: Ptr MAP -> Ptr Word8 -> CInt -> Bool -> IO Bool++foreign import ccall safe "tcmapmove2"+  c_tcmapmove2 :: Ptr MAP -> CString -> Bool -> IO Bool++foreign import ccall safe "tcmapiterinit"+  c_tcmapiterinit :: Ptr MAP -> IO ()++foreign import ccall safe "tcmapiternext"+  c_tcmapiternext :: Ptr MAP -> Ptr CInt -> IO (Ptr Word8)++foreign import ccall safe "tcmapiternext2"+  c_tcmapiternext2 :: Ptr MAP -> IO CString++foreign import ccall safe "tcmaprnum"+  c_tcmaprnum :: Ptr MAP -> IO Word64++foreign import ccall safe "tcmapmsiz"+  c_tcmapmsiz :: Ptr MAP -> IO Word64++foreign import ccall safe "tcmapkeys"+  c_tcmapkeys :: Ptr MAP -> IO (Ptr LIST)++foreign import ccall safe "tcmapvals"+  c_tcmapvals :: Ptr MAP -> IO (Ptr LIST)++foreign import ccall safe "tcmapaddint"+  c_tcmapaddint :: Ptr MAP -> Ptr Word8 -> CInt -> CInt -> IO CInt++foreign import ccall safe "tcmapadddouble"+  c_tcmapadddouble :: Ptr MAP -> Ptr Word8 -> CInt -> CDouble -> IO CDouble++foreign import ccall safe "tcmapclear"+  c_tcmapclear :: Ptr MAP -> IO ()++foreign import ccall safe "tcmapcutfront"+  c_tcmapcutfront :: Ptr MAP -> CInt -> IO ()++foreign import ccall safe "tcmapdump"+  c_tcmapdump :: Ptr MAP -> Ptr CInt -> IO (Ptr Word8)++foreign import ccall safe "tcmapload"+  c_tcmapload :: Ptr Word8 -> CInt -> IO (Ptr MAP)
+ Database/TokyoCabinet/TDB.hs view
@@ -0,0 +1,306 @@+-- | Interface to the table database. See also,+-- <http://tokyocabinet.sourceforge.net/spex-en.html#tctdbapi> for details+module Database.TokyoCabinet.TDB+    (+    -- $doc+      TDB+    , ECODE(..)+    , OpenMode(..)+    , TuningOption(..)+    , IndexType(..)+    , AssocList(..)+    , new+    , delete+    , ecode+    , errmsg+    , tune+    , setcache+    , setxmsiz+    , open+    , close+    , put+    , put'+    , putkeep+    , putkeep'+    , putcat+    , putcat'+    , out+    , get+    , get'+    , vsiz+    , iterinit+    , iternext+    , fwmkeys+    , addint+    , adddouble+    , sync+    , optimize+    , vanish+    , copy+    , tranbegin+    , trancommit+    , tranabort+    , path+    , rnum+    , fsiz+    , setindex+    , genuid+    ) where++import Database.TokyoCabinet.Map.C+import Database.TokyoCabinet.TDB.C+import Database.TokyoCabinet.Error+import Database.TokyoCabinet.Internal+import Database.TokyoCabinet.Storable+import Database.TokyoCabinet.Associative+import Database.TokyoCabinet.Sequence++import Data.Int+import Data.Word++import Foreign.Ptr+import Foreign.ForeignPtr+import Foreign.C.Types+import Foreign.C.String++-- $doc+-- Example+--+-- @+--  import Control.Monad (unless)+--  import Database.TokyoCabinet.TDB+--  import Database.TokyoCabinet.TDB.Query hiding (new)+--  import qualified Database.TokyoCabinet.Map as M+--  import qualified Database.TokyoCabinet.TDB.Query as Q (new)+-- @+--+-- @+--  data Profile = Profile { name :: String+--                         , age  :: Int } deriving Show+-- @+--+-- @+--  insertProfile :: TDB -> Profile -> IO Bool+--  insertProfile tdb profile =+--      do m <- M.new+--         M.put m \"name\" (name profile)+--         M.put m \"age\" (show . age $ profile)+--         Just pk <- genuid tdb+--         put tdb (show pk) m+-- @+--+-- @+--  main :: IO ()+--  main = do t <- new+--            open t \"foo.tct\" [OWRITER, OCREAT] >>= err t+-- @+--+-- @+--            mapM_ (insertProfile t) [ Profile \"tom\" 23+--                                    , Profile \"bob\" 24+--                                    , Profile \"alice\" 20 ]+-- @+--+-- @+--            q <- Q.new t+--            addcond q \"age\" QCNUMGE \"23\"+--            setorder q \"name\" QOSTRASC+--            proc q $ \pk cols -> do+--              Just name <- M.get cols \"name\"+--              putStrLn name+--              M.put cols \"name\" (name ++ \"!\")+--              return (QPPUT cols)+-- @+--+-- @+--            close t >>= err t+--            return ()+--      where+--        err tdb = flip unless $ ecode tdb >>= error . show+-- @+--++-- | Create the new table database object.+new :: IO TDB+new = TDB `fmap` (c_tctdbnew >>= newForeignPtr tctdbFinalizer)++-- | Free object resource forcibly.+delete :: TDB -> IO ()+delete tdb = finalizeForeignPtr (unTCTDB tdb)++-- | Get the last happened error code.+ecode :: TDB -> IO ECODE+ecode tdb = cintToError `fmap` withForeignPtr (unTCTDB tdb) c_tctdbecode++-- | Set the tuning parameters.+tune :: TDB   -- ^ TDB 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] -- ^ options+     -> IO Bool -- ^ if successful, the return value is True.+tune tdb bnum apow fpow opts =+    withForeignPtr (unTCTDB tdb) $ \tdb' ->+        c_tctdbtune tdb' bnum apow fpow (combineTuningOption opts)++-- | Set the caching parameters of a table database object.+setcache :: TDB   -- ^ TDB object+         -> Int32 -- ^ the maximum number of records to be cached+         -> 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 tdb rcnum lcnum ncnum =+    withForeignPtr (unTCTDB tdb) $ \tdb' ->+        c_tctdbsetcache tdb' rcnum lcnum ncnum++-- | Set the size of the extra mapped memory of a table database object.+setxmsiz :: TDB     -- ^ TDB object+         -> Int64   -- ^ the size of the extra mapped memory+         -> IO Bool -- ^ if successful, the return value is True.+setxmsiz tdb xmsiz = withForeignPtr (unTCTDB tdb) (flip c_tctdbsetxmsiz xmsiz)++-- | Open the table database file+open :: TDB -> String -> [OpenMode] -> IO Bool+open = openHelper c_tctdbopen unTCTDB combineOpenMode++-- | Open the database file+close :: TDB -> IO Bool+close tdb = withForeignPtr (unTCTDB tdb) c_tctdbclose++type FunPut' = Ptr TDB' -> Ptr Word8 -> CInt -> Ptr MAP -> IO Bool+putHelper' :: (Storable k, Storable v, Associative m) =>+              FunPut' -> TDB -> v -> m k v -> IO Bool+putHelper' c_putfunc tdb key vals =+    withForeignPtr (unTCTDB tdb) $ \tdb' ->+        withPtrLen key $ \(kbuf, ksize) ->+            withMap vals $ c_putfunc tdb' kbuf ksize++-- | Store a record into a table database object.+put :: (Storable k, Storable v, Associative m) => TDB -> v -> m k v -> IO Bool+put = putHelper' c_tctdbput++-- | Store a string record into a table database object with a zero+-- separated column string.+put' :: (Storable k, Storable v) => TDB -> k -> v -> IO Bool+put' = putHelper c_tctdbput2 unTCTDB++-- | Store a new record into a table database object.+putkeep :: (Storable k, Storable v, Associative m) => TDB -> v -> m k v -> IO Bool+putkeep = putHelper' c_tctdbputkeep++-- | Store a new string record into a table database object with a+-- zero separated column string.+putkeep' :: (Storable k, Storable v) => TDB -> k -> v -> IO Bool+putkeep' = putHelper c_tctdbputkeep2 unTCTDB++-- | Concatenate columns of the existing record in a table database object.+putcat :: (Storable k, Storable v, Associative m) => TDB -> v -> m k v -> IO Bool+putcat = putHelper' c_tctdbputcat++-- | Concatenate columns in a table database object with a zero+-- separated column string.+putcat' :: (Storable k, Storable v) => TDB -> k -> v -> IO Bool+putcat' = putHelper c_tctdbputcat2 unTCTDB++-- | Remove a record of a table database object.+out :: (Storable k) => TDB -> k -> IO Bool+out = outHelper c_tctdbout unTCTDB++-- | Retrieve a record in a table database object.+get :: (Storable k, Storable v, Associative m) => TDB -> k -> IO (m k v)+get tdb key =+    withForeignPtr (unTCTDB tdb) $ \tdb' ->+        withPtrLen key $ \(kbuf, ksize) ->+            c_tctdbget tdb' kbuf ksize >>= peekMap'++-- | Retrieve a record in a table database object as a zero separated+-- column string.+get' :: (Storable k, Storable v) => TDB -> k -> IO (Maybe v)+get' = getHelper c_tctdbget2 unTCTDB++-- | Get the size of the value of a record in a table database object.+vsiz :: (Storable k) => TDB -> k -> IO (Maybe Int)+vsiz = vsizHelper c_tctdbvsiz unTCTDB++-- | Initialize the iterator of a table database object.+iterinit :: TDB -> IO Bool+iterinit tdb = withForeignPtr (unTCTDB tdb) c_tctdbiterinit++-- | Get the next primary key of the iterator of a table database object.+iternext :: (Storable k) => TDB -> IO (Maybe k)+iternext = iternextHelper c_tctdbiternext unTCTDB++-- | Get forward matching primary keys in a table database object.+fwmkeys :: (Storable k1, Storable k2, Sequence q) => TDB -> k1 -> Int -> IO (q k2)+fwmkeys = fwmHelper c_tctdbfwmkeys unTCTDB++-- | Add an integer to a column of a record in a table database object.+addint :: (Storable k) => TDB -> k -> Int -> IO (Maybe Int)+addint = addHelper c_tctdbaddint unTCTDB fromIntegral fromIntegral (== cINT_MIN)++-- | Add a real number to a column of a record in a table database object.+adddouble :: (Storable k) => TDB -> k -> Double -> IO (Maybe Double)+adddouble = addHelper c_tctdbadddouble unTCTDB realToFrac realToFrac isNaN++-- | Synchronize updated contents of a table database object with the+-- file and the device.+sync :: TDB -> IO Bool+sync tdb = withForeignPtr (unTCTDB tdb) c_tctdbsync++-- | Optimize the file of a table database object.+optimize :: TDB   -- ^ TDB 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] -- ^ options+         -> IO Bool -- ^ if successful, the return value is True.+optimize tdb bnum apow fpow opts =+    withForeignPtr (unTCTDB tdb) $ \tdb' ->+        c_tctdboptimize tdb' bnum apow fpow (combineTuningOption opts)++-- | Remove all records of a table database object.+vanish :: TDB -> IO Bool+vanish tdb = withForeignPtr (unTCTDB tdb) c_tctdbvanish++-- | Copy the database file of a table database object.+copy :: TDB     -- ^ TDB object+     -> String  -- ^ new file path+     -> IO Bool -- ^ if successful, the return value is True+copy = copyHelper c_tctdbcopy unTCTDB++-- | Begin the transaction of a table database object.+tranbegin :: TDB -> IO Bool+tranbegin tdb = withForeignPtr (unTCTDB tdb) c_tctdbtranbegin++-- | Commit the transaction of a table database object.+trancommit :: TDB -> IO Bool+trancommit tdb = withForeignPtr (unTCTDB tdb) c_tctdbtrancommit++-- | Abort the transaction of a table database object.+tranabort :: TDB -> IO Bool+tranabort tdb = withForeignPtr (unTCTDB tdb) c_tctdbtranabort++-- | Get the file path of a table database object.+path :: TDB -> IO (Maybe String)+path = pathHelper c_tctdbpath unTCTDB++-- | Get the number of records of a table database object.+rnum :: TDB -> IO Word64+rnum tdb = withForeignPtr (unTCTDB tdb) c_tctdbrnum++-- | Get the size of the database file of a table database object.+fsiz :: TDB -> IO Word64+fsiz tdb = withForeignPtr (unTCTDB tdb) c_tctdbfsiz++-- | Set a column index to a table database object.+setindex :: TDB -> String -> IndexType -> IO Bool+setindex tdb name itype =+    withForeignPtr (unTCTDB tdb) $ \tdb' ->+        withCString name $ \c_name ->+            c_tctdbsetindex tdb' c_name (indexTypeToCInt itype)++-- | Generate a unique ID number of a table database object.+genuid :: TDB -> IO (Maybe Int64)+genuid tdb = withForeignPtr (unTCTDB tdb) $ \tdb' -> do+               uid <- c_tctdbgenuid tdb'+               return $ if uid == (-1) then Nothing else Just uid
+ Database/TokyoCabinet/TDB/C.hsc view
@@ -0,0 +1,215 @@+{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-}+module Database.TokyoCabinet.TDB.C where++import Data.Int+import Data.Word+import Data.Bits++import Foreign.Ptr+import Foreign.ForeignPtr+import Foreign.C.Types+import Foreign.C.String++import Database.TokyoCabinet.Map.C+import Database.TokyoCabinet.List.C++#include <tctdb.h>++-- | Represents open mode+data OpenMode =+    OREADER | -- ^ read only mode+    OWRITER | -- ^ write mode+    OCREAT  | -- ^ if this value is included in open mode list, `open+              -- function' creates a new database if not exist.+    OTRUNC  | -- ^ creates a new database regardless if one exists+    ONOLCK  | -- ^ open the database file without file locking+    OLCKNB  | -- ^ open the database file with locking performed+              -- without blocking.+    OTSYNC    -- ^ every transaction synchronizes updated contents+              -- with the device+    deriving (Eq, Ord, Show)++data TuningOption =+    TLARGE   |+    TDEFLATE |+    TBZIP    |+    TTCBS    |+    TEXCODEC+    deriving (Eq, Ord, Show)++-- | Represents the index type+data IndexType =+    ITLEXICAL | -- ^ for lexical string+    ITDECIMAL | -- ^ for decimal string+    ITOPT     | -- ^ the index is optimized+    ITVOID    | -- ^ the index is removed+    ITKEEP IndexType -- ^ if the index exists, setindex function merely returns failure+    deriving (Eq, Ord, Show)++openModeToCInt :: OpenMode -> CInt+openModeToCInt OREADER = #const TDBOREADER+openModeToCInt OWRITER = #const TDBOWRITER+openModeToCInt OCREAT  = #const TDBOCREAT+openModeToCInt OTRUNC  = #const TDBOTRUNC+openModeToCInt ONOLCK  = #const TDBONOLCK+openModeToCInt OLCKNB  = #const TDBOLCKNB+openModeToCInt OTSYNC  = #const TDBOTSYNC++tuningOptionToWord8 :: TuningOption -> Word8+tuningOptionToWord8 TLARGE   = #const TDBTLARGE+tuningOptionToWord8 TDEFLATE = #const TDBTDEFLATE+tuningOptionToWord8 TBZIP    = #const TDBTBZIP+tuningOptionToWord8 TTCBS    = #const TDBTTCBS+tuningOptionToWord8 TEXCODEC = #const TDBTEXCODEC++indexTypeToCInt :: IndexType -> CInt+indexTypeToCInt ITLEXICAL = #const TDBITLEXICAL+indexTypeToCInt ITDECIMAL = #const TDBITDECIMAL+indexTypeToCInt ITOPT     = #const TDBITOPT+indexTypeToCInt ITVOID    = #const TDBITVOID+indexTypeToCInt (ITKEEP ixt) = (#const TDBITKEEP) .|. (indexTypeToCInt ixt)++combineOpenMode :: [OpenMode] -> CInt+combineOpenMode = foldr ((.|.) . openModeToCInt) 0++combineTuningOption :: [TuningOption] -> Word8+combineTuningOption = foldr ((.|.) . tuningOptionToWord8) 0++data TDB = TDB { unTCTDB :: !(ForeignPtr TDB') }++data TDB'++foreign import ccall safe "tctdbnew"+  c_tctdbnew :: IO (Ptr TDB')++foreign import ccall safe "tctdbdel"+  c_tctdbdel :: Ptr TDB' -> IO ()++foreign import ccall safe "&tctdbdel"+  tctdbFinalizer :: FunPtr (Ptr TDB' -> IO ())++foreign import ccall safe "tctdbecode"+  c_tctdbecode :: Ptr TDB' -> IO CInt++foreign import ccall safe "tctdbsetmutex"+  c_tctdbsetmutex :: Ptr TDB' -> IO Bool++foreign import ccall safe "tctdbtune"+  c_tctdbtune :: Ptr TDB' -> Int64 -> Int8 -> Int8 -> Word8 -> IO Bool++foreign import ccall safe "tctdbsetcache"+  c_tctdbsetcache :: Ptr TDB' -> Int32 -> Int32 -> Int32 -> IO Bool++foreign import ccall safe "tctdbsetxmsiz"+  c_tctdbsetxmsiz :: Ptr TDB' -> Int64 -> IO Bool++foreign import ccall safe "tctdbopen"+  c_tctdbopen :: Ptr TDB' -> CString -> CInt -> IO Bool++foreign import ccall safe "tctdbclose"+  c_tctdbclose :: Ptr TDB' -> IO Bool++foreign import ccall safe "tctdbput"+  c_tctdbput :: Ptr TDB' -> Ptr Word8 -> CInt -> Ptr MAP -> IO Bool++foreign import ccall safe "tctdbput2"+  c_tctdbput2 :: Ptr TDB' -> Ptr Word8 -> CInt -> Ptr Word8 -> CInt -> IO Bool++foreign import ccall safe "tctdbput3"+  c_tctdbput3 :: Ptr TDB' -> CString -> CString -> IO Bool++foreign import ccall safe "tctdbputkeep"+  c_tctdbputkeep :: Ptr TDB' -> Ptr Word8 -> CInt -> Ptr MAP -> IO Bool++foreign import ccall safe "tctdbputkeep2"+  c_tctdbputkeep2 :: Ptr TDB' -> Ptr Word8 -> CInt -> Ptr Word8 -> CInt -> IO Bool++foreign import ccall safe "tctdbputkeep3"+  c_tctdbputkeep3 :: Ptr TDB' -> CString -> CString -> IO Bool++foreign import ccall safe "tctdbputcat"+  c_tctdbputcat :: Ptr TDB' -> Ptr Word8 -> CInt -> Ptr MAP -> IO Bool++foreign import ccall safe "tctdbputcat2"+  c_tctdbputcat2 :: Ptr TDB' -> Ptr Word8 -> CInt -> Ptr Word8 -> CInt -> IO Bool++foreign import ccall safe "tctdbputcat3"+  c_tctdbputcat3 :: Ptr TDB' -> CString -> CString -> IO Bool++foreign import ccall safe "tctdbout"+  c_tctdbout :: Ptr TDB' -> Ptr Word8 -> CInt -> IO Bool++foreign import ccall safe "tctdbout2"+  c_tctdbout2 :: Ptr TDB' -> CString -> IO Bool++foreign import ccall safe "tctdbget"+  c_tctdbget :: Ptr TDB' -> Ptr Word8 -> CInt -> IO (Ptr MAP)++foreign import ccall safe "tctdbget2"+  c_tctdbget2 :: Ptr TDB' -> Ptr Word8 -> CInt -> Ptr CInt -> IO (Ptr Word8)++foreign import ccall safe "tctdbget3"+  c_tctdbget3 :: Ptr TDB' -> CString -> IO CString++foreign import ccall safe "tctdbvsiz"+  c_tctdbvsiz :: Ptr TDB' -> Ptr Word8 -> CInt -> IO CInt++foreign import ccall safe "tctdbvsiz2"+  c_tctdbvsiz2 :: Ptr TDB' -> CString -> IO CInt++foreign import ccall safe "tctdbiterinit"+  c_tctdbiterinit :: Ptr TDB' -> IO Bool++foreign import ccall safe "tctdbiternext"+  c_tctdbiternext :: Ptr TDB' -> Ptr CInt -> IO (Ptr Word8)++foreign import ccall safe "tctdbiternext2"+  c_tctdbiternext2 :: Ptr TDB' -> IO CString++foreign import ccall safe "tctdbfwmkeys"+  c_tctdbfwmkeys :: Ptr TDB' -> Ptr Word8 -> CInt -> CInt -> IO (Ptr LIST)++foreign import ccall safe "tctdbfwmkeys2"+  c_tctdbfwmkeys2 :: Ptr TDB' -> CString -> CInt -> IO (Ptr LIST)++foreign import ccall safe "tctdbaddint"+  c_tctdbaddint :: Ptr TDB' -> Ptr Word8 -> CInt -> CInt -> IO CInt++foreign import ccall safe "tctdbadddouble"+  c_tctdbadddouble :: Ptr TDB' -> Ptr Word8 -> CInt -> CDouble -> IO CDouble++foreign import ccall safe "tctdbsync"+  c_tctdbsync :: Ptr TDB' -> IO Bool++foreign import ccall safe "tctdboptimize"+  c_tctdboptimize :: Ptr TDB' -> Int64 -> Int8 -> Int8 -> Word8 -> IO Bool++foreign import ccall safe "tctdbvanish"+  c_tctdbvanish :: Ptr TDB' -> IO Bool++foreign import ccall safe "tctdbcopy"+  c_tctdbcopy :: Ptr TDB' -> CString -> IO Bool++foreign import ccall safe "tctdbtranbegin"+  c_tctdbtranbegin :: Ptr TDB' -> IO Bool++foreign import ccall safe "tctdbtrancommit"+  c_tctdbtrancommit :: Ptr TDB' -> IO Bool++foreign import ccall safe "tctdbtranabort"+  c_tctdbtranabort :: Ptr TDB' -> IO Bool++foreign import ccall safe "tctdbpath"+  c_tctdbpath :: Ptr TDB' -> IO CString++foreign import ccall safe "tctdbrnum"+  c_tctdbrnum :: Ptr TDB' -> IO Word64++foreign import ccall safe "tctdbfsiz"+  c_tctdbfsiz :: Ptr TDB' -> IO Word64++foreign import ccall safe "tctdbsetindex"+  c_tctdbsetindex :: Ptr TDB' -> CString -> CInt -> IO Bool++foreign import ccall safe "tctdbgenuid"+  c_tctdbgenuid :: Ptr TDB' -> IO Int64
+ Database/TokyoCabinet/TDB/Query.hs view
@@ -0,0 +1,120 @@+module Database.TokyoCabinet.TDB.Query+    (+      Condition(..)+    , OrderType(..)+    , PostTreatment(..)+    , new+    , delete+    , addcond+    , setorder+    , setlimit+    , search+    , searchout+    , hint+    , proc+    ) where++import Data.Word++import Foreign.C.String++import Foreign.Ptr+import Foreign.ForeignPtr+import Foreign.Storable (pokeByteOff, peek)+import Foreign.Marshal (mallocBytes, alloca)+import Foreign.Marshal.Utils (copyBytes)++import Database.TokyoCabinet.Storable+import Database.TokyoCabinet.Sequence+import Database.TokyoCabinet.Associative+import Database.TokyoCabinet.Map.C+import Database.TokyoCabinet.TDB.C+import Database.TokyoCabinet.TDB.Query.C++-- | Create a query object.+new :: TDB -> IO TDBQRY+new tdb = withForeignPtr (unTCTDB tdb) $ \tdb' ->+          flip TDBQRY tdb `fmap` (c_tctdbqrynew tdb' >>= newForeignPtr tctdbqryFinalizer)++-- | Free object resource forcibly.+delete :: TDBQRY -> IO ()+delete qry = finalizeForeignPtr (unTDBQRY qry)++-- | Add a narrowing condition to a query object.+addcond :: (Storable k, Storable v) => TDBQRY -> k -> Condition -> v -> IO ()+addcond qry name op expr =+    withForeignPtr (unTDBQRY qry) $ \qry' ->+        withPtrLen name $ \(name', nlen) ->+        withPtrLen expr $ \(expr', elen) ->+            do pokeByteOff name' (fromIntegral nlen) (0 :: Word8)+               pokeByteOff expr' (fromIntegral elen) (0 :: Word8)+               c_tctdbqryaddcond qry' (castPtr name') (condToCInt op) (castPtr expr')+++-- | Set the order of a query object.+setorder :: (Storable k) => TDBQRY -> k -> OrderType -> IO ()+setorder qry name otype =+    withForeignPtr (unTDBQRY qry) $ \qry' ->+        withPtrLen name $ \(name', nlen) ->+            do pokeByteOff name' (fromIntegral nlen) (0 :: Word8)+               c_tctdbqrysetorder qry' (castPtr name') (orderToCInt otype)++-- | Set the limit number of records of the result of a query object.+setlimit :: TDBQRY -> Int -> Int -> IO ()+setlimit qry maxn skip =+    withForeignPtr (unTDBQRY qry) $ \qry' ->+        c_tctdbqrysetlimit qry' (fromIntegral maxn) (fromIntegral skip)++-- | Execute the search of a query object. The return value is a list+-- object of the primary keys of the corresponding records.+search :: (Storable k, Sequence q) => TDBQRY -> IO (q k)+search qry = withForeignPtr (unTDBQRY qry) $ (>>= peekList') . c_tctdbqrysearch++-- | Remove each record corresponding to a query object.+searchout :: TDBQRY -> IO Bool+searchout qry = withForeignPtr (unTDBQRY qry) c_tctdbqrysearchout++hint :: TDBQRY -> IO String+hint qry = withForeignPtr (unTDBQRY qry) $ \qry' -> c_tctdbqryhint qry' >>= peekCString++-- |  Process each record corresponding to a query object.+proc :: (Storable k, Storable v, Associative m) =>+        TDBQRY  -- ^ Query object.+     -> (v -> m k v -> IO (PostTreatment m k v)) -- ^ the iterator+                                                 -- function called+                                                 -- for each record.+     -> IO Bool -- ^ If successful, the return value is true, else, it is false.+proc qry callback =+    withForeignPtr (unTDBQRY qry) $ \qry' ->+        do cb <- mkProc proc'+           c_tctdbqryproc qry' cb nullPtr+    where+      proc' :: TDBQRYPROC'+      proc' pkbuf pksiz m _ = do+        let siz = fromIntegral pksiz+        pbuf <- mallocBytes siz+        copyBytes pbuf pkbuf siz+        pkey <- peekPtrLen (pbuf, pksiz)+        pt <- c_tcmapdup m >>= peekMap' >>= callback pkey+        case pt of+          QPPUT m' -> withMap m' (flip copyMap m)+          _ -> return ()+        return (ptToCInt pt)++      copyMap :: Ptr MAP -> Ptr MAP -> IO ()+      copyMap msrc mdist =+          do c_tcmapclear mdist+             c_tcmapiterinit msrc+             storeKeyValue msrc mdist++      storeKeyValue :: Ptr MAP -> Ptr MAP -> IO ()+      storeKeyValue msrc mdist =+          alloca $ \sizbuf -> do+              kbuf <- c_tcmapiternext msrc sizbuf+              if kbuf == nullPtr+                then return ()+                else do ksiz <- peek sizbuf+                        vbuf <- c_tcmapget msrc kbuf ksiz sizbuf+                        vsiz <- peek sizbuf+                        c_tcmapput mdist kbuf ksiz vbuf vsiz+                        storeKeyValue msrc mdist
+ Database/TokyoCabinet/TDB/Query/C.hsc view
@@ -0,0 +1,124 @@+{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-}+module Database.TokyoCabinet.TDB.Query.C where++import Data.Word+import Data.Bits++import Foreign.Ptr+import Foreign.ForeignPtr+import Foreign.C.Types+import Foreign.C.String++import Database.TokyoCabinet.TDB.C+import Database.TokyoCabinet.Map.C+import Database.TokyoCabinet.List.C++#include <tctdb.h>++data Condition =+    QCSTREQ   |+    QCSTRINC  |+    QCSTRBW   |+    QCSTREW   |+    QCSTRAND  |+    QCSTROR   |+    QCSTROREQ |+    QCSTRRX   |+    QCNUMEQ   |+    QCNUMGT   |+    QCNUMGE   |+    QCNUMLT   |+    QCNUMLE   |+    QCNUMBT   |+    QCNUMOREQ |+    QCNEGATE Condition |+    QCNOIDX  Condition+    deriving (Eq, Ord, Show)++data OrderType =+    QOSTRASC  |+    QOSTRDESC |+    QONUMASC  |+    QONUMDESC+    deriving (Eq, Ord, Show)++data PostTreatment m k v =+    QPPUT (m k v) |+    QPOUT  |+    QPNOP  |+    QPSTOP+    deriving (Eq, Ord, Show)++condToCInt :: Condition -> CInt+condToCInt QCSTREQ   = #const TDBQCSTREQ+condToCInt QCSTRINC  = #const TDBQCSTRINC+condToCInt QCSTRBW   = #const TDBQCSTRBW+condToCInt QCSTREW   = #const TDBQCSTREW+condToCInt QCSTRAND  = #const TDBQCSTRAND+condToCInt QCSTROR   = #const TDBQCSTROR+condToCInt QCSTROREQ = #const TDBQCSTROREQ+condToCInt QCSTRRX   = #const TDBQCSTRRX+condToCInt QCNUMEQ   = #const TDBQCNUMEQ+condToCInt QCNUMGT   = #const TDBQCNUMGT+condToCInt QCNUMGE   = #const TDBQCNUMGE+condToCInt QCNUMLT   = #const TDBQCNUMLT+condToCInt QCNUMLE   = #const TDBQCNUMLE+condToCInt QCNUMBT   = #const TDBQCNUMBT+condToCInt QCNUMOREQ = #const TDBQCNUMOREQ+condToCInt (QCNEGATE c) = (#const TDBQCNEGATE) .|. (condToCInt c)+condToCInt (QCNOIDX  c) = (#const TDBQCNOIDX) .|. (condToCInt c)++orderToCInt :: OrderType -> CInt+orderToCInt QOSTRASC  = #const TDBQOSTRASC+orderToCInt QOSTRDESC = #const TDBQOSTRDESC+orderToCInt QONUMASC  = #const TDBQONUMASC+orderToCInt QONUMDESC = #const TDBQONUMDESC++ptToCInt :: PostTreatment m k v -> CInt+ptToCInt QPNOP  = 0+ptToCInt QPOUT  = #const TDBQPOUT+ptToCInt QPSTOP = #const TDBQPSTOP+ptToCInt (QPPUT _) = #const TDBQPPUT++data TDBQRY = TDBQRY { unTDBQRY :: !(ForeignPtr QRY)+                     , unTDBOBJ :: TDB }++data QRY++foreign import ccall safe "tctdbqrynew"+  c_tctdbqrynew :: Ptr TDB' -> IO (Ptr QRY)++foreign import ccall safe "tctdbqrydel"+  c_tctdbqrydel :: Ptr QRY -> IO ()++foreign import ccall safe "&tctdbqrydel"+  tctdbqryFinalizer :: FunPtr (Ptr QRY -> IO ())++foreign import ccall safe "tctdbqryaddcond"+  c_tctdbqryaddcond :: Ptr QRY -> CString -> CInt -> CString -> IO ()++foreign import ccall safe "tctdbqrysetorder"+  c_tctdbqrysetorder :: Ptr QRY -> CString -> CInt -> IO ()++foreign import ccall safe "tctdbqrysetlimit"+  c_tctdbqrysetlimit :: Ptr QRY -> CInt -> CInt -> IO ()++foreign import ccall safe "tctdbqrysearch"+  c_tctdbqrysearch :: Ptr QRY -> IO (Ptr LIST)++foreign import ccall safe "tctdbqrysearchout"+  c_tctdbqrysearchout :: Ptr QRY -> IO Bool++foreign import ccall safe "tctdbqryhint"+  c_tctdbqryhint :: Ptr QRY -> IO CString++type TDBQRYPROC' = Ptr Word8 -> CInt -> Ptr MAP -> Ptr Word8 -> IO CInt++foreign import ccall safe "tctdbqryproc"+  c_tctdbqryproc :: Ptr QRY+                 -> FunPtr TDBQRYPROC'+                 -> Ptr Word8+                 -> IO Bool++foreign import ccall "wrapper"+  mkProc :: TDBQRYPROC' -> IO (FunPtr TDBQRYPROC')
+ examples/MyApp1/TokyoCabinet.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module MyApp1.TokyoCabinet+    (+      TCM+    , runTCM+    , new+    , open+    , close+    , put+    , putcat+    , putkeep+    , get+    , out+    , iterinit+    , iternext+    , fwmkeys+    , rnum+    , size+    , liftT+    , TC.defaultExtension+    , TCDB+    , HDB+    , BDB+    , FDB+    , OpenMode(..)+    ) where++import Data.Int++import Control.Monad+import Control.Monad.Reader++import Database.TokyoCabinet.Storable+import Database.TokyoCabinet (TCDB, FDB, BDB, HDB, OpenMode(..))+import qualified Database.TokyoCabinet as TC++newtype TCM tc a =+    TCM { unTCM :: ReaderT tc TC.TCM a } deriving (Monad, MonadReader tc)++runTCM :: (TCDB tc) => TCM tc a -> tc -> IO a+runTCM tcm tc = TC.runTCM $ runReaderT (unTCM tcm) tc++new :: (TCDB tc) => IO tc+new = TC.runTCM TC.new++liftT :: (TCDB tc) => TC.TCM a -> TCM tc a+liftT = TCM . lift++open :: (TCDB tc) => String -> [OpenMode] -> TCM tc Bool+open name mode = do tc <- ask+                    liftT $ TC.open tc name mode++close :: (TCDB tc) => TCM tc Bool+close = ask >>= liftT . TC.close++put :: (TCDB tc, Storable k, Storable v) => k -> v -> TCM tc Bool+put key val = do tc <- ask+                 liftT $ TC.put tc key val++putcat :: (TCDB tc, Storable k, Storable v) => k -> v -> TCM tc Bool+putcat key val = do tc <- ask+                    liftT $ TC.putcat tc key val++putkeep :: (TCDB tc, Storable k, Storable v) => k -> v -> TCM tc Bool+putkeep key val = do tc <- ask+                     liftT $ TC.putkeep tc key val++get :: (TCDB tc, Storable k, Storable v) => k -> TCM tc (Maybe v)+get key = do tc <- ask+             liftT $ TC.get tc key++out :: (TCDB tc, Storable k) => k -> TCM tc Bool+out key = do tc <- ask+             liftT $ TC.out tc key++iterinit :: (TCDB tc) => TCM tc Bool+iterinit = ask >>= liftT . TC.iterinit++iternext :: (TCDB tc, Storable v) => TCM tc (Maybe v)+iternext = ask >>= liftT . TC.iternext++fwmkeys :: (TCDB tc, Storable k1, Storable k2) => k1 -> Int -> TCM tc [k2]+fwmkeys key maxn = do tc <- ask+                      liftT $ TC.fwmkeys tc key maxn++rnum :: (TCDB tc) => TCM tc Int64+rnum = do tc <- ask+          liftT $ TC.rnum tc++size :: (TCDB tc) => TCM tc Int64+size = do tc <- ask+          liftT $ TC.size tc
+ examples/MyApp2/TokyoCabinet.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module MyApp2.TokyoCabinet+    (+      TCDB+    , HDB+    , BDB+    , FDB+    , TCM+    , runTCM+    , new+    , open+    , close+    , put+    , get+    , TC.defaultExtension+    , ECODE(..)+    , OpenMode(..)+    ) where++import Control.Monad.Error+import Control.Monad.Reader++import Database.TokyoCabinet+    (+      OpenMode(..)+    , TCDB+    , HDB+    , BDB+    , FDB+    )++import Database.TokyoCabinet.Error+import Database.TokyoCabinet.Storable+import qualified Database.TokyoCabinet as TC++instance Error ECODE where+    noMsg = ESUCCESS+    strMsg "ESUCCESS" = ESUCCESS+    strMsg "ETHREAD" = ETHREAD+    strMsg "EINVALID" = EINVALID+    strMsg "ENOFILE" = ENOFILE+    strMsg "ENOPERM" = ENOPERM+    strMsg "EMETA" = EMETA+    strMsg "ERHEAD" = ERHEAD+    strMsg "EOPEN" = EOPEN+    strMsg "ECLOSE" = ECLOSE+    strMsg "ETRUNC" = ETRUNC+    strMsg "ESYNC" = ESYNC+    strMsg "ESTAT" = ESTAT+    strMsg "ESEEK" = ESEEK+    strMsg "EREAD" = EREAD+    strMsg "EWRITE" = EWRITE+    strMsg "EMMAP" = EMMAP+    strMsg "ELOCK" = ELOCK+    strMsg "EUNLINK" = EUNLINK+    strMsg "ERENAME" = ERENAME+    strMsg "EMKDIR" = EMKDIR+    strMsg "ERMDIR" = ERMDIR+    strMsg "EKEEP" = EKEEP+    strMsg "ENOREC" = ENOREC+    strMsg _ = EMISC++newtype TCM tc a = TCM { unTCM :: ErrorT ECODE (ReaderT tc TC.TCM) a }+    deriving (Monad, MonadIO, MonadReader tc, MonadError ECODE)++runTCM :: (TCDB tc) => TCM tc a -> tc -> IO (Either ECODE a)+runTCM tcm tc = TC.runTCM $ runReaderT (runErrorT $ unTCM tcm) tc++liftT :: (TCDB tc) => TC.TCM a -> TCM tc a+liftT = TCM . lift . lift++throwTCError :: (TCDB tc) => tc -> Bool -> TCM tc ()+throwTCError tc False = (liftT $ TC.ecode tc) >>= throwError+throwTCError _ _ = return ()++new :: (TCDB tc) => IO tc+new = TC.runTCM TC.new++open :: (TCDB tc) => String -> [OpenMode] -> TCM tc ()+open name mode = do tc <- ask+                    (liftT $ TC.open tc name mode) >>= throwTCError tc++close :: (TCDB tc) => TCM tc ()+close = do tc <- ask+           (liftT $ TC.close tc) >>= throwTCError tc++put :: (TCDB tc, Storable k, Storable v) => k -> v -> TCM tc ()+put key val = do tc <- ask+                 (liftT $ TC.put tc key val) >>= throwTCError tc++get :: (TCDB tc, Storable k, Storable v) => k -> TCM tc (Maybe v)+get key = do tc <- ask+             liftT $ TC.get tc key
+ examples/myapp1.hs view
@@ -0,0 +1,21 @@+import System+import MyApp1.TokyoCabinet++main :: IO ()+main = do args <- getArgs+          case head args of+            "-h" -> (new :: IO HDB) >>= main' +            "-b" -> (new :: IO BDB) >>= main' +            "-f" -> (new :: IO FDB) >>= main' +            _ -> putStrLn "./myapp1 [-h|-b|-f]"+    where+      main' tc = do+        let ext = defaultExtension tc+        v <- flip runTCM tc $ do+                 open ("foo" ++ ext) [OWRITER, OCREAT]+                 put "100" "bar"+                 putcat "100" "bar"+                 v <- get "100"+                 close+                 return v+        print (v :: Maybe String)
+ examples/myapp2.hs view
@@ -0,0 +1,19 @@+import MyApp2.TokyoCabinet++import Control.Monad.Trans+import Control.Monad.Error++main :: IO ()+main = do h <- new :: IO HDB+          let ext = defaultExtension h+          v <- flip runTCM h $ do+                 open ("foo" ++ ext) [OWRITER, OCREAT]+                 put "100" "foo"+--                 throwError EMISC+                 v <- get "100"+                 close+                 return v+               `catchError` const (close >> fail "oops")+          case v of+            Left  e  -> putStrLn (show e)+            Right v' -> putStrLn (show (v' :: Maybe String))
+ examples/simple.hs view
@@ -0,0 +1,21 @@+import Database.TokyoCabinet+import Data.ByteString.Char8 (ByteString, pack)++putsample :: String -> [(ByteString, ByteString)] -> TCM Bool+putsample file kv =+    do tc <- new :: TCM HDB+       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+       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)
+ examples/tcbdb.hs view
@@ -0,0 +1,33 @@+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 []
+ examples/tcfdb.hs view
@@ -0,0 +1,19 @@+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
+ examples/tchdb.hs view
@@ -0,0 +1,30 @@+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)
+ examples/tctdb.hs view
@@ -0,0 +1,38 @@+import Control.Monad (unless)+import Database.TokyoCabinet.TDB+import Database.TokyoCabinet.TDB.Query hiding (new)+import qualified Database.TokyoCabinet.Map as M+import qualified Database.TokyoCabinet.TDB.Query as Q (new)++data Profile = Profile { name :: String+                       , age  :: Int } deriving Show++insertProfile :: TDB -> Profile -> IO Bool+insertProfile tdb profile =+    do m <- M.new+       M.put m "name" (name profile)+       M.put m "age" (show . age $ profile)+       Just pk <- genuid tdb+       put tdb (show pk) m++main :: IO ()+main = do t <- new+          open t "foo.tct" [OWRITER, OCREAT] >>= err t++          mapM_ (insertProfile t) [ Profile "tom" 23+                                  , Profile "bob" 24+                                  , Profile "alice" 20 ]++          q <- Q.new t+          addcond q "age" QCNUMGE "23"+          setorder q "name" QOSTRASC+          proc q $ \pk cols -> do+            Just name <- M.get cols "name"+            putStrLn name+            M.put cols "name" (name ++ "!")+            return (QPPUT cols)++          close t >>= err t+          return ()+    where+      err tdb = flip unless $ ecode tdb >>= error . show
tokyocabinet-haskell.cabal view
@@ -1,5 +1,5 @@ Name:           tokyocabinet-haskell-Version:        0.0.3+Version:        0.0.4 Cabal-Version:  >= 1.2 License:        BSD3 License-File:   LICENSE@@ -9,6 +9,10 @@ Stability:      experimental Category:       Database Synopsis:       Haskell binding of Tokyo Cabinet+Extra-source-files: examples/tcfdb.hs examples/tcbdb.hs examples/tctdb.hs+                    examples/tchdb.hs examples/simple.hs examples/myapp1.hs+                    examples/myapp2.hs examples/MyApp1/TokyoCabinet.hs+                    examples/MyApp2/TokyoCabinet.hs Description:   Bindings to Tokyo Cabinet library.   Tokyo Cabinet is a modern implementation of DBM.@@ -16,16 +20,18 @@    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 +Flag BuildTest+  Description:  make tests and install it if True+  Default:      False+ Library   Build-Depends:        base >= 4.0, bytestring >= 0.9, mtl >= 1.1   Exposed-modules:-    Database.TokyoCabinet,+    Database.TokyoCabinet     Database.TokyoCabinet.HDB     Database.TokyoCabinet.HDB.C     Database.TokyoCabinet.BDB@@ -35,13 +41,20 @@     Database.TokyoCabinet.FDB     Database.TokyoCabinet.FDB.C     Database.TokyoCabinet.FDB.Key+    Database.TokyoCabinet.TDB+    Database.TokyoCabinet.TDB.C+    Database.TokyoCabinet.TDB.Query+    Database.TokyoCabinet.TDB.Query.C     Database.TokyoCabinet.Error+    Database.TokyoCabinet.Map+    Database.TokyoCabinet.Map.C     Database.TokyoCabinet.List     Database.TokyoCabinet.List.C     Database.TokyoCabinet.Storable     Database.TokyoCabinet.Sequence+    Database.TokyoCabinet.Associative -  other-modules:+  Other-modules:     Database.TokyoCabinet.Internal   Extensions:           CPP, ForeignFunctionInterface,                         EmptyDataDecls, TypeSynonymInstances,