{-# LANGUAGE MagicHash #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE UnboxedTuples #-}
{-----------------------------------------------------------------------------
    reactive-banana
------------------------------------------------------------------------------}
module Reactive.Banana.Prim.Low.Ref
    ( -- * Mutable references with 'Unique'
      Ref
    , getUnique
    , new
    , equal
    , read
    , put
    , modify'

      -- * Garbage collection and weak pointers to 'Ref'
    , addFinalizer
    , getWeakRef

    , WeakRef
    , mkWeak
    , deRefWeak
    , deRefWeaks
    , finalize
    ) where

import Prelude hiding ( read )

import Control.DeepSeq
    ( NFData (..) )
import Control.Monad
    ( void )
import Control.Monad.IO.Class
    ( MonadIO (liftIO) )
import Data.Hashable
    ( Hashable (..) )
import Data.IORef
    ( IORef, newIORef, readIORef, writeIORef )
import Data.Maybe
    ( catMaybes )
import Data.Unique.Really
    ( Unique, newUnique )

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

{-----------------------------------------------------------------------------
    Ref
------------------------------------------------------------------------------}
-- | A mutable reference which has a 'Unique' associated with it.
data Ref a = Ref
    !Unique         -- Unique associated to the 'Ref'
    !(IORef a)      -- 'IORef' that stores the value of type 'a'
    !(WeakRef a)    -- For convenience, a weak pointer to itself

instance NFData (Ref a) where rnf :: Ref a -> ()
rnf (Ref Unique
_ IORef a
_ WeakRef a
_) = ()

instance Eq (Ref a) where == :: Ref a -> Ref a -> Bool
(==) = Ref a -> Ref a -> Bool
forall a b. Ref a -> Ref b -> Bool
equal

instance Hashable (Ref a) where hashWithSalt :: Int -> Ref a -> Int
hashWithSalt Int
s (Ref Unique
u IORef a
_ WeakRef a
_) = Int -> Unique -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
s Unique
u

getUnique :: Ref a -> Unique
getUnique :: forall a. Ref a -> Unique
getUnique (Ref Unique
u IORef a
_ WeakRef a
_) = Unique
u

getWeakRef :: Ref a -> WeakRef a
getWeakRef :: forall a. Ref a -> WeakRef a
getWeakRef (Ref Unique
_ IORef a
_ WeakRef a
w) = WeakRef a
w

equal :: Ref a -> Ref b -> Bool
equal :: forall a b. Ref a -> Ref b -> Bool
equal (Ref Unique
ua IORef a
_ WeakRef a
_) (Ref Unique
ub IORef b
_ WeakRef b
_) = Unique
ua Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
ub

new :: MonadIO m => a -> m (Ref a)
new :: forall (m :: * -> *) a. MonadIO m => a -> m (Ref a)
new a
a = IO (Ref a) -> m (Ref a)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Ref a) -> m (Ref a)) -> IO (Ref a) -> m (Ref a)
forall a b. (a -> b) -> a -> b
$ mdo
    IORef a
ra     <- a -> IO (IORef a)
forall a. a -> IO (IORef a)
newIORef a
a
    Ref a
result <- Unique -> IORef a -> WeakRef a -> Ref a
forall a. Unique -> IORef a -> WeakRef a -> Ref a
Ref (Unique -> IORef a -> WeakRef a -> Ref a)
-> IO Unique -> IO (IORef a -> WeakRef a -> Ref a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Unique
newUnique IO (IORef a -> WeakRef a -> Ref a)
-> IO (IORef a) -> IO (WeakRef a -> Ref a)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IORef a -> IO (IORef a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure IORef a
ra IO (WeakRef a -> Ref a) -> IO (WeakRef a) -> IO (Ref a)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> WeakRef a -> IO (WeakRef a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure WeakRef a
wa
    WeakRef a
wa     <- IORef a -> Ref a -> Maybe (IO ()) -> IO (WeakRef a)
forall k v. IORef k -> v -> Maybe (IO ()) -> IO (Weak v)
mkWeakIORef IORef a
ra Ref a
result Maybe (IO ())
forall a. Maybe a
Nothing
    Ref a -> IO (Ref a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Ref a
result

read :: MonadIO m => Ref a -> m a
read :: forall (m :: * -> *) a. MonadIO m => Ref a -> m a
read ~(Ref Unique
_ IORef a
r WeakRef a
_) = IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ IORef a -> IO a
forall a. IORef a -> IO a
readIORef IORef a
r

put :: MonadIO m => Ref a -> a -> m ()
put :: forall (m :: * -> *) a. MonadIO m => Ref a -> a -> m ()
put ~(Ref Unique
_ IORef a
r WeakRef a
_) = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (a -> IO ()) -> a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IORef a -> a -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef a
r

-- | Strictly modify a 'Ref'.
modify' :: MonadIO m => Ref a -> (a -> a) -> m ()
modify' :: forall (m :: * -> *) a. MonadIO m => Ref a -> (a -> a) -> m ()
modify' ~(Ref Unique
_ IORef a
r WeakRef a
_) a -> a
f = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
    IORef a -> IO a
forall a. IORef a -> IO a
readIORef IORef a
r IO a -> (a -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
x -> IORef a -> a -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef a
r (a -> IO ()) -> a -> IO ()
forall a b. (a -> b) -> a -> b
$! a -> a
f a
x

{-----------------------------------------------------------------------------
    Weak pointers
------------------------------------------------------------------------------}
-- | Add a finalizer to a 'Ref'.
--
-- See 'System.Mem.Weak.addFinalizer'.
addFinalizer :: Ref v -> IO () -> IO ()
addFinalizer :: forall v. Ref v -> IO () -> IO ()
addFinalizer (Ref Unique
_ IORef v
r WeakRef v
_) = IO (Weak ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Weak ()) -> IO ())
-> (IO () -> IO (Weak ())) -> IO () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IORef v -> () -> Maybe (IO ()) -> IO (Weak ())
forall k v. IORef k -> v -> Maybe (IO ()) -> IO (Weak v)
mkWeakIORef IORef v
r () (Maybe (IO ()) -> IO (Weak ()))
-> (IO () -> Maybe (IO ())) -> IO () -> IO (Weak ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> Maybe (IO ())
forall a. a -> Maybe a
Just

-- | Weak pointer to a 'Ref'.
type WeakRef v = Weak.Weak (Ref v)

-- | Create a weak pointer that associates a key with a value.
--
-- See 'System.Mem.Weak.mkWeak'.
mkWeak
    :: Ref k -- ^ key
    -> v -- ^ value
    -> Maybe (IO ()) -- ^ finalizer
    -> IO (Weak.Weak v)
mkWeak :: forall k v. Ref k -> v -> Maybe (IO ()) -> IO (Weak v)
mkWeak (Ref Unique
_ IORef k
r WeakRef k
_) = IORef k -> v -> Maybe (IO ()) -> IO (Weak v)
forall k v. IORef k -> v -> Maybe (IO ()) -> IO (Weak v)
mkWeakIORef IORef k
r

-- | Finalize a 'WeakRef'.
--
-- See 'System.Mem.Weak.finalize'.
finalize :: WeakRef v -> IO ()
finalize :: forall v. WeakRef v -> IO ()
finalize = Weak (Ref v) -> IO ()
forall v. Weak v -> IO ()
Weak.finalize

-- | Dereference a 'WeakRef'.
--
-- See 'System.Mem.Weak.deRefWeak'.
deRefWeak :: Weak.Weak v -> IO (Maybe v)
deRefWeak :: forall v. Weak v -> IO (Maybe v)
deRefWeak = Weak v -> IO (Maybe v)
forall v. Weak v -> IO (Maybe v)
Weak.deRefWeak

-- | Dereference a list of weak pointers while discarding dead ones.
deRefWeaks :: [Weak.Weak v] -> IO [v]
deRefWeaks :: forall v. [Weak v] -> IO [v]
deRefWeaks [Weak v]
ws = [Maybe v] -> [v]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe v] -> [v]) -> IO [Maybe v] -> IO [v]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Weak v -> IO (Maybe v)) -> [Weak v] -> IO [Maybe v]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Weak v -> IO (Maybe v)
forall v. Weak v -> IO (Maybe v)
Weak.deRefWeak [Weak v]
ws

{-----------------------------------------------------------------------------
    Helpers
------------------------------------------------------------------------------}
-- | Create a weak pointer to an 'IORef'.
--
-- Unpacking the constructors (e.g. 'GHC.IORef' etc.) is necessary
-- because the constructors may be unpacked while the 'IORef' is used
-- — so, the value contained therein is alive, but the constructors are not.
mkWeakIORef
    :: IORef k -- ^ key
    -> v       -- ^ value
    -> Maybe (IO ()) -- ^ finalizer
    -> IO (Weak.Weak v)
mkWeakIORef :: forall k v. IORef k -> v -> Maybe (IO ()) -> IO (Weak v)
mkWeakIORef (GHC.IORef (GHC.STRef MutVar# RealWorld k
r#)) v
v (Just (GHC.IO State# RealWorld -> (# State# RealWorld, () #)
finalizer)) =
    (State# RealWorld -> (# State# RealWorld, Weak v #)) -> IO (Weak v)
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
GHC.IO ((State# RealWorld -> (# State# RealWorld, Weak v #))
 -> IO (Weak v))
-> (State# RealWorld -> (# State# RealWorld, Weak v #))
-> IO (Weak v)
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s -> case MutVar# RealWorld k
-> v
-> (State# RealWorld -> (# State# RealWorld, () #))
-> State# RealWorld
-> (# State# RealWorld, Weak# v #)
forall a b c.
a
-> b
-> (State# RealWorld -> (# State# RealWorld, c #))
-> State# RealWorld
-> (# State# RealWorld, Weak# b #)
GHC.mkWeak# MutVar# RealWorld k
r# v
v State# RealWorld -> (# State# RealWorld, () #)
finalizer State# RealWorld
s of
        (# State# RealWorld
s1, Weak# v
w #) -> (# State# RealWorld
s1, Weak# v -> Weak v
forall v. Weak# v -> Weak v
GHC.Weak Weak# v
w #)
mkWeakIORef (GHC.IORef (GHC.STRef MutVar# RealWorld k
r#)) v
v Maybe (IO ())
Nothing =
    (State# RealWorld -> (# State# RealWorld, Weak v #)) -> IO (Weak v)
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
GHC.IO ((State# RealWorld -> (# State# RealWorld, Weak v #))
 -> IO (Weak v))
-> (State# RealWorld -> (# State# RealWorld, Weak v #))
-> IO (Weak v)
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s -> case MutVar# RealWorld k
-> v -> State# RealWorld -> (# State# RealWorld, Weak# v #)
forall a b.
a -> b -> State# RealWorld -> (# State# RealWorld, Weak# b #)
GHC.mkWeakNoFinalizer# MutVar# RealWorld k
r# v
v State# RealWorld
s of
        (# State# RealWorld
s1, Weak# v
w #) -> (# State# RealWorld
s1, Weak# v -> Weak v
forall v. Weak# v -> Weak v
GHC.Weak Weak# v
w #)