{-----------------------------------------------------------------------------
    reactive-banana
------------------------------------------------------------------------------}
{-# LANGUAGE MagicHash, UnboxedTuples #-}
module Reactive.Banana.Prim.Util where

import           Control.Monad
import           Control.Monad.IO.Class
import           Data.Hashable
import           Data.IORef
import           Data.Maybe                    (catMaybes)
import           Data.Unique.Really
import qualified GHC.Base               as GHC
import qualified GHC.IORef              as GHC
import qualified GHC.STRef              as GHC
import qualified GHC.Weak               as GHC
import           System.Mem.Weak

debug :: MonadIO m => String -> m ()
-- debug = liftIO . putStrLn
debug :: String -> m ()
debug String
_ = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

nop :: Monad m => m ()
nop :: m ()
nop = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

{-----------------------------------------------------------------------------
    IORefs that can be hashed
------------------------------------------------------------------------------}
data Ref a = Ref !(IORef a) !Unique

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

equalRef :: Ref a -> Ref b -> Bool
equalRef :: Ref a -> Ref b -> Bool
equalRef (Ref IORef a
_ Unique
a) (Ref IORef b
_ Unique
b) = Unique
a Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
b

newRef :: MonadIO m => a -> m (Ref a)
newRef :: a -> m (Ref a)
newRef a
a = IO (Ref a) -> m (Ref 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
$ (IORef a -> Unique -> Ref a)
-> IO (IORef a) -> IO Unique -> IO (Ref a)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 IORef a -> Unique -> Ref a
forall a. IORef a -> Unique -> Ref a
Ref (a -> IO (IORef a)
forall a. a -> IO (IORef a)
newIORef a
a) IO Unique
newUnique

readRef :: MonadIO m => Ref a -> m a
readRef :: Ref a -> m a
readRef ~(Ref IORef a
ref Unique
_) = 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
ref

put :: MonadIO m => Ref a -> a -> m ()
put :: Ref a -> a -> m ()
put ~(Ref IORef a
ref Unique
_) = IO () -> m ()
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
ref

-- | Strictly modify an 'IORef'.
modify' :: MonadIO m => Ref a -> (a -> a) -> m ()
modify' :: Ref a -> (a -> a) -> m ()
modify' ~(Ref IORef a
ref Unique
_) a -> a
f = IO () -> m ()
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
ref IO a -> (a -> IO ()) -> IO ()
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
ref (a -> IO ()) -> a -> IO ()
forall a b. (a -> b) -> a -> b
$! a -> a
f a
x

{-----------------------------------------------------------------------------
    Weak pointers
------------------------------------------------------------------------------}
mkWeakIORefValue :: IORef a -> value -> IO (Weak value)
mkWeakIORefValue :: IORef a -> value -> IO (Weak value)
mkWeakIORefValue (GHC.IORef (GHC.STRef MutVar# RealWorld a
r#)) value
val = (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, Weak# value #)
forall a b.
a -> b -> State# RealWorld -> (# State# RealWorld, Weak# b #)
GHC.mkWeakNoFinalizer# MutVar# RealWorld a
r# value
val 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 #)

mkWeakRefValue :: MonadIO m => Ref a -> value -> m (Weak value)
mkWeakRefValue :: Ref a -> value -> m (Weak value)
mkWeakRefValue (Ref IORef a
ref Unique
_) value
v = IO (Weak value) -> m (Weak value)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Weak value) -> m (Weak value))
-> IO (Weak value) -> m (Weak value)
forall a b. (a -> b) -> a -> b
$ IORef a -> value -> IO (Weak value)
forall a value. IORef a -> value -> IO (Weak value)
mkWeakIORefValue IORef a
ref value
v

-- | Dereference a list of weak pointers while discarding dead ones.
deRefWeaks :: [Weak v] -> IO [v]
deRefWeaks :: [Weak v] -> IO [v]
deRefWeaks [Weak v]
ws = {-# SCC deRefWeaks #-} ([Maybe v] -> [v]) -> IO [Maybe v] -> IO [v]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe v] -> [v]
forall a. [Maybe a] -> [a]
catMaybes (IO [Maybe v] -> IO [v]) -> IO [Maybe v] -> IO [v]
forall a b. (a -> b) -> a -> 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)
mapM Weak v -> IO (Maybe v)
forall v. Weak v -> IO (Maybe v)
deRefWeak [Weak v]
ws