{-# LANGUAGE RecordWildCards, CPP, ExistentialQuantification #-}
{-# LANGUAGE MagicHash, UnboxedTuples #-}
module Foreign.RemotePtr (
    -- * Synopsis
    -- | Toolbox for managing remote objects in Haskell.
    
    -- * RemotePtr
    RemotePtr,
    withRemotePtr, addFinalizer, destroy, addReachable, clearReachable,
    unprotectedGetCoupon,

    -- * Coupons and Vendors
    Coupon, newCoupon,
    Vendor, newVendor, lookup,
    newRemotePtr,
    ) where

import Prelude hiding (lookup)
import Control.Monad
import           Control.Concurrent
import qualified Data.Text             as T
import qualified Data.Map              as Map
import Data.Functor
import Data.IORef

import           System.IO.Unsafe         (unsafePerformIO)
import           System.Mem.Weak          hiding (addFinalizer)
import qualified System.Mem.Weak  as Weak

import qualified GHC.Base  as GHC
import qualified GHC.Weak  as GHC
import qualified GHC.IORef as GHC
import qualified GHC.STRef as GHC

#if CABAL
#if MIN_VERSION_base(4,6,0)
#else
atomicModifyIORef' = atomicModifyIORef
#endif
#endif

mkWeakIORefValue :: IORef a -> value -> IO () -> IO (Weak value)
#if CABAL
#if MIN_VERSION_base(4,9,0)
mkWeakIORefValue :: IORef a -> value -> IO () -> IO (Weak value)
mkWeakIORefValue r :: IORef a
r@(GHC.IORef (GHC.STRef MutVar# RealWorld a
r#)) value
v (GHC.IO State# RealWorld -> (# State# RealWorld, () #)
f) = (State# RealWorld -> (# State# RealWorld, Weak value #))
-> IO (Weak value)
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
GHC.IO ((State# RealWorld -> (# State# RealWorld, Weak value #))
 -> IO (Weak value))
-> (State# RealWorld -> (# State# RealWorld, Weak value #))
-> IO (Weak value)
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s ->
  case MutVar# RealWorld a
-> value
-> (State# RealWorld -> (# State# RealWorld, () #))
-> State# RealWorld
-> (# State# RealWorld, Weak# value #)
forall a b c.
a
-> b
-> (State# RealWorld -> (# State# RealWorld, c #))
-> State# RealWorld
-> (# State# RealWorld, Weak# b #)
GHC.mkWeak# MutVar# RealWorld a
r# value
v State# RealWorld -> (# State# RealWorld, () #)
f State# RealWorld
s of (# State# RealWorld
s1, Weak# value
w #) -> (# State# RealWorld
s1, Weak# value -> Weak value
forall v. Weak# v -> Weak v
GHC.Weak Weak# value
w #)
#else
mkWeakIORefValue r@(GHC.IORef (GHC.STRef r#)) v f = GHC.IO $ \s ->
  case GHC.mkWeak# r# v f s of (# s1, w #) -> (# s1, GHC.Weak w #)
#endif
#else
mkWeakIORefValue r@(GHC.IORef (GHC.STRef r#)) v (GHC.IO f) = GHC.IO $ \s ->
  case GHC.mkWeak# r# v f s of (# s1, w #) -> (# s1, GHC.Weak w #)
#endif

type Map = Map.Map

{-----------------------------------------------------------------------------
    Types
------------------------------------------------------------------------------}
-- | A 'Coupon' is a unique identifier.
-- 
-- It is a string of alphanumeric ASCII characters and it is intended to
-- be sent to or received from a remote program.
--
-- The data structure 'Vendor' associates 'Coupon's to 'RemotPtr' objects.
type Coupon = T.Text


-- | A 'RemotePtr' is a pointer to a foreign object.
-- 
-- Like a 'ForeignPtr', it refers to an object managed by an environment
-- external to the Haskell runtime.
-- Likewise, you can assign finalizers to a 'RemotePtr'. The finalizers
-- will be run when the Haskell runtime garbage collects this value.
-- They can perform some cleanup operations, like freeing memory.
--
-- Unlike a 'ForeignPtr', the object referenced by a 'RemotePtr' is not
-- necessarily a block of RAM. Instead, it can refer to things like an object
-- managed by a remote program.

type RemotePtr a = IORef (RemoteData a)

data RemoteData a = RemoteData
    { RemoteData a -> Weak (RemotePtr a)
self     :: Weak (RemotePtr a)
    , RemoteData a -> Coupon
coupon   :: Coupon
    , RemoteData a -> a
value    :: a
    , RemoteData a -> IORef [SomeWeak]
children :: IORef [SomeWeak]
    }

-- Existentially quantified weak pointer. We only care about its finalizer.
data SomeWeak = forall a. SomeWeak (Weak a)

-- | A 'Vendor' is a bijective mapping from 'Coupon' to 'RemotePtr'.
--
-- Every 'Coupon' has at most one 'RemotePtr' associated to it.
-- A single 'RemotePtr' will always be associated with the same 'Coupon'.

data Vendor a = Vendor
    { Vendor a -> MVar (Map Coupon (Weak (RemotePtr a)))
coupons :: MVar (Map Coupon (Weak (RemotePtr a)))
    , Vendor a -> MVar [Integer]
counter :: MVar [Integer]
    }

{-----------------------------------------------------------------------------
    Vendor and Coupons
------------------------------------------------------------------------------}
-- | Create a new 'Vendor' for trading 'Coupon's and 'RemotePtr's.
newVendor :: IO (Vendor a)
newVendor :: IO (Vendor a)
newVendor = do
    MVar [Integer]
counter <- [Integer] -> IO (MVar [Integer])
forall a. a -> IO (MVar a)
newMVar [Integer
0..]
    MVar (Map Coupon (Weak (RemotePtr a)))
coupons <- Map Coupon (Weak (RemotePtr a))
-> IO (MVar (Map Coupon (Weak (RemotePtr a))))
forall a. a -> IO (MVar a)
newMVar Map Coupon (Weak (RemotePtr a))
forall k a. Map k a
Map.empty
    Vendor a -> IO (Vendor a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Vendor a -> IO (Vendor a)) -> Vendor a -> IO (Vendor a)
forall a b. (a -> b) -> a -> b
$ Vendor :: forall a.
MVar (Map Coupon (Weak (RemotePtr a)))
-> MVar [Integer] -> Vendor a
Vendor {MVar [Integer]
MVar (Map Coupon (Weak (RemotePtr a)))
coupons :: MVar (Map Coupon (Weak (RemotePtr a)))
counter :: MVar [Integer]
counter :: MVar [Integer]
coupons :: MVar (Map Coupon (Weak (RemotePtr a)))
..}

-- | Take a 'Coupon' to a 'Vendor' and maybe you'll get a 'RemotePtr' for it.
lookup :: Coupon -> Vendor a -> IO (Maybe (RemotePtr a))
lookup :: Coupon -> Vendor a -> IO (Maybe (RemotePtr a))
lookup Coupon
coupon Vendor{MVar [Integer]
MVar (Map Coupon (Weak (RemotePtr a)))
counter :: MVar [Integer]
coupons :: MVar (Map Coupon (Weak (RemotePtr a)))
counter :: forall a. Vendor a -> MVar [Integer]
coupons :: forall a. Vendor a -> MVar (Map Coupon (Weak (RemotePtr a)))
..} = do
    Maybe (Weak (RemotePtr a))
w <- Coupon
-> Map Coupon (Weak (RemotePtr a)) -> Maybe (Weak (RemotePtr a))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Coupon
coupon (Map Coupon (Weak (RemotePtr a)) -> Maybe (Weak (RemotePtr a)))
-> IO (Map Coupon (Weak (RemotePtr a)))
-> IO (Maybe (Weak (RemotePtr a)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVar (Map Coupon (Weak (RemotePtr a)))
-> IO (Map Coupon (Weak (RemotePtr a)))
forall a. MVar a -> IO a
readMVar MVar (Map Coupon (Weak (RemotePtr a)))
coupons
    IO (Maybe (RemotePtr a))
-> (Weak (RemotePtr a) -> IO (Maybe (RemotePtr a)))
-> Maybe (Weak (RemotePtr a))
-> IO (Maybe (RemotePtr a))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe (RemotePtr a) -> IO (Maybe (RemotePtr a))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (RemotePtr a)
forall a. Maybe a
Nothing) Weak (RemotePtr a) -> IO (Maybe (RemotePtr a))
forall v. Weak v -> IO (Maybe v)
deRefWeak Maybe (Weak (RemotePtr a))
w

-- | Create a new 'Coupon'.
--
-- WARNING: This coupon is only unique relative to this 'Vendor'.
-- There is no guarantee that this 'Coupon' is globally unique,
-- certainly not on a remote machine.
newCoupon :: Vendor a -> IO Coupon
newCoupon :: Vendor a -> IO Coupon
newCoupon Vendor{MVar [Integer]
MVar (Map Coupon (Weak (RemotePtr a)))
counter :: MVar [Integer]
coupons :: MVar (Map Coupon (Weak (RemotePtr a)))
counter :: forall a. Vendor a -> MVar [Integer]
coupons :: forall a. Vendor a -> MVar (Map Coupon (Weak (RemotePtr a)))
..} =
    String -> Coupon
T.pack (String -> Coupon) -> (Integer -> String) -> Integer -> Coupon
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> String
forall a. Show a => a -> String
show (Integer -> Coupon) -> IO Integer -> IO Coupon
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVar [Integer]
-> ([Integer] -> IO ([Integer], Integer)) -> IO Integer
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar [Integer]
counter (\(Integer
n:[Integer]
ns) -> ([Integer], Integer) -> IO ([Integer], Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Integer]
ns,Integer
n))

-- | Create a new 'RemotePtr' from a 'Coupon' and register it with a 'Vendor'.
newRemotePtr :: Coupon -> a -> Vendor a -> IO (RemotePtr a)
newRemotePtr :: Coupon -> a -> Vendor a -> IO (RemotePtr a)
newRemotePtr Coupon
coupon a
value Vendor{MVar [Integer]
MVar (Map Coupon (Weak (RemotePtr a)))
counter :: MVar [Integer]
coupons :: MVar (Map Coupon (Weak (RemotePtr a)))
counter :: forall a. Vendor a -> MVar [Integer]
coupons :: forall a. Vendor a -> MVar (Map Coupon (Weak (RemotePtr a)))
..} = do
    IORef [SomeWeak]
children <- [SomeWeak] -> IO (IORef [SomeWeak])
forall a. a -> IO (IORef a)
newIORef []
    let self :: a
self = a
forall a. HasCallStack => a
undefined
    RemotePtr a
ptr      <- RemoteData a -> IO (RemotePtr a)
forall a. a -> IO (IORef a)
newIORef RemoteData :: forall a.
Weak (RemotePtr a)
-> Coupon -> a -> IORef [SomeWeak] -> RemoteData a
RemoteData{a
Coupon
IORef [SomeWeak]
Weak (RemotePtr a)
forall a. a
self :: forall a. a
children :: IORef [SomeWeak]
value :: a
coupon :: Coupon
children :: IORef [SomeWeak]
value :: a
coupon :: Coupon
self :: Weak (RemotePtr a)
..}
    
    let finalize :: IO ()
finalize = MVar (Map Coupon (Weak (RemotePtr a)))
-> (Map Coupon (Weak (RemotePtr a))
    -> IO (Map Coupon (Weak (RemotePtr a)), ()))
-> IO ()
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar (Map Coupon (Weak (RemotePtr a)))
coupons ((Map Coupon (Weak (RemotePtr a))
  -> IO (Map Coupon (Weak (RemotePtr a)), ()))
 -> IO ())
-> (Map Coupon (Weak (RemotePtr a))
    -> IO (Map Coupon (Weak (RemotePtr a)), ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \Map Coupon (Weak (RemotePtr a))
m -> (Map Coupon (Weak (RemotePtr a)), ())
-> IO (Map Coupon (Weak (RemotePtr a)), ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Coupon
-> Map Coupon (Weak (RemotePtr a))
-> Map Coupon (Weak (RemotePtr a))
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Coupon
coupon Map Coupon (Weak (RemotePtr a))
m, ())
    Weak (RemotePtr a)
w <- RemotePtr a -> IO () -> IO (Weak (RemotePtr a))
forall a. IORef a -> IO () -> IO (Weak (IORef a))
mkWeakIORef RemotePtr a
ptr IO ()
finalize
    MVar (Map Coupon (Weak (RemotePtr a)))
-> (Map Coupon (Weak (RemotePtr a))
    -> IO (Map Coupon (Weak (RemotePtr a)), ()))
-> IO ()
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar (Map Coupon (Weak (RemotePtr a)))
coupons ((Map Coupon (Weak (RemotePtr a))
  -> IO (Map Coupon (Weak (RemotePtr a)), ()))
 -> IO ())
-> (Map Coupon (Weak (RemotePtr a))
    -> IO (Map Coupon (Weak (RemotePtr a)), ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \Map Coupon (Weak (RemotePtr a))
m -> (Map Coupon (Weak (RemotePtr a)), ())
-> IO (Map Coupon (Weak (RemotePtr a)), ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Coupon
-> Weak (RemotePtr a)
-> Map Coupon (Weak (RemotePtr a))
-> Map Coupon (Weak (RemotePtr a))
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Coupon
coupon Weak (RemotePtr a)
w Map Coupon (Weak (RemotePtr a))
m, ())
    RemotePtr a -> (RemoteData a -> (RemoteData a, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' RemotePtr a
ptr ((RemoteData a -> (RemoteData a, ())) -> IO ())
-> (RemoteData a -> (RemoteData a, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \RemoteData a
itemdata -> (RemoteData a
itemdata { self :: Weak (RemotePtr a)
self = Weak (RemotePtr a)
w }, ())
    RemotePtr a -> IO (RemotePtr a)
forall (m :: * -> *) a. Monad m => a -> m a
return RemotePtr a
ptr

{-----------------------------------------------------------------------------
    RemotePtr
------------------------------------------------------------------------------}
-- | Access the data of the 'RemotePtr'.
-- 
-- While the action is being performed, it is ensured that the 'RemotePtr'
-- will not be garbage collected
-- and its 'Coupon' can be successfully redeemed at the 'Vendor'.
withRemotePtr :: RemotePtr a -> (Coupon -> a -> IO b) -> IO b
withRemotePtr :: RemotePtr a -> (Coupon -> a -> IO b) -> IO b
withRemotePtr RemotePtr a
ptr Coupon -> a -> IO b
f = do
        RemoteData{a
Coupon
IORef [SomeWeak]
Weak (RemotePtr a)
children :: IORef [SomeWeak]
value :: a
coupon :: Coupon
self :: Weak (RemotePtr a)
children :: forall a. RemoteData a -> IORef [SomeWeak]
value :: forall a. RemoteData a -> a
coupon :: forall a. RemoteData a -> Coupon
self :: forall a. RemoteData a -> Weak (RemotePtr a)
..} <- RemotePtr a -> IO (RemoteData a)
forall a. IORef a -> IO a
readIORef RemotePtr a
ptr
        b
b <- Coupon -> a -> IO b
f Coupon
coupon a
value
        RemotePtr a -> IO ()
forall a. IORef a -> IO ()
touch RemotePtr a
ptr
        b -> IO b
forall (m :: * -> *) a. Monad m => a -> m a
return b
b
    where
    -- make sure that the pointer is alive at this point in the code
    touch :: IORef a -> IO ()
touch IORef a
ptr = IO a -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO a -> IO ()) -> IO a -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef a -> IO a
forall a. IORef a -> IO a
readIORef IORef a
ptr

-- | Unprotected access the 'Coupon' of a 'RemotePtr'.
--
-- Note: There is no guarantee that the 'RemotePtr' is alive
-- after this operation and that the 'Coupon' can be redeemed at a 'Vendor'.
-- Most of the time, you should use 'withRemotePtr' instead.
--
-- Note: In particular, if you use this with @unsafePerformIO@,
-- the risk is high that you only refer to the 'RemotePtr' argument via
-- the result just obtained, and the pointer will be garbage collected.
unprotectedGetCoupon :: RemotePtr a -> IO Coupon
unprotectedGetCoupon :: RemotePtr a -> IO Coupon
unprotectedGetCoupon RemotePtr a
ptr = RemoteData a -> Coupon
forall a. RemoteData a -> Coupon
coupon (RemoteData a -> Coupon) -> IO (RemoteData a) -> IO Coupon
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RemotePtr a -> IO (RemoteData a)
forall a. IORef a -> IO a
readIORef RemotePtr a
ptr


-- | Add a finalizer that is run when the 'RemotePtr' is garbage collected.
--
-- The associated coupon cannot be redeemed anymore while the finalizer runs.
addFinalizer :: RemotePtr a -> IO () -> IO ()
addFinalizer :: RemotePtr a -> IO () -> IO ()
addFinalizer RemotePtr a
ptr = IO (Weak (RemotePtr a)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Weak (RemotePtr a)) -> IO ())
-> (IO () -> IO (Weak (RemotePtr a))) -> IO () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RemotePtr a -> IO () -> IO (Weak (RemotePtr a))
forall a. IORef a -> IO () -> IO (Weak (IORef a))
mkWeakIORef RemotePtr a
ptr
-- | FIXME: Is this finalizer really run when 'destroy' is called?

-- | Destroy a 'RemotePtr' and run all finalizers for it.
-- 'Coupon's for this pointer can no longer be redeemed.
destroy :: RemotePtr a -> IO ()
destroy :: RemotePtr a -> IO ()
destroy RemotePtr a
ptr = Weak (RemotePtr a) -> IO ()
forall v. Weak v -> IO ()
finalize (Weak (RemotePtr a) -> IO ()) -> IO (Weak (RemotePtr a)) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< RemoteData a -> Weak (RemotePtr a)
forall a. RemoteData a -> Weak (RemotePtr a)
self (RemoteData a -> Weak (RemotePtr a))
-> IO (RemoteData a) -> IO (Weak (RemotePtr a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RemotePtr a -> IO (RemoteData a)
forall a. IORef a -> IO a
readIORef RemotePtr a
ptr


-- | When dealing with several foreign objects,
-- it is useful to model dependencies between them.
--
-- After this operation, the second 'RemotePtr' will be reachable
-- whenever the first one is reachable.
-- For instance, you should call this function when the second foreign object
-- is actually a subobject of the first one.
--
-- Note: It is possible to model dependencies in the @parent@ data,
-- but the 'addReachable' method is preferrable,
-- as it allows all child object to be garbage collected at once.
addReachable :: RemotePtr a -> RemotePtr b -> IO ()
addReachable :: RemotePtr a -> RemotePtr b -> IO ()
addReachable RemotePtr a
parent RemotePtr b
child = do
    Weak (RemotePtr b)
w   <- RemotePtr a -> RemotePtr b -> IO () -> IO (Weak (RemotePtr b))
forall a value. IORef a -> value -> IO () -> IO (Weak value)
mkWeakIORefValue RemotePtr a
parent RemotePtr b
child (IO () -> IO (Weak (RemotePtr b)))
-> IO () -> IO (Weak (RemotePtr b))
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    IORef [SomeWeak]
ref <- RemoteData a -> IORef [SomeWeak]
forall a. RemoteData a -> IORef [SomeWeak]
children (RemoteData a -> IORef [SomeWeak])
-> IO (RemoteData a) -> IO (IORef [SomeWeak])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RemotePtr a -> IO (RemoteData a)
forall a. IORef a -> IO a
readIORef RemotePtr a
parent
    IORef [SomeWeak] -> ([SomeWeak] -> ([SomeWeak], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [SomeWeak]
ref (([SomeWeak] -> ([SomeWeak], ())) -> IO ())
-> ([SomeWeak] -> ([SomeWeak], ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[SomeWeak]
ws -> (Weak (RemotePtr b) -> SomeWeak
forall a. Weak a -> SomeWeak
SomeWeak Weak (RemotePtr b)
wSomeWeak -> [SomeWeak] -> [SomeWeak]
forall a. a -> [a] -> [a]
:[SomeWeak]
ws, ())

-- | Clear all dependencies.
-- 
-- Reachability of this 'RemotePtr' no longer implies reachability
-- of other items, as formerly implied by calls to 'addReachable'.
clearReachable :: RemotePtr a -> IO ()
clearReachable :: RemotePtr a -> IO ()
clearReachable RemotePtr a
parent = do
    IORef [SomeWeak]
ref <- RemoteData a -> IORef [SomeWeak]
forall a. RemoteData a -> IORef [SomeWeak]
children (RemoteData a -> IORef [SomeWeak])
-> IO (RemoteData a) -> IO (IORef [SomeWeak])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RemotePtr a -> IO (RemoteData a)
forall a. IORef a -> IO a
readIORef RemotePtr a
parent
    [SomeWeak]
xs  <- IORef [SomeWeak]
-> ([SomeWeak] -> ([SomeWeak], [SomeWeak])) -> IO [SomeWeak]
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [SomeWeak]
ref (([SomeWeak] -> ([SomeWeak], [SomeWeak])) -> IO [SomeWeak])
-> ([SomeWeak] -> ([SomeWeak], [SomeWeak])) -> IO [SomeWeak]
forall a b. (a -> b) -> a -> b
$ \[SomeWeak]
xs -> ([], [SomeWeak]
xs)
    [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [Weak a -> IO ()
forall v. Weak v -> IO ()
finalize Weak a
x | SomeWeak Weak a
x <- [SomeWeak]
xs]