{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE CPP, NoImplicitPrelude, ScopedTypeVariables, BangPatterns #-}
module Foreign.Storable
( Storable(
sizeOf,
alignment,
peekElemOff,
pokeElemOff,
peekByteOff,
pokeByteOff,
peek,
poke)
) where
#include "MachDeps.h"
#include "HsBaseConfig.h"
import GHC.Storable
import GHC.Stable ( StablePtr )
import GHC.Num
import GHC.Int
import GHC.Word
import GHC.Ptr
import GHC.Base
import GHC.Fingerprint.Type
import Data.Bits
import GHC.Real
class Storable a where
{-# MINIMAL sizeOf, alignment,
(peek | peekElemOff | peekByteOff),
(poke | pokeElemOff | pokeByteOff) #-}
sizeOf :: a -> Int
alignment :: a -> Int
peekElemOff :: Ptr a -> Int -> IO a
pokeElemOff :: Ptr a -> Int -> a -> IO ()
peekByteOff :: Ptr b -> Int -> IO a
pokeByteOff :: Ptr b -> Int -> a -> IO ()
peek :: Ptr a -> IO a
poke :: Ptr a -> a -> IO ()
peekElemOff = peekElemOff_ undefined
where peekElemOff_ :: a -> Ptr a -> Int -> IO a
peekElemOff_ undef ptr off = peekByteOff ptr (off * sizeOf undef)
pokeElemOff ptr off val = pokeByteOff ptr (off * sizeOf val) val
peekByteOff ptr off = peek (ptr `plusPtr` off)
pokeByteOff ptr off = poke (ptr `plusPtr` off)
peek ptr = peekElemOff ptr 0
poke ptr = pokeElemOff ptr 0
instance Storable Bool where
sizeOf _ = sizeOf (undefined::HTYPE_INT)
alignment _ = alignment (undefined::HTYPE_INT)
peekElemOff p i = liftM (/= (0::HTYPE_INT)) $ peekElemOff (castPtr p) i
pokeElemOff p i x = pokeElemOff (castPtr p) i (if x then 1 else 0::HTYPE_INT)
#define STORABLE(T,size,align,read,write) \
instance Storable (T) where { \
sizeOf _ = size; \
alignment _ = align; \
peekElemOff = read; \
pokeElemOff = write }
STORABLE(Char,SIZEOF_INT32,ALIGNMENT_INT32,
readWideCharOffPtr,writeWideCharOffPtr)
STORABLE(Int,SIZEOF_HSINT,ALIGNMENT_HSINT,
readIntOffPtr,writeIntOffPtr)
STORABLE(Word,SIZEOF_HSWORD,ALIGNMENT_HSWORD,
readWordOffPtr,writeWordOffPtr)
STORABLE((Ptr a),SIZEOF_HSPTR,ALIGNMENT_HSPTR,
readPtrOffPtr,writePtrOffPtr)
STORABLE((FunPtr a),SIZEOF_HSFUNPTR,ALIGNMENT_HSFUNPTR,
readFunPtrOffPtr,writeFunPtrOffPtr)
STORABLE((StablePtr a),SIZEOF_HSSTABLEPTR,ALIGNMENT_HSSTABLEPTR,
readStablePtrOffPtr,writeStablePtrOffPtr)
STORABLE(Float,SIZEOF_HSFLOAT,ALIGNMENT_HSFLOAT,
readFloatOffPtr,writeFloatOffPtr)
STORABLE(Double,SIZEOF_HSDOUBLE,ALIGNMENT_HSDOUBLE,
readDoubleOffPtr,writeDoubleOffPtr)
STORABLE(Word8,SIZEOF_WORD8,ALIGNMENT_WORD8,
readWord8OffPtr,writeWord8OffPtr)
STORABLE(Word16,SIZEOF_WORD16,ALIGNMENT_WORD16,
readWord16OffPtr,writeWord16OffPtr)
STORABLE(Word32,SIZEOF_WORD32,ALIGNMENT_WORD32,
readWord32OffPtr,writeWord32OffPtr)
STORABLE(Word64,SIZEOF_WORD64,ALIGNMENT_WORD64,
readWord64OffPtr,writeWord64OffPtr)
STORABLE(Int8,SIZEOF_INT8,ALIGNMENT_INT8,
readInt8OffPtr,writeInt8OffPtr)
STORABLE(Int16,SIZEOF_INT16,ALIGNMENT_INT16,
readInt16OffPtr,writeInt16OffPtr)
STORABLE(Int32,SIZEOF_INT32,ALIGNMENT_INT32,
readInt32OffPtr,writeInt32OffPtr)
STORABLE(Int64,SIZEOF_INT64,ALIGNMENT_INT64,
readInt64OffPtr,writeInt64OffPtr)
instance (Storable a, Integral a) => Storable (Ratio a) where
sizeOf _ = 2 * sizeOf (undefined :: a)
alignment _ = alignment (undefined :: a )
peek p = do
q <- return $ castPtr p
r <- peek q
i <- peekElemOff q 1
return (r % i)
poke p (r :% i) = do
q <-return $ (castPtr p)
poke q r
pokeElemOff q 1 i
instance Storable Fingerprint where
sizeOf _ = 16
alignment _ = 8
peek = peekFingerprint
poke = pokeFingerprint
peekFingerprint :: Ptr Fingerprint -> IO Fingerprint
peekFingerprint p0 = do
let peekW64 :: Ptr Word8 -> Int -> Word64 -> IO Word64
peekW64 _ 0 !i = return i
peekW64 !p !n !i = do
w8 <- peek p
peekW64 (p `plusPtr` 1) (n-1)
((i `shiftL` 8) .|. fromIntegral w8)
high <- peekW64 (castPtr p0) 8 0
low <- peekW64 (castPtr p0 `plusPtr` 8) 8 0
return (Fingerprint high low)
pokeFingerprint :: Ptr Fingerprint -> Fingerprint -> IO ()
pokeFingerprint p0 (Fingerprint high low) = do
let pokeW64 :: Ptr Word8 -> Int -> Word64 -> IO ()
pokeW64 _ 0 _ = return ()
pokeW64 p !n !i = do
pokeElemOff p (n-1) (fromIntegral i)
pokeW64 p (n-1) (i `shiftR` 8)
pokeW64 (castPtr p0) 8 high
pokeW64 (castPtr p0 `plusPtr` 8) 8 low