{-# LANGUAGE RecordWildCards, CPP, ExistentialQuantification #-}
{-# LANGUAGE MagicHash, UnboxedTuples #-}
module Foreign.RemotePtr (
RemotePtr,
withRemotePtr, addFinalizer, destroy, addReachable, clearReachable,
unprotectedGetCoupon,
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
type Coupon = T.Text
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]
}
data SomeWeak = forall a. SomeWeak (Weak a)
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]
}
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)))
..}
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
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))
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
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
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
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
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
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
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, ())
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]