{-# 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.HashMap.Strict   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 :: forall a value. 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) = forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
GHC.IO forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s ->
  case mkWeak# :: 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, 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.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 <- forall a. a -> IO (IORef a)
newIORef Integer
0
    IORef (HashMap Coupon (Weak (RemotePtr a)))
coupons <- forall a. a -> IO (IORef a)
newIORef forall k v. HashMap k v
Map.empty
    forall (m :: * -> *) a. Monad m => a -> m a
return 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)))
counter :: IORef Integer
coupons :: IORef (Map Coupon (Weak (RemotePtr a)))
counter :: forall a. Vendor a -> IORef Integer
coupons :: forall a. Vendor a -> IORef (Map Coupon (Weak (RemotePtr a)))
..} = do
    Maybe (Weak (RemotePtr a))
w <- forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup Coupon
coupon forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. IORef a -> IO a
readIORef IORef (Map Coupon (Weak (RemotePtr a)))
coupons
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing) 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)))
counter :: IORef Integer
coupons :: IORef (Map Coupon (Weak (RemotePtr a)))
counter :: forall a. Vendor a -> IORef Integer
coupons :: forall a. Vendor a -> IORef (Map Coupon (Weak (RemotePtr a)))
..} =
    String -> Coupon
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Integer
counter (\Integer
n -> (Integer
nforall 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)))
counter :: IORef Integer
coupons :: IORef (Map Coupon (Weak (RemotePtr a)))
counter :: forall a. Vendor a -> IORef Integer
coupons :: forall a. Vendor a -> IORef (Map Coupon (Weak (RemotePtr a)))
..} = do
    IORef [SomeWeak]
children <- forall a. a -> IO (IORef a)
newIORef []
    let self :: a
self = forall a. HasCallStack => a
undefined
    RemotePtr a
ptr      <- forall a. a -> IO (IORef a)
newIORef RemoteData{a
Coupon
IORef [SomeWeak]
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 = forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Map Coupon (Weak (RemotePtr a)))
coupons forall a b. (a -> b) -> a -> b
$ \Map Coupon (Weak (RemotePtr a))
m -> (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 <- forall a. IORef a -> IO () -> IO (Weak (IORef a))
mkWeakIORef RemotePtr a
ptr IO ()
finalize
    forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Map Coupon (Weak (RemotePtr a)))
coupons forall a b. (a -> b) -> a -> b
$ \Map Coupon (Weak (RemotePtr a))
m -> (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, ())
    forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' RemotePtr a
ptr forall a b. (a -> b) -> a -> b
$ \RemoteData a
itemdata -> (RemoteData a
itemdata { self :: Weak (RemotePtr a)
self = Weak (RemotePtr a)
w }, ())
    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
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)
..} <- forall a. IORef a -> IO a
readIORef RemotePtr a
ptr
        b
b <- Coupon -> a -> IO b
f Coupon
coupon a
value
        forall {a}. IORef a -> IO ()
touch RemotePtr a
ptr
        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 = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ 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 = forall a. RemoteData a -> Coupon
coupon forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall v. Weak v -> IO ()
finalize forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. RemoteData a -> Weak (RemotePtr a)
self forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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   <- forall a value. IORef a -> value -> IO () -> IO (Weak value)
mkWeakIORefValue RemotePtr a
parent RemotePtr b
child forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ()
    IORef [SomeWeak]
ref <- forall a. RemoteData a -> IORef [SomeWeak]
children forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. IORef a -> IO a
readIORef RemotePtr a
parent
    forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [SomeWeak]
ref forall a b. (a -> b) -> a -> b
$ \[SomeWeak]
ws -> (forall a. Weak a -> SomeWeak
SomeWeak Weak (RemotePtr b)
wforall 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 <- forall a. RemoteData a -> IORef [SomeWeak]
children forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. IORef a -> IO a
readIORef RemotePtr a
parent
    [SomeWeak]
xs  <- forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [SomeWeak]
ref forall a b. (a -> b) -> a -> b
$ \[SomeWeak]
xs -> ([], [SomeWeak]
xs)
    forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [forall v. Weak v -> IO ()
finalize Weak a
x | SomeWeak Weak a
x <- [SomeWeak]
xs]