Map.hs

{-# OPTIONS_GHC -optc-D__GLASGOW_HASKELL__=606 #-}
{-# LINE 1 "Database/QDBM/Cabin/Map.hsc" #-}
module Database.QDBM.Cabin.Map
{-# LINE 2 "Database/QDBM/Cabin/Map.hsc" #-}
    ( Map
    , CBMAP

    , wrapMap
    , unsafePeekMap
    , withMapPtr

    , newMap
    , put
    , get

    , toList
    , fromList
    )
    where


import qualified Data.ByteString as BS
import           Data.ByteString.Base
import           Foreign.C.Types
import           Foreign.ForeignPtr
import           Foreign.Ptr
import           Foreign.Storable
import           Foreign.Marshal.Alloc


newtype Map = Map (ForeignPtr CBMAP)
data CBMAP


foreign import ccall unsafe "cabin.h cbmapopen"
        _open :: IO (Ptr CBMAP)

foreign import ccall unsafe "cabin.h &cbmapclose"
        _close :: FunPtr (Ptr CBMAP -> IO ())

foreign import ccall unsafe "cabin.h cbmapput"
        _put :: Ptr CBMAP -> Ptr CChar -> CInt -> Ptr CChar -> CInt -> CInt -> IO CInt

foreign import ccall unsafe "cabin.h cbmapget"
        _get :: Ptr CBMAP -> Ptr CChar -> CInt -> Ptr CInt -> IO (Ptr CChar)

foreign import ccall unsafe "cabin.h cbmapiterinit"
        _iterinit :: Ptr CBMAP -> IO ()

foreign import ccall unsafe "cabin.h cbmapiternext"
        _iternext :: Ptr CBMAP -> Ptr CInt -> IO (Ptr CChar)

foreign import ccall unsafe "cabin.h cbmapiterval"
        _iterval :: Ptr CChar -> Ptr CInt -> IO (Ptr CChar)


wrapMap :: Ptr CBMAP -> IO Map
wrapMap mapPtr = newForeignPtr _close mapPtr >>= return . Map


unsafePeekMap :: Ptr CBMAP -> IO Map
unsafePeekMap mapPtr = newForeignPtr_ mapPtr >>= return . Map


withMapPtr :: Map -> (Ptr CBMAP -> IO a) -> IO a
withMapPtr (Map m) = withForeignPtr m


newMap :: IO Map
newMap = _open >>= wrapMap


put :: Map -> ByteString -> ByteString -> Bool -> IO Bool
put m key value overwrite
    = withMapPtr         m     $ \ mapPtr               ->
      BS.useAsCStringLen key   $ \ (keyPtr  , keyLen  ) ->
      BS.useAsCStringLen value $ \ (valuePtr, valueLen) ->
      _put mapPtr
           keyPtr   (fromIntegral keyLen  )
           valuePtr (fromIntegral valueLen)
           (fromIntegral $ fromEnum overwrite)
           >>= return . (/= 0)


get :: Map -> ByteString -> IO (Maybe ByteString)
get m key
    = withMapPtr         m   $ \ mapPtr           ->
      BS.useAsCStringLen key $ \ (keyPtr, keyLen) ->
      alloca                 $ \ valLenPtr        ->
      do valPtr <- _get mapPtr keyPtr (fromIntegral keyLen) valLenPtr
         if valPtr == nullPtr then
             return Nothing
           else
             do valLen <- peek valLenPtr
                value  <- BS.copyCStringLen (valPtr, fromIntegral valLen)
                return $ Just value


initIterator :: Map -> IO ()
initIterator m
    = withMapPtr m $ \ mapPtr ->
      _iterinit mapPtr


iterateNext :: Map -> IO (Maybe (ByteString, ByteString))
iterateNext m
    = withMapPtr m $ \ mapPtr    ->
      alloca       $ \ keyLenPtr ->
      alloca       $ \ valLenPtr ->
      do keyPtr <- _iternext mapPtr keyLenPtr
         if keyPtr == nullPtr then
             return Nothing
           else
             do keyLen <- peek keyLenPtr
                key    <- BS.copyCStringLen (keyPtr, fromIntegral keyLen)
                -- QDBM のソースを見たら、keyPtr そのものの値からアドレ
                -- スを計算してゐた…。良くそんな無茶をやるなあと思ふ。
                valPtr <- _iterval keyPtr valLenPtr
                valLen <- peek valLenPtr
                value  <- BS.copyCStringLen (valPtr, fromIntegral valLen)
                return $ Just (key, value)


-- iterator の状態は Map 内部に格納されるので、thread-safe でない。だか
-- ら list にするなら正格にしなければならない。
toList :: Map -> IO [(ByteString, ByteString)]
toList m = initIterator m >> loop
    where
      loop :: IO [(ByteString, ByteString)]
      loop = do next <- iterateNext m
                case next of
                  Nothing   -> return []
                  Just pair -> do rest <- loop -- ここで unsafeInterleaveIO したいが出來ない。
                                  return $ pair : rest


fromList :: [(ByteString, ByteString)] -> IO Map
fromList pairs
    = do m <- newMap
         mapM_ (putPair m) pairs
         return m
    where
      putPair :: Map -> (ByteString, ByteString) -> IO ()
      putPair m (key, value) = put m key value True >> return ()