X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=Foreign%2FMarshal%2FUtils.hs;h=5ae677a19d05e37e568c3a938159cc5c2a59540e;hb=41e8fba828acbae1751628af50849f5352b27873;hp=08bee23a8bb4f8a341bab74f52227b4cd8c0c71f;hpb=6e9831fee1a4f0523bccf3ff8873fc9677f871d6;p=ghc-base.git diff --git a/Foreign/Marshal/Utils.hs b/Foreign/Marshal/Utils.hs index 08bee23..5ae677a 100644 --- a/Foreign/Marshal/Utils.hs +++ b/Foreign/Marshal/Utils.hs @@ -1,4 +1,5 @@ -{-# OPTIONS -fno-implicit-prelude #-} +{-# LANGUAGE CPP, NoImplicitPrelude, ForeignFunctionInterface #-} + ----------------------------------------------------------------------------- -- | -- Module : Foreign.Marshal.Utils @@ -24,16 +25,16 @@ module Foreign.Marshal.Utils ( -- ** Marshalling of Boolean values (non-zero corresponds to 'True') -- fromBool, -- :: Num a => Bool -> a - toBool, -- :: Num a => a -> Bool + toBool, -- :: Num a => a -> Bool -- ** Marshalling of Maybe values -- maybeNew, -- :: ( a -> IO (Ptr a)) - -- -> (Maybe a -> IO (Ptr a)) + -- -> (Maybe a -> IO (Ptr a)) maybeWith, -- :: ( a -> (Ptr b -> IO c) -> IO c) - -- -> (Maybe a -> (Ptr b -> IO c) -> IO c) + -- -> (Maybe a -> (Ptr b -> IO c) -> IO c) maybePeek, -- :: (Ptr a -> IO b ) - -- -> (Ptr a -> IO (Maybe b)) + -- -> (Ptr a -> IO (Maybe b)) -- ** Marshalling lists of storable objects -- @@ -44,29 +45,34 @@ module Foreign.Marshal.Utils ( -- copyBytes, -- :: Ptr a -> Ptr a -> Int -> IO () moveBytes, -- :: Ptr a -> Ptr a -> Int -> IO () - - -- ** DEPRECATED FUNCTIONS (don\'t use; they may disappear at any time) - -- - withObject -- :: Storable a => a -> (Ptr a -> IO b) -> IO b ) where import Data.Maybe +import Foreign.Ptr ( Ptr, nullPtr ) +import Foreign.Storable ( Storable(poke) ) +import Foreign.C.Types ( CSize ) +import Foreign.Marshal.Alloc ( malloc, alloca ) #ifdef __GLASGOW_HASKELL__ -import Foreign.Ptr ( Ptr, nullPtr ) -import GHC.Storable ( Storable(poke) ) -import Foreign.C.TypesISO ( CSize ) -import Foreign.Marshal.Alloc ( malloc, alloca ) -import GHC.IOBase -import GHC.Real ( fromIntegral ) +import GHC.Real ( fromIntegral ) import GHC.Num import GHC.Base #endif +#ifdef __NHC__ +import Foreign.C.Types ( CInt(..) ) +#endif + -- combined allocation and marshalling -- ----------------------------------- --- |Allocate storage for a value and marshal it into this storage +-- |Allocate a block of memory and marshal a value into it +-- (the combination of 'malloc' and 'poke'). +-- The size of the area allocated is determined by the 'Foreign.Storable.sizeOf' +-- method from the instance of 'Storable' for the appropriate type. +-- +-- The memory may be deallocated using 'Foreign.Marshal.Alloc.free' or +-- 'Foreign.Marshal.Alloc.finalizerFree' when no longer required. -- new :: Storable a => a -> IO (Ptr a) new val = @@ -75,9 +81,12 @@ new val = poke ptr val return ptr --- |Allocate temporary storage for a value and marshal it into this storage +-- |@'with' val f@ executes the computation @f@, passing as argument +-- a pointer to a temporarily allocated block of memory into which +-- @val@ has been marshalled (the combination of 'alloca' and 'poke'). -- --- * see the life time constraints imposed by 'alloca' +-- The memory is freed when @f@ terminates (either normally or via an +-- exception), so the pointer passed to @f@ must /not/ be used after this. -- with :: Storable a => a -> (Ptr a -> IO b) -> IO b with val f = @@ -86,12 +95,6 @@ with val f = res <- f ptr return res --- old DEPRECATED name (don't use; may disappear at any time) --- -withObject :: Storable a => a -> (Ptr a -> IO b) -> IO b -{-# DEPRECATED withObject "use `with' instead" #-} -withObject = with - -- marshalling of Boolean values (non-zero corresponds to 'True') -- ----------------------------- @@ -111,19 +114,19 @@ toBool = (/= 0) -- marshalling of Maybe values -- --------------------------- --- |Allocate storage and marshall a storable value wrapped into a 'Maybe' +-- |Allocate storage and marshal a storable value wrapped into a 'Maybe' -- -- * the 'nullPtr' is used to represent 'Nothing' -- maybeNew :: ( a -> IO (Ptr a)) - -> (Maybe a -> IO (Ptr a)) + -> (Maybe a -> IO (Ptr a)) maybeNew = maybe (return nullPtr) --- |Converts a @withXXX@ combinator into one marshalling a value wrapped into a --- 'Maybe' +-- |Converts a @withXXX@ combinator into one marshalling a value wrapped +-- into a 'Maybe', using 'nullPtr' to represent 'Nothing'. -- maybeWith :: ( a -> (Ptr b -> IO c) -> IO c) - -> (Maybe a -> (Ptr b -> IO c) -> IO c) + -> (Maybe a -> (Ptr b -> IO c) -> IO c) maybeWith = maybe ($ nullPtr) -- |Convert a peek combinator into a one returning 'Nothing' if applied to a @@ -131,7 +134,7 @@ maybeWith = maybe ($ nullPtr) -- maybePeek :: (Ptr a -> IO b) -> Ptr a -> IO (Maybe b) maybePeek peek ptr | ptr == nullPtr = return Nothing - | otherwise = do a <- peek ptr; return (Just a) + | otherwise = do a <- peek ptr; return (Just a) -- marshalling lists of storable objects @@ -141,12 +144,12 @@ maybePeek peek ptr | ptr == nullPtr = return Nothing -- marshalled objects -- withMany :: (a -> (b -> res) -> res) -- withXXX combinator for one object - -> [a] -- storable objects - -> ([b] -> res) -- action on list of marshalled obj.s - -> res + -> [a] -- storable objects + -> ([b] -> res) -- action on list of marshalled obj.s + -> res withMany _ [] f = f [] withMany withFoo (x:xs) f = withFoo x $ \x' -> - withMany withFoo xs (\xs' -> f (x':xs')) + withMany withFoo xs (\xs' -> f (x':xs')) -- Haskellish interface to memcpy and memmove @@ -156,13 +159,15 @@ withMany withFoo (x:xs) f = withFoo x $ \x' -> -- first (destination); the copied areas may /not/ overlap -- copyBytes :: Ptr a -> Ptr a -> Int -> IO () -copyBytes dest src size = memcpy dest src (fromIntegral size) +copyBytes dest src size = do _ <- memcpy dest src (fromIntegral size) + return () --- |Copies the given number of elements from the second area (source) into the +-- |Copies the given number of bytes from the second area (source) into the -- first (destination); the copied areas /may/ overlap -- moveBytes :: Ptr a -> Ptr a -> Int -> IO () -moveBytes dest src size = memmove dest src (fromIntegral size) +moveBytes dest src size = do _ <- memmove dest src (fromIntegral size) + return () -- auxilliary routines @@ -170,5 +175,5 @@ moveBytes dest src size = memmove dest src (fromIntegral size) -- |Basic C routines needed for memory copying -- -foreign import ccall unsafe memcpy :: Ptr a -> Ptr a -> CSize -> IO () -foreign import ccall unsafe memmove :: Ptr a -> Ptr a -> CSize -> IO () +foreign import ccall unsafe "string.h" memcpy :: Ptr a -> Ptr a -> CSize -> IO (Ptr a) +foreign import ccall unsafe "string.h" memmove :: Ptr a -> Ptr a -> CSize -> IO (Ptr a)