{-# LANGUAGE CPP #-}
{-----------------------------------------------------------------------------
    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 _ = () -> 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 s :: Int
s (Ref _ u :: 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 _ a :: Unique
a) (Ref _ 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
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 ref :: IORef a
ref _) = 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 ref :: IORef a
ref _) = 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 ref :: IORef a
ref _) f :: 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
>>= \x :: 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
------------------------------------------------------------------------------}
mkWeakIORefValueFinalizer :: IORef a -> value -> IO () -> IO (Weak value)
#if MIN_VERSION_base(4,9,0)
mkWeakIORefValueFinalizer :: IORef a -> value -> IO () -> IO (Weak value)
mkWeakIORefValueFinalizer r :: IORef a
r@(GHC.IORef (GHC.STRef r# :: MutVar# RealWorld a
r#)) v :: value
v (GHC.IO f :: 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
$ \s :: 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 (# s1 :: State# RealWorld
s1, w :: Weak# value
w #) -> (# State# RealWorld
s1, Weak# value -> Weak value
forall v. Weak# v -> Weak v
GHC.Weak Weak# value
w #)
#else
mkWeakIORefValueFinalizer 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

mkWeakIORefValue :: IORef a -> value -> IO (Weak value)
mkWeakIORefValue :: IORef a -> value -> IO (Weak value)
mkWeakIORefValue a :: IORef a
a b :: value
b = IORef a -> value -> IO () -> IO (Weak value)
forall a value. IORef a -> value -> IO () -> IO (Weak value)
mkWeakIORefValueFinalizer IORef a
a value
b (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())

mkWeakRefValue :: MonadIO m => Ref a -> value -> m (Weak value)
mkWeakRefValue :: Ref a -> value -> m (Weak value)
mkWeakRefValue (Ref ref :: IORef a
ref _) v :: 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 ws :: [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