{-# 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
(==) = 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
_) = 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 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 = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ mdo
    IORef a
ra     <- forall a. a -> IO (IORef a)
newIORef a
a
    Ref a
result <- forall a. Unique -> IORef a -> WeakRef a -> Ref a
Ref forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Unique
newUnique forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure IORef a
ra forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure WeakRef a
wa
    WeakRef a
wa     <- forall k v. IORef k -> v -> Maybe (IO ()) -> IO (Weak v)
mkWeakIORef IORef a
ra Ref a
result forall a. Maybe a
Nothing
    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
_) = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ 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
_) = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
    forall a. IORef a -> IO a
readIORef IORef a
r forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
x -> forall a. IORef a -> a -> IO ()
writeIORef IORef a
r 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
_) = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k v. IORef k -> v -> Maybe (IO ()) -> IO (Weak v)
mkWeakIORef IORef v
r () forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
_) = 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 = 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 = 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 = forall a. [Maybe a] -> [a]
catMaybes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM 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)) =
    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 k
r# v
v State# RealWorld -> (# State# RealWorld, () #)
finalizer State# RealWorld
s of
        (# State# RealWorld
s1, Weak# v
w #) -> (# State# RealWorld
s1, 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 =
    forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
GHC.IO forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s -> case mkWeakNoFinalizer# :: 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, forall v. Weak# v -> Weak v
GHC.Weak Weak# v
w #)