@@ -4,6 +4,10 @@
44#ifdef USE_REFLEX_OPTIMIZER
55{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
66#endif
7+#ifdef ghcjs_HOST_OS
8+{-# LANGUAGE ForeignFunctionInterface #-}
9+{-# LANGUAGE JavaScriptFFI #-}
10+#endif
711-- | This module defines the 'FastWeakBag' type, which represents a mutable
812-- collection of items that does not cause the items to be retained in memory.
913-- This is useful for situations where a value needs to be inspected or modified
@@ -18,7 +22,9 @@ module Data.FastWeakBag
1822 , remove
1923 -- * Internal functions
2024 -- These will not always be available.
25+#ifndef ghcjs_HOST_OS
2126 , _weakBag_children --TODO: Don't export this
27+#endif
2228 ) where
2329
2430import Control.Exception
@@ -30,31 +36,48 @@ import qualified Data.IntMap.Strict as IntMap
3036import Data.IORef
3137import System.Mem.Weak
3238
39+#ifdef ghcjs_HOST_OS
40+import GHCJS.Types
41+import Reflex.FastWeak (unsafeFromRawJSVal, unsafeToRawJSVal, js_isNull)
42+#endif
43+
3344import Prelude hiding (mapM_, traverse)
3445
3546-- | A @FastWeakBag a@ holds a set of values of type @a@, but does not retain them -
3647-- that is, they can still be garbage-collected. As long as the @a@s remain
3748-- alive, the 'FastWeakBag' will continue to refer to them.
49+#ifdef ghcjs_HOST_OS
50+newtype FastWeakBag a = FastWeakBag JSVal
51+#else
3852data FastWeakBag a = FastWeakBag
3953 { _weakBag_nextId :: {-# UNPACK #-} !(IORef Int) --TODO: what if this wraps around?
4054 , _weakBag_children :: {-# UNPACK #-} !(IORef (IntMap (Weak a)))
4155 }
56+#endif
4257
4358-- | When inserting an item into a 'FastWeakBag', a 'FastWeakBagTicket' is returned. If
4459-- the caller retains the ticket, the item is guranteed to stay in memory (and
4560-- thus in the 'FastWeakBag'). The ticket can also be used to remove the item from
4661-- the 'FastWeakBag' prematurely (i.e. while it is still alive), using 'remove'.
47−data FastWeakBagTicket = forall a. FastWeakBagTicket
62+#ifdef ghcjs_HOST_OS
63+newtype FastWeakBagTicket a = FastWeakBagTicket JSVal
64+#else
65+data FastWeakBagTicket a = forall FastWeakBagTicket
4866 { _weakBagTicket_weakItem :: {-# UNPACK #-} !(Weak a)
4967 , _weakBagTicket_item :: {-# NOUNPACK #-} !a
5068 }
69+#endif
5170
5271-- | Insert an item into a 'FastWeakBag'.
5372{-# INLINE insert #-}
5473insert :: a -- ^ The item
5574 -> FastWeakBag a -- ^ The 'FastWeakBag' to insert into
56− -> IO FastWeakBagTicket -- ^ Returns a 'FastWeakBagTicket' that ensures the item
75+ -> IO (FastWeakBagTicket a) -- ^ Returns a 'FastWeakBagTicket' that ensures the item
5776 -- is retained and allows the item to be removed.
77+#ifdef ghcjs_HOST_OS
78+insert a wb = js_insert (unsafeToRawJSVal a) wb
79+foreign import javascript unsafe "$r = new h$FastWeakBagTicket($2, $1);" js_insert :: JSVal -> FastWeakBag a -> IO (FastWeakBagTicket a)
80+#else
5881insert a (FastWeakBag nextId children) = {-# SCC "insert" #-} do
5982 a' <- evaluate a
6083 myId <- atomicModifyIORef' nextId $ \n -> (succ n, n)
@@ -65,10 +88,15 @@ insert a (FastWeakBag nextId children) = {-# SCC "insert" #-} do
6588 { _weakBagTicket_weakItem = wa
6689 , _weakBagTicket_item = a'
6790 }
91+#endif
6892
6993-- | Create an empty 'FastWeakBag'.
7094{-# INLINE empty #-}
7195empty :: IO (FastWeakBag a)
96+#ifdef ghcjs_HOST_OS
97+empty = js_empty
98+foreign import javascript unsafe "$r = new h$FastWeakBag();" js_empty :: IO (FastWeakBag a)
99+#else
72100empty = {-# SCC "empty" #-} do
73101 nextId <- newIORef 1
74102 children <- newIORef IntMap.empty
@@ -77,29 +105,53 @@ empty = {-# SCC "empty" #-} do
77105 , _weakBag_children = children
78106 }
79107 return bag
108+#endif
80109
81110-- | Check whether a 'FastWeakBag' is empty.
82111{-# INLINE isEmpty #-}
83112isEmpty :: FastWeakBag a -> IO Bool
113+#ifdef ghcjs_HOST_OS
114+isEmpty = js_isEmpty
115+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
116+#else
84117isEmpty bag = {-# SCC "isEmpty" #-} IntMap.null <$> readIORef (_weakBag_children bag)
118+#endif
85119
86120{-# INLINE traverse #-}
87121-- | Visit every node in the given list. If new nodes are appended during the
88122-- traversal, they will not be visited. Every live node that was in the list
89123-- when the traversal began will be visited exactly once; however, no guarantee
90124-- is made about the order of the traversal.
91−traverse :: MonadIO m => FastWeakBag a -> (a -> m ()) -> m ()
125+traverse :: forall a m. MonadIO m => FastWeakBag a -> (a -> m ()) -> m ()
126+#ifdef ghcjs_HOST_OS
127+traverse wb f = do
128+ let go cursor = when (not $ js_isNull cursor) $ do
129+ val <- liftIO $ js_getTicketValue cursor
130+ f $ unsafeFromRawJSVal val
131+ go =<< liftIO (js_getNext (FastWeakBagTicket cursor))
132+ go =<< liftIO (js_getInitial wb)
133+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
134+foreign import javascript unsafe "$r = $1.val;" js_getTicketValue :: JSVal -> IO JSVal
135+--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
136+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
137+#else
92138traverse (FastWeakBag _ children) f = {-# SCC "traverse" #-} do
93139 cs <- liftIO $ readIORef children
94140 forM_ cs $ \c -> do
95141 ma <- liftIO $ deRefWeak c
96142 mapM_ f ma
143+#endif
97144
98145-- | Remove an item from the 'FastWeakBag'; does nothing if invoked multiple times
99146-- on the same 'FastWeakBagTicket'.
100147{-# INLINE remove #-}
101−remove :: FastWeakBagTicket -> IO ()
148+remove :: FastWeakBagTicket a -> IO ()
149+#ifdef ghcjs_HOST_OS
150+remove = js_remove
151+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
152+#else
102153remove (FastWeakBagTicket w _) = {-# SCC "remove" #-} finalize w
154+#endif
103155--TODO: Should 'remove' also drop the reference to the item?
104156
105157--TODO: can/should we provide a null FastWeakBagTicket?