List.hsc

{-# LANGUAGE
    EmptyDataDecls
  , ForeignFunctionInterface
  , UnicodeSyntax
  #-}
module Database.QDBM.Cabin.List
    ( List
    , CBLIST

    , wrapList
    , withListPtr

    , newList
    , push
    , length
    , (!!)

    , toList
    , fromList
    )
    where
import qualified Data.ByteString as Strict (ByteString)
import qualified Data.ByteString.Char8 as C8 hiding (ByteString)
import Data.Maybe
import Foreign.C.Types
import Foreign.ForeignPtr
import Foreign.Ptr
import Foreign.Storable
import Foreign.Marshal.Alloc
import Prelude hiding (length, (!!))
import Prelude.Unicode


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 = fmap List (newForeignPtr _close listPtr)


withListPtr ∷ List → (Ptr CBLIST → IO a) → IO a
withListPtr (List list) = withForeignPtr list


newList ∷ IO List
newList = _open >>= wrapList


push ∷ List → Strict.ByteString → IO ()
push list value
    = withListPtr        list  $ \ listPtr              →
      C8.useAsCStringLen value $ \ (valuePtr, valueLen) →
      _push listPtr valuePtr (fromIntegral valueLen)


length ∷ List → IO Int
length list
    = withListPtr list $ \ listPtr →
      fmap fromIntegral (_num listPtr)


(!!) ∷ List → Int → IO (Maybe Strict.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  ← C8.packCStringLen (valPtr, fromIntegral valLen)
                return $ Just value


toList ∷ List → IO [Strict.ByteString]
toList list
    = do len ← length list
         fmap catMaybes (mapM (list !!) [0..len])


fromList ∷ [Strict.ByteString] → IO List
fromList values
    = do list ← newList
         mapM_ (push list) values
         return list