git.iko.soy/reflex
on documentation help sign in
reflex/src/Data/FastWeakBag.hs
156 lines 6.7 kB history raw
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE ExistentialQuantification #-}
3#ifdef USE_REFLEX_OPTIMIZER
4{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
5#endif
6#ifdef GHCJS_FAST_WEAK
7{-# LANGUAGE ForeignFunctionInterface #-}
8{-# LANGUAGE JavaScriptFFI #-}
9#endif
10-- | This module defines the 'FastWeakBag' type, which represents a mutable
11-- collection of items that does not cause the items to be retained in memory.
12-- This is useful for situations where a value needs to be inspected or modified
13-- if it is still alive, but can be ignored if it is dead.
14module Data.FastWeakBag
15 ( FastWeakBag
16 , FastWeakBagTicket
17 , empty
18 , isEmpty
19 , insert
20 , traverse
21 , remove
22 -- * Internal functions
23 -- These will not always be available.
24#ifndef GHCJS_FAST_WEAK
25 , _weakBag_children --TODO: Don't export this
26#endif
27 ) where
29import Prelude hiding (traverse)
31import Control.Monad
32import Control.Monad.IO.Class
34#ifdef GHCJS_FAST_WEAK
35import GHCJS.Types
36import Reflex.FastWeak (js_isNull, unsafeFromRawJSVal, unsafeToRawJSVal)
37#else
38import Control.Exception
39import Data.IntMap.Strict (IntMap)
40import qualified Data.IntMap.Strict as IntMap
41import Data.IORef
42import System.Mem.Weak
43#endif
45-- | A 'FastWeakBag' holds a set of values of type @/a/@, but does not retain them -
46-- that is, they can still be garbage-collected. As long as the @/a/@ values remain
47-- alive, the 'FastWeakBag' will continue to refer to them.
48#ifdef GHCJS_FAST_WEAK
49newtype FastWeakBag a = FastWeakBag JSVal
50#else
51data FastWeakBag a = FastWeakBag
52 { _weakBag_nextId :: {-# UNPACK #-} !(IORef Int) --TODO: what if this wraps around?
53 , _weakBag_children :: {-# UNPACK #-} !(IORef (IntMap (Weak a))) -- ^ Map of items contained by the 'FastWeakBag'
54 }
55#endif
57-- | When inserting an item into a 'FastWeakBag', a 'FastWeakBagTicket' is returned. If
58-- the caller retains the ticket, the item is guranteed to stay in memory (and
59-- thus in the 'FastWeakBag'). The ticket can also be used to remove the item from
60-- the 'FastWeakBag' prematurely (i.e. while it is still alive), using 'remove'.
61#ifdef GHCJS_FAST_WEAK
62newtype FastWeakBagTicket a = FastWeakBagTicket JSVal
63#else
64data FastWeakBagTicket a = FastWeakBagTicket
65 { _weakBagTicket_weakItem :: {-# UNPACK #-} !(Weak a)
66 , _weakBagTicket_item :: {-# NOUNPACK #-} !a
67 }
68#endif
70-- | Insert an item into a 'FastWeakBag'.
71{-# INLINE insert #-}
72insert :: a -- ^ The item
73 -> FastWeakBag a -- ^ The 'FastWeakBag' to insert into
74 -> IO (FastWeakBagTicket a) -- ^ Returns a 'FastWeakBagTicket' that ensures the item
75 -- is retained and allows the item to be removed.
76#ifdef GHCJS_FAST_WEAK
77insert a wb = js_insert (unsafeToRawJSVal a) wb
78foreign import javascript unsafe "$r = new h$FastWeakBagTicket($2, $1);" js_insert :: JSVal -> FastWeakBag a -> IO (FastWeakBagTicket a)
79#else
80insert a (FastWeakBag nextId children) = {-# SCC "insert" #-} do
81 a' <- evaluate a
82 myId <- atomicModifyIORef' nextId $ \n -> (succ n, n)
83 let cleanup = atomicModifyIORef' children $ \cs -> (IntMap.delete myId cs, ())
84 wa <- mkWeakPtr a' $ Just cleanup
85 atomicModifyIORef' children $ \cs -> (IntMap.insert myId wa cs, ())
86 return $ FastWeakBagTicket
87 { _weakBagTicket_weakItem = wa
88 , _weakBagTicket_item = a'
89 }
90#endif
92-- | Create an empty 'FastWeakBag'.
93{-# INLINE empty #-}
94empty :: IO (FastWeakBag a)
95#ifdef GHCJS_FAST_WEAK
96empty = js_empty
97foreign import javascript unsafe "$r = new h$FastWeakBag();" js_empty :: IO (FastWeakBag a)
98#else
99empty = {-# SCC "empty" #-} do
100 nextId <- newIORef 1
101 children <- newIORef IntMap.empty
102 let bag = FastWeakBag
103 { _weakBag_nextId = nextId
104 , _weakBag_children = children
105 }
106 return bag
107#endif
109-- | Check whether a 'FastWeakBag' is empty.
110{-# INLINE isEmpty #-}
111isEmpty :: FastWeakBag a -> IO Bool
112#ifdef GHCJS_FAST_WEAK
113isEmpty = js_isEmpty
114foreign 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
115#else
116isEmpty bag = {-# SCC "isEmpty" #-} IntMap.null <$> readIORef (_weakBag_children bag)
117#endif
119{-# INLINE traverse #-}
120-- | Visit every node in the given list. If new nodes are appended during the
121-- traversal, they will not be visited. Every live node that was in the list
122-- when the traversal began will be visited exactly once; however, no guarantee
123-- is made about the order of the traversal.
124traverse :: forall a m. MonadIO m => FastWeakBag a -> (a -> m ()) -> m ()
125#ifdef GHCJS_FAST_WEAK
126traverse wb f = do
127 let go cursor = when (not $ js_isNull cursor) $ do
128 val <- liftIO $ js_getTicketValue cursor
129 f $ unsafeFromRawJSVal val
130 go =<< liftIO (js_getNext (FastWeakBagTicket cursor))
131 go =<< liftIO (js_getInitial wb)
132foreign 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
133foreign import javascript unsafe "$r = $1.val;" js_getTicketValue :: JSVal -> IO JSVal
134--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
135foreign 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
136#else
137traverse (FastWeakBag _ children) f = {-# SCC "traverse" #-} do
138 cs <- liftIO $ readIORef children
139 forM_ cs $ \c -> do
140 ma <- liftIO $ deRefWeak c
141 mapM_ f ma
142#endif
144-- | Remove an item from the 'FastWeakBag'; does nothing if invoked multiple times
145-- on the same 'FastWeakBagTicket'.
146{-# INLINE remove #-}
147remove :: FastWeakBagTicket a -> IO ()
148#ifdef GHCJS_FAST_WEAK
149remove = js_remove
150foreign 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
151#else
152remove (FastWeakBagTicket w _) = {-# SCC "remove" #-} finalize w
153#endif
154--TODO: Should 'remove' also drop the reference to the item?
156--TODO: can/should we provide a null FastWeakBagTicket?