Storable.hs

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