git.iko.soy/reflex
on 8eac9a2 help sign in
90891e1
swap
1 ahead, 731 behind
reflex.cabal+1−1
since splitsnapshots
unifiedsplit
@@ -143,7 +143,7 @@ library
143 ghc-options: -DEXPERIMENTAL_DEPENDENT_SUM_INSTANCES
143 ghc-options: -DEXPERIMENTAL_DEPENDENT_SUM_INSTANCES
144
144
145 if impl(ghcjs)
145 if impl(ghcjs)
146− build-depends: ghcjs-base
146+ build-depends: ghcjs-base, ghcjs-prim, ghc-prim
147
147
148test-suite semantics
148test-suite semantics
149 type: exitcode-stdio-1.0
149 type: exitcode-stdio-1.0
src/Data/FastMutableIntMap.hs+143−6
@@ -1,13 +1,26 @@
1+{-# LANGUAGE BangPatterns #-}
2+{-# LANGUAGE CPP #-}
1{-# LANGUAGE DeriveFunctor #-}
3{-# LANGUAGE DeriveFunctor #-}
2{-# LANGUAGE DeriveFoldable #-}
4{-# LANGUAGE DeriveFoldable #-}
3{-# LANGUAGE DeriveTraversable #-}
5{-# LANGUAGE DeriveTraversable #-}
4{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7+{-# LANGUAGE LambdaCase #-}
8+{-# LANGUAGE ScopedTypeVariables #-}
5{-# LANGUAGE TypeFamilies #-}
9{-# 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
6module Data.FastMutableIntMap
17module Data.FastMutableIntMap
7 ( FastMutableIntMap
18 ( FastMutableIntMap
8 , new
19 , new
9 , newEmpty
20 , newEmpty
10 , insert
21 , insert
22+ , insertLookup
23+ , deleteLookup
11 , isEmpty
24 , isEmpty
12 , getFrozenAndClear
25 , getFrozenAndClear
13 , size
26 , size
@@ -27,56 +40,180 @@ module Data.FastMutableIntMap
27--TODO: Fast patch type
40--TODO: Fast patch type
28
41
29import Prelude hiding (lookup)
42import Prelude hiding (lookup)
30−import Data.IORef
43+
31import Data.IntMap.Strict (IntMap)
44import Data.IntMap.Strict (IntMap)
32import qualified Data.IntMap.Strict as IntMap
45import qualified Data.IntMap.Strict as IntMap
33import Data.Maybe
46import Data.Maybe
34import Reflex.Patch.Class
47import Reflex.Patch.Class
35−import Data.Foldable (traverse_)
36import Control.Monad.IO.Class
48import Control.Monad.IO.Class
37
49
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
38−newtype FastMutableIntMap a = FastMutableIntMap (IORef (IntMap a))
69+ FastMutableIntMap (IORef (IntMap a))
70+#endif
39
71
40new :: IntMap a -> IO (FastMutableIntMap a)
72new :: 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
41new m = FastMutableIntMap <$> newIORef m
79new m = FastMutableIntMap <$> newIORef m
80+#endif
42
81
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
43newEmpty :: IO (FastMutableIntMap a)
85newEmpty :: IO (FastMutableIntMap a)
44newEmpty = FastMutableIntMap <$> newIORef IntMap.empty
86newEmpty = FastMutableIntMap <$> newIORef IntMap.empty
87+#endif
45
88
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
47insert (FastMutableIntMap r) k v = modifyIORef' r $ IntMap.insert k v
94insert (FastMutableIntMap r) k v = modifyIORef' r $ IntMap.insert k v
48−
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+
49−lookup :: FastMutableIntMap a -> Int -> IO (Maybe a)
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
50lookup (FastMutableIntMap r) k = IntMap.lookup k <$> readIORef r
140lookup (FastMutableIntMap r) k = IntMap.lookup k <$> readIORef r
141+#endif
51
142
143+--TODO: Do something faster than trying every one
144+{-# INLINE forIntersectionWithImmutable_ #-}
52forIntersectionWithImmutable_ :: MonadIO m => FastMutableIntMap a -> IntMap b -> (a -> b -> m ()) -> m ()
145forIntersectionWithImmutable_ :: 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
53forIntersectionWithImmutable_ (FastMutableIntMap r) b f = do
152forIntersectionWithImmutable_ (FastMutableIntMap r) b f = do
54 a <- liftIO $ readIORef r
153 a <- liftIO $ readIORef r
55 traverse_ (uncurry f) $ IntMap.intersectionWith (,) a b
154 traverse_ (uncurry f) $ IntMap.intersectionWith (,) a b
155+#endif
56
156
157+{-# INLINE for_ #-}
57for_ :: MonadIO m => FastMutableIntMap a -> (a -> m ()) -> m ()
158for_ :: 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
58for_ (FastMutableIntMap r) f = do
166for_ (FastMutableIntMap r) f = do
59 a <- liftIO $ readIORef r
167 a <- liftIO $ readIORef r
60 traverse_ f a
168 traverse_ f a
169+#endif
61
170
171+#ifdef ghcjs_HOST_OS
172+foreign import javascript unsafe "$r = $1.d2.d1 === 0;" isEmpty :: FastMutableIntMap a -> IO Bool
173+#else
62isEmpty :: FastMutableIntMap a -> IO Bool
174isEmpty :: FastMutableIntMap a -> IO Bool
63isEmpty (FastMutableIntMap r) = IntMap.null <$> readIORef r
175isEmpty (FastMutableIntMap r) = IntMap.null <$> readIORef r
176+#endif
64
177
178+#ifdef ghcjs_HOST_OS
179+foreign import javascript unsafe "$r = $1.d2.d1;" size :: FastMutableIntMap a -> IO Int
180+#else
65size :: FastMutableIntMap a -> IO Int
181size :: FastMutableIntMap a -> IO Int
66size (FastMutableIntMap r) = IntMap.size <$> readIORef r
182size (FastMutableIntMap r) = IntMap.size <$> readIORef r
183+#endif
67
184
68-- | Make an immutable snapshot of the datastructure and clear it
185-- | Make an immutable snapshot of the datastructure and clear it
69getFrozenAndClear :: FastMutableIntMap a -> IO (IntMap a)
186getFrozenAndClear :: 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
70getFrozenAndClear (FastMutableIntMap r) = do
200getFrozenAndClear (FastMutableIntMap r) = do
71 result <- readIORef r
201 result <- readIORef r
72 writeIORef r IntMap.empty
202 writeIORef r IntMap.empty
73 return result
203 return result
204+#endif
74
205
75applyPatch :: FastMutableIntMap a -> PatchIntMap a -> IO (IntMap a)
206applyPatch :: 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
76applyPatch (FastMutableIntMap r) p@(PatchIntMap m) = do
212applyPatch (FastMutableIntMap r) p@(PatchIntMap m) = do
77 v <- readIORef r
213 v <- readIORef r
78 writeIORef r $! applyAlways p v
214 writeIORef r $! applyAlways p v
79 return $ IntMap.intersection v m
215 return $ IntMap.intersection v m
216+#endif
80
217
81newtype PatchIntMap a = PatchIntMap (IntMap (Maybe a)) deriving (Functor, Foldable, Traversable, Monoid)
218newtype PatchIntMap a = PatchIntMap (IntMap (Maybe a)) deriving (Functor, Foldable, Traversable, Monoid)
82
219