{-# LANGUAGE CPP             #-}
{-# LANGUAGE RoleAnnotations #-}
-- | Exposed internals of `Foreign.SharedObjectName`.
--
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
import           Text.Read

#define HS_IMPORT_CONSTANTS_ONLY
#include "MachDeps.h"
#include "common.h"

-- | Reference to a shared object; can be sent to other processes.
newtype SOName a = SOName (ForeignPtr CChar)
type role SOName phantom

instance Show (SOName a) where
    showsPrec :: Int -> SOName a -> ShowS
showsPrec Int
d (SOName ForeignPtr CChar
a)
      = Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
10) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String -> ShowS
showString String
"SOName " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
10 String
getstr
      where
        getstr :: String
getstr = IO String -> String
forall a. IO a -> a
unsafePerformIO (IO String -> String) -> IO String -> String
forall a b. (a -> b) -> a -> b
$ ForeignPtr CChar -> (Ptr CChar -> IO String) -> IO String
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr CChar
a Ptr CChar -> IO String
peekCAString
        {-# NOINLINE getstr #-}

instance Read (SOName a) where
    readPrec :: ReadPrec (SOName a)
readPrec = ReadPrec (SOName a) -> ReadPrec (SOName a)
forall a. ReadPrec a -> ReadPrec a
parens (ReadPrec (SOName a) -> ReadPrec (SOName a))
-> ReadPrec (SOName a) -> ReadPrec (SOName a)
forall a b. (a -> b) -> a -> b
$ Int -> ReadPrec (SOName a) -> ReadPrec (SOName a)
forall a. Int -> ReadPrec a -> ReadPrec a
prec Int
10 (ReadPrec (SOName a) -> ReadPrec (SOName a))
-> ReadPrec (SOName a) -> ReadPrec (SOName a)
forall a b. (a -> b) -> a -> b
$ do
        Ident String
"SOName" <- ReadPrec Lexeme
lexP
        String
s <- ReadPrec String -> ReadPrec String
forall a. ReadPrec a -> ReadPrec a
step ReadPrec String
forall a. Read a => ReadPrec a
readPrec
        SOName a -> ReadPrec (SOName a)
forall (m :: * -> *) a. Monad m => a -> m a
return (SOName a -> ReadPrec (SOName a))
-> SOName a -> ReadPrec (SOName a)
forall a b. (a -> b) -> a -> b
$ String -> SOName a
forall a. String -> SOName a
putstr String
s
      where
        writeStr :: String -> Int -> Ptr CChar -> IO ()
writeStr [] Int
n     Ptr CChar
ptr
          = Ptr CChar -> Int -> CChar -> IO ()
forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr CChar
ptr Int
n CChar
0 -- put end of string character
        writeStr (Char
c:String
cs) Int
n Ptr CChar
ptr
          = Ptr CChar -> Int -> CChar -> IO ()
forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr CChar
ptr Int
n (Char -> CChar
castCharToCChar Char
c) IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Int -> Ptr CChar -> IO ()
writeStr String
cs (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Ptr CChar
ptr
        putstr :: String -> SOName a
putstr String
s = IO (SOName a) -> SOName a
forall a. IO a -> a
unsafePerformIO (IO (SOName a) -> SOName a) -> IO (SOName a) -> SOName a
forall a b. (a -> b) -> a -> b
$ do
          SOName a
n <- IO (SOName a)
forall a. IO (SOName a)
newEmptySOName
          SOName a -> (Ptr CChar -> IO ()) -> IO ()
forall a b. SOName a -> (Ptr CChar -> IO b) -> IO b
unsafeWithSOName SOName a
n ((Ptr CChar -> IO ()) -> IO ()) -> (Ptr CChar -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Int -> Ptr CChar -> IO ()
writeStr String
s Int
0
          SOName a -> IO (SOName a)
forall (m :: * -> *) a. Monad m => a -> m a
return SOName a
n
        {-# NOINLINE putstr #-}

instance Eq (SOName a) where
    (SOName ForeignPtr CChar
a) == :: SOName a -> SOName a -> Bool
== (SOName ForeignPtr CChar
b)
      = Ptr CChar -> Ptr CChar -> Ordering
cmpCStrings (ForeignPtr CChar -> Ptr CChar
forall a. ForeignPtr a -> Ptr a
unsafeForeignPtrToPtr ForeignPtr CChar
a) (ForeignPtr CChar -> Ptr CChar
forall a. ForeignPtr a -> Ptr a
unsafeForeignPtrToPtr ForeignPtr CChar
b) Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
EQ

instance Ord (SOName a) where
    compare :: SOName a -> SOName a -> Ordering
compare (SOName ForeignPtr CChar
a) (SOName ForeignPtr CChar
b)
      = Ptr CChar -> Ptr CChar -> Ordering
cmpCStrings (ForeignPtr CChar -> Ptr CChar
forall a. ForeignPtr a -> Ptr a
unsafeForeignPtrToPtr ForeignPtr CChar
a) (ForeignPtr CChar -> Ptr CChar
forall a. ForeignPtr a -> Ptr a
unsafeForeignPtrToPtr ForeignPtr CChar
b)

instance Storable (SOName a) where
    sizeOf :: SOName a -> Int
sizeOf SOName a
_ = SHARED_OBJECT_NAME_LENGTH
    alignment :: SOName a -> Int
alignment SOName a
_ = SIZEOF_HSWORD
    poke :: Ptr (SOName a) -> SOName a -> IO ()
poke Ptr (SOName a)
p (SOName ForeignPtr CChar
qp) = ForeignPtr CChar -> (Ptr CChar -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr CChar
qp
        ((Ptr CChar -> IO ()) -> IO ()) -> (Ptr CChar -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr CChar
q -> Ptr (SOName a) -> Ptr CChar -> CInt -> IO ()
forall a b. Ptr a -> Ptr b -> CInt -> IO ()
c_memcpy Ptr (SOName a)
p Ptr CChar
q SHARED_OBJECT_NAME_LENGTH
    peek :: Ptr (SOName a) -> IO (SOName a)
peek Ptr (SOName a)
p = do
      ForeignPtr CChar
qp <- Int -> IO (ForeignPtr CChar)
forall a. Int -> IO (ForeignPtr a)
mallocForeignPtrBytes SHARED_OBJECT_NAME_LENGTH
      ForeignPtr CChar -> (Ptr CChar -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr CChar
qp
        ((Ptr CChar -> IO ()) -> IO ()) -> (Ptr CChar -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr CChar
q -> Ptr CChar -> Ptr (SOName a) -> CInt -> IO ()
forall a b. Ptr a -> Ptr b -> CInt -> IO ()
c_memcpy Ptr CChar
q Ptr (SOName a)
p SHARED_OBJECT_NAME_LENGTH
      SOName a -> IO (SOName a)
forall (m :: * -> *) a. Monad m => a -> m a
return (SOName a -> IO (SOName a)) -> SOName a -> IO (SOName a)
forall a b. (a -> b) -> a -> b
$ ForeignPtr CChar -> SOName a
forall a. ForeignPtr CChar -> SOName a
SOName ForeignPtr CChar
qp

-- | Write a shared object name into somwhere referenced by a handle.
--   Useful for sending references to other processes via pipes.
hPutSOName :: Handle -> SOName a -> IO ()
hPutSOName :: Handle -> SOName a -> IO ()
hPutSOName Handle
h (SOName ForeignPtr CChar
q)
    = ForeignPtr CChar -> (Ptr CChar -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr CChar
q ((Ptr CChar -> IO ()) -> IO ()) -> (Ptr CChar -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ (Ptr CChar -> Int -> IO ()) -> Int -> Ptr CChar -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Handle -> Ptr CChar -> Int -> IO ()
forall a. Handle -> Ptr a -> Int -> IO ()
hPutBuf Handle
h) SHARED_OBJECT_NAME_LENGTH

-- | Read a shared object name from somwhere referenced by a handle.
--   Returns @Nothing@ if @hGetBuf@ gets less than @SHARED_OBJECT_NAME_LENGTH@ bytes.
--   Useful for sending references to other processes via pipes.
hGetSOName :: Handle -> IO (Maybe (SOName a))
hGetSOName :: Handle -> IO (Maybe (SOName a))
hGetSOName Handle
h = do
    let n :: Int
n = SHARED_OBJECT_NAME_LENGTH
    ForeignPtr CChar
q <- Int -> IO (ForeignPtr CChar)
forall a. Int -> IO (ForeignPtr a)
mallocForeignPtrBytes Int
n
    Int
n' <- ForeignPtr CChar -> (Ptr CChar -> IO Int) -> IO Int
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr CChar
q ((Ptr CChar -> IO Int) -> IO Int)
-> (Ptr CChar -> IO Int) -> IO Int
forall a b. (a -> b) -> a -> b
$ \Ptr CChar
p -> Handle -> Ptr CChar -> Int -> IO Int
forall a. Handle -> Ptr a -> Int -> IO Int
hGetBuf Handle
h Ptr CChar
p Int
n
    Maybe (SOName a) -> IO (Maybe (SOName a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (SOName a) -> IO (Maybe (SOName a)))
-> Maybe (SOName a) -> IO (Maybe (SOName a))
forall a b. (a -> b) -> a -> b
$
      if Int
n' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
n
      then Maybe (SOName a)
forall a. Maybe a
Nothing
      else SOName a -> Maybe (SOName a)
forall a. a -> Maybe a
Just (ForeignPtr CChar -> SOName a
forall a. ForeignPtr CChar -> SOName a
SOName ForeignPtr CChar
q)

-- | Generate a new unique shared object name.
genSOName :: IO (SOName a)
genSOName :: IO (SOName a)
genSOName = do
    ForeignPtr CChar
fp <- Int -> IO (ForeignPtr CChar)
forall a. Int -> IO (ForeignPtr a)
mallocForeignPtrBytes SHARED_OBJECT_NAME_LENGTH
    ForeignPtr CChar -> (Ptr CChar -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr CChar
fp Ptr CChar -> IO ()
c_genSharedObjectName
    SOName a -> IO (SOName a)
forall (m :: * -> *) a. Monad m => a -> m a
return (SOName a -> IO (SOName a)) -> SOName a -> IO (SOName a)
forall a b. (a -> b) -> a -> b
$ ForeignPtr CChar -> SOName a
forall a. ForeignPtr CChar -> SOName a
SOName ForeignPtr CChar
fp

-- | Allocate a new shared object name.
newEmptySOName :: IO (SOName a)
newEmptySOName :: IO (SOName a)
newEmptySOName = ForeignPtr CChar -> SOName a
forall a. ForeignPtr CChar -> SOName a
SOName (ForeignPtr CChar -> SOName a)
-> IO (ForeignPtr CChar) -> IO (SOName a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IO (ForeignPtr CChar)
forall a. Int -> IO (ForeignPtr a)
mallocForeignPtrBytes SHARED_OBJECT_NAME_LENGTH


-- | Use a pointer to a C string to pass to some low-level (e.g. foreign) functions.
--   `SOName` is asserted immutable, so do not modify it!
unsafeWithSOName :: SOName a -> (CString -> IO b) -> IO b
unsafeWithSOName :: SOName a -> (Ptr CChar -> IO b) -> IO b
unsafeWithSOName (SOName ForeignPtr CChar
fp) = ForeignPtr CChar -> (Ptr CChar -> IO b) -> IO b
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr CChar
fp

-- | Check first if two CString point to the same memory location.
--   Otherwise, compare them using C @strcmp@ function.
cmpCStrings :: CString -> CString -> Ordering
cmpCStrings :: Ptr CChar -> Ptr CChar -> Ordering
cmpCStrings Ptr CChar
a Ptr CChar
b
    | Ptr CChar
a Ptr CChar -> Ptr CChar -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr CChar
b = Ordering
EQ
    | Bool
otherwise = Ptr CChar -> Ptr CChar -> CInt
c_strcmp Ptr CChar
a Ptr CChar
b CInt -> CInt -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` CInt
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 ()