{-# LANGUAGE CPP #-}
{-# LANGUAGE ExistentialQuantification #-}
#ifdef USE_REFLEX_OPTIMIZER
{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
#endif
#ifdef GHCJS_FAST_WEAK
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE JavaScriptFFI #-}
#endif
-- | This module defines the 'FastWeakBag' type, which represents a mutable
-- collection of items that does not cause the items to be retained in memory.
-- This is useful for situations where a value needs to be inspected or modified
-- if it is still alive, but can be ignored if it is dead.
module Data.FastWeakBag
  ( FastWeakBag
  , FastWeakBagTicket
  , empty
  , isEmpty
  , insert
  , traverse
  , traverse_
  , remove
  -- * Internal functions
  -- These will not always be available.
#ifndef GHCJS_FAST_WEAK
  , _weakBag_children --TODO: Don't export this
#endif
  ) where

import Prelude hiding (traverse)

import Control.Monad
import Control.Monad.IO.Class

#ifdef GHCJS_FAST_WEAK
import GHCJS.Types
import Reflex.FastWeak (js_isNull, unsafeFromRawJSVal, unsafeToRawJSVal)
#else
import Control.Exception
import Data.IntMap.Strict (IntMap)
import qualified Data.IntMap.Strict as IntMap
import Data.IORef
import System.Mem.Weak
#endif

-- | A 'FastWeakBag' holds a set of values of type @/a/@, but does not retain them -
-- that is, they can still be garbage-collected.  As long as the @/a/@ values remain
-- alive, the 'FastWeakBag' will continue to refer to them.
#ifdef GHCJS_FAST_WEAK
newtype FastWeakBag a = FastWeakBag JSVal
#else
data FastWeakBag a = FastWeakBag
  { FastWeakBag a -> IORef Int
_weakBag_nextId :: {-# UNPACK #-} !(IORef Int) --TODO: what if this wraps around?
  , FastWeakBag a -> IORef (IntMap (Weak a))
_weakBag_children :: {-# UNPACK #-} !(IORef (IntMap (Weak a))) -- ^ Map of items contained by the 'FastWeakBag'
  }
#endif

-- | When inserting an item into a 'FastWeakBag', a 'FastWeakBagTicket' is returned.  If
-- the caller retains the ticket, the item is guranteed to stay in memory (and
-- thus in the 'FastWeakBag').  The ticket can also be used to remove the item from
-- the 'FastWeakBag' prematurely (i.e. while it is still alive), using 'remove'.
#ifdef GHCJS_FAST_WEAK
newtype FastWeakBagTicket a = FastWeakBagTicket JSVal
#else
data FastWeakBagTicket a = FastWeakBagTicket
  { FastWeakBagTicket a -> Weak a
_weakBagTicket_weakItem :: {-# UNPACK #-} !(Weak a)
  , FastWeakBagTicket a -> a
_weakBagTicket_item :: {-# NOUNPACK #-} !a
  }
#endif

-- | Insert an item into a 'FastWeakBag'.
{-# INLINE insert #-}
insert :: a -- ^ The item
       -> FastWeakBag a -- ^ The 'FastWeakBag' to insert into
       -> IO (FastWeakBagTicket a) -- ^ Returns a 'FastWeakBagTicket' that ensures the item
                           -- is retained and allows the item to be removed.
#ifdef GHCJS_FAST_WEAK
insert a wb = js_insert (unsafeToRawJSVal a) wb
foreign import javascript unsafe "$r = new h$FastWeakBagTicket($2, $1);" js_insert :: JSVal -> FastWeakBag a -> IO (FastWeakBagTicket a)
#else
insert :: a -> FastWeakBag a -> IO (FastWeakBagTicket a)
insert a :: a
a (FastWeakBag nextId :: IORef Int
nextId children :: IORef (IntMap (Weak a))
children) = {-# SCC "insert" #-} do
  a
a' <- a -> IO a
forall a. a -> IO a
evaluate a
a
  Int
myId <- IORef Int -> (Int -> (Int, Int)) -> IO Int
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Int
nextId ((Int -> (Int, Int)) -> IO Int) -> (Int -> (Int, Int)) -> IO Int
forall a b. (a -> b) -> a -> b
$ \n :: Int
n -> (Int -> Int
forall a. Enum a => a -> a
succ Int
n, Int
n)
  let cleanup :: IO ()
cleanup = IORef (IntMap (Weak a))
-> (IntMap (Weak a) -> (IntMap (Weak a), ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (IntMap (Weak a))
children ((IntMap (Weak a) -> (IntMap (Weak a), ())) -> IO ())
-> (IntMap (Weak a) -> (IntMap (Weak a), ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \cs :: IntMap (Weak a)
cs -> (Int -> IntMap (Weak a) -> IntMap (Weak a)
forall a. Int -> IntMap a -> IntMap a
IntMap.delete Int
myId IntMap (Weak a)
cs, ())
  Weak a
wa <- a -> Maybe (IO ()) -> IO (Weak a)
forall k. k -> Maybe (IO ()) -> IO (Weak k)
mkWeakPtr a
a' (Maybe (IO ()) -> IO (Weak a)) -> Maybe (IO ()) -> IO (Weak a)
forall a b. (a -> b) -> a -> b
$ IO () -> Maybe (IO ())
forall a. a -> Maybe a
Just IO ()
cleanup
  IORef (IntMap (Weak a))
-> (IntMap (Weak a) -> (IntMap (Weak a), ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (IntMap (Weak a))
children ((IntMap (Weak a) -> (IntMap (Weak a), ())) -> IO ())
-> (IntMap (Weak a) -> (IntMap (Weak a), ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \cs :: IntMap (Weak a)
cs -> (Int -> Weak a -> IntMap (Weak a) -> IntMap (Weak a)
forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert Int
myId Weak a
wa IntMap (Weak a)
cs, ())
  FastWeakBagTicket a -> IO (FastWeakBagTicket a)
forall (m :: * -> *) a. Monad m => a -> m a
return (FastWeakBagTicket a -> IO (FastWeakBagTicket a))
-> FastWeakBagTicket a -> IO (FastWeakBagTicket a)
forall a b. (a -> b) -> a -> b
$ $WFastWeakBagTicket :: forall a. Weak a -> a -> FastWeakBagTicket a
FastWeakBagTicket
    { _weakBagTicket_weakItem :: Weak a
_weakBagTicket_weakItem = Weak a
wa
    , _weakBagTicket_item :: a
_weakBagTicket_item = a
a'
    }
#endif

-- | Create an empty 'FastWeakBag'.
{-# INLINE empty #-}
empty :: IO (FastWeakBag a)
#ifdef GHCJS_FAST_WEAK
empty = js_empty
foreign import javascript unsafe "$r = new h$FastWeakBag();" js_empty :: IO (FastWeakBag a)
#else
empty :: IO (FastWeakBag a)
empty = {-# SCC "empty" #-} do
  IORef Int
nextId <- Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef 1
  IORef (IntMap (Weak a))
children <- IntMap (Weak a) -> IO (IORef (IntMap (Weak a)))
forall a. a -> IO (IORef a)
newIORef IntMap (Weak a)
forall a. IntMap a
IntMap.empty
  let bag :: FastWeakBag a
bag = $WFastWeakBag :: forall a. IORef Int -> IORef (IntMap (Weak a)) -> FastWeakBag a
FastWeakBag
        { _weakBag_nextId :: IORef Int
_weakBag_nextId = IORef Int
nextId
        , _weakBag_children :: IORef (IntMap (Weak a))
_weakBag_children = IORef (IntMap (Weak a))
children
        }
  FastWeakBag a -> IO (FastWeakBag a)
forall (m :: * -> *) a. Monad m => a -> m a
return FastWeakBag a
bag
#endif

-- | Check whether a 'FastWeakBag' is empty.
{-# INLINE isEmpty #-}
isEmpty :: FastWeakBag a -> IO Bool
#ifdef GHCJS_FAST_WEAK
isEmpty = js_isEmpty
foreign import javascript unsafe "(function(){ for(var i = 0; i < $1.tickets.length; i++) { if($1.tickets[i] !== null) { return false; } }; return true; })()" js_isEmpty :: FastWeakBag a -> IO Bool --TODO: Clean up as we go along so this isn't O(n) every time
#else
isEmpty :: FastWeakBag a -> IO Bool
isEmpty bag :: FastWeakBag a
bag = {-# SCC "isEmpty" #-} IntMap (Weak a) -> Bool
forall a. IntMap a -> Bool
IntMap.null (IntMap (Weak a) -> Bool) -> IO (IntMap (Weak a)) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (IntMap (Weak a)) -> IO (IntMap (Weak a))
forall a. IORef a -> IO a
readIORef (FastWeakBag a -> IORef (IntMap (Weak a))
forall a. FastWeakBag a -> IORef (IntMap (Weak a))
_weakBag_children FastWeakBag a
bag)
#endif

{-# INLINE traverse_ #-}
-- | Visit every node in the given list.  If new nodes are appended during the
-- traversal, they will not be visited.  Every live node that was in the list
-- when the traversal began will be visited exactly once; however, no guarantee
-- is made about the order of the traversal.
traverse_ :: forall a m. MonadIO m => FastWeakBag a -> (a -> m ()) -> m ()
#ifdef GHCJS_FAST_WEAK
traverse_ wb f = do
  let go cursor = when (not $ js_isNull cursor) $ do
        val <- liftIO $ js_getTicketValue cursor
        f $ unsafeFromRawJSVal val
        go =<< liftIO (js_getNext (FastWeakBagTicket cursor))
  go =<< liftIO (js_getInitial wb)
foreign import javascript unsafe "(function(){ for(var i = $1.tickets.length - 1; i >= 0; i--) { if($1.tickets[i] !== null) { return $1.tickets[i]; } }; return null; })()" js_getInitial :: FastWeakBag a -> IO JSVal --TODO: Clean up as we go along so this isn't O(n) every time -- Result can be null or a FastWeakBagTicket a
foreign import javascript unsafe "$r = $1.val;" js_getTicketValue :: JSVal -> IO JSVal
--TODO: Fix the race condition where if a cursor is deleted (presumably using 'remove', below) while we're holding it, it can't find its way back to the correct bag
foreign import javascript unsafe "(function(){ for(var i = $1.pos - 1; i >= 0; i--) { if($1.bag.tickets[i] !== null) { return $1.bag.tickets[i]; } }; return null; })()" js_getNext :: FastWeakBagTicket a -> IO JSVal --TODO: Clean up as we go along so this isn't O(n) every time -- Result can be null or a FastWeakBagTicket a
#else
traverse_ :: FastWeakBag a -> (a -> m ()) -> m ()
traverse_ (FastWeakBag _ children :: IORef (IntMap (Weak a))
children) f :: a -> m ()
f = {-# SCC "traverse_" #-} do
  IntMap (Weak a)
cs <- IO (IntMap (Weak a)) -> m (IntMap (Weak a))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IntMap (Weak a)) -> m (IntMap (Weak a)))
-> IO (IntMap (Weak a)) -> m (IntMap (Weak a))
forall a b. (a -> b) -> a -> b
$ IORef (IntMap (Weak a)) -> IO (IntMap (Weak a))
forall a. IORef a -> IO a
readIORef IORef (IntMap (Weak a))
children
  IntMap (Weak a) -> (Weak a -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ IntMap (Weak a)
cs ((Weak a -> m ()) -> m ()) -> (Weak a -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \c :: Weak a
c -> do
    Maybe a
ma <- IO (Maybe a) -> m (Maybe a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe a) -> m (Maybe a)) -> IO (Maybe a) -> m (Maybe a)
forall a b. (a -> b) -> a -> b
$ Weak a -> IO (Maybe a)
forall v. Weak v -> IO (Maybe v)
deRefWeak Weak a
c
    (a -> m ()) -> Maybe a -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ a -> m ()
f Maybe a
ma
#endif

{-# DEPRECATED traverse "Use 'traverse_' instead" #-}
traverse :: forall a m. MonadIO m => FastWeakBag a -> (a -> m ()) -> m ()
traverse :: FastWeakBag a -> (a -> m ()) -> m ()
traverse = FastWeakBag a -> (a -> m ()) -> m ()
forall a (m :: * -> *).
MonadIO m =>
FastWeakBag a -> (a -> m ()) -> m ()
traverse_

-- | Remove an item from the 'FastWeakBag'; does nothing if invoked multiple times
-- on the same 'FastWeakBagTicket'.
{-# INLINE remove #-}
remove :: FastWeakBagTicket a -> IO ()
#ifdef GHCJS_FAST_WEAK
remove = js_remove
foreign import javascript unsafe "$1.bag.tickets[$1.pos] = null; $1.bag = new h$FastWeakBag(); $1.bag.tickets.push($1); $1.pos = 0;" js_remove :: FastWeakBagTicket a -> IO () --TODO: Don't bother with the new surrogate FastWeakBag; instead, make the GC check for bag === null, and then null it out here
#else
remove :: FastWeakBagTicket a -> IO ()
remove (FastWeakBagTicket w :: Weak a
w _) = {-# SCC "remove" #-} Weak a -> IO ()
forall v. Weak v -> IO ()
finalize Weak a
w
#endif
--TODO: Should 'remove' also drop the reference to the item?

--TODO: can/should we provide a null FastWeakBagTicket?