List.hs

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

    , wrapList
    , withListPtr

    , newList
    , push
    , length
    , (!!)

    , toList
    , fromList
    )
    where

import qualified Data.ByteString as BS
import           Data.ByteString.Base
import           Data.Maybe
import           Foreign.C.Types
import           Foreign.ForeignPtr
import           Foreign.Ptr
import           Foreign.Storable
import           Foreign.Marshal.Alloc
import           Prelude hiding (length, (!!))


infixl 9 !!


newtype List = List (ForeignPtr CBLIST)
data CBLIST


foreign import ccall unsafe "cabin.h cblistopen"
        _open :: IO (Ptr CBLIST)

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

foreign import ccall unsafe "cabin.h cblistnum"
        _num :: Ptr CBLIST -> IO CInt

foreign import ccall unsafe "cabin.h cblistval"
        _val :: Ptr CBLIST -> CInt -> Ptr CInt -> IO (Ptr CChar)

foreign import ccall unsafe "cabin.h cblistpush"
        _push :: Ptr CBLIST -> Ptr CChar -> CInt -> IO ()


wrapList :: Ptr CBLIST -> IO List
wrapList listPtr = newForeignPtr _close listPtr >>= return . List


withListPtr :: List -> (Ptr CBLIST -> IO a) -> IO a
withListPtr (List list) = withForeignPtr list


newList :: IO List
newList = _open >>= wrapList


push :: List -> ByteString -> IO ()
push list value
    = withListPtr        list  $ \ listPtr              ->
      BS.useAsCStringLen value $ \ (valuePtr, valueLen) ->
      _push listPtr valuePtr (fromIntegral valueLen)


length :: List -> IO Int
length list
    = withListPtr list $ \ listPtr ->
      _num listPtr >>= return . fromIntegral


(!!) :: List -> Int -> IO (Maybe ByteString)
list !! index
    = withListPtr list $ \ listPtr   ->
      alloca           $ \ valLenPtr ->
      do valPtr <- _val listPtr (fromIntegral index) valLenPtr
         if valPtr == nullPtr then
             return Nothing
           else
             do valLen <- peek valLenPtr
                value  <- BS.copyCStringLen (valPtr, fromIntegral valLen)
                return $ Just value


toList :: List -> IO [ByteString]
toList list
    = do len <- length list
         mapM (list !!) [0..len] >>= return . catMaybes


fromList :: [ByteString] -> IO List
fromList values
    = do list <- newList
         mapM_ (push list) values
         return list