{-# 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 qualified Data.Text             as T
import qualified Data.HashMap.Strict   as Map
import Data.IORef

import           System.Mem.Weak          hiding (addFinalizer)

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 :: forall a value. IORef a -> value -> IO () -> IO (Weak value)
mkWeakIORefValue (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 (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 (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.HashMap

{-----------------------------------------------------------------------------
    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
    { forall a. RemoteData a -> Weak (RemotePtr a)
self     :: Weak (RemotePtr a)
    , forall a. RemoteData a -> Coupon
coupon   :: Coupon
    , forall a. RemoteData a -> a
value    :: a
    , forall 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
    { forall a. Vendor a -> IORef (Map Coupon (Weak (RemotePtr a)))
coupons :: IORef (Map Coupon (Weak (RemotePtr a)))
    , forall a. Vendor a -> IORef Integer
counter :: IORef Integer
    }

{-----------------------------------------------------------------------------
    Vendor and Coupons
------------------------------------------------------------------------------}
-- | Create a new 'Vendor' for trading 'Coupon's and 'RemotePtr's.
newVendor :: IO (Vendor a)
newVendor :: forall a. IO (Vendor a)
newVendor = do
    IORef Integer
counter <- Integer -> IO (IORef Integer)
forall a. a -> IO (IORef a)
newIORef Integer
0
    IORef (HashMap Coupon (Weak (RemotePtr a)))
coupons <- HashMap Coupon (Weak (RemotePtr a))
-> IO (IORef (HashMap Coupon (Weak (RemotePtr a))))
forall a. a -> IO (IORef a)
newIORef HashMap Coupon (Weak (RemotePtr a))
forall k v. HashMap k v
Map.empty
    Vendor a -> IO (Vendor a)
forall a. a -> IO 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 {IORef Integer
IORef (HashMap Coupon (Weak (RemotePtr a)))
coupons :: IORef (HashMap Coupon (Weak (RemotePtr a)))
counter :: IORef Integer
counter :: IORef Integer
coupons :: IORef (HashMap 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 :: forall a. Coupon -> Vendor a -> IO (Maybe (RemotePtr a))
lookup Coupon
coupon Vendor{IORef Integer
IORef (Map Coupon (Weak (RemotePtr a)))
coupons :: forall a. Vendor a -> IORef (Map Coupon (Weak (RemotePtr a)))
counter :: forall a. Vendor a -> IORef Integer
coupons :: IORef (Map Coupon (Weak (RemotePtr a)))
counter :: IORef Integer
..} = do
    Maybe (Weak (RemotePtr a))
w <- Coupon
-> Map Coupon (Weak (RemotePtr a)) -> Maybe (Weak (RemotePtr a))
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
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
<$> IORef (Map Coupon (Weak (RemotePtr a)))
-> IO (Map Coupon (Weak (RemotePtr a)))
forall a. IORef a -> IO a
readIORef IORef (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 a. a -> IO 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 :: forall a. Vendor a -> IO Coupon
newCoupon Vendor{IORef Integer
IORef (Map Coupon (Weak (RemotePtr a)))
coupons :: forall a. Vendor a -> IORef (Map Coupon (Weak (RemotePtr a)))
counter :: forall a. Vendor a -> IORef Integer
coupons :: IORef (Map Coupon (Weak (RemotePtr a)))
counter :: IORef Integer
..} =
    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
<$> IORef Integer -> (Integer -> (Integer, Integer)) -> IO Integer
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Integer
counter (\Integer
n -> (Integer
nInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
1,Integer
n))

-- | Create a new 'RemotePtr' from a 'Coupon' and register it with a 'Vendor'.
newRemotePtr :: Coupon -> a -> Vendor a -> IO (RemotePtr a)
newRemotePtr :: forall a. Coupon -> a -> Vendor a -> IO (RemotePtr a)
newRemotePtr Coupon
coupon a
value Vendor{IORef Integer
IORef (Map Coupon (Weak (RemotePtr a)))
coupons :: forall a. Vendor a -> IORef (Map Coupon (Weak (RemotePtr a)))
counter :: forall a. Vendor a -> IORef Integer
coupons :: IORef (Map Coupon (Weak (RemotePtr a)))
counter :: IORef Integer
..} = 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{a
Coupon
IORef [SomeWeak]
Weak (RemotePtr a)
forall {a}. a
self :: Weak (RemotePtr a)
coupon :: Coupon
value :: a
children :: IORef [SomeWeak]
coupon :: Coupon
value :: a
children :: IORef [SomeWeak]
self :: forall {a}. a
..}
    
    let doFinalize :: IO ()
doFinalize =
            IORef (Map Coupon (Weak (RemotePtr a)))
-> (Map Coupon (Weak (RemotePtr a))
    -> (Map Coupon (Weak (RemotePtr a)), ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Map Coupon (Weak (RemotePtr a)))
coupons ((Map Coupon (Weak (RemotePtr a))
  -> (Map Coupon (Weak (RemotePtr a)), ()))
 -> IO ())
-> (Map Coupon (Weak (RemotePtr a))
    -> (Map Coupon (Weak (RemotePtr a)), ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \Map Coupon (Weak (RemotePtr a))
m -> (Coupon
-> Map Coupon (Weak (RemotePtr a))
-> Map Coupon (Weak (RemotePtr a))
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
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 ()
doFinalize
    IORef (Map Coupon (Weak (RemotePtr a)))
-> (Map Coupon (Weak (RemotePtr a))
    -> (Map Coupon (Weak (RemotePtr a)), ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Map Coupon (Weak (RemotePtr a)))
coupons ((Map Coupon (Weak (RemotePtr a))
  -> (Map Coupon (Weak (RemotePtr a)), ()))
 -> IO ())
-> (Map Coupon (Weak (RemotePtr a))
    -> (Map Coupon (Weak (RemotePtr a)), ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \Map Coupon (Weak (RemotePtr a))
m -> (Coupon
-> Weak (RemotePtr a)
-> Map Coupon (Weak (RemotePtr a))
-> Map Coupon (Weak (RemotePtr a))
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
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 = w }, ())
    RemotePtr a -> IO (RemotePtr a)
forall a. a -> IO 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 :: forall a b. RemotePtr a -> (Coupon -> a -> IO b) -> IO b
withRemotePtr RemotePtr a
ptr0 Coupon -> a -> IO b
f = do
        RemoteData{a
Coupon
IORef [SomeWeak]
Weak (RemotePtr a)
self :: forall a. RemoteData a -> Weak (RemotePtr a)
coupon :: forall a. RemoteData a -> Coupon
value :: forall a. RemoteData a -> a
children :: forall a. RemoteData a -> IORef [SomeWeak]
self :: Weak (RemotePtr a)
coupon :: Coupon
value :: a
children :: IORef [SomeWeak]
..} <- RemotePtr a -> IO (RemoteData a)
forall a. IORef a -> IO a
readIORef RemotePtr a
ptr0
        b
b <- Coupon -> a -> IO b
f Coupon
coupon a
value
        RemotePtr a -> IO ()
forall {a}. IORef a -> IO ()
touch RemotePtr a
ptr0
        b -> IO b
forall a. a -> IO a
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 :: forall a. 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 :: forall a. 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 :: forall a. 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 :: forall a b. 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 a. a -> IO a
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 :: forall a. 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]