@@ -1,13 +1,26 @@
1+{-# LANGUAGE BangPatterns #-}
2+{-# LANGUAGE CPP #-}
13{-# LANGUAGE DeriveFunctor #-}
24{-# LANGUAGE DeriveFoldable #-}
35{-# LANGUAGE DeriveTraversable #-}
46{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7+{-# LANGUAGE LambdaCase #-}
8+{-# LANGUAGE ScopedTypeVariables #-}
59{-# LANGUAGE TypeFamilies #-}
10+#undef ghcjs_HOST_OS
11+#ifdef ghcjs_HOST_OS
12+{-# LANGUAGE ForeignFunctionInterface #-}
13+{-# LANGUAGE JavaScriptFFI #-}
14+{-# LANGUAGE MagicHash #-}
15+{-# LANGUAGE UnliftedFFITypes #-}
16+#endif
617module Data.FastMutableIntMap
718 ( FastMutableIntMap
819 , new
920 , newEmpty
1021 , insert
22+ , insertLookup
23+ , deleteLookup
1124 , isEmpty
1225 , getFrozenAndClear
1326 , size
@@ -27,56 +40,180 @@ module Data.FastMutableIntMap
2740--TODO: Fast patch type
2841
2942import Prelude hiding (lookup)
30−import Data.IORef
43+
3144import Data.IntMap.Strict (IntMap)
3245import qualified Data.IntMap.Strict as IntMap
3346import Data.Maybe
3447import Reflex.Patch.Class
35−import Data.Foldable (traverse_)
3648import Control.Monad.IO.Class
3749
38−newtype FastMutableIntMap a = FastMutableIntMap (IORef (IntMap a))
50+#ifdef ghcjs_HOST_OS
51+import Control.Lens (imapM_, iforM_, iforM)
52+import Control.Monad
53+import GHCJS.Types
54+import GHCJS.Marshal
55+import JavaScript.Array (JSArray)
56+import qualified JavaScript.Array as JSArray
57+import GHCJS.Prim (JSVal (..))
58+import GHC.Exts (ByteArray#)
59+import GHC.Prim (unsafeCoerce#)
60+#else
61+import Data.IORef
62+import Data.Foldable (traverse_)
63+#endif
64+
65+newtype FastMutableIntMap a =
66+#ifdef ghcjs_HOST_OS
67+ FastMutableIntMap JSVal
68+#else
69+ FastMutableIntMap (IORef (IntMap a))
70+#endif
3971
4072new :: IntMap a -> IO (FastMutableIntMap a)
73+#ifdef ghcjs_HOST_OS
74+new m = do
75+ result <- newEmpty
76+ imapM_ (insert result) m
77+ return result
78+#else
4179new m = FastMutableIntMap <$> newIORef m
80+#endif
4281
82+#ifdef ghcjs_HOST_OS
83+foreign import javascript unsafe "var a = []; a.__ghcjsArray = true; $r = { f: { n: 'FastMutableIntMap', size: 2 }, d1: a, d2: { d1: 0 }, m: 0 }" newEmpty :: IO (FastMutableIntMap a)
84+#else
4385newEmpty :: IO (FastMutableIntMap a)
4486newEmpty = FastMutableIntMap <$> newIORef IntMap.empty
87+#endif
4588
46−insert :: FastMutableIntMap a -> Int -> a -> IO ()
89+insert :: forall a. FastMutableIntMap a -> Int -> a -> IO ()
90+#ifdef ghcjs_HOST_OS
91+insert m k !v = insert_ m k ((unsafeCoerce# :: a -> ByteArray#) v)
92+foreign import javascript unsafe "if($1.d1[$2 & 0x7FFFFFFF] === undefined) { ++$1.d2.d1; } $1.d1[$2 & 0x7FFFFFFF] = $3;" insert_ :: FastMutableIntMap a -> Int -> ByteArray# -> IO ()
93+#else
4794insert (FastMutableIntMap r) k v = modifyIORef' r $ IntMap.insert k v
48−
49−lookup :: FastMutableIntMap a -> Int -> IO (Maybe a)
95+#endif
96+
97+insertLookup :: forall a. FastMutableIntMap a -> Int -> a -> IO (Maybe a)
98+#ifdef ghcjs_HOST_OS
99+insertLookup m k !newVal = do
100+ oldVal <- insertLookup_ m k ((unsafeCoerce# :: a -> ByteArray#) newVal)
101+ return $ elemFromJSVal oldVal
102+foreign import javascript unsafe "$r = $1.d1[$2 & 0x7FFFFFFF]; if($r === undefined) { ++$1.d2.d1; } $1.d1[$2 & 0x7FFFFFFF] = $3;" insertLookup_ :: FastMutableIntMap a -> Int -> ByteArray# -> IO JSVal
103+#else
104+insertLookup (FastMutableIntMap r) k v = do
105+ oldMap <- readIORef r
106+ let (oldVal, newMap) = IntMap.updateLookupWithKey (\_ _ -> Just v) k oldMap
107+ writeIORef r $! newMap
108+ return oldVal
109+#endif
110+
111+deleteLookup :: FastMutableIntMap a -> Int -> IO (Maybe a)
112+#ifdef ghcjs_HOST_OS
113+deleteLookup m k = do
114+ v <- deleteLookup_ m k
115+ return $ elemFromJSVal v
116+foreign import javascript unsafe "$r = $1.d1[$2 & 0x7FFFFFFF]; if($r !== undefined) { --$1.d2.d1; } delete $1.d1[$2 & 0x7FFFFFFF];" deleteLookup_ :: FastMutableIntMap a -> Int -> IO JSVal
117+#else
118+deleteLookup (FastMutableIntMap r) k = do
119+ oldMap <- readIORef r
120+ let (oldVal, newMap) = IntMap.updateLookupWithKey (\_ _ -> Nothing) k oldMap
121+ writeIORef r $! newMap
122+ return oldVal
123+#endif
124+
125+lookup :: forall a. FastMutableIntMap a -> Int -> IO (Maybe a)
126+#ifdef ghcjs_HOST_OS
127+lookup m k = do
128+ v <- lookup_ m k
129+ return $ elemFromJSVal v
130+foreign import javascript unsafe "$r = $1.d1[$2 & 0x7FFFFFFF];" lookup_ :: FastMutableIntMap a -> Int -> IO JS
131+
132+--TODO: Find out whether it's possible for Haskell objects to be represented as 'undefined'; if so, we need to do something slightly better to represent missing values
133+
134+elemFromJSVal :: JSVal -> Maybe a
135+elemFromJSVal v = case isUndefined v of
136+ True -> Nothing
137+ False -> Just $ (unsafeCoerce# :: ByteArray# -> a) (case v of JSVal raw -> raw)
138+Val
139+#else
50140lookup (FastMutableIntMap r) k = IntMap.lookup k <$> readIORef r
141+#endif
51142
143+--TODO: Do something faster than trying every one
144+{-# INLINE forIntersectionWithImmutable_ #-}
52145forIntersectionWithImmutable_ :: MonadIO m => FastMutableIntMap a -> IntMap b -> (a -> b -> m ()) -> m ()
146+#ifdef ghcjs_HOST_OS
147+forIntersectionWithImmutable_ ma mb f = iforM_ mb $ \k b -> do
148+ liftIO (lookup ma k) >>= \case
149+ Nothing -> return ()
150+ Just a -> f a b
151+#else
53152forIntersectionWithImmutable_ (FastMutableIntMap r) b f = do
54153 a <- liftIO $ readIORef r
55154 traverse_ (uncurry f) $ IntMap.intersectionWith (,) a b
155+#endif
56156
157+{-# INLINE for_ #-}
57158for_ :: MonadIO m => FastMutableIntMap a -> (a -> m ()) -> m ()
159+#ifdef ghcjs_HOST_OS
160+for_ m f = do
161+ raw <- liftIO $ packFastMutableIntMap m --TODO: Don't pack the keys, since we don't need them
162+ forM_ (JSArray.toList raw) $ \p -> do
163+ (_ :: Int, JSVal v) <- liftIO $ fromJSValUnchecked p
164+ f $ (unsafeCoerce# :: ByteArray# -> a) v
165+#else
58166for_ (FastMutableIntMap r) f = do
59167 a <- liftIO $ readIORef r
60168 traverse_ f a
169+#endif
61170
171+#ifdef ghcjs_HOST_OS
172+foreign import javascript unsafe "$r = $1.d2.d1 === 0;" isEmpty :: FastMutableIntMap a -> IO Bool
173+#else
62174isEmpty :: FastMutableIntMap a -> IO Bool
63175isEmpty (FastMutableIntMap r) = IntMap.null <$> readIORef r
176+#endif
64177
178+#ifdef ghcjs_HOST_OS
179+foreign import javascript unsafe "$r = $1.d2.d1;" size :: FastMutableIntMap a -> IO Int
180+#else
65181size :: FastMutableIntMap a -> IO Int
66182size (FastMutableIntMap r) = IntMap.size <$> readIORef r
183+#endif
67184
68185-- | Make an immutable snapshot of the datastructure and clear it
69186getFrozenAndClear :: FastMutableIntMap a -> IO (IntMap a)
187+#ifdef ghcjs_HOST_OS
188+getFrozenAndClear m = do
189+ raw <- packFastMutableIntMap m
190+ clear m
191+ pairs <- forM (JSArray.toList raw) $ \p -> do
192+ (k, JSVal v) <- fromJSValUnchecked p
193+ return (k, (unsafeCoerce# :: ByteArray# -> a) v)
194+ return $ IntMap.fromDistinctAscList pairs
195+-- | Make a copy of a FastMutableIntMap's contents, as an array of key/value pairs
196+foreign import javascript unsafe "$r = new Array($1.d2.d1); $r.__ghcjsArray = true; var i = 0; for(var k in $1.d1) { if(k !== '__ghcjsArray') { var p = [k, $1.d1[k]]; p.__ghcjsArray = true; $r[i++] = p; } } $r.sort(function(a, b) { return a[0] - b[0]; });" packFastMutableIntMap :: FastMutableIntMap a -> IO JSArray
197+foreign import javascript unsafe "$1.d1 = []; $1.d1.__ghcjsArray = true; $1.d2.d1 = 0;" clear :: FastMutableIntMap a -> IO ()
198+--NOTE: We would like to use Array.forEach here, but, at least on Chrome 59, forEach appears to be linear in the maximum key in the array. Since we sometimes use very large indexes, this is unusable. for(... in ...), on the other hand, appears to actually operate sparsely - but this requires us to sort the array in a second step.
199+#else
70200getFrozenAndClear (FastMutableIntMap r) = do
71201 result <- readIORef r
72202 writeIORef r IntMap.empty
73203 return result
204+#endif
74205
75206applyPatch :: FastMutableIntMap a -> PatchIntMap a -> IO (IntMap a)
207+#ifdef ghcjs_HOST_OS
208+applyPatch f (PatchIntMap m) = fmap (IntMap.mapMaybe id) $ iforM m $ \k mv -> case mv of
209+ Nothing -> deleteLookup f k
210+ Just v -> insertLookup f k v
211+#else
76212applyPatch (FastMutableIntMap r) p@(PatchIntMap m) = do
77213 v <- readIORef r
78214 writeIORef r $! applyAlways p v
79215 return $ IntMap.intersection v m
216+#endif
80217
81218newtype PatchIntMap a = PatchIntMap (IntMap (Maybe a)) deriving (Functor, Foldable, Traversable, Monoid)
82219