module System.Win32.Com.HDirect.HDirect
(module System.Win32.Com.HDirect.HDirect
, Int8, Int16, Int32, Int64
, Word8, Word16, Word32, Word64
, Char, Double, Float, Bool
, Ptr, StablePtr
, deRefStablePtr) where
import Data.Char
import Data.Int ( Int8, Int16, Int32, Int64 )
import Data.Word ( Word8, Word16, Word32, Word64 )
import Control.Monad
import System.Win32.Com.HDirect.Pointer
import System.IO.Unsafe ( unsafePerformIO )
import Foreign.StablePtr
import Foreign.Storable
import Foreign.ForeignPtr
import Foreign.ForeignPtr.Unsafe
import Foreign.Ptr
import Foreign.C.Types ( CChar )
import Foreign.C.String
import Foreign.Marshal.Alloc (mallocBytes)
import qualified Foreign.Marshal.Alloc as Alloc (free)
import Data.Bits
import GHC.Base ( Int(..), Int#, getTag )
infixl 5 .+.
foreignPtrToPtr = unsafeForeignPtrToPtr
marshallInt :: Int -> IO Int
marshallInt x = return x
unmarshallInt :: Int -> IO Int
unmarshallInt x = return x
writeInt :: Ptr Int -> Int -> IO ()
writeInt ptr v = poke ptr v
readInt :: Ptr Int -> IO Int
readInt ptr = peek ptr
sizeofInt :: Word32
sizeofInt = fromIntegral (sizeOf (0 :: Int))
--Int8
marshallInt8 :: Int8 -> IO Int8
marshallInt8 v = return v
unmarshallInt8 :: Int8 -> IO Int8
unmarshallInt8 v = return v
writeInt8 :: Ptr Int8 -> Int8 -> IO ()
writeInt8 ptr v = poke ptr v
readInt8 :: Ptr Int8 -> IO Int8
readInt8 ptr = peek ptr
sizeofInt8 :: Word32
sizeofInt8 = fromIntegral (sizeOf (1 :: Int8))
--Int16
marshallInt16 :: Int16 -> IO Int16
marshallInt16 x = return x
unmarshallInt16 :: Int16 -> IO Int16
unmarshallInt16 x = return x
writeInt16 :: Ptr Int16 -> Int16 -> IO ()
writeInt16 ptr v = poke ptr v
readInt16 :: Ptr Int16 -> IO Int16
readInt16 ptr = peek ptr
sizeofInt16 :: Word32
sizeofInt16 = fromIntegral (sizeOf (0 :: Int16))
marshallInt32 :: Int32 -> IO Int32
marshallInt32 x = return x
unmarshallInt32 :: Int32 -> IO Int32
unmarshallInt32 x = return x
writeInt32 :: Ptr Int32 -> Int32 -> IO ()
writeInt32 ptr v = poke ptr v
readInt32 :: Ptr Int32 -> IO Int32
readInt32 ptr = peek ptr
sizeofInt32 :: Word32
sizeofInt32 = fromIntegral (sizeOf (0::Int32))
marshallInt64 :: Int64 -> IO Int64
marshallInt64 x = return x
unmarshallInt64 :: Int64 -> IO Int64
unmarshallInt64 x = return x
writeInt64 :: Ptr Int64 -> Int64 -> IO ()
readInt64 :: Ptr Int64 -> IO Int64
writeInt64 ptr v = poke ptr v
readInt64 ptr = peek ptr
sizeofInt64 :: Word32
sizeofInt64 = fromIntegral (sizeOf (0 :: Int64))
type Hyper = Int64
marshallHyper :: Hyper -> IO Int64
unmarshallHyper :: Int64 -> IO Hyper
writeHyper :: Ptr Hyper -> Hyper -> IO ()
readHyper :: Ptr Hyper -> IO Hyper
sizeofHyper :: Word32
marshallHyper = marshallInt64
unmarshallHyper = unmarshallInt64
writeHyper = writeInt64
readHyper = readInt64
sizeofHyper = fromIntegral (sizeOf (0 :: Int64))
writeInteger :: Ptr Integer -> Integer -> IO ()
writeInteger ptr x = writeInt64 (castPtr ptr) (fromIntegral x)
readInteger :: Ptr Integer -> IO Integer
readInteger ptr = do
x <- readInt64 (castPtr ptr)
return (fromIntegral x)
marshallInteger :: Integer -> IO (Int32, Int32)
marshallInteger i = return (fromInteger lo, fromInteger hi)
where
(hi,lo) = i `divMod` (toInteger (maxBound :: Int) + 1)
unmarshallInteger :: (Int32,Int32) -> IO Integer
unmarshallInteger (hi,lo) = return ((toInteger lo) + (toInteger hi) * (toInteger (maxBound :: Int) + 1))
marshallUInteger :: Integer -> IO (Int32, Int32)
marshallUInteger = marshallInteger
unmarshallUInteger :: (Int32,Int32) -> IO Integer
unmarshallUInteger = unmarshallInteger
readUInteger :: Ptr Integer -> IO Integer
readUInteger = readInteger
writeUInteger :: Ptr Integer -> Integer -> IO ()
writeUInteger = writeInteger
marshallChar :: Char -> IO Char
marshallChar x = return x
unmarshallChar :: Char -> IO Char
unmarshallChar x = return x
writeChar :: Ptr Char -> Char -> IO ()
writeChar ptr v = poke ((castPtr ptr) :: Ptr CChar) (castCharToCChar v)
readChar :: Ptr Char -> IO Char
readChar ptr = peek ((castPtr ptr) :: Ptr CChar) >>= return.castCCharToChar
sizeofChar :: Word32
sizeofChar = fromIntegral (sizeOf (undefined :: CChar))
type Wchar_t = Word16
marshallWchar_t :: Wchar_t -> IO Wchar_t
marshallWchar_t = marshallWord16
unmarshallWchar_t :: Wchar_t -> IO Wchar_t
unmarshallWchar_t = unmarshallWord16
writeWchar_t :: Ptr Wchar_t -> Wchar_t -> IO ()
writeWchar_t = writeWord16
readWchar_t :: Ptr Wchar_t -> IO Wchar_t
readWchar_t = readWord16
sizeofWchar_t :: Word32
sizeofWchar_t = fromIntegral (sizeOf (0::Word16))
type Octet = Byte
type Byte = Word8
marshallByte :: Byte -> IO Byte
marshallByte = marshallWord8
unmarshallByte :: Byte -> IO Byte
unmarshallByte = unmarshallWord8
writeByte :: Ptr Byte -> Byte -> IO ()
writeByte = writeWord8
readByte :: Ptr Byte -> IO Byte
readByte = readWord8
sizeofByte :: Word32
sizeofByte = fromIntegral (sizeOf (0::Word8))
--Words:
marshallWord8 :: Word8 -> IO Word8
marshallWord8 x = return x
unmarshallWord8 :: Word8 -> IO Word8
unmarshallWord8 x = return x
writeWord8 :: Ptr Word8 -> Word8 -> IO ()
writeWord8 ptr v = poke ptr v
readWord8 :: Ptr Word8 -> IO Word8
readWord8 ptr = peek ptr
sizeofWord8 :: Word32
sizeofWord8 = fromIntegral (sizeOf (undefined :: Word8))
marshallWord16 :: Word16 -> IO Word16
marshallWord16 x = return x
unmarshallWord16 :: Word16 -> IO Word16
unmarshallWord16 x = return x
writeWord16 :: Ptr Word16 -> Word16 -> IO ()
writeWord16 ptr v = poke ptr v
readWord16 :: Ptr Word16 -> IO Word16
readWord16 ptr = peek ptr
sizeofWord16 :: Word32
sizeofWord16 = fromIntegral (sizeOf (undefined :: Word16))
marshallWord32 :: Word32 -> IO Word32
marshallWord32 x = return x
unmarshallWord32 :: Word32 -> IO Word32
unmarshallWord32 x = return x
writeWord32 :: Ptr Word32 -> Word32 -> IO ()
writeWord32 ptr v = poke ptr v
readWord32 :: Ptr Word32 -> IO Word32
readWord32 ptr = peek ptr
sizeofWord32 :: Word32
sizeofWord32 = fromIntegral (sizeOf (undefined :: Word32))
marshallWord64 :: Word64 -> IO Word64
marshallWord64 x = return x
unmarshallWord64 :: Word64 -> IO Word64
unmarshallWord64 x = return x
writeWord64 :: Ptr Word64 -> Word64 -> IO ()
readWord64 :: Ptr Word64 -> IO Word64
writeWord64 p v = poke p v
readWord64 p = peek p
sizeofWord64 :: Word32
sizeofWord64 = fromIntegral (sizeOf (undefined :: Word64))
marshallDouble :: Double -> IO Double
marshallDouble x = return x
unmarshallDouble :: Double -> IO Double
unmarshallDouble x = return x
writeDouble :: Ptr Double -> Double -> IO ()
writeDouble ptr x = poke ptr x
readDouble :: Ptr Double -> IO Double
readDouble ptr = peek ptr
sizeofDouble :: Word32
sizeofDouble = fromIntegral (sizeOf (undefined :: Double))
writeFloat :: Ptr Float -> Float -> IO ()
writeFloat ptr x = poke ptr x
readFloat :: Ptr Float -> IO Float
readFloat ptr = peek ptr
sizeofFloat :: Word32
sizeofFloat = fromIntegral (sizeOf (undefined :: Float))
marshallBool :: Bool -> IO Int32
marshallBool v = marshallInt32 (if v then (1) else 0)
unmarshallBool :: Int32 -> IO Bool
unmarshallBool v = return (v /= 0)
writeBool :: Ptr Bool -> Bool -> IO ()
writeBool ptr v = writeInt32 (castPtr ptr) (if v then (1) else 0)
readBool :: Ptr Bool -> IO Bool
readBool ptr = do
v <- readInt32 (castPtr ptr)
return ( v /= 0 )
sizeofBool :: Word32
sizeofBool = fromIntegral (sizeOf (0 :: Int32))
addNCastPtr :: Ptr a -> Word32 -> Ptr b
addNCastPtr v off = v `plusPtr` (fromIntegral off)
derefPtr :: Ptr (Ptr a) -> IO (Ptr a)
derefPtr p = peek p
indexPtr :: Ptr (Ptr a) -> Int -> IO (Ptr a)
indexPtr p off = peekElemOff p off
allocOutPtr :: IO (Ptr a)
allocOutPtr = alloc 4
allocBytes :: Int -> IO (Ptr a)
allocBytes len = alloc (fromIntegral len)
allocWords :: Int -> IO (Ptr a)
allocWords len = alloc (4 * fromIntegral len)
alloc_malloc :: Word32 -> IO (Ptr a)
alloc_malloc s = mallocBytes (fromIntegral s)
free_malloc = Alloc.free
free = freeMemory
alloc :: Word32 -> IO (Ptr a)
alloc s = allocMemory s
doThenFree ::(Ptr a -> IO ()) -> (Ptr b -> IO c) -> Ptr d -> IO c
doThenFree f act ptr = do
v <- act (castPtr ptr)
f (castPtr ptr)
return v
trivialFree :: a -> IO ()
trivialFree _ = return ()
fillIn :: Int -> (Ptr a -> IO ()) -> IO (Ptr a)
fillIn sz refreemarshall = do
ptr <- allocBytes sz
refreemarshall ptr
return ptr
marshallPtr :: Ptr a -> IO (Ptr a)
marshallPtr v = return v
unmarshallPtr :: Ptr a -> IO (Ptr a)
unmarshallPtr v = return v
writePtr :: Ptr (Ptr a) -> Ptr a -> IO ()
writePtr a v = poke a v
readPtr :: Ptr a -> IO (Ptr b)
readPtr a = peek (castPtr a)
writefptr :: Ptr b -> ForeignPtr a -> IO ()
writefptr p v = poke (castPtr p) (foreignPtrToPtr v)
marshallunique :: (IO (Ptr a))
-> (Ptr a -> a -> IO ())
-> Maybe a
-> IO (Ptr a)
marshallunique allocRef marshallInto mb =
case mb of
Nothing -> return nullPtr
Just x -> marshallref allocRef marshallInto x
marshallMaybe :: (a -> IO b) -> b -> Maybe a -> IO b
marshallMaybe _mshall def Nothing = return def
marshallMaybe mshall _def (Just x) = mshall x
writeMaybe :: (Ptr a -> a -> IO ())
-> Ptr (Maybe a)
-> Maybe a
-> IO ()
writeMaybe _ ptr Nothing = writePtr (castPtr ptr) nullPtr
writeMaybe wr ptr (Just x) = wr (castPtr ptr) x
readMaybe :: (Ptr a -> IO b) -> Ptr a -> IO (Maybe b)
readMaybe rd ptr
| ptr == nullPtr = return Nothing
| otherwise = rd ptr >>= return . Just
writeunique :: IO (Ptr a)
-> (Ptr a -> a -> IO ())
-> Ptr (Maybe a)
-> Maybe a
-> IO ()
writeunique allocRef marshallInto p mb =
case mb of
Nothing -> writePtr (castPtr p) nullPtr
Just x -> writeref allocRef marshallInto (castPtr p) x
writeunique_fun :: IO (Ptr a)
-> (Ptr (Ptr a) -> a -> IO ())
-> Ptr (Maybe a)
-> Maybe a
-> IO ()
writeunique_fun allocRef marshallInto p mb =
case mb of
Nothing -> writePtr (castPtr p) nullPtr
Just x -> writeref allocRef (\ pv v -> marshallInto (castPtr pv) v) (castPtr p) x
unmarshallunique :: (Ptr a -> IO a) -> Ptr a -> IO (Maybe a)
unmarshallunique refUnmarshall ptr
| ptr == nullPtr = return Nothing
| otherwise = do
x <- unmarshallref refUnmarshall ptr
return (Just x)
readunique :: (Ptr a -> IO a) -> Ptr b -> IO (Maybe a)
readunique refUnmarshall ptr
| ptr == nullPtr = return Nothing
| otherwise = do
v <- readPtr (castPtr ptr)
if nullPtr == v then
return Nothing
else do
x <- refUnmarshall (castPtr v)
return (Just x)
freeunique :: (Ptr a -> IO ()) -> Ptr (Ptr a) -> IO ()
freeunique freeptee ptr
| ptr == nullPtr = return ()
| otherwise = do
ptr' <- derefPtr ptr
freeptee ptr'
free ptr
marshallunique_ptr :: Maybe (Ptr a) -> IO (Ptr a)
marshallunique_ptr mb =
case mb of
Nothing -> marshallPtr nullPtr
Just x -> marshallPtr x
marshallref :: (IO (Ptr a)) -> (Ptr a -> a -> IO ()) -> a -> IO (Ptr a)
marshallref allocRef marshallInto v = do
px <- allocRef
marshallInto px v
return px
writeref :: (IO (Ptr a)) -> (Ptr a -> a -> IO ()) -> Ptr (Ptr a) -> a -> IO ()
writeref allocRef marshallInto ptr v = do
px <- marshallref allocRef marshallInto v
writePtr ptr px
unmarshallref :: (Ptr a -> IO b) -> Ptr a -> IO b
unmarshallref refUnmarshall ptr = refUnmarshall ptr
readref :: (Ptr a -> IO a) -> Ptr (Ptr a) -> IO a
readref refUnmarshall ptr = do
px <- readPtr ptr
unmarshallref refUnmarshall (castPtr px)
freeref :: (Ptr b -> IO ()) -> Ptr a -> IO ()
freeref free_inner pptr = do
ptr <- readPtr (castPtr pptr)
free_inner ptr
free pptr
writeenum16 :: (b -> IO Int16) -> Ptr Int16 -> b -> IO ()
writeenum16 marshall pv v =
marshall v >>= \ x ->
writeInt16 pv x
readenum16 :: (Int16 -> IO a) -> Ptr (Int16) -> IO a
readenum16 unmarshall pv = do
v <- readInt16 pv
unmarshall v
marshallEnum16 :: Enum a => a -> IO Int16
marshallEnum16 v = return (fromIntegral (fromEnum v))
unmarshallEnum16 :: Enum a => Int16 -> IO a
unmarshallEnum16 x = return (toEnum (fromIntegral x))
marshallEnum32 :: Enum a => a -> IO Int32
marshallEnum32 v = return (fromIntegral (fromEnum v))
unmarshallEnum32 :: Enum a => Int32 -> IO a
unmarshallEnum32 x = return (toEnum (fromIntegral x))
writeEnum32 :: Enum a => Ptr b -> a -> IO ()
writeEnum32 p v = writeInt32 (castPtr p) (fromIntegral (fromEnum v))
readEnum32 :: Enum a => Ptr b -> IO a
readEnum32 p = do
x <- readInt32 (castPtr p)
return (toEnum (fromIntegral x))
writeEnum16 :: Enum a => Ptr b -> a -> IO ()
writeEnum16 p v = writeInt16 (castPtr p) (fromIntegral (fromEnum v))
readEnum16 :: Enum a => Ptr b -> IO a
readEnum16 p = do
x <- readInt16 (castPtr p)
return (toEnum (fromIntegral x))
marshalllist :: Word32
-> (Ptr a -> a -> IO ())
-> [a]
-> IO (Ptr b)
marshalllist szof writeelt ls = do
arr <- alloc (len*szof)
foldM writeElt (castPtr arr) ls
return (castPtr arr)
where
len = fromIntegral (length ls)
writeElt addr v = do
writeelt addr v
return (addNCastPtr addr szof)
unmarshalllist :: Word32 -> Word32 -> Word32 -> (Ptr any -> IO a) -> Ptr b -> IO [a]
unmarshalllist szof offset len unpack ptr = do
let ptr0 = addNCastPtr ptr (offset*szof)
loop ptr0 len
where
loop _ 0 = return []
loop p n = do
v <- unpack p
let p' = addNCastPtr p szof
vs <- loop p' (n1)
return (v:vs)
unmarshallSingle :: (Ptr a -> IO a) -> Ptr a -> IO [a]
unmarshallSingle ref ptr
| ptr == nullPtr = return []
| otherwise = do
x <- ref ptr
return [x]
writelist :: Bool -> Word32 -> (Ptr a -> a -> IO ()) -> Ptr [a] -> [a] -> IO ()
writelist do_alloc szof writeelt pptr ls = do
the_ptr <-
(if do_alloc then do
ptr <- alloc (szof * fromIntegral len)
writePtr (castPtr pptr) ptr
return (castPtr ptr)
else
return (castPtr pptr))
foldM writeElt the_ptr ls
return ()
where
len = length ls
writeElt addr v = do
writeelt addr v
return (addNCastPtr addr szof)
readlist :: Word32 -> Word32 -> (Ptr a -> IO a) -> Ptr [a] -> IO [a]
readlist szof len unpack ptr = do
let ptr0 = castPtr ptr
loop ptr0 len
where
loop _ 0 = return []
loop p n = do
v <- unpack p
let p' = addNCastPtr p szof
vs <- loop p' (n1)
return (v:vs)
freelist :: Word32 -> Word32 -> (Ptr a -> IO ()) -> Ptr [a] -> IO ()
freelist szof len free_elt ptr = do
go (castPtr ptr) len
free ptr
where
go _pptr 0 = return ()
go pptr x = do
p <- readPtr pptr
free_elt p
let pptr' = addNCastPtr pptr szof
go pptr' (x1)
marshallString :: String -> IO (Ptr String)
marshallString str = do
pstr <- alloc (len*sizeofChar)
pstr' <- foldM writeElt (castPtr pstr) str
writeChar (castPtr pstr') '\0'
return pstr
where
len = fromIntegral (length str + 1)
writeElt addr v = do
writeChar addr v
return (addNCastPtr addr sizeofChar)
marshallBString :: Int -> String -> IO (Ptr String)
marshallBString len str = do
pstr <- alloc (len'*sizeofChar)
pstr' <- foldM writeElt (castPtr pstr) (take len str)
writeChar (castPtr pstr') '\0'
return pstr
where
len' = fromIntegral (len + 1)
writeElt addr v = do
writeChar addr v
return (addNCastPtr addr sizeofChar)
unmarshallString :: Ptr String -> IO String
unmarshallString ptr
| ptr == nullPtr = return ""
| otherwise = do
let ptr0 = addNCastPtr ptr 0
loop ptr0
where
loop p = do
v <- readChar p
if v == '\0'
then return []
else do
let p' = addNCastPtr p sizeofChar
vs <- loop p'
return (v:vs)
unmarshallBString :: Int -> Ptr String -> IO String
unmarshallBString len ptr
| ptr == nullPtr = return ""
| otherwise = do
let ptr0 = addNCastPtr ptr 0
loop ptr0 0
where
loop _ n | n > len = return ""
loop p n = do
v <- readChar p
if v == '\0'
then return []
else do
let p' = addNCastPtr p sizeofChar
vs <- loop p' (n+1)
return (v:vs)
readString :: Ptr (Ptr String) -> IO String
readString pstr = do
ptr <- readPtr pstr
unmarshallString ptr
readBString :: Int -> Ptr (Ptr String) -> IO String
readBString len pstr = do
ptr <- readPtr pstr
unmarshallBString len ptr
writeString :: Bool -> Ptr String -> String -> IO ()
writeString do_alloc ppstr str = do
pstr <-
if not do_alloc then
return (castPtr ppstr)
else do
arr <- alloc (fromIntegral string_len)
writePtr (castPtr ppstr) arr
return arr
pstr' <- foldM writeElt (castPtr pstr) str
writeChar (castPtr pstr') '\0'
where
string_len = length str + 1
writeElt addr v = do
writeChar addr v
return (addNCastPtr addr sizeofChar)
writeBString :: Bool -> Int -> Ptr a -> String -> IO ()
writeBString do_alloc len ptr str = do
pstr <-
if do_alloc then
alloc (fromIntegral len * sizeofChar)
else
return (castPtr ptr)
pstr' <- foldM writeElt pstr (take len str)
writeChar pstr' '\0'
where
writeElt addr v = do
writeChar addr v
return (addNCastPtr addr sizeofChar)
freeString :: Ptr String -> IO ()
freeString = free
marshallSequence :: (Ptr a -> a -> IO ())
-> (Ptr a -> IO ())
-> Word32
-> Maybe Word32
-> [a]
-> IO (Ptr a)
marshallSequence wElt wTermin szElt mbLen ls = do
pseq <- alloc (len*szElt)
pseq' <- foldM writeElt pseq the_ls
wTermin pseq'
return pseq'
where
(len, the_ls) =
case mbLen of
Nothing -> (fromIntegral (length ls + 1), ls)
Just x -> (x + 1, take (fromIntegral x) ls)
writeElt addr v = do
wElt addr v
return (addNCastPtr addr szElt)
unmarshallSequence :: ( Eq a )
=> (Ptr (Ptr a) -> IO a)
-> (Ptr (Ptr a) -> IO Bool)
-> Word32
-> Maybe Word32
-> Ptr (Ptr a)
-> IO [a]
unmarshallSequence rElt termPred szElt mbLen ptr
| ptr == nullPtr = return []
| otherwise = do
let ptr0 = addNCastPtr ptr 0
loop 0 ptr0
where
lenPred =
case mbLen of
Nothing -> const False
Just x -> \ y -> y >= x
loop len p = do
flg <- termPred p
if flg || (lenPred len)
then return []
else do
v <- rElt p
let p' = addNCastPtr p szElt
vs <- loop (len+1) p'
return (v:vs)
readSequence :: ( Eq a )
=> (Ptr (Ptr a) -> IO a)
-> (Ptr (Ptr a) -> IO Bool)
-> Word32
-> Maybe Word32
-> Ptr (Ptr a)
-> IO [a]
readSequence rElt termPred szElt mbLen ptr = do
ptr' <- readPtr ptr
unmarshallSequence rElt termPred szElt mbLen (castPtr ptr')
writeSequence :: ( Eq a )
=> Bool
-> (Ptr a -> a -> IO ())
-> (Ptr a -> IO ())
-> Word32
-> Maybe Word32
-> Ptr a
-> [a]
-> IO ()
writeSequence do_alloc wElt wTermin szElt mbLen ppseq ls = do
pseq <-
if not do_alloc then
return (castPtr ppseq)
else do
arr <- alloc (szElt * seq_len)
writePtr (castPtr ppseq) arr
return arr
pseq' <- foldM writeElt pseq the_ls
wTermin pseq'
where
(seq_len, the_ls) =
case mbLen of
Nothing -> (fromIntegral (length ls + 1), ls)
Just x -> (x + 1, take (fromIntegral x) ls)
writeElt addr v = do
wElt addr v
return (addNCastPtr addr szElt)
freeSequence :: Ptr a -> IO ()
freeSequence = free
marshallblist :: Word32 -> Word32 -> (Ptr a -> a -> IO ()) -> [a] -> IO (Ptr [a])
marshallblist szof l writeelt ls = do
arr <- alloc (l'*szof)
foldM writeElt (castPtr arr) ls
return arr
where
l' = atLeast l (fromIntegral (0::Int)) ls
atLeast len n _ | len == n = len
atLeast _len n [] = n
atLeast len n (_:xs) = atLeast len (n+1) xs
writeElt addr v = do
writeelt addr v
return (addNCastPtr addr szof)
writeblist :: Word32 -> Word32 -> (Ptr a -> a -> IO ()) -> Ptr [a] -> [a] -> IO ()
writeblist szof len writeelt ptr ls = do
foldM writeElt (castPtr ptr) (take (fromIntegral len) ls)
return ()
where
writeElt addr v = do
writeelt addr v
return (addNCastPtr addr szof)
readblist :: Word32 -> Word32 -> (Ptr a -> IO a) -> Ptr a -> IO [a]
readblist szof len unpack ptr = do
let ptr0 = castPtr ptr
loop ptr0 len
where
loop _p 0 = return []
loop p n = do
v <- unpack p
let p' = addNCastPtr p szof
vs <- loop p' (n1)
return (v:vs)
word16ToInt32 :: Word16 -> Int32
word16ToInt32 w = fromIntegral w
word32ToInt32 :: Word32 -> Int32
word32ToInt32 w = fromIntegral w
int32ToWord32 :: Int32 -> Word32
int32ToWord32 w = fromIntegral w
int16ToWord32 :: Int16 -> Word32
int16ToWord32 w = fromIntegral w
intToChar :: Int -> Char
intToChar = chr
charToInt32 :: Char -> Int32
charToInt32 c = fromIntegral (ord c)
word32ToChar :: Word32 -> Char
word32ToChar w = chr (fromIntegral w)
charToWord32 :: Char -> Word32
charToWord32 c = fromIntegral (ord c)
toInt32 :: Integral a => a -> Int32
toInt32 i = fromIntegral i
toInt16 :: Integral a => a -> Int16
toInt16 i = fromIntegral i
marshallFO :: ForeignPtr a -> IO (ForeignPtr a)
marshallFO x = return x
unmarshallFO :: ForeignPtr a -> IO (ForeignPtr a)
unmarshallFO x = return x
writeFO :: Ptr (ForeignPtr a) -> ForeignPtr a -> IO ()
writeFO ptr fo = poke (castPtr ptr) (foreignPtrToPtr fo)
sizeofForeignPtr :: Word32
sizeofForeignPtr = sizeofPtr
nullFinaliser :: FunPtr (Ptr a -> IO ())
nullFinaliser = castFunPtr (castPtrToFunPtr finalNoFree)
nullFO :: ForeignPtr a
nullFO = unsafePerformIO $ makeFO nullPtr nullFinaliser
readStablePtr :: Ptr (StablePtr a) -> IO (StablePtr a)
readStablePtr ptr = peek ptr
marshallStruct :: String -> a -> IO b
marshallStruct nm _ = ioError (userError (nm ++ ": Marshalling structs by value is not supported yet."))
unmarshallStruct :: String -> a -> IO c
unmarshallStruct nm _ = ioError (userError (nm ++ ": Unmarshalling structs by value is not supported yet."))
marshallUnion :: String -> a -> IO b
marshallUnion nm _ = ioError (userError (nm ++ ": Marshalling unions by value is not supported yet."))
unmarshallUnion :: String -> a -> b -> IO c
unmarshallUnion nm _ _ = ioError (userError (nm ++ ": Unmarshalling unions by value is not supported yet."))
marshallPointer :: Ptr a -> IO (Ptr a)
marshallPointer p = return p
unmarshallPointer :: Ptr a -> IO (Ptr a)
unmarshallPointer ptr = return ptr
writePointer :: Ptr (Ptr a) -> Ptr a -> IO ()
writePointer = poke
readPointer :: Ptr (Ptr a) -> IO (Ptr a)
readPointer ptr = peek ptr
sizeofPtr :: Word32
sizeofPtr = fromIntegral (sizeOf (undefined :: Foreign.Ptr.Ptr ()))
primInvokeIt :: (Ptr b -> Ptr a -> IO c) -> Int -> IO (Ptr a) -> IO c
primInvokeIt meth offset mk_obj_ptr = do
obj_ptr <- mk_obj_ptr
lpVtbl <- derefPtr (castPtr obj_ptr)
methPtr <- indexPtr lpVtbl offset
meth methPtr obj_ptr
primInvokeItFO :: (Ptr b -> Ptr a -> IO c) -> Int -> IO (ForeignPtr a) -> IO c
primInvokeItFO meth offset mk_obj_ptr = do
obj_ptr <- mk_obj_ptr
lpVtbl <- peek (foreignPtrToPtr (castForeignPtr obj_ptr))
methPtr <- indexPtr lpVtbl offset
withForeignPtr obj_ptr (\ optr -> meth methPtr optr)
stackStringLen :: Int -> String -> (Ptr String -> IO a) -> IO a
stackStringLen len str f
= let slen = length str + 1 `max` len
in stackFrame (fromIntegral slen) $ \pstr -> do
writeString False pstr str
f pstr
enumToFlag :: Enum a => a -> Int
enumToFlag tg = fromIntegral ((1::Word32) `shiftL` enumToInt tg)
enumToInt :: Enum a => a -> Int
enumToInt tg = I# (getTag tg)
flagToIntTag :: Int -> Int
flagToIntTag f | f < 0 = error "flagToIntTag: negative tag"
| otherwise = go 0 f
where
go n 0 = n
go n 1 = n + 1
go n x = go (n + 1) (x `div` 2)
unboxInt :: Int -> Int#
unboxInt (I# x#) = x#
toIntFlag :: Int -> Int -> Int
toIntFlag b v = fromIntegral ((1::Word32) `shiftL` (v + flagToIntTag b))
pow2Series :: Int -> Int32 -> [Int32]
pow2Series len start = take len (iterate double start)
where
double x
| x == 0 = 1
| otherwise = 2*x
orList :: [Int] -> Int
orList ls = fromIntegral (foldl (\ acc x -> (fromIntegral x) .|. acc) (0::Int32) ls)
orFlags :: (Num a,Flags a) => [a] -> a
orFlags ls = foldl (.+.) 0 ls
class Flags a where
(.+.) :: a -> a -> a