{-# LANGUAGE CPP #-}
{-# LANGUAGE RoleAnnotations #-}
module Foreign.SharedObjectName.Internal
( SOName (..), hPutSOName, hGetSOName, unsafeWithSOName
, genSOName, newEmptySOName
) where
import Foreign.C.String
import Foreign.C.Types
import Foreign.ForeignPtr
import Foreign.ForeignPtr.Unsafe
import Foreign.Ptr
import Foreign.Storable
import System.IO
import System.IO.Unsafe
#define HS_IMPORT_CONSTANTS_ONLY
#include "SharedObjectName.h"
#include "MachDeps.h"
newtype SOName a = SOName (ForeignPtr CChar)
type role SOName phantom
instance Show (SOName a) where
showsPrec d (SOName a)
= showParen (d >= 10) $ showString "SOName " . showsPrec 10 getstr
where
getstr = unsafePerformIO $ withForeignPtr a peekCString
{-# NOINLINE getstr #-}
instance Eq (SOName a) where
(SOName a) == (SOName b)
= cmpCStrings (unsafeForeignPtrToPtr a) (unsafeForeignPtrToPtr b) == EQ
instance Ord (SOName a) where
compare (SOName a) (SOName b)
= cmpCStrings (unsafeForeignPtrToPtr a) (unsafeForeignPtrToPtr b)
instance Storable (SOName a) where
sizeOf _ = SHARED_OBJECT_NAME_LENGTH
alignment _ = SIZEOF_HSWORD
poke p (SOName qp) = withForeignPtr qp
$ \q -> c_memcpy p q SHARED_OBJECT_NAME_LENGTH
peek p = do
qp <- mallocForeignPtrBytes SHARED_OBJECT_NAME_LENGTH
withForeignPtr qp
$ \q -> c_memcpy q p SHARED_OBJECT_NAME_LENGTH
return $ SOName qp
hPutSOName :: Handle -> SOName a -> IO ()
hPutSOName h (SOName q)
= withForeignPtr q $ flip (hPutBuf h) SHARED_OBJECT_NAME_LENGTH
hGetSOName :: Handle -> IO (Maybe (SOName a))
hGetSOName h = do
let n = SHARED_OBJECT_NAME_LENGTH
q <- mallocForeignPtrBytes n
n' <- withForeignPtr q $ \p -> hGetBuf h p n
return $
if n' < n
then Nothing
else Just (SOName q)
genSOName :: IO (SOName a)
genSOName = do
fp <- mallocForeignPtrBytes SHARED_OBJECT_NAME_LENGTH
withForeignPtr fp c_genSharedObjectName
return $ SOName fp
newEmptySOName :: IO (SOName a)
newEmptySOName = SOName <$> mallocForeignPtrBytes SHARED_OBJECT_NAME_LENGTH
unsafeWithSOName :: SOName a -> (CString -> IO b) -> IO b
unsafeWithSOName (SOName fp) = withForeignPtr fp
cmpCStrings :: CString -> CString -> Ordering
cmpCStrings a b
| a == b = EQ
| otherwise = c_strcmp a b `compare` 0
foreign import ccall unsafe "strcmp"
c_strcmp :: CString -> CString -> CInt
foreign import ccall unsafe "memcpy"
c_memcpy :: Ptr a -> Ptr b -> CInt -> IO ()
foreign import ccall unsafe "genSharedObjectName"
c_genSharedObjectName :: CString -> IO ()