git.iko.soy/patch
on develop help sign in
Major refactor
d20ce36Ryan Trinkle
bench/Main.hs+26−28
compare with develop
unifiedsplit
@@ -1,38 +1,36 @@
1+{-# LANGUAGE CPP #-}
1{-# LANGUAGE BangPatterns #-}
2{-# LANGUAGE BangPatterns #-}
2{-# LANGUAGE TupleSections #-}
3{-# LANGUAGE TupleSections #-}
3{-# LANGUAGE ScopedTypeVariables #-}
4{-# LANGUAGE ScopedTypeVariables #-}
4{-# LANGUAGE TypeFamilies #-}
5{-# LANGUAGE TypeFamilies #-}
6+
7+-- The instance for NFData (TVar a) is an orphan, but necessary here
8+{-# OPTIONS_GHC -fno-warn-orphans #-}
9+
5module Main where
10module Main where
6
11
7import Data.Functor.Misc
12import Data.Functor.Misc
8−import Control.Monad.Primitive
9import Control.Monad.IO.Class
13import Control.Monad.IO.Class
10import Control.Monad.Identity
14import Control.Monad.Identity
11import Data.Dependent.Sum
15import Data.Dependent.Sum
12import Control.Concurrent.STM
16import Control.Concurrent.STM
13−import Control.Applicative
14−import System.IO.Unsafe
15import Data.IORef
17import Data.IORef
16import Control.DeepSeq
18import Control.DeepSeq
17import Control.Exception (evaluate)
19import Control.Exception (evaluate)
18−import Control.Monad
19import Reflex
20import Reflex
20import Reflex.Host.Class
21import Reflex.Host.Class
21−import System.Mem
22−import System.IO
23import Criterion.Main
22import Criterion.Main
24−
23+import Data.Dependent.Map (DMap)
25−import qualified Data.Traversable as T
26−
27−import qualified Data.Dependent.Map as DM
24+import qualified Data.Dependent.Map as DMap
28−
29
25
30main :: IO ()
26main :: IO ()
31main = defaultMain
27main = defaultMain
32 [ bgroup "micro" micros ]
28 [ bgroup "micro" micros ]
33
29
30+#if !(MIN_VERSION_deepseq(1,4,2))
34instance NFData (IORef a) where
31instance NFData (IORef a) where
35 rnf x = seq x ()
32 rnf x = seq x ()
33+#endif
36
34
37instance NFData (TVar a) where
35instance NFData (TVar a) where
38 rnf x = seq x ()
36 rnf x = seq x ()
@@ -41,15 +39,14 @@ newtype WHNF a = WHNF a
41instance NFData (WHNF a) where
39instance NFData (WHNF a) where
42 rnf (WHNF a) = seq a ()
40 rnf (WHNF a) = seq a ()
43
41
44−withSetup :: NFData b => String -> SpiderHost a -> (a -> SpiderHost b) -> Benchmark
42+withSetup :: NFData b => String -> SpiderHost Global a -> (a -> SpiderHost Global b) -> Benchmark
45withSetup name setup action = env (WHNF <$> runSpiderHost setup) $ \ ~(WHNF a) ->
43withSetup name setup action = env (WHNF <$> runSpiderHost setup) $ \ ~(WHNF a) ->
46 bench name . nfIO $ runSpiderHost (action a)
44 bench name . nfIO $ runSpiderHost (action a)
47
45
48−withSetupWHNF :: String -> SpiderHost a -> (a -> SpiderHost b) -> Benchmark
46+withSetupWHNF :: String -> SpiderHost Global a -> (a -> SpiderHost Global b) -> Benchmark
49withSetupWHNF name setup action = env (WHNF <$> runSpiderHost setup) $ \ ~(WHNF a) ->
47withSetupWHNF name setup action = env (WHNF <$> runSpiderHost setup) $ \ ~(WHNF a) ->
50 bench name . whnfIO $ runSpiderHost (action a)
48 bench name . whnfIO $ runSpiderHost (action a)
51
49
52−
53micros :: [Benchmark]
50micros :: [Benchmark]
54micros =
51micros =
55 [ bench "newIORef" $ whnfIO $ void $ newIORef ()
52 [ bench "newIORef" $ whnfIO $ void $ newIORef ()
@@ -72,40 +69,41 @@ micros =
72 (\(subd, trigger) -> fireAndRead trigger (42 :: Int) subd)
69 (\(subd, trigger) -> fireAndRead trigger (42 :: Int) subd)
73 , withSetupWHNF "fireEventsOnly"
70 , withSetupWHNF "fireEventsOnly"
74 (newEventWithTriggerRef >>= subscribePair)
71 (newEventWithTriggerRef >>= subscribePair)
75− (\(subd, trigger) -> do
72+ (\(_, trigger) -> do
76 Just key <- liftIO $ readIORef trigger
73 Just key <- liftIO $ readIORef trigger
77 fireEvents [key :=> Identity (42 :: Int)])
74 fireEvents [key :=> Identity (42 :: Int)])
78 , withSetupWHNF "fireEventsAndRead(head/merge1)"
75 , withSetupWHNF "fireEventsAndRead(head/merge1)"
79 (setupMerge 1 >>= subscribePair)
76 (setupMerge 1 >>= subscribePair)
80− (\(subd, t:riggers) -> fireAndRead t (42 :: Int) subd)
77+ (\(subd, t:_) -> fireAndRead t (42 :: Int) subd)
81 , withSetupWHNF "fireEventsAndRead(head/merge100)"
78 , withSetupWHNF "fireEventsAndRead(head/merge100)"
82 (setupMerge 100 >>= subscribePair)
79 (setupMerge 100 >>= subscribePair)
83− (\(subd, t:riggers) -> fireAndRead t (42 :: Int) subd)
80+ (\(subd, t:_) -> fireAndRead t (42 :: Int) subd)
84 , withSetupWHNF "fireEventsAndRead(head/merge10000)"
81 , withSetupWHNF "fireEventsAndRead(head/merge10000)"
85 (setupMerge 10000 >>= subscribePair)
82 (setupMerge 10000 >>= subscribePair)
86− (\(subd, t:riggers) -> fireAndRead t (42 :: Int) subd)
83+ (\(subd, t:_) -> fireAndRead t (42 :: Int) subd)
87 , withSetupWHNF "fireEventsOnly(head/merge100)"
84 , withSetupWHNF "fireEventsOnly(head/merge100)"
88 (setupMerge 100 >>= subscribePair)
85 (setupMerge 100 >>= subscribePair)
89− (\(subd, t:riggers) -> do
86+ (\(_, t:_) -> do
90 Just key <- liftIO $ readIORef t
87 Just key <- liftIO $ readIORef t
91 fireEvents [key :=> Identity (42 :: Int)])
88 fireEvents [key :=> Identity (42 :: Int)])
92− , withSetupWHNF "hold" newEventWithTriggerRef $ \(ev,trigger) -> hold (42 :: Int) ev
89+ , withSetupWHNF "hold" newEventWithTriggerRef $ \(ev, _) -> hold (42 :: Int) ev
93 , withSetupWHNF "sample" (newEventWithTriggerRef >>= hold (42 :: Int) . fst) sample
90 , withSetupWHNF "sample" (newEventWithTriggerRef >>= hold (42 :: Int) . fst) sample
94 ]
91 ]
95
92
96setupMerge :: Int
93setupMerge :: Int
97− -> SpiderHost (Event Spider (DM.DMap (Const2 Int a) Identity),
94+ -> SpiderHost Global ( Event (SpiderEnv Global) (DMap (Const2 Int a) Identity)
98− [IORef (Maybe (EventTrigger Spider a))])
95+ , [IORef (Maybe (EventTrigger Spider a))]
96+ )
99setupMerge num = do
97setupMerge num = do
100− (evs, triggers) <- unzip <$> replicateM 100 newEventWithTriggerRef
98+ (evs, triggers) <- unzip <$> replicateM num newEventWithTriggerRef
101− let !m = DM.fromList [(Const2 i) :=> v | (i,v) <- zip [0..] evs]
99+ let !m = DMap.fromList [(Const2 i) :=> v | (i,v) <- zip [0..] evs]
102 pure (merge m, triggers)
100 pure (merge m, triggers)
103
101
104−subscribePair :: (Event Spider a, b) -> SpiderHost (EventHandle Spider a, b)
102+subscribePair :: (Event (SpiderEnv Global) a, b) -> SpiderHost Global (EventHandle (SpiderEnv Global) a, b)
105subscribePair (ev, b) = (,b) <$> subscribeEvent ev
103subscribePair (ev, b) = (,b) <$> subscribeEvent ev
106
104
107−fireAndRead :: IORef (Maybe (EventTrigger Spider a)) -> a -> EventHandle Spider b
105+fireAndRead :: IORef (Maybe (EventTrigger (SpiderEnv Global) a)) -> a -> EventHandle (SpiderEnv Global) b
108− -> SpiderHost (Maybe b)
106+ -> SpiderHost Global (Maybe b)
109fireAndRead trigger val subd = do
107fireAndRead trigger val subd = do
110 Just key <- liftIO $ readIORef trigger
108 Just key <- liftIO $ readIORef trigger
111− fireEventsAndRead [key :=> Identity val] $ readEvent subd >>= T.sequence
109+ fireEventsAndRead [key :=> Identity val] $ readEvent subd >>= sequence
bench/RunAll.hs+2−3
@@ -32,7 +32,6 @@ import Data.Monoid
32import Control.Arrow
32import Control.Arrow
33import Control.Monad
33import Control.Monad
34import Data.Bool
34import Data.Bool
35−import qualified GHC.Event as GHC
36import Control.Concurrent.STM
35import Control.Concurrent.STM
37import Data.Int
36import Data.Int
38import Control.Exception
37import Control.Exception
@@ -80,10 +79,10 @@ benchFiring runHost tc n = runHost $ do
80 case tc of
79 case tc of
81 TestE p -> do
80 TestE p -> do
82 (h, s) <- setupFiring p
81 (h, s) <- setupFiring p
83− runIterations $ readSchedule s $ readEvent' h
82+ runIterations $ readSchedule_ s $ readEvent' h
84 TestB p -> do
83 TestB p -> do
85 (b, s) <- runPlan p
84 (b, s) <- runPlan p
86− runIterations $ readSchedule (makeDense s) $ sample b
85+ runIterations $ readSchedule_ (makeDense s) $ sample b
87
86
88waitForFinalizers :: IO ()
87waitForFinalizers :: IO ()
89waitForFinalizers = do
88waitForFinalizers = do
reflex.cabal+17−11
@@ -16,22 +16,23 @@ bug-reports: https://github.com/reflex-frp/reflex/issues
16library
16library
17 hs-source-dirs: src
17 hs-source-dirs: src
18 build-depends:
18 build-depends:
19− base >= 4.7 && < 4.9,
19+ base >= 4.7 && < 4.10,
20 dependent-sum == 0.3.*,
20 dependent-sum == 0.3.*,
21− dependent-map == 0.2.*,
21+ dependent-map >= 0.2.2 && < 0.3,
22 semigroups >= 0.16 && < 0.19,
22 semigroups >= 0.16 && < 0.19,
23 mtl >= 2.1 && < 2.3,
23 mtl >= 2.1 && < 2.3,
24 containers == 0.5.*,
24 containers == 0.5.*,
25 these >= 0.4 && < 0.7,
25 these >= 0.4 && < 0.7,
26 primitive >= 0.5 && < 0.7,
26 primitive >= 0.5 && < 0.7,
27− template-haskell >= 2.9 && < 2.11,
27+ template-haskell >= 2.9 && < 2.12,
28 ref-tf == 0.4.*,
28 ref-tf == 0.4.*,
29 exception-transformers == 0.4.*,
29 exception-transformers == 0.4.*,
30 transformers >= 0.2,
30 transformers >= 0.2,
31 transformers-compat >= 0.3,
31 transformers-compat >= 0.3,
32 haskell-src-exts >= 1.16 && < 1.18,
32 haskell-src-exts >= 1.16 && < 1.18,
33 haskell-src-meta == 0.6.*,
33 haskell-src-meta == 0.6.*,
34− syb >= 0.5 && < 0.7
34+ syb >= 0.5 && < 0.7,
35+ stm == 2.4.*
35
36
36 exposed-modules:
37 exposed-modules:
37 Reflex,
38 Reflex,
@@ -41,16 +42,18 @@ library
41 Reflex.Dynamic,
42 Reflex.Dynamic,
42 Reflex.Dynamic.TH,
43 Reflex.Dynamic.TH,
43 Reflex.Host.Class,
44 Reflex.Host.Class,
44− Data.Functor.Misc
45+ Data.Functor.Misc,
46+ Data.WeakBag
45
47
46 other-extensions: TemplateHaskell
48 other-extensions: TemplateHaskell
47 ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2
49 ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2
50+ ghc-prof-options: -auto-all
48
51
49
52
50test-suite all
53test-suite all
51 type: exitcode-stdio-1.0
54 type: exitcode-stdio-1.0
52 main-is: Reflex/Test/RunAll.hs
55 main-is: Reflex/Test/RunAll.hs
53− ghc-options: -O2 -Wall
56+ ghc-options: -O2 -Wall -rtsopts
54 hs-source-dirs: test
57 hs-source-dirs: test
55 build-depends:
58 build-depends:
56 base,
59 base,
@@ -60,8 +63,9 @@ test-suite all
60 containers,
63 containers,
61 dependent-map,
64 dependent-map,
62 dependent-sum,
65 dependent-sum,
63− transformers >= 0.3 && < 0.5,
66+ transformers >= 0.3,
64 MemoTrie == 0.6.*,
67 MemoTrie == 0.6.*,
68+ deepseq >= 1.3 && < 1.5,
65 bifunctors,
69 bifunctors,
66 split
70 split
67
71
@@ -70,12 +74,12 @@ benchmark spider-bench
70 type: exitcode-stdio-1.0
74 type: exitcode-stdio-1.0
71 hs-source-dirs: bench
75 hs-source-dirs: bench
72 main-is: Main.hs
76 main-is: Main.hs
73− ghc-options: -O2 -rtsopts
77+ ghc-options: -Wall -O2 -rtsopts
74 build-depends:
78 build-depends:
75 base,
79 base,
76 dependent-sum,
80 dependent-sum,
77 dependent-map,
81 dependent-map,
78− transformers >= 0.3 && < 0.5,
82+ transformers >= 0.3,
79 stm == 2.4.*,
83 stm == 2.4.*,
80 deepseq >= 1.3 && < 1.5,
84 deepseq >= 1.3 && < 1.5,
81 mtl,
85 mtl,
@@ -83,19 +87,21 @@ benchmark spider-bench
83 criterion == 1.1.*,
87 criterion == 1.1.*,
84 reflex
88 reflex
85
89
90+
86benchmark saulzar-bench
91benchmark saulzar-bench
87 type: exitcode-stdio-1.0
92 type: exitcode-stdio-1.0
88 hs-source-dirs: bench test
93 hs-source-dirs: bench test
89 c-sources: bench-cbits/checkCapability.c
94 c-sources: bench-cbits/checkCapability.c
90 main-is: RunAll.hs
95 main-is: RunAll.hs
91− ghc-options: -O2 -rtsopts -threaded
96+ ghc-options: -Wall -O2 -rtsopts -threaded
97+ ghc-prof-options: -auto-all
92 build-depends:
98 build-depends:
93 base,
99 base,
94 containers == 0.5.*,
100 containers == 0.5.*,
95 ref-tf == 0.4,
101 ref-tf == 0.4,
96 dependent-sum,
102 dependent-sum,
97 dependent-map,
103 dependent-map,
98− transformers >= 0.3 && < 0.5,
104+ transformers >= 0.3,
99 stm == 2.4.*,
105 stm == 2.4.*,
100 deepseq >= 1.3 && < 1.5,
106 deepseq >= 1.3 && < 1.5,
101 mtl,
107 mtl,
src/Data/Functor/Misc.hs+19−6
@@ -1,10 +1,12 @@
1−{-# LANGUAGE KindSignatures, GADTs, DeriveDataTypeable, RankNTypes, ScopedTypeVariables, PolyKinds #-}
1+{-# LANGUAGE KindSignatures, GADTs, DeriveDataTypeable, RankNTypes, ScopedTypeVariables, PolyKinds, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, StandaloneDeriving #-}
2module Data.Functor.Misc where
2module Data.Functor.Misc where
3
3
4import Data.GADT.Compare
4import Data.GADT.Compare
5import Data.Map (Map)
5import Data.Map (Map)
6import qualified Data.Map as Map
6import qualified Data.Map as Map
7+import Data.GADT.Show
8+import Data.Dependent.Sum
7−import Data.Dependent.Map (DMap, DSum (..))
9+import Data.Dependent.Map (DMap)
8import qualified Data.Dependent.Map as DMap
10import qualified Data.Dependent.Map as DMap
9import Data.Typeable hiding (Refl)
11import Data.Typeable hiding (Refl)
10import Data.These
12import Data.These
@@ -26,6 +28,14 @@ data Const2 :: * -> * -> * -> * where
26 Const2 :: k -> Const2 k v v
28 Const2 :: k -> Const2 k v v
27 deriving (Typeable)
29 deriving (Typeable)
28
30
31+deriving instance Show k => Show (Const2 k v v)
32+
33+instance Show k => GShow (Const2 k v) where
34+ gshowsPrec n x@(Const2 _) = showsPrec n x
35+
36+instance (Show k, Show (f v)) => ShowTag (Const2 k v) f where
37+ showTaggedPrec (Const2 _) = showsPrec
38+
29instance Eq k => GEq (Const2 k v) where
39instance Eq k => GEq (Const2 k v) where
30 geq (Const2 a) (Const2 b) =
40 geq (Const2 a) (Const2 b) =
31 if a == b
41 if a == b
@@ -55,13 +65,13 @@ combineDMapsWithKey f mg mh = DMap.fromList $ go (DMap.toList mg) (DMap.toList m
55 GGT -> (hk :=> f hk (That hv)) : go gs hs'
65 GGT -> (hk :=> f hk (That hv)) : go gs hs'
56
66
57wrapDMap :: (forall a. a -> f a) -> DMap k Identity -> DMap k f
67wrapDMap :: (forall a. a -> f a) -> DMap k Identity -> DMap k f
58−wrapDMap f = DMap.fromDistinctAscList . map (\(k :=> Identity v) -> k :=> f v) . DMap.toAscList
68+wrapDMap f = DMap.mapWithKey $ \_ -> f . runIdentity
59
69
60rewrapDMap :: (forall (a :: *). f a -> g a) -> DMap k f -> DMap k g
70rewrapDMap :: (forall (a :: *). f a -> g a) -> DMap k f -> DMap k g
61−rewrapDMap f = DMap.fromDistinctAscList . map (\(k :=> v) -> k :=> f v) . DMap.toAscList
71+rewrapDMap f = DMap.mapWithKey $ \_ -> f
62
72
63unwrapDMap :: (forall a. f a -> a) -> DMap k f -> DMap k Identity
73unwrapDMap :: (forall a. f a -> a) -> DMap k f -> DMap k Identity
64−unwrapDMap f = DMap.fromDistinctAscList . map (\(k :=> v) -> k :=> Identity (f v)) . DMap.toAscList
74+unwrapDMap f = DMap.mapWithKey $ \_ -> Identity . f
65
75
66unwrapDMapMaybe :: (forall a. f a -> Maybe a) -> DMap k f -> DMap k Identity
76unwrapDMapMaybe :: (forall a. f a -> Maybe a) -> DMap k f -> DMap k Identity
67unwrapDMapMaybe f m = DMap.fromDistinctAscList [k :=> Identity w | (k :=> v) <- DMap.toAscList m, Just w <- [f v]]
77unwrapDMapMaybe f m = DMap.fromDistinctAscList [k :=> Identity w | (k :=> v) <- DMap.toAscList m, Just w <- [f v]]
@@ -70,7 +80,10 @@ mapToDMap :: Map k v -> DMap (Const2 k v) Identity
70mapToDMap = DMap.fromDistinctAscList . map (\(k, v) -> Const2 k :=> Identity v) . Map.toAscList
80mapToDMap = DMap.fromDistinctAscList . map (\(k, v) -> Const2 k :=> Identity v) . Map.toAscList
71
81
72mapWithFunctorToDMap :: Map k (f v) -> DMap (Const2 k v) f
82mapWithFunctorToDMap :: Map k (f v) -> DMap (Const2 k v) f
73−mapWithFunctorToDMap = DMap.fromDistinctAscList . map (\(k, v) -> (Const2 k) :=> v) . Map.toAscList
83+mapWithFunctorToDMap = DMap.fromDistinctAscList . map (\(k, v) -> Const2 k :=> v) . Map.toAscList
84+
85+extractFunctorDMap :: DMap (Const2 k (f v)) Identity -> DMap (Const2 k v) f
86+extractFunctorDMap = DMap.fromDistinctAscList . map (\(Const2 k :=> Identity v) -> Const2 k :=> v) . DMap.toAscList
74
87
75dmapToMap :: DMap (Const2 k v) Identity -> Map k v
88dmapToMap :: DMap (Const2 k v) Identity -> Map k v
76dmapToMap = Map.fromDistinctAscList . map (\(Const2 k :=> Identity v) -> (k, v)) . DMap.toAscList
89dmapToMap = Map.fromDistinctAscList . map (\(Const2 k :=> Identity v) -> (k, v)) . DMap.toAscList
src/Data/WeakBag.hsnew file+81
@@ -0,0 +1,81 @@
1+{-# LANGUAGE BangPatterns #-}
2+module Data.WeakBag (WeakBag, WeakBagTicket, empty, singleton, insert, Data.WeakBag.traverse, remove) where
3+
4+import Control.Concurrent.STM
5+import Control.Exception
6+import Control.Monad
7+import Control.Monad.IO.Class
8+import Data.IORef
9+import System.Mem.Weak
10+import Data.IntMap.Strict (IntMap)
11+import qualified Data.IntMap.Strict as IntMap
12+
13+data WeakBag a = WeakBag
14+ { _weakBag_nextId :: {-# UNPACK #-} !(TVar Int) --TODO: what if this wraps around?
15+ , _weakBag_children :: {-# UNPACK #-} !(TVar (IntMap (Weak a)))
16+ }
17+
18+data WeakBagTicket a = WeakBagTicket
19+ { _weakBagTicket_weakItem :: {-# UNPACK #-} !(Weak a)
20+ , _weakBagTicket_item :: {-# NOUNPACK #-} !a
21+ }
22+
23+{-# INLINE insert #-}
24+insert :: a -> WeakBag a -> IORef (Weak b) -> (b -> IO ()) -> IO (WeakBagTicket a)
25+insert a (WeakBag nextId children) wbRef finalizer = do
26+ a' <- evaluate a
27+ wbRef' <- evaluate wbRef
28+ myId <- atomically $ do
29+ myId <- readTVar nextId
30+ writeTVar nextId $! succ myId
31+ return myId
32+ let cleanup = do
33+ wb <- readIORef wbRef'
34+ mb <- deRefWeak wb
35+ forM_ mb $ \b -> do
36+ isLastNode <- atomically $ do
37+ cs <- readTVar children
38+ let csWithoutMe = IntMap.delete myId cs
39+ writeTVar children $! csWithoutMe
40+ return $ IntMap.size csWithoutMe == 0
41+ when isLastNode $ finalizer b
42+ return ()
43+ return ()
44+ wa <- mkWeakPtr a' $ Just cleanup
45+ atomically $ modifyTVar' children $ IntMap.insert myId wa
46+ return $ WeakBagTicket
47+ { _weakBagTicket_weakItem = wa
48+ , _weakBagTicket_item = a'
49+ }
50+
51+{-# INLINE empty #-}
52+empty :: IO (WeakBag a)
53+empty = do
54+ nextId <- newTVarIO 1
55+ children <- newTVarIO IntMap.empty
56+ let bag = WeakBag
57+ { _weakBag_nextId = nextId
58+ , _weakBag_children = children
59+ }
60+ return bag
61+
62+{-# INLINE singleton #-}
63+singleton :: a -> IORef (Weak b) -> (b -> IO ()) -> IO (WeakBag a, WeakBagTicket a)
64+singleton a wbRef finalizer = do
65+ bag <- empty
66+ ticket <- insert a bag wbRef finalizer
67+ return (bag, ticket)
68+
69+{-# INLINE traverse #-}
70+-- | Visit every node in the given list. If new nodes are appended during the traversal, they will not be visited.
71+-- 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.
72+traverse :: MonadIO m => WeakBag a -> (a -> m ()) -> m ()
73+traverse (WeakBag _ children) f = do
74+ cs <- liftIO $ readTVarIO children
75+ forM_ cs $ \c -> do
76+ ma <- liftIO $ deRefWeak c
77+ mapM_ f ma
78+
79+{-# INLINE remove #-}
80+remove :: WeakBagTicket a -> IO ()
81+remove = finalize . _weakBagTicket_weakItem
src/Reflex/Class.hs+132−3
@@ -19,19 +19,31 @@ import Data.Map (Map)
19import Data.Dependent.Map (DMap, DSum (..), GCompare (..), GOrdering (..))
19import Data.Dependent.Map (DMap, DSum (..), GCompare (..), GOrdering (..))
20import qualified Data.Dependent.Map as DMap
20import qualified Data.Dependent.Map as DMap
21import Data.Functor.Misc
21import Data.Functor.Misc
22−import Data.Semigroup
22+import Data.Semigroup (Semigroup, (<>), sconcat, stimes, stimesIdempotentMonoid)
23import Data.Traversable
23import Data.Traversable
24+import Data.Functor.Compose
25+import Data.Functor.Constant
26+import Data.Foldable
27+import Data.Maybe
24
28
25-- Note: must come last to silence warnings due to AMP on GHC < 7.10
29-- Note: must come last to silence warnings due to AMP on GHC < 7.10
26import Prelude hiding (mapM, mapM_, sequence, sequence_, foldl)
30import Prelude hiding (mapM, mapM_, sequence, sequence_, foldl)
27
31
28import Debug.Trace (trace)
32import Debug.Trace (trace)
29
33
30−class (MonadHold t (PushM t), MonadSample t (PullM t), MonadFix (PushM t), Functor (Event t), Functor (Behavior t)) => Reflex t where
34+class (MonadHold t (PushM t), MonadSample t (PullM t), MonadFix (PushM t), Functor (Event t), Functor (Behavior t), Functor (Dynamic t), Monad (Dynamic t)) => Reflex t where
31 -- | A container for a value that can change over time. Behaviors can be sampled at will, but it is not possible to be notified when they change
35 -- | A container for a value that can change over time. Behaviors can be sampled at will, but it is not possible to be notified when they change
32 data Behavior t :: * -> *
36 data Behavior t :: * -> *
33 -- | A stream of occurrences. During any given frame, an Event is either occurring or not occurring; if it is occurring, it will contain a value of the given type (its "occurrence type")
37 -- | A stream of occurrences. During any given frame, an Event is either occurring or not occurring; if it is occurring, it will contain a value of the given type (its "occurrence type")
34 data Event t :: * -> *
38 data Event t :: * -> *
39+ -- | A container for a value that can change over time and allows notifications on changes.
40+ -- Basically a combination of a 'Behavior' and an 'Event', with a rule that the Behavior will
41+ -- change if and only if the Event fires.
42+ data Dynamic t :: * -> *
43+ -- | A container for a value that can change over time and allows notifications on changes.
44+ -- Basically a combination of a 'Behavior' and an 'Event', with a rule that the Behavior will
45+ -- change if and only if the Event fires.
46+ data Incremental t :: (* -> *) -> * -> *
35 -- | An Event with no occurrences
47 -- | An Event with no occurrences
36 never :: Event t a
48 never :: Event t a
37 -- | Create a Behavior that always has the given value
49 -- | Create a Behavior that always has the given value
@@ -52,6 +64,61 @@ class (MonadHold t (PushM t), MonadSample t (PullM t), MonadFix (PushM t), Funct
52 switch :: Behavior t (Event t a) -> Event t a
64 switch :: Behavior t (Event t a) -> Event t a
53 -- | Create an Event that will occur whenever the input event is occurring and its occurrence value, another Event, is also occurring
65 -- | Create an Event that will occur whenever the input event is occurring and its occurrence value, another Event, is also occurring
54 coincidence :: Event t (Event t a) -> Event t a
66 coincidence :: Event t (Event t a) -> Event t a
67+ -- | Extract the 'Behavior' of a 'Dynamic'.
68+ current :: Dynamic t a -> Behavior t a
69+ -- | Extract the 'Event' of the 'Dynamic'.
70+ updated :: Dynamic t a -> Event t a
71+ -- | Create a new 'Dynamic'. The given PullM must always return the most recent firing of the given Event, if any.
72+ unsafeBuildDynamic :: PullM t a -> Event t a -> Dynamic t a
73+ -- | Create a new 'Incremental'. The given PullM's value must always change in the same way that the accumulated application of patches would change that value.
74+ unsafeBuildIncremental :: Patch p => PullM t a -> Event t (p a) -> Incremental t p a
75+ -- | Create a merge whose parents can change over time
76+ mergeIncremental :: GCompare k => Incremental t PatchDMap (DMap k (Event t)) -> Event t (DMap k Identity)
77+ -- | Extract the 'Behavior' component of an 'Incremental'
78+ currentIncremental :: Patch p => Incremental t p a -> Behavior t a
79+ -- | Extract the 'Event' component of an 'Incremental'
80+ updatedIncremental :: Patch p => Incremental t p a -> Event t (p a)
81+ -- | Convert an 'Incremental' to a 'Dynamic'
82+ incrementalToDynamic :: Patch p => Incremental t p a -> Dynamic t a
83+
84+class Patch p where
85+ apply :: p a -> a -> Maybe a -- Return Nothing if no change is necessary
86+
87+instance Patch Identity where
88+ apply (Identity a) _ = Just a
89+
90+data PatchDMap a where
91+ PatchDMap :: GCompare k => DMap k (Compose Maybe v) -> PatchDMap (DMap k v)
92+
93+instance GCompare k => Semigroup (PatchDMap (DMap k v)) where
94+ PatchDMap a <> PatchDMap b = PatchDMap $ a `mappend` b --TODO: Add a semigroup instance for DMap
95+ -- PatchDMap is idempotent, so stimes n is id for every n
96+#if MIN_VERSION_semigroups(0,17,0)
97+ stimes = stimesIdempotentMonoid
98+#else
99+ times1p n x = case compare n 0 of
100+ LT -> error "stimesIdempotentMonoid: negative multiplier"
101+ EQ -> mempty
102+ GT -> x
103+#endif
104+
105+instance GCompare k => Monoid (PatchDMap (DMap k v)) where
106+ mempty = PatchDMap mempty
107+ mappend = (<>)
108+
109+instance Patch PatchDMap where
110+ apply (PatchDMap diff) old = Just $! insertions `DMap.union` (old `DMap.difference` deletions) --TODO: return Nothing sometimes --Note: the strict application here is critical to ensuring that incremental merges don't hold onto all their prerequisite events forever; can we make this more robust?
111+ where insertions = DMap.mapMaybeWithKey (const $ id . getCompose) diff
112+ deletions = DMap.mapMaybeWithKey (const $ nothingToJust . getCompose) diff
113+ nothingToJust = \case
114+ Nothing -> Just $ Constant ()
115+ Just _ -> Nothing
116+
117+unsafeDynamic :: Reflex t => Behavior t a -> Event t a -> Dynamic t a
118+unsafeDynamic = unsafeBuildDynamic . sample
119+
120+constDyn :: Reflex t => a -> Dynamic t a
121+constDyn = pure
55
122
56class (Applicative m, Monad m) => MonadSample t m | m -> t where
123class (Applicative m, Monad m) => MonadSample t m | m -> t where
57 -- | Get the current value in the Behavior
124 -- | Get the current value in the Behavior
@@ -60,6 +127,12 @@ class (Applicative m, Monad m) => MonadSample t m | m -> t where
60class MonadSample t m => MonadHold t m where
127class MonadSample t m => MonadHold t m where
61 -- | Create a new Behavior whose value will initially be equal to the given value and will be updated whenever the given Event occurs. The update takes effect immediately after the Event occurs; if the occurrence that sets the Behavior (or one that is simultaneous with it) is used to sample the Behavior, it will see the *old* value of the Behavior, not the new one.
128 -- | Create a new Behavior whose value will initially be equal to the given value and will be updated whenever the given Event occurs. The update takes effect immediately after the Event occurs; if the occurrence that sets the Behavior (or one that is simultaneous with it) is used to sample the Behavior, it will see the *old* value of the Behavior, not the new one.
62 hold :: a -> Event t a -> m (Behavior t a)
129 hold :: a -> Event t a -> m (Behavior t a)
130+ -- | Create a 'Dynamic' value using the given initial value that changes every
131+ -- time the 'Event' occurs.
132+ holdDyn :: a -> Event t a -> m (Dynamic t a)
133+ -- | Create an 'Incremental' value using the given initial value that changes every
134+ -- time the 'Event' occurs.
135+ holdIncremental :: Patch p => a -> Event t (p a) -> m (Incremental t p a)
63
136
64newtype EventSelector t k = EventSelector { select :: forall a. k a -> Event t a }
137newtype EventSelector t k = EventSelector { select :: forall a. k a -> Event t a }
65
138
@@ -72,36 +145,48 @@ instance MonadSample t m => MonadSample t (ReaderT r m) where
72
145
73instance MonadHold t m => MonadHold t (ReaderT r m) where
146instance MonadHold t m => MonadHold t (ReaderT r m) where
74 hold a0 = lift . hold a0
147 hold a0 = lift . hold a0
148+ holdDyn a0 = lift . holdDyn a0
149+ holdIncremental a0 = lift . holdIncremental a0
75
150
76instance (MonadSample t m, Monoid r) => MonadSample t (WriterT r m) where
151instance (MonadSample t m, Monoid r) => MonadSample t (WriterT r m) where
77 sample = lift . sample
152 sample = lift . sample
78
153
79instance (MonadHold t m, Monoid r) => MonadHold t (WriterT r m) where
154instance (MonadHold t m, Monoid r) => MonadHold t (WriterT r m) where
80 hold a0 = lift . hold a0
155 hold a0 = lift . hold a0
156+ holdDyn a0 = lift . holdDyn a0
157+ holdIncremental a0 = lift . holdIncremental a0
81
158
82instance MonadSample t m => MonadSample t (StateT s m) where
159instance MonadSample t m => MonadSample t (StateT s m) where
83 sample = lift . sample
160 sample = lift . sample
84
161
85instance MonadHold t m => MonadHold t (StateT s m) where
162instance MonadHold t m => MonadHold t (StateT s m) where
86 hold a0 = lift . hold a0
163 hold a0 = lift . hold a0
164+ holdDyn a0 = lift . holdDyn a0
165+ holdIncremental a0 = lift . holdIncremental a0
87
166
88instance MonadSample t m => MonadSample t (ExceptT e m) where
167instance MonadSample t m => MonadSample t (ExceptT e m) where
89 sample = lift . sample
168 sample = lift . sample
90
169
91instance MonadHold t m => MonadHold t (ExceptT e m) where
170instance MonadHold t m => MonadHold t (ExceptT e m) where
92 hold a0 = lift . hold a0
171 hold a0 = lift . hold a0
172+ holdDyn a0 = lift . holdDyn a0
173+ holdIncremental a0 = lift . holdIncremental a0
93
174
94instance (MonadSample t m, Monoid w) => MonadSample t (RWST r w s m) where
175instance (MonadSample t m, Monoid w) => MonadSample t (RWST r w s m) where
95 sample = lift . sample
176 sample = lift . sample
96
177
97instance (MonadHold t m, Monoid w) => MonadHold t (RWST r w s m) where
178instance (MonadHold t m, Monoid w) => MonadHold t (RWST r w s m) where
98 hold a0 = lift . hold a0
179 hold a0 = lift . hold a0
180+ holdDyn a0 = lift . holdDyn a0
181+ holdIncremental a0 = lift . holdIncremental a0
99
182
100instance MonadSample t m => MonadSample t (ContT r m) where
183instance MonadSample t m => MonadSample t (ContT r m) where
101 sample = lift . sample
184 sample = lift . sample
102
185
103instance MonadHold t m => MonadHold t (ContT r m) where
186instance MonadHold t m => MonadHold t (ContT r m) where
104 hold a0 = lift . hold a0
187 hold a0 = lift . hold a0
188+ holdDyn a0 = lift . holdDyn a0
189+ holdIncremental a0 = lift . holdIncremental a0
105
190
106--------------------------------------------------------------------------------
191--------------------------------------------------------------------------------
107-- Convenience functions
192-- Convenience functions
@@ -151,6 +236,9 @@ class FunctorMaybe f where
151 -- | Combined mapping and filtering function.
236 -- | Combined mapping and filtering function.
152 fmapMaybe :: (a -> Maybe b) -> f a -> f b
237 fmapMaybe :: (a -> Maybe b) -> f a -> f b
153
238
239+instance FunctorMaybe [] where
240+ fmapMaybe f = catMaybes . fmap f
241+
154-- | Flipped version of 'fmapMaybe'.
242-- | Flipped version of 'fmapMaybe'.
155fforMaybe :: FunctorMaybe f => f a -> (a -> Maybe b) -> f b
243fforMaybe :: FunctorMaybe f => f a -> (a -> Maybe b) -> f b
156fforMaybe = flip fmapMaybe
244fforMaybe = flip fmapMaybe
@@ -311,9 +399,18 @@ sequenceThese t = case t of
311 These ma mb -> liftM2 These ma mb
399 These ma mb -> liftM2 These ma mb
312 That mb -> liftM That mb
400 That mb -> liftM That mb
313
401
402+instance (Semigroup a, Reflex t) => Semigroup (Event t a) where
403+ (<>) = alignWith (mergeThese (<>))
404+ sconcat = fmap sconcat . mergeList . toList
405+#if MIN_VERSION_semigroups(0,17,0)
406+ stimes n = fmap $ stimes n
407+#else
408+ times1p n = fmap $ times1p n
409+#endif
410+
314instance (Semigroup a, Reflex t) => Monoid (Event t a) where
411instance (Semigroup a, Reflex t) => Monoid (Event t a) where
315 mempty = never
412 mempty = never
316− mappend a b = mconcat [a, b]
413+ mappend = (<>)
317 mconcat = fmap sconcat . mergeList
414 mconcat = fmap sconcat . mergeList
318
415
319-- | Create a new 'Event' that occurs if at least one of the 'Event's
416-- | Create a new 'Event' that occurs if at least one of the 'Event's
@@ -372,3 +469,35 @@ gate = attachWithMaybe $ \allow a -> if allow then Just a else Nothing
372switcher :: (Reflex t, MonadHold t m)
469switcher :: (Reflex t, MonadHold t m)
373 => Behavior t a -> Event t (Behavior t a) -> m (Behavior t a)
470 => Behavior t a -> Event t (Behavior t a) -> m (Behavior t a)
374switcher b eb = pull . (sample <=< sample) <$> hold b eb
471switcher b eb = pull . (sample <=< sample) <$> hold b eb
472+
473+zipDynWith :: Reflex t => (a -> b -> c) -> Dynamic t a -> Dynamic t b -> Dynamic t c
474+zipDynWith f da db =
475+ let eab = align (updated da) (updated db)
476+ ec = flip push eab $ \o -> do
477+ (a, b) <- case o of
478+ This a -> do
479+ b <- sample $ current db
480+ return (a, b)
481+ That b -> do
482+ a <- sample $ current da
483+ return (a, b)
484+ These a b -> return (a, b)
485+ return $ Just $ f a b
486+ in unsafeBuildDynamic (f <$> sample (current da) <*> sample (current db)) ec
487+
488+instance (Reflex t, Monoid a) => Monoid (Dynamic t a) where
489+ mconcat = fmap (mconcat . map (\(Const2 _ :=> Identity v) -> v) . DMap.toList) . distributeDMapOverDynPure . DMap.fromList . map (\(k, v) -> Const2 k :=> v) . zip [0 :: Int ..]
490+ mempty = constDyn mempty
491+ mappend = zipDynWith mappend
492+
493+distributeDMapOverDynPure :: forall t k. (Reflex t, GCompare k) => DMap k (Dynamic t) -> Dynamic t (DMap k Identity)
494+distributeDMapOverDynPure dm = case DMap.toList dm of
495+ [] -> constDyn DMap.empty
496+ [k :=> v] -> fmap (DMap.singleton k . Identity) v
497+ _ ->
498+ let getInitial = DMap.traverseWithKey (\_ -> fmap Identity . sample . current) dm
499+ edmPre = merge $ rewrapDMap updated dm
500+ result = unsafeBuildDynamic getInitial $ flip pushAlways edmPre $ \news -> do
501+ olds <- sample $ current result
502+ return $ DMap.unionWithKey (\_ _ new -> new) olds news
503+ in result
src/Reflex/Dynamic.hs+65−148
@@ -1,4 +1,4 @@
1−{-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes, GADTs, ScopedTypeVariables, FunctionalDependencies, RecursiveDo, UndecidableInstances, GeneralizedNewtypeDeriving, StandaloneDeriving, EmptyDataDecls, NoMonomorphismRestriction, TypeOperators, DeriveDataTypeable, PackageImports, TemplateHaskell, LambdaCase, DataKinds, PolyKinds #-}
1+{-# LANGUAGE CPP, TypeFamilies, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes, GADTs, ScopedTypeVariables, FunctionalDependencies, RecursiveDo, UndecidableInstances, GeneralizedNewtypeDeriving, StandaloneDeriving, EmptyDataDecls, NoMonomorphismRestriction, TypeOperators, DeriveDataTypeable, PackageImports, TemplateHaskell, LambdaCase, DataKinds, PolyKinds #-}
2module Reflex.Dynamic ( Dynamic -- Abstract so we can preserve the law that the current value is always equal to the most recent update
2module Reflex.Dynamic ( Dynamic -- Abstract so we can preserve the law that the current value is always equal to the most recent update
3 , current
3 , current
4 , updated
4 , updated
@@ -14,7 +14,6 @@ module Reflex.Dynamic ( Dynamic -- Abstract so we can preserve the law that the
14 , attachDynWithMaybe
14 , attachDynWithMaybe
15 , mapDyn
15 , mapDyn
16 , forDyn
16 , forDyn
17− , mapDynM
18 , foldDyn
17 , foldDyn
19 , foldDynM
18 , foldDynM
20 , foldDynMaybe
19 , foldDynMaybe
@@ -29,6 +28,7 @@ module Reflex.Dynamic ( Dynamic -- Abstract so we can preserve the law that the
29 , traceDyn
28 , traceDyn
30 , traceDynWith
29 , traceDynWith
31 , splitDyn
30 , splitDyn
31+ , splitDynPure
32 , Demux
32 , Demux
33 , demux
33 , demux
34 , getDemuxed
34 , getDemuxed
@@ -49,16 +49,15 @@ import Control.Monad hiding (mapM, mapM_, forM, forM_)
49import Control.Monad.Fix
49import Control.Monad.Fix
50import Control.Monad.Identity hiding (mapM, mapM_, forM, forM_)
50import Control.Monad.Identity hiding (mapM, mapM_, forM, forM_)
51import Data.These
51import Data.These
52−import Data.Traversable (mapM, forM)
53import Data.Align
52import Data.Align
54import Data.Map (Map)
53import Data.Map (Map)
55−import qualified Data.Map as Map
56import Data.Dependent.Map (DMap)
54import Data.Dependent.Map (DMap)
57import qualified Data.Dependent.Map as DMap
55import qualified Data.Dependent.Map as DMap
58import Data.Dependent.Sum (DSum (..))
56import Data.Dependent.Sum (DSum (..))
59import Data.GADT.Compare (GCompare (..), GEq (..), (:~:) (..), GOrdering (..))
57import Data.GADT.Compare (GCompare (..), GEq (..), (:~:) (..), GOrdering (..))
60import Data.Monoid
58import Data.Monoid
61−--import Data.HList (HList (..), hBuild)
59+
60+import Debug.Trace
62
61
63data HList (l::[*]) where
62data HList (l::[*]) where
64 HNil :: HList '[]
63 HNil :: HList '[]
@@ -91,45 +90,12 @@ instance HBuild' (a ': l) r
91 => HBuild' l (a->r) where
90 => HBuild' l (a->r) where
92 hBuild' l x = hBuild' (HCons x l)
91 hBuild' l x = hBuild' (HCons x l)
93
92
94−-- | A container for a value that can change over time and allows notifications on changes.
95−-- Basically a combination of a 'Behavior' and an 'Event', with a rule that the Behavior will
96−-- change if and only if the Event fires.
97−--
98−-- Although @Dynamic@ logically has a 'Functor' instance, currently it can\'t
99−-- be implemented without potentially requiring the mapped function to be
100−-- evaluated twice. Instead, you can use 'mapDyn', which runs in a 'MonadHold'
101−-- instance, to achieve the same result.
102−data Dynamic t a
103− = Dynamic (Behavior t a) (Event t a)
104−
105−unsafeDynamic :: Behavior t a -> Event t a -> Dynamic t a
106−unsafeDynamic = Dynamic
107−
108−-- | Extract the 'Behavior' of a 'Dynamic'.
109−current :: Dynamic t a -> Behavior t a
110−current (Dynamic b _) = b
111−
112−-- | Extract the 'Event' of the 'Dynamic'.
113−updated :: Dynamic t a -> Event t a
114−updated (Dynamic _ e) = e
115−
116−-- | 'Dynamic' with the constant supplied value.
117−constDyn :: Reflex t => a -> Dynamic t a
118−constDyn x = Dynamic (constant x) never
119−
120−-- | Create a 'Dynamic' using the initial value that changes every
121−-- time the 'Event' occurs.
122−holdDyn :: MonadHold t m => a -> Event t a -> m (Dynamic t a)
123−holdDyn v0 e = do
124− b <- hold v0 e
125− return $ Dynamic b e
126−
127-- | Create a new 'Dynamic' that only signals changes if the values
93-- | Create a new 'Dynamic' that only signals changes if the values
128-- actually changed.
94-- actually changed.
129nubDyn :: (Reflex t, Eq a) => Dynamic t a -> Dynamic t a
95nubDyn :: (Reflex t, Eq a) => Dynamic t a -> Dynamic t a
130nubDyn d =
96nubDyn d =
131 let e' = attachWithMaybe (\x x' -> if x' == x then Nothing else Just x') (current d) (updated d)
97 let e' = attachWithMaybe (\x x' -> if x' == x then Nothing else Just x') (current d) (updated d)
132− in Dynamic (current d) e' --TODO: Avoid invalidating the outgoing Behavior
98+ in unsafeDynamic (current d) e' --TODO: Avoid invalidating the outgoing Behavior
133
99
134{-
100{-
135instance Reflex t => Functor (Dynamic t) where
101instance Reflex t => Functor (Dynamic t) where
@@ -141,25 +107,13 @@ instance Reflex t => Functor (Dynamic t) where
141-}
107-}
142
108
143-- | Map a function over a 'Dynamic'.
109-- | Map a function over a 'Dynamic'.
144−mapDyn :: (Reflex t, MonadHold t m) => (a -> b) -> Dynamic t a -> m (Dynamic t b)
110+mapDyn :: (Reflex t, Monad m) => (a -> b) -> Dynamic t a -> m (Dynamic t b)
145−mapDyn f = mapDynM $ return . f
111+mapDyn f = return . fmap f
146
112
147-- | Flipped version of 'mapDyn'.
113-- | Flipped version of 'mapDyn'.
148−forDyn :: (Reflex t, MonadHold t m) => Dynamic t a -> (a -> b) -> m (Dynamic t b)
114+forDyn :: (Reflex t, Monad m) => Dynamic t a -> (a -> b) -> m (Dynamic t b)
149forDyn = flip mapDyn
115forDyn = flip mapDyn
150
116
151−-- | Map a monadic function over a 'Dynamic'. The only monadic action that the given function can
152−-- perform is 'sample'.
153−{-# INLINE mapDynM #-}
154−mapDynM :: forall t m a b. (Reflex t, MonadHold t m) => (forall m'. MonadSample t m' => a -> m' b) -> Dynamic t a -> m (Dynamic t b)
155−mapDynM f d = do
156− let e' = push (liftM Just . f :: a -> PushM t (Maybe b)) $ updated d
157− eb' = fmap constant e'
158− v0 = pull $ f =<< sample (current d)
159− bb' :: Behavior t (Behavior t b) <- hold v0 eb'
160− let b' = pull $ sample =<< sample bb'
161− return $ Dynamic b' e'
162−
163-- | Create a 'Dynamic' using the initial value and change it each
117-- | Create a 'Dynamic' using the initial value and change it each
164-- time the 'Event' occurs using a folding function on the previous
118-- time the 'Event' occurs using a folding function on the previous
165-- value and the value of the 'Event'.
119-- value and the value of the 'Event'.
@@ -178,10 +132,10 @@ foldDynMaybe f = foldDynMaybeM $ \o v -> return $ f o v
178foldDynMaybeM :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe b)) -> b -> Event t a -> m (Dynamic t b)
132foldDynMaybeM :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe b)) -> b -> Event t a -> m (Dynamic t b)
179foldDynMaybeM f z e = do
133foldDynMaybeM f z e = do
180 rec let e' = flip push e $ \o -> do
134 rec let e' = flip push e $ \o -> do
181− v <- sample b'
135+ v <- sample $ current d'
182 f o v
136 f o v
183− b' <- hold z e'
137+ d' <- holdDyn z e'
184− return $ Dynamic b' e'
138+ return d'
185
139
186-- | Create a new 'Dynamic' that counts the occurences of the 'Event'.
140-- | Create a new 'Dynamic' that counts the occurences of the 'Event'.
187count :: (Reflex t, MonadHold t m, MonadFix m, Num b) => Event t a -> m (Dynamic t b)
141count :: (Reflex t, MonadHold t m, MonadFix m, Num b) => Event t a -> m (Dynamic t b)
@@ -222,55 +176,29 @@ mconcatE = concatEventsWith mappend
222
176
223-- | Split the 'Dynamic' into two 'Dynamic's, each taking the
177-- | Split the 'Dynamic' into two 'Dynamic's, each taking the
224-- respective value of the tuple.
178-- respective value of the tuple.
225−splitDyn :: (Reflex t, MonadHold t m) => Dynamic t (a, b) -> m (Dynamic t a, Dynamic t b)
179+splitDyn :: (Reflex t, Monad m) => Dynamic t (a, b) -> m (Dynamic t a, Dynamic t b)
226−splitDyn d = liftM2 (,) (mapDyn fst d) (mapDyn snd d)
180+splitDyn = return . splitDynPure
181+
182+splitDynPure :: Reflex t => Dynamic t (a, b) -> (Dynamic t a, Dynamic t b)
183+splitDynPure d = (fmap fst d, fmap snd d)
227
184
228-- | Merge the 'Dynamic' values using their 'Monoid' instance.
185-- | Merge the 'Dynamic' values using their 'Monoid' instance.
229−mconcatDyn :: forall t m a. (Reflex t, MonadHold t m, Monoid a) => [Dynamic t a] -> m (Dynamic t a)
186+mconcatDyn :: forall t m a. (Reflex t, Monad m, Monoid a) => [Dynamic t a] -> m (Dynamic t a)
230−mconcatDyn es = do
187+mconcatDyn = return . mconcat
231− ddm :: Dynamic t (DMap (Const2 Int a) Identity) <- distributeDMapOverDyn . DMap.fromList . map (\(k, v) -> Const2 k :=> v) $ zip [0 :: Int ..] es
232− mapDyn (mconcat . map (\(Const2 _ :=> Identity v) -> v) . DMap.toList) ddm
233
188
234-- | Create a 'Dynamic' with a 'DMap' of values out of a 'DMap' of
189-- | Create a 'Dynamic' with a 'DMap' of values out of a 'DMap' of
235-- Dynamic values.
190-- Dynamic values.
236−distributeDMapOverDyn :: forall t m k. (Reflex t, MonadHold t m, GCompare k) => DMap k (Dynamic t) -> m (Dynamic t (DMap k Identity))
191+distributeDMapOverDyn :: (Reflex t, Monad m, GCompare k) => DMap k (Dynamic t) -> m (Dynamic t (DMap k Identity))
237−distributeDMapOverDyn dm = case DMap.toList dm of
192+distributeDMapOverDyn = return . distributeDMapOverDynPure
238− [] -> return $ constDyn DMap.empty
193+
239− [k :=> v] -> mapDyn (DMap.singleton k . Identity) v
194+distributeMapOverDynPure :: (Reflex t, Ord k) => Map k (Dynamic t v) -> Dynamic t (Map k v)
240− _ -> do
195+distributeMapOverDynPure = fmap dmapToMap . distributeDMapOverDynPure . mapWithFunctorToDMap
241− let edmPre = merge $ rewrapDMap updated dm
242− edm :: Event t (DMap k Identity) = flip push edmPre $ \o -> return . Just =<< do
243− let f _ = \case
244− This origDyn -> sample $ current origDyn
245− That _ -> error "distributeDMapOverDyn: should be impossible to have an event occurring that is not present in the original DMap"
246− These _ (Identity newVal) -> return newVal
247− sequenceDmap $ combineDMapsWithKey f dm (wrapDMap Identity o)
248− dm0 :: Behavior t (DMap k Identity) = pull $ do
249− liftM DMap.fromList . forM (DMap.toList dm) $ \(k :=> dv) -> liftM ((k :=>) . Identity) . sample $ current dv
250− bbdm :: Behavior t (Behavior t (DMap k Identity)) <- hold dm0 $ fmap constant edm
251− let bdm = pull $ sample =<< sample bbdm
252− return $ Dynamic bdm edm
253
196
254-- | Merge two 'Dynamic's into a new one using the provided
197-- | Merge two 'Dynamic's into a new one using the provided
255-- function. The new 'Dynamic' changes its value each time one of the
198-- function. The new 'Dynamic' changes its value each time one of the
256-- original 'Dynamic's changes its value.
199-- original 'Dynamic's changes its value.
257−combineDyn :: forall t m a b c. (Reflex t, MonadHold t m) => (a -> b -> c) -> Dynamic t a -> Dynamic t b -> m (Dynamic t c)
200+combineDyn :: forall t m a b c. (Reflex t, Monad m) => (a -> b -> c) -> Dynamic t a -> Dynamic t b -> m (Dynamic t c)
258−combineDyn f da db = do
201+combineDyn f da db = return $ zipDynWith f da db
259− let eab = align (updated da) (updated db)
260− ec = flip push eab $ \o -> do
261− (a, b) <- case o of
262− This a -> do
263− b <- sample $ current db
264− return (a, b)
265− That b -> do
266− a <- sample $ current da
267− return (a, b)
268− These a b -> return (a, b)
269− return $ Just $ f a b
270− c0 :: Behavior t c = pull $ liftM2 f (sample $ current da) (sample $ current db)
271− bbc :: Behavior t (Behavior t c) <- hold c0 $ fmap constant ec
272− let bc :: Behavior t c = pull $ sample =<< sample bbc
273− return $ Dynamic bc ec
274
202
275-- | A psuedo applicative version of ap for 'Dynamic'. Example useage:
203-- | A psuedo applicative version of ap for 'Dynamic'. Example useage:
276--
204--
@@ -279,49 +207,22 @@ combineDyn f da db = do
279-- > `apDyn` dynListName
207-- > `apDyn` dynListName
280-- > `apDyn` dynAge
208-- > `apDyn` dynAge
281-- > `apDyn` dynAddress
209-- > `apDyn` dynAddress
282−apDyn :: forall t m a b. (Reflex t, MonadHold t m)
210+apDyn :: forall t m a b. (Reflex t, Monad m)
283 => m (Dynamic t (a -> b))
211 => m (Dynamic t (a -> b))
284 -> Dynamic t a
212 -> Dynamic t a
285 -> m (Dynamic t b)
213 -> m (Dynamic t b)
286apDyn m a = do
214apDyn m a = do
287 r <- m
215 r <- m
288− combineDyn (\f c -> f c) r a
216+ return $ r <*> a
289−
290−{-
291−tagInnerDyn :: Reflex t => Event t (Dynamic t a) -> Event t a
292−tagInnerDyn e =
293− let eSlow = push (liftM Just . sample . current) e
294− eFast = coincidence $ fmap updated e
295− in leftmost [eFast, eSlow]
296−-}
297
217
298−-- | Join a nested 'Dynamic' into a new 'Dynamic' that has the value
299−-- of the inner 'Dynamic'.
300−joinDyn :: forall t a. (Reflex t) => Dynamic t (Dynamic t a) -> Dynamic t a
218+joinDyn :: Reflex t => Dynamic t (Dynamic t a) -> Dynamic t a
301−joinDyn dd =
219+joinDyn = join
302− let b' = pull $ sample . current =<< sample (current dd)
303− eOuter :: Event t a = pushAlways (sample . current) $ updated dd
304− eInner :: Event t a = switch $ fmap updated (current dd)
305− eBoth :: Event t a = coincidence $ fmap updated (updated dd)
306− e' = leftmost [eBoth, eOuter, eInner]
307− in Dynamic b' e'
308
220
309--TODO: Generalize this to functors other than Maps
221--TODO: Generalize this to functors other than Maps
310-- | Combine a 'Dynamic' of a 'Map' of 'Dynamic's into a 'Dynamic'
222-- | Combine a 'Dynamic' of a 'Map' of 'Dynamic's into a 'Dynamic'
311-- with the current values of the 'Dynamic's in a map.
223-- with the current values of the 'Dynamic's in a map.
312joinDynThroughMap :: forall t k a. (Reflex t, Ord k) => Dynamic t (Map k (Dynamic t a)) -> Dynamic t (Map k a)
224joinDynThroughMap :: forall t k a. (Reflex t, Ord k) => Dynamic t (Map k (Dynamic t a)) -> Dynamic t (Map k a)
313−joinDynThroughMap dd =
225+joinDynThroughMap = joinDyn . fmap distributeMapOverDynPure
314− let b' = pull $ mapM (sample . current) =<< sample (current dd)
315− eOuter :: Event t (Map k a) = pushAlways (mapM (sample . current)) $ updated dd
316− eInner :: Event t (Map k a) = attachWith (flip Map.union) b' $ switch $ fmap (mergeMap . fmap updated) (current dd) --Note: the flip is important because Map.union is left-biased
317− readNonFiring :: MonadSample t m => These (Dynamic t a) a -> m a
318− readNonFiring = \case
319− This d -> sample $ current d
320− That a -> return a
321− These _ a -> return a
322− eBoth :: Event t (Map k a) = coincidence $ fmap (\m -> pushAlways (mapM readNonFiring . align m) $ mergeMap $ fmap updated m) (updated dd)
323− e' = leftmost [eBoth, eOuter, eInner]
324− in Dynamic b' e'
325
226
326-- | Print the value of the 'Dynamic' on each change and prefix it
227-- | Print the value of the 'Dynamic' on each change and prefix it
327-- with the provided string. This should /only/ be used for debugging.
228-- with the provided string. This should /only/ be used for debugging.
@@ -340,7 +241,10 @@ traceDyn s = traceDynWith $ \x -> s <> ": " <> show x
340traceDynWith :: Reflex t => (a -> String) -> Dynamic t a -> Dynamic t a
241traceDynWith :: Reflex t => (a -> String) -> Dynamic t a -> Dynamic t a
341traceDynWith f d =
242traceDynWith f d =
342 let e' = traceEventWith f $ updated d
243 let e' = traceEventWith f $ updated d
244+ getV0 = do
343− in Dynamic (current d) e'
245+ x <- sample $ current d
246+ trace (f x) $ return x
247+ in unsafeBuildDynamic getV0 e'
344
248
345-- | Replace the value of the 'Event' with the current value of the 'Dynamic'
249-- | Replace the value of the 'Event' with the current value of the 'Dynamic'
346-- each time the 'Event' occurs.
250-- each time the 'Event' occurs.
@@ -410,12 +314,13 @@ demux k = Demux (current k)
410--TODO: The pattern of using hold (sample b0) can be reused in various places as a safe way of building certain kinds of Dynamics; see if we can factor this out
314--TODO: The pattern of using hold (sample b0) can be reused in various places as a safe way of building certain kinds of Dynamics; see if we can factor this out
411-- | Select a particular output of the 'Demux'; this is equivalent to (but much faster than)
315-- | Select a particular output of the 'Demux'; this is equivalent to (but much faster than)
412-- mapping over the original 'Dynamic' and checking whether it is equal to the given key.
316-- mapping over the original 'Dynamic' and checking whether it is equal to the given key.
413−getDemuxed :: (Reflex t, MonadHold t m, Eq k) => Demux t k -> k -> m (Dynamic t Bool)
317+getDemuxed :: (Reflex t, Monad m, Eq k) => Demux t k -> k -> m (Dynamic t Bool)
414−getDemuxed d k = do
318+getDemuxed d k = return $ demuxed d k
319+
320+demuxed :: (Reflex t, Eq k) => Demux t k -> k -> Dynamic t Bool
321+demuxed d k =
415 let e = select (demuxSelector d) (Const2 k)
322 let e = select (demuxSelector d) (Const2 k)
416− bb <- hold (liftM (==k) $ sample $ demuxValue d) $ fmap return e
323+ in unsafeBuildDynamic (liftM (==k) $ sample $ demuxValue d) e
417− let b = pull $ join $ sample bb
418− return $ Dynamic b e
419
324
420--------------------------------------------------------------------------------
325--------------------------------------------------------------------------------
421-- collectDyn
326-- collectDyn
@@ -473,16 +378,11 @@ instance RebuildSortedHList t => RebuildSortedHList (h ': t) where
473dmapToHList :: forall l. RebuildSortedHList l => DMap (HListPtr l) Identity -> HList l
378dmapToHList :: forall l. RebuildSortedHList l => DMap (HListPtr l) Identity -> HList l
474dmapToHList = rebuildSortedHList . DMap.toList
379dmapToHList = rebuildSortedHList . DMap.toList
475
380
476−distributeFHListOverDyn :: forall t m l. (Reflex t, MonadHold t m, RebuildSortedHList l) => FHList (Dynamic t) l -> m (Dynamic t (HList l))
381+distributeFHListOverDyn :: forall t m l. (Reflex t, Monad m, RebuildSortedHList l) => FHList (Dynamic t) l -> m (Dynamic t (HList l))
477−distributeFHListOverDyn l = mapDyn dmapToHList =<< distributeDMapOverDyn (fhlistToDMap l)
382+distributeFHListOverDyn = return . distributeFHListOverDynPure
478−{-
383+
479−distributeFHListOverDyn l = do
384+distributeFHListOverDynPure :: (Reflex t, RebuildSortedHList l) => FHList (Dynamic t) l -> Dynamic t (HList l)
480− let ec = undefined
385+distributeFHListOverDynPure l = fmap dmapToHList $ distributeDMapOverDynPure $ fhlistToDMap l
481− c0 = pull $ sequenceFHList $ natMap (sample . current) l
482− bbc <- hold c0 $ fmap constant ec
483− let bc = pull $ sample =<< sample bbc
484− return $ Dynamic bc ec
485−-}
486
386
487class AllAreFunctors (f :: a -> *) (l :: [a]) where
387class AllAreFunctors (f :: a -> *) (l :: [a]) where
488 type FunctorList f l :: [*]
388 type FunctorList f l :: [*]
@@ -493,24 +393,35 @@ instance AllAreFunctors f '[] where
493 type FunctorList f '[] = '[]
393 type FunctorList f '[] = '[]
494 toFHList l = case l of
394 toFHList l = case l of
495 HNil -> FHNil
395 HNil -> FHNil
396+#if !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ < 800
496 _ -> error "toFHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139
397 _ -> error "toFHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139
398+#endif
497 fromFHList FHNil = HNil
399 fromFHList FHNil = HNil
498
400
499instance AllAreFunctors f t => AllAreFunctors f (h ': t) where
401instance AllAreFunctors f t => AllAreFunctors f (h ': t) where
500 type FunctorList f (h ': t) = f h ': FunctorList f t
402 type FunctorList f (h ': t) = f h ': FunctorList f t
501 toFHList l = case l of
403 toFHList l = case l of
502 a `HCons` b -> a `FHCons` toFHList b
404 a `HCons` b -> a `FHCons` toFHList b
405+#if !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ < 800
503 _ -> error "toFHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139
406 _ -> error "toFHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139
407+#endif
504 fromFHList (a `FHCons` b) = a `HCons` fromFHList b
408 fromFHList (a `FHCons` b) = a `HCons` fromFHList b
505
409
506collectDyn :: ( RebuildSortedHList (HListElems b)
410collectDyn :: ( RebuildSortedHList (HListElems b)
507 , IsHList a, IsHList b
411 , IsHList a, IsHList b
508 , AllAreFunctors (Dynamic t) (HListElems b)
412 , AllAreFunctors (Dynamic t) (HListElems b)
509− , Reflex t, MonadHold t m
413+ , Reflex t, Monad m
510 , HListElems a ~ FunctorList (Dynamic t) (HListElems b)
414 , HListElems a ~ FunctorList (Dynamic t) (HListElems b)
511 ) => a -> m (Dynamic t b)
415 ) => a -> m (Dynamic t b)
512−collectDyn ds =
416+collectDyn = return . collectDynPure
417+
418+collectDynPure :: ( RebuildSortedHList (HListElems b)
419+ , IsHList a, IsHList b
420+ , AllAreFunctors (Dynamic t) (HListElems b)
421+ , Reflex t
422+ , HListElems a ~ FunctorList (Dynamic t) (HListElems b)
423+ ) => a -> Dynamic t b
513− mapDyn fromHList =<< distributeFHListOverDyn (toFHList $ toHList ds)
424+collectDynPure ds = fmap fromHList $ distributeFHListOverDynPure $ toFHList $ toHList ds
514
425
515-- Poor man's Generic
426-- Poor man's Generic
516class IsHList a where
427class IsHList a where
@@ -523,18 +434,24 @@ instance IsHList (a, b) where
523 toHList (a, b) = hBuild a b
434 toHList (a, b) = hBuild a b
524 fromHList l = case l of
435 fromHList l = case l of
525 a `HCons` b `HCons` HNil -> (a, b)
436 a `HCons` b `HCons` HNil -> (a, b)
437+#if !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ < 800
526 _ -> error "fromHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139
438 _ -> error "fromHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139
439+#endif
527
440
528instance IsHList (a, b, c, d) where
441instance IsHList (a, b, c, d) where
529 type HListElems (a, b, c, d) = [a, b, c, d]
442 type HListElems (a, b, c, d) = [a, b, c, d]
530 toHList (a, b, c, d) = hBuild a b c d
443 toHList (a, b, c, d) = hBuild a b c d
531 fromHList l = case l of
444 fromHList l = case l of
532 a `HCons` b `HCons` c `HCons` d `HCons` HNil -> (a, b, c, d)
445 a `HCons` b `HCons` c `HCons` d `HCons` HNil -> (a, b, c, d)
446+#if !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ < 800
533 _ -> error "fromHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139
447 _ -> error "fromHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139
448+#endif
534
449
535instance IsHList (a, b, c, d, e, f) where
450instance IsHList (a, b, c, d, e, f) where
536 type HListElems (a, b, c, d, e, f) = [a, b, c, d, e, f]
451 type HListElems (a, b, c, d, e, f) = [a, b, c, d, e, f]
537 toHList (a, b, c, d, e, f) = hBuild a b c d e f
452 toHList (a, b, c, d, e, f) = hBuild a b c d e f
538 fromHList l = case l of
453 fromHList l = case l of
539 a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` f `HCons` HNil -> (a, b, c, d, e, f)
454 a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` f `HCons` HNil -> (a, b, c, d, e, f)
455+#if !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ < 800
540 _ -> error "fromHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139
456 _ -> error "fromHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139
457+#endif
src/Reflex/Spider.hs+4−1
@@ -1,5 +1,8 @@
1module Reflex.Spider ( Spider
1module Reflex.Spider ( Spider
2− , SpiderHost (..) --Temporary, until Widget no longer uses unsafePerformIO
2+ , SpiderEnv
3+ , Global
4+ , SpiderHost
5+ , runSpiderHost
3 ) where
6 ) where
4
7
5import Reflex.Spider.Internal
8import Reflex.Spider.Internal
src/Reflex/Spider/Internal.hs+1454−703
@@ -1,9 +1,12 @@
1−{-# LANGUAGE CPP, ExistentialQuantification, GADTs, ScopedTypeVariables, TypeFamilies, FlexibleInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving, RankNTypes, BangPatterns, UndecidableInstances, EmptyDataDecls, RecursiveDo, RoleAnnotations, LambdaCase, TypeOperators #-}
1+{-# LANGUAGE CPP, ExistentialQuantification, GADTs, ScopedTypeVariables, TypeFamilies, FlexibleInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving, RankNTypes, BangPatterns, UndecidableInstances, EmptyDataDecls, RecursiveDo, RoleAnnotations, LambdaCase, TypeOperators, FlexibleContexts, ConstraintKinds, MagicHash, UnboxedTuples, FunctionalDependencies #-}
2−module Reflex.Spider.Internal where
2+module Reflex.Spider.Internal (Spider, SpiderEnv (..), Global, SpiderHost, runSpiderHost, SpiderEventHandle (..), showSubscriberType, showEventType, ComputeM (..), MergeSubscribedParent (..), HasSpiderEnv (..), newSpiderEnv, SpiderPullM (..), SpiderPushM (..), ReadPhase (..)) where
3
3
4import qualified Reflex.Class as R
4import qualified Reflex.Class as R
5import qualified Reflex.Host.Class as R
5import qualified Reflex.Host.Class as R
6+import Data.WeakBag (WeakBag, WeakBagTicket)
7+import qualified Data.WeakBag as WeakBag
6
8
9+import Data.List
7import Data.IORef
10import Data.IORef
8import System.Mem.Weak
11import System.Mem.Weak
9import Data.Foldable
12import Data.Foldable
@@ -11,8 +14,10 @@ import Data.Traversable
11import Control.Monad hiding (mapM, mapM_, forM_, forM, sequence)
14import Control.Monad hiding (mapM, mapM_, forM_, forM, sequence)
12import Control.Monad.Identity hiding (mapM, mapM_, forM_, forM, sequence)
15import Control.Monad.Identity hiding (mapM, mapM_, forM_, forM, sequence)
13import Control.Monad.Reader hiding (mapM, mapM_, forM_, forM, sequence)
16import Control.Monad.Reader hiding (mapM, mapM_, forM_, forM, sequence)
14−import GHC.Exts
17+import Control.Monad.State hiding (mapM, mapM_, forM_, forM, sequence)
15import Control.Applicative -- Unconditionally import, because otherwise it breaks on GHC 7.10.1RC2
18import Control.Applicative -- Unconditionally import, because otherwise it breaks on GHC 7.10.1RC2
19+import Data.Some (Some)
20+import qualified Data.Some as Some
16import Data.Dependent.Map (DMap, DSum (..))
21import Data.Dependent.Map (DMap, DSum (..))
17import qualified Data.Dependent.Map as DMap
22import qualified Data.Dependent.Map as DMap
18import Data.GADT.Compare
23import Data.GADT.Compare
@@ -22,32 +27,52 @@ import qualified Data.IntMap as IntMap
22import Control.Monad.Ref
27import Control.Monad.Ref
23import Control.Monad.Exception
28import Control.Monad.Exception
24import Data.Monoid ((<>))
29import Data.Monoid ((<>))
25−import Data.Coerce
30+import Data.Functor.Compose
26import Control.Exception
31import Control.Exception
32+import Control.Concurrent
33+import Data.Function
34+import Data.These
35+import Data.Align
36+
37+import GHC.IORef (IORef (..))
38+import GHC.Base (IO (..))
39+import GHC.Stack
27
40
28import System.IO.Unsafe
41import System.IO.Unsafe
29import Unsafe.Coerce
42import Unsafe.Coerce
43+import Data.Coerce
30import Control.Monad.Primitive
44import Control.Monad.Primitive
31
45
46+import qualified Data.List.NonEmpty as NonEmpty
47+import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
48+import Data.Tree (Tree (..), Forest, drawForest)
49+
32-- Note: must come last to silence warnings due to AMP on GHC < 7.10
50-- Note: must come last to silence warnings due to AMP on GHC < 7.10
33import Prelude hiding (mapM, mapM_, any, sequence, concat)
51import Prelude hiding (mapM, mapM_, any, sequence, concat)
34
52
53+type SubscriberList a = WeakBag (Subscriber a)
54+type SubscriberListTicket a = WeakBagTicket (Subscriber a)
55+
35debugPropagate :: Bool
56debugPropagate :: Bool
36
57
37debugInvalidateHeight :: Bool
58debugInvalidateHeight :: Bool
38
59
60+debugInvalidate :: Bool
61+
39#ifdef DEBUG
62#ifdef DEBUG
40
63
41#define DEBUG_NODEIDS
64#define DEBUG_NODEIDS
42
65
43debugPropagate = True
66debugPropagate = True
44
67
45−debugInvalidateHeight = True
68+debugInvalidateHeight = False
69+
70+debugInvalidate = True
46
71
47class HasNodeId a where
72class HasNodeId a where
48 getNodeId :: a -> Int
73 getNodeId :: a -> Int
49
74
50−instance HasNodeId (Hold a) where
75+instance HasNodeId (Hold p a) where
51 getNodeId = holdNodeId
76 getNodeId = holdNodeId
52
77
53instance HasNodeId (PushSubscribed a b) where
78instance HasNodeId (PushSubscribed a b) where
@@ -68,6 +93,10 @@ instance HasNodeId (CoincidenceSubscribed a) where
68instance HasNodeId (RootSubscribed a) where
93instance HasNodeId (RootSubscribed a) where
69 getNodeId = rootSubscribedNodeId
94 getNodeId = rootSubscribedNodeId
70
95
96+instance HasNodeId (Pull a) where
97+ getNodeId = pullNodeId
98+
99+{-# INLINE showNodeId #-}
71showNodeId :: HasNodeId a => a -> String
100showNodeId :: HasNodeId a => a -> String
72showNodeId = ("#"<>) . show . getNodeId
101showNodeId = ("#"<>) . show . getNodeId
73
102
@@ -77,8 +106,12 @@ debugPropagate = False
77
106
78debugInvalidateHeight = False
107debugInvalidateHeight = False
79
108
109+debugInvalidate = False
110+
111+-- This must be inline, or error messages will cause memory leaks due to retaining the node in question
112+{-# INLINE showNodeId #-}
80showNodeId :: a -> String
113showNodeId :: a -> String
81−showNodeId = const ""
114+showNodeId _ = ""
82
115
83#endif
116#endif
84
117
@@ -87,116 +120,208 @@ showNodeId = const ""
87nextNodeIdRef :: IORef Int
120nextNodeIdRef :: IORef Int
88nextNodeIdRef = unsafePerformIO $ newIORef 1
121nextNodeIdRef = unsafePerformIO $ newIORef 1
89
122
123+newNodeId :: IO Int
124+newNodeId = atomicModifyIORef' nextNodeIdRef $ \n -> (succ n, n)
125+
90{-# NOINLINE unsafeNodeId #-}
126{-# NOINLINE unsafeNodeId #-}
91unsafeNodeId :: a -> Int
127unsafeNodeId :: a -> Int
92unsafeNodeId a = unsafePerformIO $ do
128unsafeNodeId a = unsafePerformIO $ do
93 touch a
129 touch a
94− atomicModifyIORef' nextNodeIdRef $ \n -> (succ n, n)
130+ newNodeId
95#endif
131#endif
96
132
97--TODO: Figure out why certain things are not 'representational', then make them representational so we can use coerce
133--TODO: Figure out why certain things are not 'representational', then make them representational so we can use coerce
98--type role Hold representational
134--type role Hold representational
99−data Hold a
135+data Hold p a
100 = Hold { holdValue :: !(IORef a)
136 = Hold { holdValue :: !(IORef a)
101 , holdInvalidators :: !(IORef [Weak Invalidator])
137 , holdInvalidators :: !(IORef [Weak Invalidator])
102− -- We need to use 'Any' for the next two things, because otherwise Hold inherits a nominal role for its 'a' parameter, and we want to be able to use 'coerce'
103− , holdSubscriber :: !(IORef Any) -- Keeps its subscription alive; for some reason, a regular (or strict) reference to the Subscriber itself wasn't working, so had to use an IORef
104− , holdParent :: !(IORef Any) -- Keeps its parent alive (will be undefined until the hold is initialized --TODO: Probably shouldn't be an IORef
138+ , holdParent :: !(IORef (Either (Event (p a)) (EventSubscription (p a)))) -- Keeps its parent alive (will be undefined until the hold is initialized) --TODO: Probably shouldn't be an IORef
105#ifdef DEBUG_NODEIDS
139#ifdef DEBUG_NODEIDS
106 , holdNodeId :: Int
140 , holdNodeId :: Int
107#endif
141#endif
108 }
142 }
109
143
110−data EventEnv
144+data EventEnv x
145+ = EventEnv { eventEnvSpiderEnv :: !(SpiderEnv x)
111− = EventEnv { eventEnvAssignments :: !(IORef [SomeAssignment])
146+ , eventEnvAssignments :: !(IORef [SomeAssignment]) -- Needed for Subscribe
112− , eventEnvHoldInits :: !(IORef [SomeHoldInit])
147+ , eventEnvHoldInits :: !(IORef [SomeHoldInit]) -- Needed for Subscribe
148+ , eventEnvMergeUpdates :: !(IORef [SomeMergeUpdate])
149+ , eventEnvMergeInits :: !(IORef [SomeMergeInit]) -- Needed for Subscribe
113− , eventEnvClears :: !(IORef [SomeMaybeIORef])
150+ , eventEnvClears :: !(IORef [SomeClear]) -- Needed for Subscribe
114− , eventEnvRootClears :: !(IORef [SomeDMapIORef])
151+ , eventEnvRootClears :: !(IORef [SomeRootClear])
115− , eventEnvCurrentHeight :: !(IORef Int)
152+ , eventEnvCurrentHeight :: !(IORef Height) -- Needed for Subscribe
116− , eventEnvCoincidenceInfos :: !(IORef [SomeCoincidenceInfo])
153+ , eventEnvResetCoincidences :: !(IORef [SomeResetCoincidence]) -- Needed for Subscribe
117 , eventEnvDelayedMerges :: !(IORef (IntMap [DelayedMerge]))
154 , eventEnvDelayedMerges :: !(IORef (IntMap [DelayedMerge]))
118 }
155 }
119
156
157+{-# INLINE runEventM #-}
120−runEventM :: EventM a -> EventEnv -> IO a
158+runEventM :: EventM x a -> EventEnv x -> IO a
121runEventM = runReaderT . unEventM
159runEventM = runReaderT . unEventM
122
160
123−askToAssignRef :: EventM (IORef [SomeAssignment])
161+class MonadIO m => Defer a m where
162+ getDeferralQueue :: m (IORef [a])
163+
164+{-# INLINE defer #-}
165+defer :: Defer a m => a -> m ()
166+defer a = do
167+ q <- getDeferralQueue
168+ liftIO $ modifyIORef' q (a:)
169+
170+instance Defer SomeAssignment (EventM x) where
171+ {-# INLINE getDeferralQueue #-}
124−askToAssignRef = EventM $ asks eventEnvAssignments
172+ getDeferralQueue = EventM $ asks eventEnvAssignments
125−
173+
126−askHoldInitRef :: EventM (IORef [SomeHoldInit])
174+instance Defer SomeHoldInit (EventM x) where
175+ {-# INLINE getDeferralQueue #-}
127−askHoldInitRef = EventM $ asks eventEnvHoldInits
176+ getDeferralQueue = EventM $ asks eventEnvHoldInits
128−
177+
178+instance Defer SomeHoldInit BehaviorM where
179+ {-# INLINE getDeferralQueue #-}
180+ getDeferralQueue = BehaviorM $ asks snd
181+
182+instance Defer SomeMergeUpdate (EventM x) where
183+ {-# INLINE getDeferralQueue #-}
184+ getDeferralQueue = EventM $ asks eventEnvMergeUpdates
185+
186+instance Defer SomeMergeInit (EventM x) where
187+ {-# INLINE getDeferralQueue #-}
188+ getDeferralQueue = EventM $ asks eventEnvMergeInits
189+
190+class HasCurrentHeight m where
129−getCurrentHeight :: EventM Int
191+ getCurrentHeight :: m Height
192+ scheduleMerge :: Height -> MergeSubscribed a -> m ()
193+
194+instance HasCurrentHeight (EventM x) where
195+ {-# INLINE getCurrentHeight #-}
130−getCurrentHeight = EventM $ do
196+ getCurrentHeight = EventM $ do
131− heightRef <- asks eventEnvCurrentHeight
197+ heightRef <- asks eventEnvCurrentHeight
132− liftIO $ readIORef heightRef
198+ liftIO $ readIORef heightRef
133−
199+ {-# INLINE scheduleMerge #-}
200+ scheduleMerge height subscribed = EventM $ do
201+ delayedRef <- asks eventEnvDelayedMerges
202+ liftIO $ modifyIORef' delayedRef $ IntMap.insertWith (++) (unHeight height) [DelayedMerge subscribed]
203+
204+class HasSpiderEnv x m | m -> x where
205+ askSpiderEnv :: m (SpiderEnv x)
206+
207+instance HasSpiderEnv x (EventM x) where
208+ {-# INLINE askSpiderEnv #-}
209+ askSpiderEnv = EventM $ asks eventEnvSpiderEnv
210+
211+instance HasSpiderEnv x (SpiderHost x) where
212+ {-# INLINE askSpiderEnv #-}
213+ askSpiderEnv = SpiderHost ask
214+
134−putCurrentHeight :: Int -> EventM ()
215+putCurrentHeight :: Height -> EventM x ()
135putCurrentHeight h = EventM $ do
216putCurrentHeight h = EventM $ do
136 heightRef <- asks eventEnvCurrentHeight
217 heightRef <- asks eventEnvCurrentHeight
137 liftIO $ writeIORef heightRef h
218 liftIO $ writeIORef heightRef h
138
219
139−scheduleClear :: IORef (Maybe a) -> EventM ()
220+instance Defer SomeClear (EventM x) where
140−scheduleClear r = EventM $ do
221+ {-# INLINE getDeferralQueue #-}
141− clears <- asks eventEnvClears
222+ getDeferralQueue = EventM $ asks eventEnvClears
142− liftIO $ modifyIORef' clears (SomeMaybeIORef r :)
143
223
144−scheduleRootClear :: IORef (DMap k Identity) -> EventM ()
224+{-# INLINE scheduleClear #-}
145−scheduleRootClear r = EventM $ do
225+scheduleClear :: Defer SomeClear m => IORef (Maybe a) -> m ()
146− clears <- asks eventEnvRootClears
226+scheduleClear r = defer $ SomeClear r
147− liftIO $ modifyIORef' clears (SomeDMapIORef r :)
148
227
149−scheduleMerge :: Int -> MergeSubscribed a -> EventM ()
228+instance Defer SomeRootClear (EventM x) where
150−scheduleMerge height subscribed = EventM $ do
229+ {-# INLINE getDeferralQueue #-}
151− delayedRef <- asks eventEnvDelayedMerges
230+ getDeferralQueue = EventM $ asks eventEnvRootClears
152− liftIO $ modifyIORef' delayedRef $ IntMap.insertWith (++) height [DelayedMerge subscribed]
153
231
154−emitCoincidenceInfo :: SomeCoincidenceInfo -> EventM ()
232+{-# INLINE scheduleRootClear #-}
155−emitCoincidenceInfo sci = EventM $ do
233+scheduleRootClear :: Defer SomeRootClear m => IORef (DMap k Identity) -> m ()
156− ciRef <- asks eventEnvCoincidenceInfos
234+scheduleRootClear r = defer $ SomeRootClear r
157− liftIO $ modifyIORef' ciRef (sci:)
235+
236+instance Defer SomeResetCoincidence (EventM x) where
237+ {-# INLINE getDeferralQueue #-}
238+ getDeferralQueue = EventM $ asks eventEnvResetCoincidences
158
239
159-- Note: hold cannot examine its event until after the phase is over
240-- Note: hold cannot examine its event until after the phase is over
160−hold :: a -> Event a -> EventM (Behavior a)
241+{-# SPECIALIZE hold :: R.Patch p => a -> Event (p a) -> EventM x (Hold p a) #-}
242+{-# SPECIALIZE hold :: R.Patch p => a -> Event (p a) -> ComputeM (Hold p a) #-}
243+hold :: (R.Patch p, Defer SomeHoldInit m) => a -> Event (p a) -> m (Hold p a)
161hold v0 e = do
244hold v0 e = do
162− holdInitRef <- askHoldInitRef
163− liftIO $ do
164− valRef <- newIORef v0
245+ valRef <- liftIO $ newIORef v0
165− invsRef <- newIORef []
246+ invsRef <- liftIO $ newIORef []
166− parentRef <- newIORef $ error "hold not yet initialized (parent)"
247+ parentRef <- liftIO $ newIORef $ Left e
167− subscriberRef <- newIORef $ error "hold not yet initialized (subscriber)"
168− let h = Hold
169− { holdValue = valRef
170− , holdInvalidators = invsRef
171− , holdSubscriber = subscriberRef
172− , holdParent = parentRef
173#ifdef DEBUG_NODEIDS
248#ifdef DEBUG_NODEIDS
174− , holdNodeId = unsafeNodeId (v0, e)
249+ nodeId <- liftIO newNodeId
175#endif
250#endif
176− }
251+ let h = Hold
177− s <- newSubscriberHold h
252+ { holdValue = valRef
178− writeIORef subscriberRef $ unsafeCoerce s
253+ , holdInvalidators = invsRef
179− modifyIORef' holdInitRef (SomeHoldInit e h :)
254+ , holdParent = parentRef
180− return $ BehaviorHold h
255+#ifdef DEBUG_NODEIDS
181−
256+ , holdNodeId = nodeId
182−subscribeHold :: Event a -> Hold a -> EventM ()
257+#endif
183−subscribeHold e h = do
258+ }
184− toAssignRef <- askToAssignRef
259+ defer $ SomeHoldInit h
185− !s <- liftIO $ liftM unsafeCoerce $ readIORef $ holdSubscriber h -- This must be performed strictly so that the weak pointer points at the actual item
260+ return h
186− ws <- liftIO $ mkWeakPtrWithDebug s "holdSubscriber"
261+
187− subd <- subscribe e $ WeakSubscriberSimple ws
262+{-
188− liftIO $ writeIORef (holdParent h) $ unsafeCoerce subd
263+mkWeakIORefKey :: IORef a -> b -> IO () -> IO (Weak b)
189− occ <- liftIO $ getEventSubscribedOcc subd
264+mkWeakIORefKey r@(IORef (STRef r#)) b (IO f) = IO $ \s ->
265+ case mkWeak# r# b f s of (# s1, w #) -> (# s1, Weak w #)
266+-}
267+
268+{-# INLINE getHoldEventSubscription #-}
269+getHoldEventSubscription :: forall m p a x. (Defer SomeAssignment m, Defer SomeHoldInit m, Defer SomeClear m, R.Patch p, HasCurrentHeight m, Defer SomeMergeInit m, Defer SomeResetCoincidence m, HasSpiderEnv x m) => Hold p a -> m (EventSubscription (p a))
270+getHoldEventSubscription h = do
271+ ep <- liftIO $ readIORef $ holdParent h
272+ case ep of
273+ Right subd -> return subd
274+ Left e -> do
275+ subscriptionRef <- liftIO $ newIORef $ error "getHoldEventSubscription: subdRef uninitialized"
276+ {-
277+ spiderEnv <- askSpiderEnv
278+ weakSubscriptionRef <- liftIO $ mkWeakIORef subscriptionRef $ return ()
279+ wh <- liftIO $ mkWeakIORefKey (holdValue h) h $ do
280+ msr <- deRefWeak weakSubscriptionRef
281+ forM_ msr $ \sr -> do
282+ subscription <- readIORef sr
283+ atomicModifyIORef (_spiderEnv_toUnsubscribe spiderEnv) $ \x -> (SomeEventSubscription subscription : x, ())
284+-- return ()
285+ {-
286+ -- What can we do? 1) Detect GCs at the SpiderEnv level, then go over the tree
287+ 2) Have a finalizer on every SubscriberListNode that only runs if its parent is still alive, and does a normal unsubscribe if so; this would seem to double the number of weakRefs we use, but perhaps not the weakDepth, so maybe it's OK; we will probably need to move the regular call to unsubscribe into the finalizer and then use finalize instead of that call; we can have a strong reference to the SubscriberListNode, which means we just need a single weak reference to each EventSubscribed, which we can reuse in all of the finalizers that need to (potentially) unsubscribe from it
288+-}
289+ -}
290+ subscription@(_, subd) <- subscribe e =<< liftIO (newSubscriberHold h)
291+ liftIO $ writeIORef subscriptionRef subscription
292+ occ <- liftIO $ readEventSubscribed subd
190− case occ of
293+ case occ of
191− Nothing -> return ()
294+ Nothing -> return ()
192− Just o -> liftIO $ modifyIORef' toAssignRef (SomeAssignment h o :)
295+ Just o -> do
296+ old <- liftIO $ readIORef $ holdValue h
297+ case R.apply o old of
298+ Nothing -> return ()
299+ Just new -> do
300+ -- Need to evaluate these so that we don't retain the Hold itself
301+ v <- liftIO $ evaluate $ holdValue h
302+ i <- liftIO $ evaluate $ holdInvalidators h
303+ defer $ SomeAssignment v i new
304+ liftIO $ writeIORef (holdParent h) $ Right subscription
305+ return subscription
306+
307+type BehaviorEnv = (Maybe (Weak Invalidator, IORef [SomeBehaviorSubscribed]), IORef [SomeHoldInit])
193
308
194--type role BehaviorM representational
309--type role BehaviorM representational
195-- BehaviorM can sample behaviors
310-- BehaviorM can sample behaviors
196−newtype BehaviorM a = BehaviorM { unBehaviorM :: ReaderT (Maybe (Weak Invalidator, IORef [SomeBehaviorSubscribed])) IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
311+newtype BehaviorM a = BehaviorM { unBehaviorM :: ReaderT BehaviorEnv IO a } deriving (Functor, Applicative, MonadIO, MonadFix)
312+
313+instance Monad BehaviorM where
314+ {-# INLINE (>>=) #-}
315+ BehaviorM x >>= f = BehaviorM $ x >>= unBehaviorM . f
316+ {-# INLINE (>>) #-}
317+ BehaviorM x >> BehaviorM y = BehaviorM $ x >> y
318+ {-# INLINE return #-}
319+ return x = BehaviorM $ return x
320+ {-# INLINE fail #-}
321+ fail s = BehaviorM $ fail s
197
322
198data BehaviorSubscribed a
323data BehaviorSubscribed a
199− = BehaviorSubscribedHold (Hold a)
324+ = forall p. BehaviorSubscribedHold (Hold p a)
200 | BehaviorSubscribedPull (PullSubscribed a)
325 | BehaviorSubscribedPull (PullSubscribed a)
201
326
202data SomeBehaviorSubscribed = forall a. SomeBehaviorSubscribed (BehaviorSubscribed a)
327data SomeBehaviorSubscribed = forall a. SomeBehaviorSubscribed (BehaviorSubscribed a)
@@ -213,16 +338,26 @@ data PullSubscribed a
213data Pull a
338data Pull a
214 = Pull { pullValue :: !(IORef (Maybe (PullSubscribed a)))
339 = Pull { pullValue :: !(IORef (Maybe (PullSubscribed a)))
215 , pullCompute :: !(BehaviorM a)
340 , pullCompute :: !(BehaviorM a)
341+#ifdef DEBUG_NODEIDS
342+ , pullNodeId :: Int
343+#endif
216 }
344 }
217
345
218data Invalidator
346data Invalidator
219 = forall a. InvalidatorPull (Pull a)
347 = forall a. InvalidatorPull (Pull a)
220 | forall a. InvalidatorSwitch (SwitchSubscribed a)
348 | forall a. InvalidatorSwitch (SwitchSubscribed a)
221
349
222−data RootSubscribed a
350+data RootSubscribed a = forall k. GCompare k => RootSubscribed
351+ { rootSubscribedKey :: !(k a)
352+ , rootSubscribedCachedSubscribed :: !(IORef (DMap k RootSubscribed)) -- From the original Root
223− = RootSubscribed { rootSubscribedSubscribers :: !(IORef [WeakSubscriber a])
353+ , rootSubscribedSubscribers :: !(SubscriberList a)
224− , rootSubscribedOccurrence :: !(IO (Maybe a)) -- Lookup from rootOccurrence
354+ , rootSubscribedOccurrence :: !(IO (Maybe a)) -- Lookup from rootOccurrence
355+ , rootSubscribedUninit :: IO ()
356+ , rootSubscribedWeakSelf :: !(IORef (Weak (RootSubscribed a))) --TODO: Can we make this a lazy non-IORef and then force it manually to avoid an indirection each time we use it?
357+#ifdef DEBUG_NODEIDS
358+ , rootSubscribedNodeId :: Int
359+#endif
225− }
360+ }
226
361
227data Root (k :: * -> *)
362data Root (k :: * -> *)
228 = Root { rootOccurrence :: !(IORef (DMap k Identity)) -- The currently-firing occurrence of this event
363 = Root { rootOccurrence :: !(IORef (DMap k Identity)) -- The currently-firing occurrence of this event
@@ -230,35 +365,59 @@ data Root (k :: * -> *)
230 , rootInit :: !(forall a. k a -> RootTrigger a -> IO (IO ()))
365 , rootInit :: !(forall a. k a -> RootTrigger a -> IO (IO ()))
231 }
366 }
232
367
233−data SomeHoldInit = forall a. SomeHoldInit (Event a) (Hold a)
368+data SomeHoldInit = forall p a. R.Patch p => SomeHoldInit !(Hold p a)
369+
370+data SomeMergeUpdate = forall k. GCompare k => SomeMergeUpdate (R.PatchDMap (DMap k Event)) (MergeSubscribed k)
371+
372+data SomeMergeInit = forall k. GCompare k => SomeMergeInit !(MergeSubscribed k) !(Event (R.PatchDMap (DMap k Event)))
373+
374+data SomeEventSubscription = forall a. SomeEventSubscription (EventSubscription a)
234
375
235-- EventM can do everything BehaviorM can, plus create holds
376-- EventM can do everything BehaviorM can, plus create holds
236−newtype EventM a = EventM { unEventM :: ReaderT EventEnv IO a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException) -- The environment should be Nothing if we are not in a frame, and Just if we are - in which case it is a list of assignments to be done after the frame is over
377+newtype EventM x a = EventM { unEventM :: ReaderT (EventEnv x) IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadException, MonadAsyncException) -- The environment should be Nothing if we are not in a frame, and Just if we are - in which case it is a list of assignments to be done after the frame is over
237
378
238data PushSubscribed a b
379data PushSubscribed a b
380+ = PushSubscribed { pushSubscribedCachedSubscribed :: !(IORef (Maybe (PushSubscribed a b)))
239− = PushSubscribed { pushSubscribedOccurrence :: !(IORef (Maybe b)) -- If the current height is less than our height, this should always be Nothing; during our height, this will get filled in at some point, always before our children are notified; after our height, this will be filled in with the correct value (Nothing if we are not firing, Just if we are)
381+ , pushSubscribedOccurrence :: !(IORef (Maybe b)) -- If the current height is less than our height, this should always be Nothing; during our height, this will get filled in at some point, always before our children are notified; after our height, this will be filled in with the correct value (Nothing if we are not firing, Just if we are)
240− , pushSubscribedHeight :: !(IORef Int)
382+ , pushSubscribedHeight :: !(IORef Height)
241− , pushSubscribedSubscribers :: !(IORef [WeakSubscriber b])
383+ , pushSubscribedSubscribers :: !(SubscriberList b)
242− , pushSubscribedSelf :: !(Subscriber a) -- Hold this in memory to ensure our WeakReferences don't die
384+ , pushSubscribedSelf :: !(Subscriber a) -- Hold this in memory to ensure our WeakReferences don't die --TODO: Probably unneeded now
385+ , pushSubscribedWeakSelf :: !(IORef (Weak (PushSubscribed a b)))
243− , pushSubscribedParent :: !(EventSubscribed a)
386+ , pushSubscribedParent :: !(EventSubscription a)
244#ifdef DEBUG_NODEIDS
387#ifdef DEBUG_NODEIDS
245 , pushSubscribedNodeId :: Int
388 , pushSubscribedNodeId :: Int
246#endif
389#endif
247 }
390 }
248
391
392+newtype ComputeM a = ComputeM { unComputeM :: ReaderT (IORef [SomeHoldInit]) IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
393+
394+instance Defer SomeHoldInit ComputeM where
395+ getDeferralQueue = ComputeM ask
396+
397+{-# SPECIALIZE runComputeM :: ComputeM a -> EventM x a #-}
398+runComputeM :: Defer SomeHoldInit m => ComputeM a -> m a
399+runComputeM (ComputeM a) = liftIO . runReaderT a =<< getDeferralQueue
400+
249data Push a b
401data Push a b
250− = Push { pushCompute :: !(a -> EventM (Maybe b)) -- Compute the current firing value; assumes that its parent has been computed
402+ = Push { pushCompute :: !(a -> ComputeM (Maybe b)) -- Compute the current firing value; assumes that its parent has been computed --TODO: This only uses Defer SomeHoldInit EventM; perhaps only the hold init queue should be passed in (also, perhaps those hold inits can be accelerated - can there be a loop we would need to worry about?)
251 , pushParent :: !(Event a)
403 , pushParent :: !(Event a)
252 , pushSubscribed :: !(IORef (Maybe (PushSubscribed a b))) --TODO: Can we replace this with an unsafePerformIO thunk?
404 , pushSubscribed :: !(IORef (Maybe (PushSubscribed a b))) --TODO: Can we replace this with an unsafePerformIO thunk?
253 }
405 }
254
406
407+data MergeSubscribedParent k a
408+ = MergeSubscribedParent { mergeSubscribedParentSubscription :: !(EventSubscription a)
409+ , mergeSubscribedParentSubscriber :: !(Subscriber a)
410+ }
411+
255data MergeSubscribed k
412data MergeSubscribed k
413+ = MergeSubscribed { mergeSubscribedCachedSubscribed :: !(IORef (Maybe (MergeSubscribed k))) -- From the original merge
256− = MergeSubscribed { mergeSubscribedOccurrence :: !(IORef (Maybe (DMap k Identity)))
414+ , mergeSubscribedOccurrence :: !(IORef (Maybe (DMap k Identity)))
257 , mergeSubscribedAccum :: !(IORef (DMap k Identity)) -- This will accumulate occurrences until our height is reached, at which point it will be transferred to mergeSubscribedOccurrence
415 , mergeSubscribedAccum :: !(IORef (DMap k Identity)) -- This will accumulate occurrences until our height is reached, at which point it will be transferred to mergeSubscribedOccurrence
258− , mergeSubscribedHeight :: !(IORef Int)
416+ , mergeSubscribedHeight :: !(IORef Height)
259− , mergeSubscribedSubscribers :: !(IORef [WeakSubscriber (DMap k Identity)])
417+ , mergeSubscribedSubscribers :: !(SubscriberList (DMap k Identity))
260− , mergeSubscribedSelf :: !Any -- Hold all our Subscribers in memory
418+ , mergeSubscribedChange :: !(IORef (Subscriber (R.PatchDMap (DMap k Event)), EventSubscribed (R.PatchDMap (DMap k Event))))
261− , mergeSubscribedParents :: !(DMap k EventSubscribed)
419+ , mergeSubscribedParents :: !(IORef (DMap k (MergeSubscribedParent k)))
420+ , mergeSubscribedWeakSelf :: !(IORef (Weak (MergeSubscribed k)))
262#ifdef DEBUG_NODEIDS
421#ifdef DEBUG_NODEIDS
263 , mergeSubscribedNodeId :: Int
422 , mergeSubscribedNodeId :: Int
264#endif
423#endif
@@ -266,28 +425,19 @@ data MergeSubscribed k
266
425
267--TODO: DMap sucks; we should really write something better (with a functor for the value as well as the key)
426--TODO: DMap sucks; we should really write something better (with a functor for the value as well as the key)
268data Merge k
427data Merge k
269− = Merge { mergeParents :: !(DMap k Event)
428+ = Merge { mergeParents :: !(Dynamic R.PatchDMap (DMap k Event))
270− , mergeSubscribed :: !(IORef (Maybe (MergeSubscribed k))) --TODO: Can we replace this with an unsafePerformIO thunk?
429+ , mergeSubscribed :: !(IORef (Maybe (MergeSubscribed k)))
271 }
430 }
272
431
273−data FanSubscriberKey k a where
432+data FanSubscribedChildren k a = FanSubscribedChildren
274− FanSubscriberKey :: k a -> FanSubscriberKey k [WeakSubscriber a]
433+ { _fanSubscribedChildren_list :: !(SubscriberList a)
275−
434+ , _fanSubscribedChildren_weakSelf :: !(IORef (Weak (k a, FanSubscribed k)))
276−instance GEq k => GEq (FanSubscriberKey k) where
435+ }
277− geq (FanSubscriberKey a) (FanSubscriberKey b) = case geq a b of
278− Nothing -> Nothing
279− Just Refl -> Just Refl
280−
281−instance GCompare k => GCompare (FanSubscriberKey k) where
282− gcompare (FanSubscriberKey a) (FanSubscriberKey b) = case gcompare a b of
283− GLT -> GLT
284− GEQ -> GEQ
285− GGT -> GGT
286
436
287data FanSubscribed k
437data FanSubscribed k
438+ = FanSubscribed { fanSubscribedCachedSubscribed :: !(IORef (Maybe (FanSubscribed k)))
288− = FanSubscribed { fanSubscribedSubscribers :: !(IORef (DMap (FanSubscriberKey k) Identity))
439+ , fanSubscribedSubscribers :: !(IORef (DMap k (FanSubscribedChildren k))) -- This DMap should never be empty
289− , fanSubscribedParent :: !(EventSubscribed (DMap k Identity))
440+ , fanSubscribedParent :: !(EventSubscription (DMap k Identity))
290− , fanSubscribedSelf :: {-# NOUNPACK #-} (Subscriber (DMap k Identity))
291#ifdef DEBUG_NODEIDS
441#ifdef DEBUG_NODEIDS
292 , fanSubscribedNodeId :: Int
442 , fanSubscribedNodeId :: Int
293#endif
443#endif
@@ -299,16 +449,16 @@ data Fan k
299 }
449 }
300
450
301data SwitchSubscribed a
451data SwitchSubscribed a
452+ = SwitchSubscribed { switchSubscribedCachedSubscribed :: !(IORef (Maybe (SwitchSubscribed a)))
302− = SwitchSubscribed { switchSubscribedOccurrence :: !(IORef (Maybe a))
453+ , switchSubscribedOccurrence :: !(IORef (Maybe a))
303− , switchSubscribedHeight :: !(IORef Int)
454+ , switchSubscribedHeight :: !(IORef Height)
304− , switchSubscribedSubscribers :: !(IORef [WeakSubscriber a])
455+ , switchSubscribedSubscribers :: !(SubscriberList a)
305− , switchSubscribedSelf :: {-# NOUNPACK #-} (Subscriber a)
306− , switchSubscribedSelfWeak :: !(IORef (Weak (Subscriber a)))
307− , switchSubscribedOwnInvalidator :: {-# NOUNPACK #-} Invalidator
456+ , switchSubscribedOwnInvalidator :: {-# NOUNPACK #-} !Invalidator
308 , switchSubscribedOwnWeakInvalidator :: !(IORef (Weak Invalidator))
457 , switchSubscribedOwnWeakInvalidator :: !(IORef (Weak Invalidator))
309 , switchSubscribedBehaviorParents :: !(IORef [SomeBehaviorSubscribed])
458 , switchSubscribedBehaviorParents :: !(IORef [SomeBehaviorSubscribed])
310 , switchSubscribedParent :: !(Behavior (Event a))
459 , switchSubscribedParent :: !(Behavior (Event a))
311− , switchSubscribedCurrentParent :: !(IORef (EventSubscribed a))
460+ , switchSubscribedCurrentParent :: !(IORef (EventSubscription a))
461+ , switchSubscribedWeakSelf :: !(IORef (Weak (SwitchSubscribed a)))
312#ifdef DEBUG_NODEIDS
462#ifdef DEBUG_NODEIDS
313 , switchSubscribedNodeId :: Int
463 , switchSubscribedNodeId :: Int
314#endif
464#endif
@@ -320,12 +470,14 @@ data Switch a
320 }
470 }
321
471
322data CoincidenceSubscribed a
472data CoincidenceSubscribed a
473+ = CoincidenceSubscribed { coincidenceSubscribedCachedSubscribed :: !(IORef (Maybe (CoincidenceSubscribed a)))
323− = CoincidenceSubscribed { coincidenceSubscribedOccurrence :: !(IORef (Maybe a))
474+ , coincidenceSubscribedOccurrence :: !(IORef (Maybe a))
324− , coincidenceSubscribedSubscribers :: !(IORef [WeakSubscriber a])
475+ , coincidenceSubscribedSubscribers :: !(SubscriberList a)
325− , coincidenceSubscribedHeight :: !(IORef Int)
476+ , coincidenceSubscribedHeight :: !(IORef Height)
326 , coincidenceSubscribedOuter :: {-# NOUNPACK #-} (Subscriber (Event a))
477 , coincidenceSubscribedOuter :: {-# NOUNPACK #-} (Subscriber (Event a))
327− , coincidenceSubscribedOuterParent :: !(EventSubscribed (Event a))
478+ , coincidenceSubscribedOuterParent :: !(EventSubscription (Event a))
328 , coincidenceSubscribedInnerParent :: !(IORef (Maybe (EventSubscribed a)))
479 , coincidenceSubscribedInnerParent :: !(IORef (Maybe (EventSubscribed a)))
480+ , coincidenceSubscribedWeakSelf :: !(IORef (Weak (CoincidenceSubscribed a)))
329#ifdef DEBUG_NODEIDS
481#ifdef DEBUG_NODEIDS
330 , coincidenceSubscribedNodeId :: Int
482 , coincidenceSubscribedNodeId :: Int
331#endif
483#endif
@@ -336,41 +488,30 @@ data Coincidence a
336 , coincidenceSubscribed :: !(IORef (Maybe (CoincidenceSubscribed a)))
488 , coincidenceSubscribed :: !(IORef (Maybe (CoincidenceSubscribed a)))
337 }
489 }
338
490
339−data Box a = Box { unBox :: a }
340−
341−--type WeakSubscriber a = Weak (Subscriber a)
342−data WeakSubscriber a
343− = forall k. GCompare k => WeakSubscriberMerge !(k a) !(Weak (Box (MergeSubscribed k))) --TODO: Can we inline the GCompare?
344− | WeakSubscriberSimple !(Weak (Subscriber a))
345−
346−showWeakSubscriberType :: WeakSubscriber a -> String
347−showWeakSubscriberType = \case
348− WeakSubscriberMerge _ _ -> "WeakSubscriberMerge"
349− WeakSubscriberSimple _ -> "WeakSubscriberSimple"
350−
351−deRefWeakSubscriber :: WeakSubscriber a -> IO (Maybe (Subscriber a))
352−deRefWeakSubscriber ws = case ws of
353− WeakSubscriberSimple w -> deRefWeak w
354− WeakSubscriberMerge k w -> liftM (fmap $ SubscriberMerge k . unBox) $ deRefWeak w
355−
356data Subscriber a
491data Subscriber a
357− = forall b. SubscriberPush !(a -> EventM (Maybe b)) (PushSubscribed a b)
492+ = forall b. SubscriberPush (a -> ComputeM (Maybe b)) (PushSubscribed a b) --TODO: Why does this have the pushCompute in it?
358 | forall k. GCompare k => SubscriberMerge !(k a) (MergeSubscribed k) --TODO: Can we inline the GCompare?
493 | forall k. GCompare k => SubscriberMerge !(k a) (MergeSubscribed k) --TODO: Can we inline the GCompare?
494+ | forall k. (a ~ R.PatchDMap (DMap k Event), GCompare k) => SubscriberMergeChange (MergeSubscribed k)
359 | forall k. (GCompare k, a ~ DMap k Identity) => SubscriberFan (FanSubscribed k)
495 | forall k. (GCompare k, a ~ DMap k Identity) => SubscriberFan (FanSubscribed k)
360− | SubscriberHold !(Hold a)
496+ | forall p b. (a ~ p b, R.Patch p) => SubscriberHold !(Hold p b)
497+ | forall b. (a ~ Identity b) => SubscriberHoldIdentity !(Hold Identity b)
361 | SubscriberSwitch (SwitchSubscribed a)
498 | SubscriberSwitch (SwitchSubscribed a)
362 | forall b. a ~ Event b => SubscriberCoincidenceOuter (CoincidenceSubscribed b)
499 | forall b. a ~ Event b => SubscriberCoincidenceOuter (CoincidenceSubscribed b)
363 | SubscriberCoincidenceInner (CoincidenceSubscribed a)
500 | SubscriberCoincidenceInner (CoincidenceSubscribed a)
501+ | SubscriberHandle
364
502
365showSubscriberType :: Subscriber a -> String
503showSubscriberType :: Subscriber a -> String
366showSubscriberType = \case
504showSubscriberType = \case
367 SubscriberPush _ _ -> "SubscriberPush"
505 SubscriberPush _ _ -> "SubscriberPush"
368 SubscriberMerge _ _ -> "SubscriberMerge"
506 SubscriberMerge _ _ -> "SubscriberMerge"
369 SubscriberFan _ -> "SubscriberFan"
507 SubscriberFan _ -> "SubscriberFan"
508+ SubscriberMergeChange _ -> "SubscriberMergeChange"
370 SubscriberHold _ -> "SubscriberHold"
509 SubscriberHold _ -> "SubscriberHold"
510+ SubscriberHoldIdentity _ -> "SubscriberHoldIdentity"
371 SubscriberSwitch _ -> "SubscriberSwitch"
511 SubscriberSwitch _ -> "SubscriberSwitch"
372 SubscriberCoincidenceOuter _ -> "SubscriberCoincidenceOuter"
512 SubscriberCoincidenceOuter _ -> "SubscriberCoincidenceOuter"
373 SubscriberCoincidenceInner _ -> "SubscriberCoincidenceInner"
513 SubscriberCoincidenceInner _ -> "SubscriberCoincidenceInner"
514+ SubscriberHandle -> "SubscriberHandle"
374
515
375data Event a
516data Event a
376 = forall k. GCompare k => EventRoot !(k a) !(Root k)
517 = forall k. GCompare k => EventRoot !(k a) !(Root k)
@@ -380,6 +521,10 @@ data Event a
380 | forall k. GCompare k => EventFan !(k a) !(Fan k)
521 | forall k. GCompare k => EventFan !(k a) !(Fan k)
381 | EventSwitch !(Switch a)
522 | EventSwitch !(Switch a)
382 | EventCoincidence !(Coincidence a)
523 | EventCoincidence !(Coincidence a)
524+ | forall p b. (a ~ p b, R.Patch p) => EventHold !(Hold p b)
525+ | forall p b. (a ~ p b, R.Patch p) => EventDyn !(Dyn p b)
526+ | forall b. (a ~ Identity b) => EventHoldIdentity !(Hold Identity b)
527+ | forall b. (a ~ Identity b) => EventDynIdentity !(Dyn Identity b)
383
528
384showEventType :: Event a -> String
529showEventType :: Event a -> String
385showEventType = \case
530showEventType = \case
@@ -390,6 +535,12 @@ showEventType = \case
390 EventFan _ _ -> "EventFan"
535 EventFan _ _ -> "EventFan"
391 EventSwitch _ -> "EventSwitch"
536 EventSwitch _ -> "EventSwitch"
392 EventCoincidence _ -> "EventCoincidence"
537 EventCoincidence _ -> "EventCoincidence"
538+ EventHold _ -> "EventHold"
539+ EventDyn _ -> "EventDyn"
540+ EventHoldIdentity _ -> "EventHoldIdentity"
541+ EventDynIdentity _ -> "EventDynIdentity"
542+
543+type EventSubscription a = (Maybe (SubscriberListTicket a), EventSubscribed a)
393
544
394data EventSubscribed a
545data EventSubscribed a
395 = EventSubscribedRoot {-# NOUNPACK #-} (RootSubscribed a)
546 = EventSubscribedRoot {-# NOUNPACK #-} (RootSubscribed a)
@@ -400,6 +551,9 @@ data EventSubscribed a
400 | EventSubscribedSwitch !(SwitchSubscribed a)
551 | EventSubscribedSwitch !(SwitchSubscribed a)
401 | EventSubscribedCoincidence !(CoincidenceSubscribed a)
552 | EventSubscribedCoincidence !(CoincidenceSubscribed a)
402
553
554+unsubscribe :: EventSubscription a -> IO ()
555+unsubscribe (msln, _) = forM_ msln $ \sln -> WeakBag.remove sln
556+
403-- These function are constructor functions that are marked NOINLINE so they are
557-- These function are constructor functions that are marked NOINLINE so they are
404-- opaque to GHC. If we do not do this, then GHC will sometimes fuse the constructor away
558-- opaque to GHC. If we do not do this, then GHC will sometimes fuse the constructor away
405-- so any weak references that are attached to the constructors will have their
559-- so any weak references that are attached to the constructors will have their
@@ -409,22 +563,30 @@ data EventSubscribed a
409-- The result is also evaluated to WHNF, since forcing a thunk invalidates
563-- The result is also evaluated to WHNF, since forcing a thunk invalidates
410-- the weak pointer to it in some cases.
564-- the weak pointer to it in some cases.
411
565
412−{-# NOINLINE newRootSubscribed #-}
566+--TODO: I think all of these noinlines are now unnecessary
413−newRootSubscribed :: IO (Maybe a) -> IORef [WeakSubscriber a] -> IO (RootSubscribed a)
414−newRootSubscribed occ subs =
415− return $! RootSubscribed
416− { rootSubscribedOccurrence = occ
417− , rootSubscribedSubscribers = subs
418− }
419−
420{-# NOINLINE newSubscriberPush #-}
567{-# NOINLINE newSubscriberPush #-}
421−newSubscriberPush :: (a -> EventM (Maybe b)) -> PushSubscribed a b -> IO (Subscriber a)
568+newSubscriberPush :: (a -> ComputeM (Maybe b)) -> PushSubscribed a b -> IO (Subscriber a)
422newSubscriberPush compute subd = return $! SubscriberPush compute subd
569newSubscriberPush compute subd = return $! SubscriberPush compute subd
423
570
571+{-# RULES
572+ "newSubscriberHold/Identity" forall h. newSubscriberHold h = newSubscriberHoldIdentity h
573+ #-}
424{-# NOINLINE newSubscriberHold #-}
574{-# NOINLINE newSubscriberHold #-}
425−newSubscriberHold :: Hold a -> IO (Subscriber a)
575+newSubscriberHold :: R.Patch p => Hold p a -> IO (Subscriber (p a))
426newSubscriberHold h = return $! SubscriberHold h
576newSubscriberHold h = return $! SubscriberHold h
427
577
578+{-# NOINLINE newSubscriberHoldIdentity #-}
579+newSubscriberHoldIdentity :: Hold Identity a -> IO (Subscriber (Identity a))
580+newSubscriberHoldIdentity h = return $! SubscriberHoldIdentity h
581+
582+{-# NOINLINE newSubscriberMerge #-}
583+newSubscriberMerge :: GCompare k => k a -> MergeSubscribed k -> IO (Subscriber a)
584+newSubscriberMerge k subd = return $! SubscriberMerge k subd
585+
586+{-# NOINLINE newSubscriberMergeChange #-}
587+newSubscriberMergeChange :: GCompare k => MergeSubscribed k -> IO (Subscriber (R.PatchDMap (DMap k Event)))
588+newSubscriberMergeChange subd = return $! SubscriberMergeChange subd
589+
428{-# NOINLINE newSubscriberFan #-}
590{-# NOINLINE newSubscriberFan #-}
429newSubscriberFan :: GCompare k => FanSubscribed k -> IO (Subscriber (DMap k Identity))
591newSubscriberFan :: GCompare k => FanSubscribed k -> IO (Subscriber (DMap k Identity))
430newSubscriberFan subd = return $! SubscriberFan subd
592newSubscriberFan subd = return $! SubscriberFan subd
@@ -449,15 +611,100 @@ newInvalidatorSwitch subd = return $! InvalidatorSwitch subd
449newInvalidatorPull :: Pull a -> IO Invalidator
611newInvalidatorPull :: Pull a -> IO Invalidator
450newInvalidatorPull p = return $! InvalidatorPull p
612newInvalidatorPull p = return $! InvalidatorPull p
451
613
452−{-# NOINLINE newBox #-}
614+data Dynamic p a
453−newBox :: a -> IO (Box a)
615+ = DynamicHold !(Hold p a)
454−newBox a = return $! Box a
616+ | p ~ Identity => DynamicHoldIdentity !(Hold Identity a)
617+ | DynamicConst !a
618+ | DynamicDyn !(Dyn p a)
619+ | p ~ Identity => DynamicDynIdentity !(Dyn Identity a)
620+
621+{-# INLINE current #-}
622+current :: R.Patch p => Dynamic p a -> Behavior a
623+current = \case
624+ DynamicHold h -> BehaviorHold h
625+ DynamicHoldIdentity h -> BehaviorHoldIdentity h
626+ DynamicConst a -> BehaviorConst a
627+ DynamicDyn d -> BehaviorDyn d
628+ DynamicDynIdentity d -> BehaviorDynIdentity d
629+
630+--TODO: If you only need updated, not current, can we avoid actually constructing the Hold?
631+{-# INLINE updated #-}
632+updated :: R.Patch p => Dynamic p a -> Event (p a)
633+updated = \case
634+ DynamicHold h -> EventHold h
635+ DynamicHoldIdentity h -> EventHoldIdentity h
636+ DynamicConst _ -> EventNever
637+ DynamicDyn d -> EventDyn d
638+ DynamicDynIdentity d -> EventDynIdentity d
639+
640+newMapDyn :: (a -> b) -> Dynamic Identity a -> Dynamic Identity b
641+newMapDyn f d = DynamicDynIdentity $ unsafeDyn (fmap f $ readBehaviorTracked $ current d) (fmap (Identity . f . runIdentity) $ updated d)
642+
643+instance Functor (Dynamic Identity) where
644+ fmap f d = newMapDyn f d
645+
646+instance Applicative (Dynamic Identity) where
647+ pure = DynamicConst
648+ (<*>) = zipDynWith ($)
649+ _ *> b = b
650+ a <* _ = a
651+
652+instance R.FunctorMaybe Event where
653+ fmapMaybe f = push $ return . f
654+
655+instance Align Event where
656+ nil = EventNever
657+ align ea eb = R.fmapMaybe R.dmapToThese $ merge $ DynamicConst $ DMap.fromList [R.LeftTag :=> ea, R.RightTag :=> eb]
658+
659+--TODO: Avoid the duplication between this and R.zipDynWith
660+zipDynWith :: (a -> b -> c) -> Dynamic Identity a -> Dynamic Identity b -> Dynamic Identity c
661+zipDynWith f da db =
662+ let eab = align (updated da) (updated db)
663+ ec = flip push eab $ \o -> do
664+ (a, b) <- case o of
665+ This (Identity a) -> do
666+ b <- readBehaviorUntracked $ current db
667+ return (a, b)
668+ That (Identity b) -> do
669+ a <- readBehaviorUntracked $ current da
670+ return (a, b)
671+ These (Identity a) (Identity b) -> return (a, b)
672+ return $ Just $ Identity $ f a b
673+ in DynamicDynIdentity $ unsafeDyn (f <$> readBehaviorUntracked (current da) <*> readBehaviorUntracked (current db)) ec
674+
675+instance Monad (Dynamic Identity) where
676+ {-# INLINE return #-}
677+ return = pure
678+ {-# INLINE (>>=) #-}
679+ x >>= f = DynamicDynIdentity $ newJoinDyn $ newMapDyn f x --TODO: (>>), fail
680+ {-# INLINE (>>) #-}
681+ _ >> y = y
682+ {-# INLINE fail #-}
683+ fail _ = error "Dynamic does not support 'fail'"
684+
685+newtype Dyn p a = Dyn { unDyn :: IORef (Either (BehaviorM a, Event (p a)) (Hold p a)) }
686+
687+unsafeDyn :: BehaviorM a -> Event (p a) -> Dyn p a
688+unsafeDyn readV0 v' = Dyn $ unsafeNewIORef x $ Left x
689+ where x = (readV0, v')
690+
691+newJoinDyn :: Dynamic Identity (Dynamic Identity a) -> Dyn Identity a
692+newJoinDyn d =
693+ let readV0 = readBehaviorTracked . current =<< readBehaviorTracked (current d)
694+ eOuter = push (fmap (Just . Identity) . readBehaviorUntracked . current . runIdentity) $ updated d
695+ eInner = switch $ fmap updated $ current d
696+ eBoth = coincidence $ fmap (updated . runIdentity) $ updated d
697+ v' = unSpiderEvent $ R.leftmost $ map SpiderEvent [eBoth, eOuter, eInner]
698+ in unsafeDyn readV0 v'
455
699
456--type role Behavior representational
700--type role Behavior representational
457data Behavior a
701data Behavior a
458− = BehaviorHold !(Hold a)
702+ = forall p. BehaviorHold !(Hold p a)
703+ | BehaviorHoldIdentity !(Hold Identity a)
459 | BehaviorConst !a
704 | BehaviorConst !a
460 | BehaviorPull !(Pull a)
705 | BehaviorPull !(Pull a)
706+ | BehaviorDynIdentity !(Dyn Identity a)
707+ | forall p. R.Patch p => BehaviorDyn !(Dyn p a)
461
708
462-- ResultM can read behaviors and events
709-- ResultM can read behaviors and events
463type ResultM = EventM
710type ResultM = EventM
@@ -473,21 +720,23 @@ instance Functor Behavior where
473 fmap f = pull . liftM f . readBehaviorTracked
720 fmap f = pull . liftM f . readBehaviorTracked
474
721
475{-# NOINLINE push #-} --TODO: If this is helpful, we can get rid of the unsafeNewIORef and use unsafePerformIO directly
722{-# NOINLINE push #-} --TODO: If this is helpful, we can get rid of the unsafeNewIORef and use unsafePerformIO directly
476−push :: (a -> EventM (Maybe b)) -> Event a -> Event b
723+push :: forall a b. (a -> ComputeM (Maybe b)) -> Event a -> Event b
477push f e = EventPush $ Push
724push f e = EventPush $ Push
478 { pushCompute = f
725 { pushCompute = f
479 , pushParent = e
726 , pushParent = e
480 , pushSubscribed = unsafeNewIORef (f, e) Nothing --TODO: Does the use of the tuple here create unnecessary overhead?
727 , pushSubscribed = unsafeNewIORef (f, e) Nothing --TODO: Does the use of the tuple here create unnecessary overhead?
481 }
728 }
482−{-# RULES "push/push" forall f g e. push f (push g e) = push (maybe (return Nothing) f <=< g) e #-}
729+-- DISABLED: {- RULES "push/push" forall f g e. push f (push g e) = push (maybe (return Nothing) f <=< g) e #-}
483
730
484{-# NOINLINE pull #-}
731{-# NOINLINE pull #-}
485pull :: BehaviorM a -> Behavior a
732pull :: BehaviorM a -> Behavior a
486pull a = BehaviorPull $ Pull
733pull a = BehaviorPull $ Pull
487 { pullCompute = a
734 { pullCompute = a
488 , pullValue = unsafeNewIORef a Nothing
735 , pullValue = unsafeNewIORef a Nothing
736+#ifdef DEBUG_NODEIDS
737+ , pullNodeId = unsafeNodeId a
738+#endif
489 }
739 }
490−{-# RULES "pull/pull" forall a. pull (readBehaviorTracked (pull a)) = pull a #-}
491
740
492{-# NOINLINE switch #-}
741{-# NOINLINE switch #-}
493switch :: Behavior (Event a) -> Event a
742switch :: Behavior (Event a) -> Event a
@@ -495,7 +744,6 @@ switch a = EventSwitch $ Switch
495 { switchParent = a
744 { switchParent = a
496 , switchSubscribed = unsafeNewIORef a Nothing
745 , switchSubscribed = unsafeNewIORef a Nothing
497 }
746 }
498−{-# RULES "switch/constB" forall e. switch (BehaviorConst e) = e #-}
499
747
500coincidence :: Event (Event a) -> Event a
748coincidence :: Event (Event a) -> Event a
501coincidence a = EventCoincidence $ Coincidence
749coincidence a = EventCoincidence $ Coincidence
@@ -503,32 +751,20 @@ coincidence a = EventCoincidence $ Coincidence
503 , coincidenceSubscribed = unsafeNewIORef a Nothing
751 , coincidenceSubscribed = unsafeNewIORef a Nothing
504 }
752 }
505
753
506−newRoot :: IO (Root k)
507−newRoot = do
508− occRef <- newIORef DMap.empty
509− subscribedRef <- newIORef DMap.empty
510− return $ Root
511− { rootOccurrence = occRef
512− , rootSubscribed = subscribedRef
513− , rootInit = \_ _ -> return $ return ()
514− }
515−
516−propagateAndUpdateSubscribersRef :: IORef [WeakSubscriber a] -> a -> EventM ()
754+propagateAndUpdateSubscribersRef :: SubscriberList a -> a -> EventM x ()
517propagateAndUpdateSubscribersRef subscribersRef a = do
755propagateAndUpdateSubscribersRef subscribersRef a = do
518− subscribers <- liftIO $ readIORef subscribersRef
519− liftIO $ writeIORef subscribersRef []
520− stillAlive <- propagate a subscribers
521− liftIO $ modifyIORef' subscribersRef (++stillAlive)
756+ propagate a subscribersRef
522
757
523-- Propagate the given event occurrence; before cleaning up, run the given action, which may read the state of events and behaviors
758-- Propagate the given event occurrence; before cleaning up, run the given action, which may read the state of events and behaviors
524−run :: [DSum RootTrigger Identity] -> ResultM b -> IO b
759+run :: [DSum RootTrigger Identity] -> ResultM x b -> SpiderHost x b
525run roots after = do
760run roots after = do
526− when debugPropagate $ putStrLn "Running an event frame"
761+ tracePropagate $ "Running an event frame with " <> show (length roots) <> " events"
527− result <- runFrame $ do
762+ spiderEnv <- SpiderHost ask
763+ result <- SpiderHost $ lift $ withMVar (_spiderEnv_lock spiderEnv) $ \_ -> flip runReaderT spiderEnv $ unSpiderHost $ runFrame $ do
528 rootsToPropagate <- forM roots $ \r@(RootTrigger (_, occRef, k) :=> a) -> do
764 rootsToPropagate <- forM roots $ \r@(RootTrigger (_, occRef, k) :=> a) -> do
529 occBefore <- liftIO $ do
765 occBefore <- liftIO $ do
530 occBefore <- readIORef occRef
766 occBefore <- readIORef occRef
531− writeIORef occRef $ DMap.insert k a occBefore
767+ writeIORef occRef $! DMap.insert k a occBefore
532 return occBefore
768 return occBefore
533 if DMap.null occBefore
769 if DMap.null occBefore
534 then do scheduleRootClear occRef
770 then do scheduleRootClear occRef
@@ -541,14 +777,14 @@ run roots after = do
541 delayed <- liftIO $ readIORef delayedRef
777 delayed <- liftIO $ readIORef delayedRef
542 case IntMap.minViewWithKey delayed of
778 case IntMap.minViewWithKey delayed of
543 Nothing -> return ()
779 Nothing -> return ()
544− Just ((currentHeight, current), future) -> do
780+ Just ((currentHeight, cur), future) -> do
545− when debugPropagate $ liftIO $ putStrLn $ "Running height " ++ show currentHeight
781+ tracePropagate $ "Running height " ++ show currentHeight
546− putCurrentHeight currentHeight
782+ putCurrentHeight $ Height currentHeight
547 liftIO $ writeIORef delayedRef future
783 liftIO $ writeIORef delayedRef future
548− forM_ current $ \d -> case d of
784+ forM_ cur $ \d -> case d of
549 DelayedMerge subscribed -> do
785 DelayedMerge subscribed -> do
550 height <- liftIO $ readIORef $ mergeSubscribedHeight subscribed
786 height <- liftIO $ readIORef $ mergeSubscribedHeight subscribed
551− case height `compare` currentHeight of
787+ case height `compare` Height currentHeight of
552 LT -> error "Somehow a merge's height has been decreased after it was scheduled"
788 LT -> error "Somehow a merge's height has been decreased after it was scheduled"
553 GT -> scheduleMerge height subscribed -- The height has been increased (by a coincidence event; TODO: is this the only way?)
789 GT -> scheduleMerge height subscribed -- The height has been increased (by a coincidence event; TODO: is this the only way?)
554 EQ -> do
790 EQ -> do
@@ -562,14 +798,14 @@ run roots after = do
562 go
798 go
563 putCurrentHeight maxBound
799 putCurrentHeight maxBound
564 after
800 after
565− when debugPropagate $ putStrLn "Done running an event frame"
801+ tracePropagate "Done running an event frame"
566 return result
802 return result
567
803
568−data SomeMaybeIORef = forall a. SomeMaybeIORef (IORef (Maybe a))
804+data SomeClear = forall a. SomeClear (IORef (Maybe a))
569
805
570−data SomeDMapIORef = forall k. SomeDMapIORef (IORef (DMap k Identity))
806+data SomeRootClear = forall k. SomeRootClear (IORef (DMap k Identity))
571
807
572−data SomeAssignment = forall a. SomeAssignment (Hold a) a
808+data SomeAssignment = forall a. SomeAssignment {-# UNPACK #-} !(IORef a) {-# UNPACK #-} !(IORef [Weak Invalidator]) a
573
809
574data DelayedMerge = forall k. DelayedMerge (MergeSubscribed k)
810data DelayedMerge = forall k. DelayedMerge (MergeSubscribed k)
575
811
@@ -577,136 +813,231 @@ debugFinalize :: Bool
577debugFinalize = False
813debugFinalize = False
578
814
579mkWeakPtrWithDebug :: a -> String -> IO (Weak a)
815mkWeakPtrWithDebug :: a -> String -> IO (Weak a)
580−mkWeakPtrWithDebug x debugNote = mkWeakPtr x $
816+mkWeakPtrWithDebug x debugNote = do
817+ x' <- evaluate x
818+ mkWeakPtr x' $
581− if debugFinalize
819+ if debugFinalize
582− then Just $ putStrLn $ "finalizing: " ++ debugNote
820+ then Just $ putStrLn $ "finalizing: " ++ debugNote
583− else Nothing
821+ else Nothing
584
822
585type WeakList a = [Weak a]
823type WeakList a = [Weak a]
586
824
587−--TODO: Is it faster to clean up every time, or to occasionally go through and clean up as needed?
825+{-# INLINE withIncreasedDepth #-}
588−traverseAndCleanWeakList_ :: Monad m => (wa -> m (Maybe a)) -> [wa] -> (a -> m ()) -> m [wa]
826+#ifdef DEBUG
589−traverseAndCleanWeakList_ deRef ws f = go ws
827+withIncreasedDepth :: CanTrace x m => m a -> m a
590− where go [] = return []
828+withIncreasedDepth a = do
591− go (h:t) = do
829+ spiderEnv <- askSpiderEnv
592− ma <- deRef h
830+ liftIO $ modifyIORef' (_spiderEnv_depth spiderEnv) succ
593− case ma of
831+ result <- a
594− Just a -> do
832+ liftIO $ modifyIORef' (_spiderEnv_depth spiderEnv) pred
595− f a
833+ return result
596− t' <- go t
834+#else
597− return $ h : t'
835+withIncreasedDepth :: m a -> m a
598− Nothing -> go t
836+withIncreasedDepth = id
837+#endif
838+
839+type CanTrace x m = (HasSpiderEnv x m, MonadIO m)
840+
841+{-# INLINE tracePropagate #-}
842+tracePropagate :: (CanTrace x m) => String -> m ()
843+tracePropagate = traceWhen debugPropagate
844+
845+{-# INLINE traceSubscribe #-}
846+traceSubscribe :: String -> IO ()
847+traceSubscribe = when debugSubscribe . liftIO . putStrLn
848+
849+{-# INLINE traceInvalidate #-}
850+traceInvalidate :: String -> IO ()
851+traceInvalidate = when debugInvalidate . liftIO . putStrLn
852+
853+{-# INLINE traceWhen #-}
854+traceWhen :: (CanTrace x m) => Bool -> String -> m ()
855+traceWhen b message = traceMWhen b $ return message
856+
857+{-# INLINE traceMWhen #-}
858+traceMWhen :: (CanTrace x m) => Bool -> m String -> m ()
859+traceMWhen b getMessage = when b $ do
860+ message <- getMessage
861+#ifdef DEBUG
862+ spiderEnv <- askSpiderEnv
863+ d <- liftIO $ readIORef $ _spiderEnv_depth spiderEnv
864+#else
865+ let d = 0
866+#endif
867+ liftIO $ putStrLn $ replicate d ' ' <> message
868+
869+whoCreatedIORef :: IORef a -> IO [String]
870+whoCreatedIORef (IORef a) = whoCreated $! a
871+
872+whoCreatedEventSubscribed :: EventSubscribed a -> IO [String]
873+whoCreatedEventSubscribed = \case
874+ EventSubscribedRoot _ -> return ["root"]
875+ EventSubscribedNever -> return ["never"]
876+ EventSubscribedPush subscribed -> whoCreatedIORef $ pushSubscribedCachedSubscribed subscribed
877+ EventSubscribedFan _ subscribed -> whoCreatedIORef $ fanSubscribedCachedSubscribed subscribed
878+ EventSubscribedMerge subscribed -> whoCreatedIORef $ mergeSubscribedCachedSubscribed subscribed
879+ EventSubscribedSwitch subscribed -> whoCreatedIORef $ switchSubscribedCachedSubscribed subscribed
880+ EventSubscribedCoincidence subscribed -> whoCreatedIORef $ coincidenceSubscribedCachedSubscribed subscribed
881+
882+walkInvalidHeightParents :: EventSubscribed a -> IO [Some EventSubscribed]
883+walkInvalidHeightParents s0 = do
884+ subscribers <- flip execStateT mempty $ ($ Some.This s0) $ fix $ \loop (Some.This s) -> do
885+ h <- liftIO $ readIORef $ eventSubscribedHeightRef s
886+ when (h == invalidHeight) $ do
887+ when (eventSubscribedHasOwnHeightRef s) $ liftIO $ writeIORef (eventSubscribedHeightRef s) invalidHeightBeingTraversed
888+ modify (Some.This s :)
889+ mapM_ loop =<< liftIO (eventSubscribedGetParents s)
890+ forM_ subscribers $ \(Some.This s) -> writeIORef (eventSubscribedHeightRef s) invalidHeight
891+ return subscribers
892+
893+groupByHead :: Eq a => [NonEmpty a] -> [(a, NonEmpty [a])]
894+groupByHead = \case
895+ [] -> []
896+ (x :| xs) : t -> case groupByHead t of
897+ [] -> [(x, xs :| [])]
898+ l@((y, yss) : t')
899+ | x == y -> (x, xs `NonEmpty.cons` yss) : t'
900+ | otherwise -> (x, xs :| []) : l
901+
902+listsToForest :: Eq a => [[a]] -> Forest a
903+listsToForest l = fmap (\(a, l') -> Node a $ listsToForest $ toList l') $ groupByHead $ catMaybes $ fmap nonEmpty l
599
904
600-- | Propagate everything at the current height
905-- | Propagate everything at the current height
601−propagate :: a -> [WeakSubscriber a] -> EventM [WeakSubscriber a]
906+propagate :: a -> SubscriberList a -> EventM x ()
602−propagate a subscribers = do
907+propagate a subscribers = withIncreasedDepth $ do
603− traverseAndCleanWeakList_ (liftIO . deRefWeakSubscriber) subscribers $ \s -> case s of
908+ -- Note: in the following traversal, we do not visit nodes that are added to the list during our traversal; they are new events, which will necessarily have full information already, so there is no need to traverse them
909+ --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work
910+ WeakBag.traverse subscribers $ \s -> case s of
604− SubscriberPush compute subscribed -> do
911+ SubscriberPush compute subscribed -> {-# SCC "traversePush" #-} do
605− when debugPropagate $ liftIO $ putStrLn $ "SubscriberPush" <> showNodeId subscribed
912+ tracePropagate $ "SubscriberPush" <> showNodeId subscribed
606− occ <- compute a
913+ occ <- runComputeM $ compute a
607 case occ of
914 case occ of
608 Nothing -> return () -- No need to write a Nothing back into the Ref
915 Nothing -> return () -- No need to write a Nothing back into the Ref
609 Just o -> do
916 Just o -> do
610 liftIO $ writeIORef (pushSubscribedOccurrence subscribed) occ
917 liftIO $ writeIORef (pushSubscribedOccurrence subscribed) occ
611 scheduleClear $ pushSubscribedOccurrence subscribed
918 scheduleClear $ pushSubscribedOccurrence subscribed
612− liftIO . writeIORef (pushSubscribedSubscribers subscribed) =<< propagate o =<< liftIO (readIORef (pushSubscribedSubscribers subscribed))
919+ propagate o $ pushSubscribedSubscribers subscribed
613− SubscriberMerge k subscribed -> do
920+ SubscriberMerge k subscribed -> {-# SCC "traverseMerge" #-} do
614− when debugPropagate $ liftIO $ putStrLn $ "SubscriberMerge" <> showNodeId subscribed
921+ tracePropagate $ "SubscriberMerge" <> showNodeId subscribed
615 oldM <- liftIO $ readIORef $ mergeSubscribedAccum subscribed
922 oldM <- liftIO $ readIORef $ mergeSubscribedAccum subscribed
616− liftIO $ writeIORef (mergeSubscribedAccum subscribed) $ DMap.insertWith (error "Same key fired multiple times for") k (Identity a) oldM
923+ let newM = DMap.insertWith (error $ "Same key fired multiple times for Merge" <> showNodeId subscribed) k (Identity a) oldM
924+ tracePropagate $ " DMap.size oldM = " <> show (DMap.size oldM) <> "; DMap.size newM = " <> show (DMap.size newM)
925+ liftIO $ writeIORef (mergeSubscribedAccum subscribed) $! newM
617 when (DMap.null oldM) $ do -- Only schedule the firing once
926 when (DMap.null oldM) $ do -- Only schedule the firing once
618 height <- liftIO $ readIORef $ mergeSubscribedHeight subscribed
927 height <- liftIO $ readIORef $ mergeSubscribedHeight subscribed
619 --TODO: assertions about height
928 --TODO: assertions about height
620 currentHeight <- getCurrentHeight
929 currentHeight <- getCurrentHeight
930+ when (height <= currentHeight) $ do
931+ myStack <- liftIO $ whoCreatedIORef $ mergeSubscribedCachedSubscribed subscribed
932+ if height /= invalidHeight
621− when (height <= currentHeight) $ error $ "Height (" ++ show height ++ ") is not greater than current height (" ++ show currentHeight ++ ")"
933+ then error $ "Height (" ++ show height ++ ") is not greater than current height (" ++ show currentHeight ++ ")\n" ++ unlines (reverse myStack)
934+ else liftIO $ do
935+ nodesInvolvedInCycle <- walkInvalidHeightParents $ EventSubscribedMerge subscribed
936+ stacks <- forM nodesInvolvedInCycle $ \(Some.This es) -> whoCreatedEventSubscribed es
937+ error $ "Causality loop found:\n" <> drawForest (listsToForest stacks)
622 scheduleMerge height subscribed
938 scheduleMerge height subscribed
939+ SubscriberMergeChange subscribed -> {-# SCC "traverseMergeChange" #-} do
940+ tracePropagate $ "SubscriberMerge" <> showNodeId subscribed
941+ defer $ SomeMergeUpdate a subscribed
623− SubscriberFan subscribed -> do
942+ SubscriberFan subscribed -> {-# SCC "traverseFan" #-} do
624 subs <- liftIO $ readIORef $ fanSubscribedSubscribers subscribed
943 subs <- liftIO $ readIORef $ fanSubscribedSubscribers subscribed
625− when debugPropagate $ liftIO $ putStrLn $ "SubscriberFan" <> showNodeId subscribed <> ": " ++ show (DMap.size subs) ++ " keys subscribed, " ++ show (DMap.size a) ++ " keys firing"
944+ tracePropagate $ "SubscriberFan" <> showNodeId subscribed <> ": " ++ show (DMap.size subs) ++ " keys subscribed, " ++ show (DMap.size a) ++ " keys firing"
626 --TODO: We need a better DMap intersection; here, we are assuming that the number of firing keys is small and the number of subscribers is large
945 --TODO: We need a better DMap intersection; here, we are assuming that the number of firing keys is small and the number of subscribers is large
627− forM_ (DMap.toList a) $ \(k :=> Identity v) -> case DMap.lookup (FanSubscriberKey k) subs of
946+ forM_ (DMap.toList a) $ \(k :=> Identity v) -> {-# SCC "SubscriberFan" #-} case DMap.lookup k subs of
628 Nothing -> do
947 Nothing -> do
629− when debugPropagate $ liftIO $ putStrLn "No subscriber for key"
948+ tracePropagate "No subscriber for key"
630 return ()
949 return ()
631− Just (Identity subsubs) -> do
950+ Just subsubs -> do
632− _ <- propagate v subsubs --TODO: use the value of this
951+ propagate v $ _fanSubscribedChildren_list subsubs
633 return ()
952 return ()
634− --TODO: The following is way too slow to do all the time
635− subs' <- liftIO $ forM (DMap.toList subs) $ ((\(FanSubscriberKey k :=> Identity subsubs) -> do
636− subsubs' <- traverseAndCleanWeakList_ (liftIO . deRefWeakSubscriber) subsubs (const $ return ())
637− return $ if null subsubs'
638− then Nothing
639− else Just $ FanSubscriberKey k :=> Identity subsubs') :: DSum (FanSubscriberKey k) Identity -> IO (Maybe (DSum (FanSubscriberKey k) Identity)))
640− liftIO $ writeIORef (fanSubscribedSubscribers subscribed) $ DMap.fromDistinctAscList $ catMaybes subs'
641− SubscriberHold h -> do
953+ SubscriberHold h -> {-# SCC "traverseHold" #-} propagateSubscriberHold h a
642− invalidators <- liftIO $ readIORef $ holdInvalidators h
954+ SubscriberHoldIdentity h -> {-# SCC "traverseHoldIdentity" #-} propagateSubscriberHold h a
643− when debugPropagate $ liftIO $ putStrLn $ "SubscriberHold" <> showNodeId h <> ": " ++ show (length invalidators)
644− toAssignRef <- askToAssignRef
645− liftIO $ modifyIORef' toAssignRef (SomeAssignment h a :)
646− SubscriberSwitch subscribed -> do
955+ SubscriberSwitch subscribed -> {-# SCC "traverseSwitch" #-} do
647− when debugPropagate $ liftIO $ putStrLn $ "SubscriberSwitch" <> showNodeId subscribed
956+ tracePropagate $ "SubscriberSwitch" <> showNodeId subscribed
648 liftIO $ writeIORef (switchSubscribedOccurrence subscribed) $ Just a
957 liftIO $ writeIORef (switchSubscribedOccurrence subscribed) $ Just a
649 scheduleClear $ switchSubscribedOccurrence subscribed
958 scheduleClear $ switchSubscribedOccurrence subscribed
650− subs <- liftIO $ readIORef $ switchSubscribedSubscribers subscribed
959+ propagate a $ switchSubscribedSubscribers subscribed
651− liftIO . writeIORef (switchSubscribedSubscribers subscribed) =<< propagate a subs
652− SubscriberCoincidenceOuter subscribed -> do
960+ SubscriberCoincidenceOuter subscribed -> {-# SCC "traverseCoincidenceOuter" #-} do
653− when debugPropagate $ liftIO $ putStrLn $ "SubscriberCoincidenceOuter" <> showNodeId subscribed
961+ tracePropagate $ "SubscriberCoincidenceOuter" <> showNodeId subscribed
654 outerHeight <- liftIO $ readIORef $ coincidenceSubscribedHeight subscribed
962 outerHeight <- liftIO $ readIORef $ coincidenceSubscribedHeight subscribed
655− when debugPropagate $ liftIO $ putStrLn $ " outerHeight = " <> show outerHeight
963+ tracePropagate $ " outerHeight = " <> show outerHeight
656 (occ, innerHeight, innerSubd) <- subscribeCoincidenceInner a outerHeight subscribed
964 (occ, innerHeight, innerSubd) <- subscribeCoincidenceInner a outerHeight subscribed
657− when debugPropagate $ liftIO $ putStrLn $ " isJust occ = " <> show (isJust occ)
965+ tracePropagate $ " isJust occ = " <> show (isJust occ)
658− when debugPropagate $ liftIO $ putStrLn $ " innerHeight = " <> show innerHeight
966+ tracePropagate $ " innerHeight = " <> show innerHeight
659 liftIO $ writeIORef (coincidenceSubscribedInnerParent subscribed) $ Just innerSubd
967 liftIO $ writeIORef (coincidenceSubscribedInnerParent subscribed) $ Just innerSubd
660 scheduleClear $ coincidenceSubscribedInnerParent subscribed
968 scheduleClear $ coincidenceSubscribedInnerParent subscribed
661 case occ of
969 case occ of
662 Nothing -> do
970 Nothing -> do
663 when (innerHeight > outerHeight) $ liftIO $ do -- If the event fires, it will fire at a later height
971 when (innerHeight > outerHeight) $ liftIO $ do -- If the event fires, it will fire at a later height
664 writeIORef (coincidenceSubscribedHeight subscribed) innerHeight
972 writeIORef (coincidenceSubscribedHeight subscribed) innerHeight
665− mapM_ invalidateSubscriberHeight =<< readIORef (coincidenceSubscribedSubscribers subscribed)
973+ WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) invalidateSubscriberHeight
666− mapM_ recalculateSubscriberHeight =<< readIORef (coincidenceSubscribedSubscribers subscribed)
974+ WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) recalculateSubscriberHeight
667 Just o -> do -- Since it's already firing, no need to adjust height
975 Just o -> do -- Since it's already firing, no need to adjust height
668 liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) occ
976 liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) occ
669 scheduleClear $ coincidenceSubscribedOccurrence subscribed
977 scheduleClear $ coincidenceSubscribedOccurrence subscribed
670− liftIO . writeIORef (coincidenceSubscribedSubscribers subscribed) =<< propagate o =<< liftIO (readIORef (coincidenceSubscribedSubscribers subscribed))
978+ propagate o $ coincidenceSubscribedSubscribers subscribed
671− SubscriberCoincidenceInner subscribed -> do
979+ SubscriberCoincidenceInner subscribed -> {-# SCC "traverseCoincidenceInner" #-} do
672− when debugPropagate $ liftIO $ putStrLn $ "SubscriberCoincidenceInner" <> showNodeId subscribed
980+ tracePropagate $ "SubscriberCoincidenceInner" <> showNodeId subscribed
981+ occ <- liftIO $ readIORef $ coincidenceSubscribedOccurrence subscribed
982+ case occ of
983+ Just _ -> return () -- SubscriberCoincidenceOuter must have already propagated this event
984+ Nothing -> do
673− liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) $ Just a
985+ liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) $ Just a
674− scheduleClear $ coincidenceSubscribedOccurrence subscribed
986+ scheduleClear $ coincidenceSubscribedOccurrence subscribed
675− liftIO . writeIORef (coincidenceSubscribedSubscribers subscribed) =<< propagate a =<< liftIO (readIORef (coincidenceSubscribedSubscribers subscribed))
987+ propagate a $ coincidenceSubscribedSubscribers subscribed
988+ SubscriberHandle -> {-# SCC "traverseHandle" #-} tracePropagate "SubscriberHandle"
989+
990+{-# INLINE propagateSubscriberHold #-}
991+propagateSubscriberHold :: R.Patch p => Hold p a -> p a -> EventM x ()
992+propagateSubscriberHold h a = do
993+ {-# SCC "trace" #-} traceMWhen debugPropagate $ liftIO $ do
994+ invalidators <- liftIO $ readIORef $ holdInvalidators h
995+ return $ "SubscriberHold" <> showNodeId h <> ": " ++ show (length invalidators)
996+ v <- {-# SCC "read" #-} liftIO $ readIORef $ holdValue h
997+ case {-# SCC "apply" #-} R.apply a v of
998+ Nothing -> return ()
999+ Just v' -> do
1000+ {-# SCC "trace2" #-} withIncreasedDepth $ tracePropagate $ "propagateSubscriberHold: assigning Hold" <> showNodeId h
1001+ vRef <- {-# SCC "vRef" #-} liftIO $ evaluate $ holdValue h
1002+ iRef <- {-# SCC "iRef" #-} liftIO $ evaluate $ holdInvalidators h
1003+ defer $ {-# SCC "assignment" #-} SomeAssignment vRef iRef v'
676
1004
677−data SomeCoincidenceInfo = forall a. SomeCoincidenceInfo (Weak (Subscriber a)) (Subscriber a) (Maybe (CoincidenceSubscribed a)) -- The CoincidenceSubscriber will be present only if heights need to be reset
1005+data SomeResetCoincidence = forall a. SomeResetCoincidence !(EventSubscription a) !(Maybe (CoincidenceSubscribed a)) -- The CoincidenceSubscriber will be present only if heights need to be reset
678
1006
1007+{-# INLINE subscribeCoincidenceInner #-}
679−subscribeCoincidenceInner :: Event a -> Int -> CoincidenceSubscribed a -> EventM (Maybe a, Int, EventSubscribed a)
1008+subscribeCoincidenceInner :: CanSubscribe x m => Event a -> Height -> CoincidenceSubscribed a -> m (Maybe a, Height, EventSubscribed a)
680subscribeCoincidenceInner o outerHeight subscribedUnsafe = do
1009subscribeCoincidenceInner o outerHeight subscribedUnsafe = do
681 subInner <- liftIO $ newSubscriberCoincidenceInner subscribedUnsafe
1010 subInner <- liftIO $ newSubscriberCoincidenceInner subscribedUnsafe
682− wsubInner <- liftIO $ mkWeakPtrWithDebug subInner "SubscriberCoincidenceInner"
1011+ subscription@(_, innerSubd) <- subscribe o subInner
683− innerSubd <- {-# SCC "innerSubd" #-} (subscribe o $ WeakSubscriberSimple wsubInner)
684− innerOcc <- liftIO $ getEventSubscribedOcc innerSubd
1012+ innerOcc <- liftIO $ readEventSubscribed innerSubd
685 innerHeight <- liftIO $ readIORef $ eventSubscribedHeightRef innerSubd
1013 innerHeight <- liftIO $ readIORef $ eventSubscribedHeightRef innerSubd
686 let height = max innerHeight outerHeight
1014 let height = max innerHeight outerHeight
687− emitCoincidenceInfo $ SomeCoincidenceInfo wsubInner subInner $ if height > outerHeight then Just subscribedUnsafe else Nothing
1015+ defer $ SomeResetCoincidence subscription $ if height > outerHeight then Just subscribedUnsafe else Nothing
688 return (innerOcc, height, innerSubd)
1016 return (innerOcc, height, innerSubd)
689
1017
690−readBehavior :: Behavior a -> IO a
1018+{-# SPECIALIZE readBehaviorUntracked :: Behavior a -> BehaviorM a #-}
1019+{-# SPECIALIZE readBehaviorUntracked :: Behavior a -> EventM x a #-}
1020+readBehaviorUntracked :: Defer SomeHoldInit m => Behavior a -> m a
1021+readBehaviorUntracked b = do
1022+ holdInits <- getDeferralQueue
691−readBehavior b = runBehaviorM (readBehaviorTracked b) Nothing --TODO: Specialize readBehaviorTracked to the Nothing and Just cases
1023+ liftIO $ runBehaviorM (readBehaviorTracked b) Nothing holdInits --TODO: Specialize readBehaviorTracked to the Nothing and Just cases
692
1024
693−runBehaviorM :: BehaviorM a -> Maybe (Weak Invalidator, IORef [SomeBehaviorSubscribed]) -> IO a
1025+runBehaviorM :: BehaviorM a -> Maybe (Weak Invalidator, IORef [SomeBehaviorSubscribed]) -> IORef [SomeHoldInit] -> IO a
694−runBehaviorM a mwi = runReaderT (unBehaviorM a) mwi
1026+runBehaviorM a mwi holdInits = runReaderT (unBehaviorM a) (mwi, holdInits)
695
1027
696askInvalidator :: BehaviorM (Maybe (Weak Invalidator))
1028askInvalidator :: BehaviorM (Maybe (Weak Invalidator))
697−askInvalidator = liftM (fmap fst) $ BehaviorM ask
1029+askInvalidator = liftM (fmap fst . fst) $ BehaviorM ask
698
1030
699askParentsRef :: BehaviorM (Maybe (IORef [SomeBehaviorSubscribed]))
1031askParentsRef :: BehaviorM (Maybe (IORef [SomeBehaviorSubscribed]))
700−askParentsRef = liftM (fmap snd) $ BehaviorM ask
1032+askParentsRef = liftM (fmap snd . fst) $ BehaviorM ask
1033+
1034+askBehaviorHoldInits :: BehaviorM (IORef [SomeHoldInit])
1035+askBehaviorHoldInits = liftM snd $ BehaviorM ask
701
1036
702readBehaviorTracked :: Behavior a -> BehaviorM a
1037readBehaviorTracked :: Behavior a -> BehaviorM a
703readBehaviorTracked b = case b of
1038readBehaviorTracked b = case b of
704− BehaviorHold h -> do
1039+ BehaviorHold h -> readHoldTracked h
705− result <- liftIO $ readIORef $ holdValue h
1040+ BehaviorHoldIdentity h -> readHoldTracked h
706− askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (holdInvalidators h) (wi:))
707− askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedHold h) :))
708− liftIO $ touch $ holdSubscriber h
709− return result
710 BehaviorConst a -> return a
1041 BehaviorConst a -> return a
711 BehaviorPull p -> do
1042 BehaviorPull p -> do
712 val <- liftIO $ readIORef $ pullValue p
1043 val <- liftIO $ readIORef $ pullValue p
@@ -720,7 +1051,8 @@ readBehaviorTracked b = case b of
720 i <- liftIO $ newInvalidatorPull p
1051 i <- liftIO $ newInvalidatorPull p
721 wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorPull"
1052 wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorPull"
722 parentsRef <- liftIO $ newIORef []
1053 parentsRef <- liftIO $ newIORef []
1054+ holdInits <- askBehaviorHoldInits
723− a <- liftIO $ runReaderT (unBehaviorM $ pullCompute p) $ Just (wi, parentsRef)
1055+ a <- liftIO $ runReaderT (unBehaviorM $ pullCompute p) (Just (wi, parentsRef), holdInits)
724 invsRef <- liftIO . newIORef . maybeToList =<< askInvalidator
1056 invsRef <- liftIO . newIORef . maybeToList =<< askInvalidator
725 parents <- liftIO $ readIORef parentsRef
1057 parents <- liftIO $ readIORef parentsRef
726 let subscribed = PullSubscribed
1058 let subscribed = PullSubscribed
@@ -732,183 +1064,321 @@ readBehaviorTracked b = case b of
732 liftIO $ writeIORef (pullValue p) $ Just subscribed
1064 liftIO $ writeIORef (pullValue p) $ Just subscribed
733 askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :))
1065 askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :))
734 return a
1066 return a
1067+ BehaviorDyn d -> readHoldTracked =<< getDynHold d
1068+ BehaviorDynIdentity d -> readHoldTracked =<< getDynHold d
1069+
1070+{-# INLINE readHoldTracked #-}
1071+readHoldTracked :: Hold p a -> BehaviorM a
1072+readHoldTracked h = do
1073+ result <- liftIO $ readIORef $ holdValue h
1074+ askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (holdInvalidators h) (wi:))
1075+ askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedHold h) :))
1076+ return result
1077+
1078+{-# INLINE getDynHold #-}
1079+getDynHold :: (Defer SomeHoldInit m, R.Patch p) => Dyn p a -> m (Hold p a)
1080+getDynHold d = do
1081+ mh <- liftIO $ readIORef $ unDyn d
1082+ case mh of
1083+ Right h -> return h
1084+ Left (readV0, v') -> do
1085+ holdInits <- getDeferralQueue
1086+ v0 <- liftIO $ runBehaviorM readV0 Nothing holdInits
1087+ h <- hold v0 v'
1088+ liftIO $ writeIORef (unDyn d) $ Right h
1089+ return h
735
1090
1091+{-
736readEvent :: Event a -> ResultM (Maybe a)
1092readEvent :: Event a -> ResultM (Maybe a)
737readEvent e = case e of
1093readEvent e = case e of
738 EventRoot k r -> liftIO . liftM (coerce . DMap.lookup k) . readIORef $ rootOccurrence r
1094 EventRoot k r -> liftIO . liftM (coerce . DMap.lookup k) . readIORef $ rootOccurrence r
739 EventNever -> return Nothing
1095 EventNever -> return Nothing
740 EventPush p -> do
1096 EventPush p -> do
741 subscribed <- getPushSubscribed p
1097 subscribed <- getPushSubscribed p
742− liftIO $ do
1098+ liftIO $ readPushSubscribed subscribed
743− result <- readIORef $ pushSubscribedOccurrence subscribed -- Since ResultM is always called after the final height is reached, this will always be valid
744− touch $ pushSubscribedSelf subscribed
745− return result
746 EventMerge m -> do
1099 EventMerge m -> do
747 subscribed <- getMergeSubscribed m
1100 subscribed <- getMergeSubscribed m
748− liftIO $ do
1101+ liftIO $ readMergeSubscribed subscribed
749− result <- readIORef $ mergeSubscribedOccurrence subscribed
750− touch $ mergeSubscribedSelf subscribed
751− return result
752 EventFan k f -> do
1102 EventFan k f -> do
753− parentOcc <- readEvent $ fanParent f
1103+ subscribed <- getFanSubscribed f
754− return . coerce $ DMap.lookup k =<< parentOcc
1104+ liftIO $ readFanSubscribed k subscribed
755 EventSwitch s -> do
1105 EventSwitch s -> do
756 subscribed <- getSwitchSubscribed s
1106 subscribed <- getSwitchSubscribed s
757− liftIO $ do
1107+ liftIO $ readSwitchSubscribed subscribed
758− result <- readIORef $ switchSubscribedOccurrence subscribed
759− touch $ switchSubscribedSelf subscribed
760− touch $ switchSubscribedOwnInvalidator subscribed
761− return result
762 EventCoincidence c -> do
1108 EventCoincidence c -> do
763 subscribed <- getCoincidenceSubscribed c
1109 subscribed <- getCoincidenceSubscribed c
764− liftIO $ do
1110+ liftIO $ readCoincidenceSubscribed subscribed
1111+ EventHold h -> liftIO . readEventSubscribed =<< getHoldEventSubscription h
1112+ EventDyn d -> liftIO . readEventSubscribed =<< getHoldEventSubscription =<< getDynHold d
1113+ EventHoldIdentity h -> liftIO . readEventSubscribed =<< getHoldEventSubscription h
1114+ EventDynIdentity d -> liftIO . readEventSubscribed =<< getHoldEventSubscription =<< getDynHold d
1115+-}
1116+
1117+readEventSubscribed :: EventSubscribed a -> IO (Maybe a)
1118+readEventSubscribed = \case
1119+ EventSubscribedRoot rs -> readRootSubscribed rs
1120+ EventSubscribedNever -> return Nothing
1121+ EventSubscribedPush ps -> readPushSubscribed ps
1122+ EventSubscribedMerge ms -> readMergeSubscribed ms
1123+ EventSubscribedFan k fs -> readFanSubscribed k fs
1124+ EventSubscribedSwitch ss -> readSwitchSubscribed ss
1125+ EventSubscribedCoincidence cs -> readCoincidenceSubscribed cs
1126+
1127+readRootSubscribed :: RootSubscribed a -> IO (Maybe a)
1128+readRootSubscribed = rootSubscribedOccurrence
1129+
1130+readPushSubscribed :: PushSubscribed b a -> IO (Maybe a)
1131+readPushSubscribed subscribed = do
1132+ result <- readIORef $ pushSubscribedOccurrence subscribed -- Since ResultM is always called after the final height is reached, this will always be valid
1133+ touch $ pushSubscribedSelf subscribed
1134+ return result
1135+
1136+readMergeSubscribed :: MergeSubscribed k -> IO (Maybe (DMap k Identity))
1137+readMergeSubscribed subscribed = do
1138+ result <- readIORef $ mergeSubscribedOccurrence subscribed
1139+ touch $ mergeSubscribedParents subscribed
1140+ return result
1141+
1142+readFanSubscribed :: GCompare k => k a -> FanSubscribed k -> IO (Maybe a)
1143+readFanSubscribed k fs = do
1144+ parentOcc <- readEventSubscribed $ snd $ fanSubscribedParent fs
1145+ return $ coerce $ DMap.lookup k =<< parentOcc
1146+
1147+readSwitchSubscribed :: SwitchSubscribed a -> IO (Maybe a)
1148+readSwitchSubscribed subscribed = do
1149+ result <- readIORef $ switchSubscribedOccurrence subscribed
1150+ touch $ switchSubscribedOwnInvalidator subscribed
1151+ return result
1152+
1153+readCoincidenceSubscribed :: CoincidenceSubscribed a -> IO (Maybe a)
1154+readCoincidenceSubscribed subscribed = do
765− result <- readIORef $ coincidenceSubscribedOccurrence subscribed
1155+ result <- readIORef $ coincidenceSubscribedOccurrence subscribed
766− touch $ coincidenceSubscribedOuter subscribed
1156+ touch $ coincidenceSubscribedOuter subscribed
767− --TODO: do we need to touch the inner subscriber?
1157+ --TODO: do we need to touch the inner subscriber?
768− return result
1158+ return result
769
1159
770-- Always refers to 0
1160-- Always refers to 0
771{-# NOINLINE zeroRef #-}
1161{-# NOINLINE zeroRef #-}
772−zeroRef :: IORef Int
1162+zeroRef :: IORef Height
773−zeroRef = unsafePerformIO $ newIORef 0
1163+zeroRef = unsafePerformIO $ newIORef zeroHeight
774−
1164+
775−getEventSubscribed :: Event a -> EventM (EventSubscribed a)
1165+{-# SPECIALIZE getEventSubscribed :: Event a -> Subscriber a -> EventM x (EventSubscription a) #-}
776−getEventSubscribed e = case e of
1166+getEventSubscribed :: forall x m a. CanSubscribe x m => Event a -> Subscriber a -> m (EventSubscription a)
1167+getEventSubscribed e sub = case e of
777− EventRoot k r -> liftM EventSubscribedRoot $ getRootSubscribed k r
1168+ EventRoot k r -> wrap EventSubscribedRoot $ liftIO . getRootSubscribed k r
778− EventNever -> return EventSubscribedNever
1169+ EventNever -> return (Nothing, EventSubscribedNever)
779− EventPush p -> liftM EventSubscribedPush $ getPushSubscribed p
1170+ EventPush p -> wrap EventSubscribedPush $ getPushSubscribed p
780− EventFan k f -> liftM (EventSubscribedFan k) $ getFanSubscribed f
1171+ EventFan k f -> wrap (EventSubscribedFan k) $ getFanSubscribed k f
781− EventMerge m -> liftM EventSubscribedMerge $ getMergeSubscribed m
1172+ EventMerge m -> wrap EventSubscribedMerge $ getMergeSubscribed m
782− EventSwitch s -> liftM EventSubscribedSwitch $ getSwitchSubscribed s
1173+ EventSwitch s -> wrap EventSubscribedSwitch $ getSwitchSubscribed s
783− EventCoincidence c -> liftM EventSubscribedCoincidence $ getCoincidenceSubscribed c
1174+ EventCoincidence c -> wrap EventSubscribedCoincidence $ getCoincidenceSubscribed c
784−
1175+ EventHold h -> subscribeHoldEvent h sub
1176+ EventDyn j -> getDynHold j >>= \h -> subscribeHoldEvent h sub
1177+ EventHoldIdentity h -> subscribeHoldEvent h sub
1178+ EventDynIdentity j -> getDynHold j >>= \h -> subscribeHoldEvent h sub
1179+ where
1180+ wrap :: (t -> EventSubscribed a) -> (Subscriber a -> m (SubscriberListTicket a, t)) -> m (EventSubscription a)
1181+ wrap tag getSpecificSubscribed = do
1182+ (sln, subd) <- getSpecificSubscribed sub
1183+ return (Just sln, tag subd)
1184+
1185+{-# INLINE subscribeHoldEvent #-}
1186+subscribeHoldEvent :: (CanSubscribe x m, R.Patch p) => Hold p a -> Subscriber (p a) -> m (EventSubscription (p a))
1187+subscribeHoldEvent h sub = do
1188+ (_, subd) <- getHoldEventSubscription h
1189+ sln <- liftIO $ subscribeEventSubscribed subd sub
1190+ return (sln, subd)
1191+
1192+{-# INLINE debugSubscribe #-}
785debugSubscribe :: Bool
1193debugSubscribe :: Bool
786debugSubscribe = False
1194debugSubscribe = False
787
1195
1196+{-# INLINE subscribeEventSubscribed #-}
788−subscribeEventSubscribed :: EventSubscribed a -> WeakSubscriber a -> IO ()
1197+subscribeEventSubscribed :: EventSubscribed a -> Subscriber a -> IO (Maybe (SubscriberListTicket a))
789−subscribeEventSubscribed es ws = case es of
1198+subscribeEventSubscribed es sub = case es of
790 EventSubscribedRoot r -> do
1199 EventSubscribedRoot r -> do
791− when debugSubscribe $ liftIO $ putStrLn $ "subscribeEventSubscribed Root"
1200+ traceSubscribe $ "subscribeEventSubscribed Root"
792− modifyIORef' (rootSubscribedSubscribers r) (ws:)
1201+ fmap Just $ subscribeRootSubscribed r sub
793 EventSubscribedNever -> do
1202 EventSubscribedNever -> do
794− when debugSubscribe $ liftIO $ putStrLn $ "subscribeEventSubscribed Never"
1203+ traceSubscribe $ "subscribeEventSubscribed Never"
795− return ()
1204+ return Nothing
796 EventSubscribedPush subscribed -> do
1205 EventSubscribedPush subscribed -> do
797− when debugSubscribe $ liftIO $ putStrLn $ "subscribeEventSubscribed Push"
1206+ traceSubscribe $ "subscribeEventSubscribed Push"
798− modifyIORef' (pushSubscribedSubscribers subscribed) (ws:)
1207+ fmap Just $ subscribePushSubscribed subscribed sub
799 EventSubscribedFan k subscribed -> do
1208 EventSubscribedFan k subscribed -> do
800− when debugSubscribe $ liftIO $ putStrLn $ "subscribeEventSubscribed Fan"
1209+ traceSubscribe $ "subscribeEventSubscribed Fan"
801− modifyIORef' (fanSubscribedSubscribers subscribed) $ DMap.insertWith (liftA2 (++)) (FanSubscriberKey k) (Identity [ws])
1210+ fmap Just $ subscribeFanSubscribed k subscribed sub
802 EventSubscribedMerge subscribed -> do
1211 EventSubscribedMerge subscribed -> do
803− when debugSubscribe $ liftIO $ putStrLn $ "subscribeEventSubscribed Merge"
1212+ traceSubscribe $ "subscribeEventSubscribed Merge"
804− modifyIORef' (mergeSubscribedSubscribers subscribed) (ws:)
1213+ fmap Just $ subscribeMergeSubscribed subscribed sub
805 EventSubscribedSwitch subscribed -> do
1214 EventSubscribedSwitch subscribed -> do
806− when debugSubscribe $ liftIO $ putStrLn $ "subscribeEventSubscribed Switch"
1215+ traceSubscribe $ "subscribeEventSubscribed Switch"
807− modifyIORef' (switchSubscribedSubscribers subscribed) (ws:)
1216+ fmap Just $ subscribeSwitchSubscribed subscribed sub
808 EventSubscribedCoincidence subscribed -> do
1217 EventSubscribedCoincidence subscribed -> do
809− when debugSubscribe $ liftIO $ putStrLn $ "subscribeEventSubscribed Coincidence"
1218+ traceSubscribe $ "subscribeEventSubscribed Coincidence"
810− modifyIORef' (coincidenceSubscribedSubscribers subscribed) (ws:)
1219+ fmap Just $ subscribeCoincidenceSubscribed subscribed sub
811
1220
812−getEventSubscribedOcc :: EventSubscribed a -> IO (Maybe a)
1221+{-# INLINE eventSubscribedHeightRef #-}
813−getEventSubscribedOcc es = case es of
814− EventSubscribedRoot r -> rootSubscribedOccurrence r
815− EventSubscribedNever -> return Nothing
816− EventSubscribedPush subscribed -> readIORef $ pushSubscribedOccurrence subscribed
817− EventSubscribedFan k subscribed -> do
818− parentOcc <- getEventSubscribedOcc $ fanSubscribedParent subscribed
819− let occ = coerce $ DMap.lookup k =<< parentOcc
820− return occ
821− EventSubscribedMerge subscribed -> readIORef $ mergeSubscribedOccurrence subscribed
822− EventSubscribedSwitch subscribed -> readIORef $ switchSubscribedOccurrence subscribed
823− EventSubscribedCoincidence subscribed -> readIORef $ coincidenceSubscribedOccurrence subscribed
824−
825−eventSubscribedHeightRef :: EventSubscribed a -> IORef Int
1222+eventSubscribedHeightRef :: EventSubscribed a -> IORef Height
826−eventSubscribedHeightRef es = case es of
1223+eventSubscribedHeightRef = \case
827 EventSubscribedRoot _ -> zeroRef
1224 EventSubscribedRoot _ -> zeroRef
828 EventSubscribedNever -> zeroRef
1225 EventSubscribedNever -> zeroRef
829 EventSubscribedPush subscribed -> pushSubscribedHeight subscribed
1226 EventSubscribedPush subscribed -> pushSubscribedHeight subscribed
830− EventSubscribedFan _ subscribed -> eventSubscribedHeightRef $ fanSubscribedParent subscribed
1227+ EventSubscribedFan _ subscribed -> eventSubscribedHeightRef $ snd $ fanSubscribedParent subscribed
831 EventSubscribedMerge subscribed -> mergeSubscribedHeight subscribed
1228 EventSubscribedMerge subscribed -> mergeSubscribedHeight subscribed
832 EventSubscribedSwitch subscribed -> switchSubscribedHeight subscribed
1229 EventSubscribedSwitch subscribed -> switchSubscribedHeight subscribed
833 EventSubscribedCoincidence subscribed -> coincidenceSubscribedHeight subscribed
1230 EventSubscribedCoincidence subscribed -> coincidenceSubscribedHeight subscribed
834
1231
835−subscribe :: Event a -> WeakSubscriber a -> EventM (EventSubscribed a)
1232+{-# INLINE eventSubscribedHasOwnHeightRef #-}
836−subscribe e ws = do
1233+eventSubscribedHasOwnHeightRef :: EventSubscribed a -> Bool
1234+eventSubscribedHasOwnHeightRef = \case
1235+ EventSubscribedRoot _ -> False
1236+ EventSubscribedNever -> False
1237+ EventSubscribedPush _ -> False
1238+ EventSubscribedFan _ _ -> False
1239+ EventSubscribedMerge _ -> True
1240+ EventSubscribedSwitch _ -> True
1241+ EventSubscribedCoincidence _ -> True
1242+
1243+{-# INLINE eventSubscribedGetParents #-}
1244+eventSubscribedGetParents :: EventSubscribed a -> IO [Some EventSubscribed]
1245+eventSubscribedGetParents = \case
1246+ EventSubscribedRoot _ -> return []
1247+ EventSubscribedNever -> return []
1248+ EventSubscribedPush subscribed -> return [Some.This $ snd $ pushSubscribedParent subscribed]
1249+ EventSubscribedFan _ subscribed -> return [Some.This $ snd $ fanSubscribedParent subscribed]
1250+ EventSubscribedMerge subscribed -> do
1251+ ps <- readIORef $ mergeSubscribedParents subscribed
1252+ return $ fmap (\(_ :=> v) -> Some.This $ snd $ mergeSubscribedParentSubscription v) $ DMap.toList ps
1253+ EventSubscribedSwitch subscribed -> do
1254+ s <- readIORef $ switchSubscribedCurrentParent subscribed
1255+ return [Some.This $ snd s]
1256+ EventSubscribedCoincidence subscribed -> do
1257+ innerSubscription <- readIORef $ coincidenceSubscribedInnerParent subscribed
1258+ let outerParent = Some.This $ snd $ coincidenceSubscribedOuterParent subscribed
1259+ innerParents = maybeToList $ fmap Some.This innerSubscription
1260+ return $ outerParent : innerParents
1261+
1262+type CanSubscribe x m =
1263+ ( HasSpiderEnv x m
1264+ , HasCurrentHeight m
1265+ , Defer SomeHoldInit m, Defer SomeMergeInit m -- The things we need to lazily initialize state
1266+ , Defer SomeClear m -- Wiping out event firings
1267+ , Defer SomeAssignment m -- Updating state
1268+ , Defer SomeResetCoincidence m
1269+ )
1270+
1271+{-# INLINE subscribe #-}
1272+subscribe :: CanSubscribe x m => Event a -> Subscriber a -> m (EventSubscription a)
837− subd <- getEventSubscribed e
1273+subscribe = getEventSubscribed
838− liftIO $ subscribeEventSubscribed subd ws
1274+
1275+getRootSubscribed :: GCompare k => k a -> Root k -> Subscriber a -> IO (SubscriberListTicket a, RootSubscribed a)
1276+getRootSubscribed k r sub = do
1277+ mSubscribed <- readIORef $ rootSubscribed r
1278+ case DMap.lookup k mSubscribed of
1279+ Just subscribed -> {-# SCC "hitRoot" #-} do
1280+ sln <- subscribeRootSubscribed subscribed sub
1281+ return (sln, subscribed)
1282+ Nothing -> {-# SCC "missRoot" #-} do
1283+ weakSelf <- newIORef $ error "getRootSubscribed: weakSelfRef not initialized"
1284+ let !cached = rootSubscribed r
1285+ uninitRef <- newIORef $ error "getRootsubscribed: uninitRef not initialized"
1286+ (subs, sln) <- WeakBag.singleton sub weakSelf cleanupRootSubscribed
1287+ when debugPropagate $ putStrLn $ "getRootSubscribed: calling rootInit"
1288+ uninit <- rootInit r k $ RootTrigger (subs, rootOccurrence r, k)
1289+ writeIORef uninitRef uninit
1290+ let subscribed = RootSubscribed
1291+ { rootSubscribedKey = k
1292+ , rootSubscribedCachedSubscribed = cached
1293+ , rootSubscribedOccurrence = liftM (coerce . DMap.lookup k) $ readIORef $ rootOccurrence r
1294+ , rootSubscribedSubscribers = subs
1295+ , rootSubscribedUninit = uninit
1296+ , rootSubscribedWeakSelf = weakSelf
1297+#ifdef DEBUG_NODEIDS
1298+ , rootSubscribedNodeId = unsafeNodeId (k, r, subs)
1299+#endif
1300+ }
1301+ writeIORef weakSelf =<< mkWeakPtrWithDebug subscribed "RootSubscribed"
1302+ modifyIORef' (rootSubscribed r) $ DMap.insertWith (error $ "getRootSubscribed: duplicate key inserted into Root" <> showNodeId r) k subscribed --TODO: I think we can just write back mSubscribed rather than re-reading it
839− return subd
1303+ return (sln, subscribed)
840
1304
841−noinlineFalse :: Bool
1305+cleanupRootSubscribed :: RootSubscribed a -> IO ()
842−noinlineFalse = False
1306+cleanupRootSubscribed self@(RootSubscribed { rootSubscribedKey = k, rootSubscribedCachedSubscribed = cached }) = do
843−{-# NOINLINE noinlineFalse #-}
1307+ rootSubscribedUninit self
1308+ modifyIORef' cached $ DMap.delete k
844
1309
845−getRootSubscribed :: GCompare k => k a -> Root k -> EventM (RootSubscribed a)
1310+{-# INLINE subscribeRootSubscribed #-}
846−getRootSubscribed k r = do
1311+subscribeRootSubscribed :: RootSubscribed a -> Subscriber a -> IO (SubscriberListTicket a)
847− mSubscribed <- liftIO $ readIORef $ rootSubscribed r
1312+subscribeRootSubscribed subscribed sub = WeakBag.insert sub (rootSubscribedSubscribers subscribed) (rootSubscribedWeakSelf subscribed) cleanupRootSubscribed
848− case DMap.lookup k mSubscribed of
849− Just subscribed -> return subscribed
850− Nothing -> liftIO $ do
851− subscribersRef <- newIORef []
852− subscribed <- newRootSubscribed (liftM (coerce . DMap.lookup k) $ readIORef $ rootOccurrence r) subscribersRef
853− -- Strangely, init needs the same stuff as a RootSubscribed has, but it must not be the same as the one that everyone's subscribing to, or it'll leak memory
854− uninit <- rootInit r k $ RootTrigger (subscribersRef, rootOccurrence r, k)
855− addFinalizer subscribed $ do
856− when noinlineFalse $ putStr "" -- For some reason, without this line, the finalizer will run earlier than it should
857−-- putStrLn "Uninit root"
858− uninit
859− liftIO $ modifyIORef' (rootSubscribed r) $ DMap.insert k subscribed
860− return subscribed
861
1313
862-- When getPushSubscribed returns, the PushSubscribed returned will have a fully filled-in
1314-- When getPushSubscribed returns, the PushSubscribed returned will have a fully filled-in
863−getPushSubscribed :: Push a b -> EventM (PushSubscribed a b)
1315+{-# SPECIALIZE getPushSubscribed :: Push a b -> Subscriber b -> EventM x (SubscriberListTicket b, PushSubscribed a b) #-}
1316+getPushSubscribed :: CanSubscribe x m => Push a b -> Subscriber b -> m (SubscriberListTicket b, PushSubscribed a b)
864−getPushSubscribed p = do
1317+getPushSubscribed p sub = do
865 mSubscribed <- liftIO $ readIORef $ pushSubscribed p
1318 mSubscribed <- liftIO $ readIORef $ pushSubscribed p
866 case mSubscribed of
1319 case mSubscribed of
1320+ Just subscribed -> {-# SCC "hitPush" #-} do
1321+ sln <- liftIO $ subscribePushSubscribed subscribed sub
867− Just subscribed -> return subscribed
1322+ return (sln, subscribed)
868− Nothing -> do -- Not yet subscribed
1323+ Nothing -> {-# SCC "missPush" #-} do -- Not yet subscribed
1324+ subscribedRef <- liftIO $ newIORef $ error "getPushSubscribed: subscribed not yet intialized"
869− subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ liftM fromJust $ readIORef $ pushSubscribed p
1325+ subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
870 s <- liftIO $ newSubscriberPush (pushCompute p) subscribedUnsafe
1326 s <- liftIO $ newSubscriberPush (pushCompute p) subscribedUnsafe
871− ws <- liftIO $ mkWeakPtrWithDebug s "SubscriberPush"
872− subd <- subscribe (pushParent p) $ WeakSubscriberSimple ws
1327+ subscription@(_, subd) <- subscribe (pushParent p) s
873− parentOcc <- liftIO $ getEventSubscribedOcc subd
1328+ parentOcc <- liftIO $ readEventSubscribed subd
874− occ <- liftM join $ mapM (pushCompute p) parentOcc
1329+ occ <- runComputeM $ liftM join $ mapM (pushCompute p) parentOcc
875 occRef <- liftIO $ newIORef occ
1330 occRef <- liftIO $ newIORef occ
876 when (isJust occ) $ scheduleClear occRef
1331 when (isJust occ) $ scheduleClear occRef
877− subscribersRef <- liftIO $ newIORef []
1332+ weakSelf <- liftIO $ newIORef $ error "getPushSubscribed: weakSelf not initialized"
1333+ let !cached = pushSubscribed p
1334+ (subs, sln) <- liftIO $ WeakBag.singleton sub weakSelf cleanupPushSubscribed
878 let subscribed = PushSubscribed
1335 let subscribed = PushSubscribed
1336+ { pushSubscribedCachedSubscribed = cached
879− { pushSubscribedOccurrence = occRef
1337+ , pushSubscribedOccurrence = occRef
880 , pushSubscribedHeight = eventSubscribedHeightRef subd -- Since pushes have the same height as their parents, share the ref
1338 , pushSubscribedHeight = eventSubscribedHeightRef subd -- Since pushes have the same height as their parents, share the ref
881− , pushSubscribedSubscribers = subscribersRef
1339+ , pushSubscribedSubscribers = subs
882− , pushSubscribedSelf = unsafeCoerce s
1340+ , pushSubscribedSelf = s
1341+ , pushSubscribedWeakSelf = weakSelf
883− , pushSubscribedParent = subd
1342+ , pushSubscribedParent = subscription
884#ifdef DEBUG_NODEIDS
1343#ifdef DEBUG_NODEIDS
885 , pushSubscribedNodeId = unsafeNodeId p
1344 , pushSubscribedNodeId = unsafeNodeId p
886#endif
1345#endif
887 }
1346 }
1347+ liftIO $ writeIORef weakSelf =<< mkWeakPtrWithDebug subscribed "PushSubscribed"
1348+ liftIO $ writeIORef subscribedRef subscribed
888 liftIO $ writeIORef (pushSubscribed p) $ Just subscribed
1349 liftIO $ writeIORef (pushSubscribed p) $ Just subscribed
889− return subscribed
1350+ return (sln, subscribed)
1351+
1352+cleanupPushSubscribed :: PushSubscribed a b -> IO ()
1353+cleanupPushSubscribed self = do
1354+ unsubscribe $ pushSubscribedParent self
1355+ writeIORef (pushSubscribedCachedSubscribed self) Nothing
1356+
1357+{-# INLINE subscribePushSubscribed #-}
1358+subscribePushSubscribed :: PushSubscribed a b -> Subscriber b -> IO (SubscriberListTicket b)
1359+subscribePushSubscribed subscribed sub = WeakBag.insert sub (pushSubscribedSubscribers subscribed) (pushSubscribedWeakSelf subscribed) cleanupPushSubscribed
890
1360
1361+{-# SPECIALIZE getMergeSubscribed :: GCompare k => Merge k -> Subscriber (DMap k Identity) -> EventM x (SubscriberListTicket (DMap k Identity), MergeSubscribed k) #-}
891−getMergeSubscribed :: forall k. GCompare k => Merge k -> EventM (MergeSubscribed k)
1362+getMergeSubscribed :: forall x k m. (CanSubscribe x m, GCompare k) => Merge k -> Subscriber (DMap k Identity) -> m (SubscriberListTicket (DMap k Identity), MergeSubscribed k)
892−getMergeSubscribed m = {-# SCC "getMergeSubscribed.entire" #-} do
1363+getMergeSubscribed m sub = do
893 mSubscribed <- liftIO $ readIORef $ mergeSubscribed m
1364 mSubscribed <- liftIO $ readIORef $ mergeSubscribed m
894 case mSubscribed of
1365 case mSubscribed of
1366+ Just subscribed -> {-# SCC "hitMerge" #-} do
1367+ sln <- liftIO $ subscribeMergeSubscribed subscribed sub
895− Just subscribed -> return subscribed
1368+ return (sln, subscribed)
896− Nothing -> if DMap.null $ mergeParents m then emptyMergeSubscribed else do
1369+ Nothing -> {-# SCC "missMerge" #-} do
897 subscribedRef <- liftIO $ newIORef $ error "getMergeSubscribed: subscribedRef not yet initialized"
1370 subscribedRef <- liftIO $ newIORef $ error "getMergeSubscribed: subscribedRef not yet initialized"
898 subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
1371 subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
899− s <- liftIO $ newBox subscribedUnsafe
1372+ initialParents <- readBehaviorUntracked $ current $ mergeParents m
900− ws <- liftIO $ mkWeakPtrWithDebug s "SubscriberMerge"
901− subscribers :: [(Any, Maybe (DSum k Identity), Int, DSum k EventSubscribed)] <- forM (DMap.toList $ mergeParents m) $ {-# SCC "getMergeSubscribed.a" #-} \(k :=> e) -> {-# SCC "getMergeSubscribed.a1" #-} do
1373+ subscribers :: [(Maybe (DSum k Identity), Height, DSum k (MergeSubscribedParent k))] <- forM (DMap.toList initialParents) $ \(k :=> e) -> do
902− parentSubd <- {-# SCC "getMergeSubscribed.a.parentSubd" #-} subscribe e $ WeakSubscriberMerge k ws
1374+ s <- liftIO $ newSubscriberMerge k subscribedUnsafe
1375+ subscription@(_, parentSubd) <- subscribe e s
903− parentOcc <- {-# SCC "getMergeSubscribed.a.parentOcc" #-} liftIO $ getEventSubscribedOcc parentSubd
1376+ parentOcc <- liftIO $ readEventSubscribed parentSubd
904− height <- {-# SCC "getMergeSubscribed.a.height" #-} liftIO $ readIORef $ eventSubscribedHeightRef parentSubd
1377+ height <- liftIO $ readIORef $ eventSubscribedHeightRef parentSubd
905− return $ {-# SCC "getMergeSubscribed.a.returnVal" #-} (unsafeCoerce s :: Any, fmap (\x -> k :=> Identity x) parentOcc, height, k :=> parentSubd)
1378+ return $ (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> (MergeSubscribedParent subscription s))
906− let dm = DMap.fromDistinctAscList $ catMaybes $ map (\(_, x, _, _) -> x) subscribers
1379+ let dm = DMap.fromDistinctAscList $ catMaybes $ map (\(x, _, _) -> x) subscribers
907− subscriberHeights = map (\(_, _, x, _) -> x) subscribers
1380+ subscriberHeights = map (\(_, x, _) -> x) subscribers
908− myHeight =
1381+ myHeight = succHeight $ foldr maxHeight zeroHeight subscriberHeights
909− if any (==invalidHeight) subscriberHeights --TODO: Replace 'any' with invalidHeight-preserving 'maximum'
910− then invalidHeight
911− else succ $ Prelude.maximum subscriberHeights -- This is safe because the DMap will never be empty here
912 currentHeight <- getCurrentHeight
1382 currentHeight <- getCurrentHeight
913 let (occ, accum) = if currentHeight >= myHeight -- If we should have fired by now
1383 let (occ, accum) = if currentHeight >= myHeight -- If we should have fired by now
914 then (if DMap.null dm then Nothing else Just dm, DMap.empty)
1384 then (if DMap.null dm then Nothing else Just dm, DMap.empty)
@@ -919,112 +1389,162 @@ getMergeSubscribed m = {-# SCC "getMergeSubscribed.entire" #-} do
919 when (isJust occ) $ scheduleClear occRef
1389 when (isJust occ) $ scheduleClear occRef
920 accumRef <- liftIO $ newIORef accum
1390 accumRef <- liftIO $ newIORef accum
921 heightRef <- liftIO $ newIORef myHeight
1391 heightRef <- liftIO $ newIORef myHeight
922− subsRef <- liftIO $ newIORef []
1392+ weakSelf <- liftIO $ newIORef $ error "getMergeSubscribed: weakSelf not yet initialized"
1393+ (subs, sln) <- liftIO $ WeakBag.singleton sub weakSelf cleanupMergeSubscribed
1394+ changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"
1395+ parentsRef <- liftIO $ newIORef $ DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers
923− let subscribed = MergeSubscribed
1396+ let !subscribed = MergeSubscribed
1397+ { mergeSubscribedCachedSubscribed = mergeSubscribed m
924− { mergeSubscribedOccurrence = occRef
1398+ , mergeSubscribedOccurrence = occRef
925 , mergeSubscribedAccum = accumRef
1399 , mergeSubscribedAccum = accumRef
926 , mergeSubscribedHeight = heightRef
1400 , mergeSubscribedHeight = heightRef
927− , mergeSubscribedSubscribers = subsRef
1401+ , mergeSubscribedSubscribers = subs
928− , mergeSubscribedSelf = unsafeCoerce $ map (\(x, _, _, _) -> x) subscribers --TODO: Does lack of strictness make this leak?
1402+ , mergeSubscribedChange = changeSubdRef
929− , mergeSubscribedParents = DMap.fromDistinctAscList $ map (\(_, _, _, x) -> x) subscribers
1403+ , mergeSubscribedParents = parentsRef
1404+ , mergeSubscribedWeakSelf = weakSelf
930#ifdef DEBUG_NODEIDS
1405#ifdef DEBUG_NODEIDS
931 , mergeSubscribedNodeId = unsafeNodeId m
1406 , mergeSubscribedNodeId = unsafeNodeId m
932#endif
1407#endif
933 }
1408 }
1409+ defer $ SomeMergeInit subscribed $ updated $ mergeParents m
934 liftIO $ writeIORef subscribedRef subscribed
1410 liftIO $ writeIORef subscribedRef subscribed
1411+ liftIO $ writeIORef weakSelf =<< mkWeakPtrWithDebug subscribed "MergeSubscribed"
1412+ liftIO $ writeIORef (mergeSubscribed m) $ Just subscribed
935− return subscribed
1413+ return (sln, subscribed)
936− where emptyMergeSubscribed = do --TODO: This should never happen
1414+
937− occRef <- liftIO $ newIORef Nothing
1415+cleanupMergeSubscribed :: MergeSubscribed k -> IO ()
938− accumRef <- liftIO $ newIORef DMap.empty
1416+cleanupMergeSubscribed subscribed = do
939− subsRef <- liftIO $ newIORef []
1417+ parents <- readIORef $ mergeSubscribedParents subscribed
940− return $ MergeSubscribed
1418+ forM_ (DMap.toList parents) $ \(_ :=> msp) -> unsubscribe $ mergeSubscribedParentSubscription msp
941− { mergeSubscribedOccurrence = occRef
1419+ -- Not necessary, because this whole MergeSubscribed is dead: writeIORef (mergeSubscribedParents subscribed) DMap.empty
942− , mergeSubscribedAccum = accumRef
1420+ writeIORef (mergeSubscribedCachedSubscribed subscribed) Nothing -- Get rid of the cached subscribed
943− , mergeSubscribedHeight = zeroRef
1421+
944− , mergeSubscribedSubscribers = subsRef --TODO: This will definitely leak
1422+{-# INLINE subscribeMergeSubscribed #-}
945− , mergeSubscribedSelf = unsafeCoerce ()
1423+subscribeMergeSubscribed :: MergeSubscribed k -> Subscriber (DMap k Identity) -> IO (SubscriberListTicket (DMap k Identity))
946− , mergeSubscribedParents = DMap.empty
1424+subscribeMergeSubscribed subscribed sub = WeakBag.insert sub (mergeSubscribedSubscribers subscribed) (mergeSubscribedWeakSelf subscribed) cleanupMergeSubscribed
947−#ifdef DEBUG_NODEIDS
1425+
948− , mergeSubscribedNodeId = -1
949−#endif
950− }
951−
952−getFanSubscribed :: GCompare k => Fan k -> EventM (FanSubscribed k)
1426+{-# SPECIALIZE getFanSubscribed :: GCompare k => k a -> Fan k -> Subscriber a -> EventM x (SubscriberListTicket a, FanSubscribed k) #-}
953−getFanSubscribed f = do
1427+getFanSubscribed :: (Defer SomeAssignment m, Defer SomeHoldInit m, Defer SomeMergeInit m, Defer SomeClear m, HasCurrentHeight m, Defer SomeResetCoincidence m, HasSpiderEnv x m, GCompare k) => k a -> Fan k -> Subscriber a -> m (SubscriberListTicket a, FanSubscribed k)
1428+getFanSubscribed k f sub = do
954 mSubscribed <- liftIO $ readIORef $ fanSubscribed f
1429 mSubscribed <- liftIO $ readIORef $ fanSubscribed f
955 case mSubscribed of
1430 case mSubscribed of
1431+ Just subscribed -> {-# SCC "hitFan" #-} do
1432+ sln <- liftIO $ subscribeFanSubscribed k subscribed sub
956− Just subscribed -> return subscribed
1433+ return (sln, subscribed)
957− Nothing -> do
1434+ Nothing -> {-# SCC "missFan" #-} do
1435+ subscribedRef <- liftIO $ newIORef $ error "getFanSubscribed: subscribedRef not yet initialized"
958− subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ liftM fromJust $ readIORef $ fanSubscribed f
1436+ subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
959− sub <- liftIO $ newSubscriberFan subscribedUnsafe
1437+ s <- liftIO $ newSubscriberFan subscribedUnsafe
960− wsub <- liftIO $ mkWeakPtrWithDebug sub "SubscriberFan"
961− subd <- subscribe (fanParent f) $ WeakSubscriberSimple wsub
1438+ subscription <- subscribe (fanParent f) s
1439+ weakSelf <- liftIO $ newIORef $ error "getFanSubscribed: weakSelf not yet initialized"
1440+ (subsForK, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupFanSubscribed
962− subscribersRef <- liftIO $ newIORef DMap.empty
1441+ subscribersRef <- liftIO $ newIORef $ DMap.singleton k $ FanSubscribedChildren subsForK weakSelf
963 let subscribed = FanSubscribed
1442 let subscribed = FanSubscribed
1443+ { fanSubscribedCachedSubscribed = fanSubscribed f
964− { fanSubscribedParent = subd
1444+ , fanSubscribedParent = subscription
965 , fanSubscribedSubscribers = subscribersRef
1445 , fanSubscribedSubscribers = subscribersRef
966− , fanSubscribedSelf = sub
967#ifdef DEBUG_NODEIDS
1446#ifdef DEBUG_NODEIDS
968 , fanSubscribedNodeId = unsafeNodeId f
1447 , fanSubscribedNodeId = unsafeNodeId f
969#endif
1448#endif
970 }
1449 }
1450+ liftIO $ writeIORef weakSelf =<< mkWeakPtrWithDebug (k, subscribed) "FanSubscribed"
1451+ liftIO $ writeIORef subscribedRef subscribed
971 liftIO $ writeIORef (fanSubscribed f) $ Just subscribed
1452 liftIO $ writeIORef (fanSubscribed f) $ Just subscribed
972− return subscribed
1453+ return (slnForSub, subscribed)
973−
1454+
1455+cleanupFanSubscribed :: GCompare k => (k a, FanSubscribed k) -> IO ()
1456+cleanupFanSubscribed (k, subscribed) = do
1457+ subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1458+ let reducedSubscribers = DMap.delete k subscribers
1459+ if DMap.null reducedSubscribers
1460+ then do
1461+ unsubscribe $ fanSubscribedParent subscribed
1462+ -- Not necessary in this case, because this whole FanSubscribed is dead: writeIORef (fanSubscribedSubscribers subscribed) reducedSubscribers
1463+ writeIORef (fanSubscribedCachedSubscribed subscribed) Nothing
1464+ else writeIORef (fanSubscribedSubscribers subscribed) reducedSubscribers
1465+
1466+{-# INLINE subscribeFanSubscribed #-}
1467+subscribeFanSubscribed :: GCompare k => k a -> FanSubscribed k -> Subscriber a -> IO (SubscriberListTicket a)
1468+subscribeFanSubscribed k subscribed sub = do
1469+ subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1470+ case DMap.lookup k subscribers of
1471+ Nothing -> do
1472+ weakSelf <- newIORef =<< mkWeakPtrWithDebug (k, subscribed) "FanSubscribed"
1473+ (list, sln) <- WeakBag.singleton sub weakSelf cleanupFanSubscribed
1474+ writeIORef (fanSubscribedSubscribers subscribed) $! DMap.insertWith (error "subscribeEventSubscribed: key that we just failed to find is present - should be impossible") k (FanSubscribedChildren list weakSelf) subscribers
1475+ return sln
1476+ Just (FanSubscribedChildren list weakSelf) -> WeakBag.insert sub list weakSelf cleanupFanSubscribed
1477+
974−getSwitchSubscribed :: Switch a -> EventM (SwitchSubscribed a)
1478+{-# SPECIALIZE getSwitchSubscribed :: Switch a -> Subscriber a -> EventM x (SubscriberListTicket a, SwitchSubscribed a) #-}
1479+getSwitchSubscribed :: (Defer SomeHoldInit m, Defer SomeAssignment m, Defer SomeMergeInit m, Defer SomeClear m, Defer SomeResetCoincidence m, HasCurrentHeight m, HasSpiderEnv x m) => Switch a -> Subscriber a -> m (SubscriberListTicket a, SwitchSubscribed a)
975−getSwitchSubscribed s = do
1480+getSwitchSubscribed s sub = do
976 mSubscribed <- liftIO $ readIORef $ switchSubscribed s
1481 mSubscribed <- liftIO $ readIORef $ switchSubscribed s
977 case mSubscribed of
1482 case mSubscribed of
1483+ Just subscribed -> {-# SCC "hitSwitch" #-} do
1484+ sln <- liftIO $ subscribeSwitchSubscribed subscribed sub
978− Just subscribed -> return subscribed
1485+ return (sln, subscribed)
979− Nothing -> do
1486+ Nothing -> {-# SCC "missSwitch" #-} do
980 subscribedRef <- liftIO $ newIORef $ error "getSwitchSubscribed: subscribed has not yet been created"
1487 subscribedRef <- liftIO $ newIORef $ error "getSwitchSubscribed: subscribed has not yet been created"
981 subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
1488 subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
982 i <- liftIO $ newInvalidatorSwitch subscribedUnsafe
1489 i <- liftIO $ newInvalidatorSwitch subscribedUnsafe
983− sub <- liftIO $ newSubscriberSwitch subscribedUnsafe
1490+ mySub <- liftIO $ newSubscriberSwitch subscribedUnsafe
984 wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorSwitch"
1491 wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorSwitch"
985 wiRef <- liftIO $ newIORef wi
1492 wiRef <- liftIO $ newIORef wi
986− wsub <- liftIO $ mkWeakPtrWithDebug sub "SubscriberSwitch"
987− selfWeakRef <- liftIO $ newIORef wsub
988 parentsRef <- liftIO $ newIORef [] --TODO: This should be unnecessary, because it will always be filled with just the single parent behavior
1493 parentsRef <- liftIO $ newIORef [] --TODO: This should be unnecessary, because it will always be filled with just the single parent behavior
1494+ holdInits <- getDeferralQueue
989− e <- liftIO $ runBehaviorM (readBehaviorTracked (switchParent s)) $ Just (wi, parentsRef)
1495+ e <- liftIO $ runBehaviorM (readBehaviorTracked (switchParent s)) (Just (wi, parentsRef)) holdInits
990− subd <- subscribe e $ WeakSubscriberSimple wsub
1496+ subscription@(_, subd) <- subscribe e mySub
991− subdRef <- liftIO $ newIORef subd
1497+ subscriptionRef <- liftIO $ newIORef subscription
992− parentOcc <- liftIO $ getEventSubscribedOcc subd
1498+ parentOcc <- liftIO $ readEventSubscribed subd
993 occRef <- liftIO $ newIORef parentOcc
1499 occRef <- liftIO $ newIORef parentOcc
994 when (isJust parentOcc) $ scheduleClear occRef
1500 when (isJust parentOcc) $ scheduleClear occRef
995 heightRef <- liftIO $ newIORef =<< readIORef (eventSubscribedHeightRef subd)
1501 heightRef <- liftIO $ newIORef =<< readIORef (eventSubscribedHeightRef subd)
996− subscribersRef <- liftIO $ newIORef []
1502+ weakSelf <- liftIO $ newIORef $ error "getSwitchSubscribed: weakSelf not yet initialized"
1503+ (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupSwitchSubscribed
997− let subscribed = SwitchSubscribed
1504+ let !subscribed = SwitchSubscribed
1505+ { switchSubscribedCachedSubscribed = switchSubscribed s
998− { switchSubscribedOccurrence = occRef
1506+ , switchSubscribedOccurrence = occRef
999 , switchSubscribedHeight = heightRef
1507 , switchSubscribedHeight = heightRef
1000− , switchSubscribedSubscribers = subscribersRef
1508+ , switchSubscribedSubscribers = subs
1001− , switchSubscribedSelf = sub
1002− , switchSubscribedSelfWeak = selfWeakRef
1003 , switchSubscribedOwnInvalidator = i
1509 , switchSubscribedOwnInvalidator = i
1004 , switchSubscribedOwnWeakInvalidator = wiRef
1510 , switchSubscribedOwnWeakInvalidator = wiRef
1005 , switchSubscribedBehaviorParents = parentsRef
1511 , switchSubscribedBehaviorParents = parentsRef
1006 , switchSubscribedParent = switchParent s
1512 , switchSubscribedParent = switchParent s
1007− , switchSubscribedCurrentParent = subdRef
1513+ , switchSubscribedCurrentParent = subscriptionRef
1514+ , switchSubscribedWeakSelf = weakSelf
1008#ifdef DEBUG_NODEIDS
1515#ifdef DEBUG_NODEIDS
1009 , switchSubscribedNodeId = unsafeNodeId s
1516 , switchSubscribedNodeId = unsafeNodeId s
1010#endif
1517#endif
1011 }
1518 }
1519+ liftIO $ writeIORef weakSelf =<< mkWeakPtrWithDebug subscribed "switchSubscribedWeakSelf"
1012 liftIO $ writeIORef subscribedRef subscribed
1520 liftIO $ writeIORef subscribedRef subscribed
1013 liftIO $ writeIORef (switchSubscribed s) $ Just subscribed
1521 liftIO $ writeIORef (switchSubscribed s) $ Just subscribed
1014− return subscribed
1522+ return (slnForSub, subscribed)
1523+
1524+cleanupSwitchSubscribed :: SwitchSubscribed a -> IO ()
1525+cleanupSwitchSubscribed subscribed = do
1526+ unsubscribe =<< readIORef (switchSubscribedCurrentParent subscribed)
1527+ finalize =<< readIORef (switchSubscribedOwnWeakInvalidator subscribed) -- We don't need to get invalidated if we're dead
1528+ writeIORef (switchSubscribedCachedSubscribed subscribed) Nothing
1529+
1530+{-# INLINE subscribeSwitchSubscribed #-}
1531+subscribeSwitchSubscribed :: SwitchSubscribed a -> Subscriber a -> IO (SubscriberListTicket a)
1532+subscribeSwitchSubscribed subscribed sub = WeakBag.insert sub (switchSubscribedSubscribers subscribed) (switchSubscribedWeakSelf subscribed) cleanupSwitchSubscribed
1015
1533
1534+{-# SPECIALIZE getCoincidenceSubscribed :: Coincidence a -> Subscriber a -> EventM x (SubscriberListTicket a, CoincidenceSubscribed a) #-}
1016−getCoincidenceSubscribed :: forall a. Coincidence a -> EventM (CoincidenceSubscribed a)
1535+getCoincidenceSubscribed :: forall x a m. (Defer SomeAssignment m, Defer SomeHoldInit m, Defer SomeMergeInit m, Defer SomeClear m, HasCurrentHeight m, Defer SomeResetCoincidence m, HasSpiderEnv x m) => Coincidence a -> Subscriber a -> m (SubscriberListTicket a, CoincidenceSubscribed a)
1017−getCoincidenceSubscribed c = do
1536+getCoincidenceSubscribed c sub = do
1018 mSubscribed <- liftIO $ readIORef $ coincidenceSubscribed c
1537 mSubscribed <- liftIO $ readIORef $ coincidenceSubscribed c
1019 case mSubscribed of
1538 case mSubscribed of
1539+ Just subscribed -> {-# SCC "hitCoincidence" #-} do
1540+ sln <- liftIO $ subscribeCoincidenceSubscribed subscribed sub
1020− Just subscribed -> return subscribed
1541+ return (sln, subscribed)
1021− Nothing -> do
1542+ Nothing -> {-# SCC "missCoincidence" #-} do
1022 subscribedRef <- liftIO $ newIORef $ error "getCoincidenceSubscribed: subscribed has not yet been created"
1543 subscribedRef <- liftIO $ newIORef $ error "getCoincidenceSubscribed: subscribed has not yet been created"
1023 subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
1544 subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
1024 subOuter <- liftIO $ newSubscriberCoincidenceOuter subscribedUnsafe
1545 subOuter <- liftIO $ newSubscriberCoincidenceOuter subscribedUnsafe
1025− wsubOuter <- liftIO $ mkWeakPtrWithDebug subOuter "subOuter"
1026− outerSubd <- subscribe (coincidenceParent c) $ WeakSubscriberSimple wsubOuter
1546+ outerSubscription@(_, outerSubd) <- subscribe (coincidenceParent c) subOuter
1027− outerOcc <- liftIO $ getEventSubscribedOcc outerSubd
1547+ outerOcc <- liftIO $ readEventSubscribed outerSubd
1028 outerHeight <- liftIO $ readIORef $ eventSubscribedHeightRef outerSubd
1548 outerHeight <- liftIO $ readIORef $ eventSubscribedHeightRef outerSubd
1029 (occ, height, mInnerSubd) <- case outerOcc of
1549 (occ, height, mInnerSubd) <- case outerOcc of
1030 Nothing -> return (Nothing, outerHeight, Nothing)
1550 Nothing -> return (Nothing, outerHeight, Nothing)
@@ -1036,23 +1556,37 @@ getCoincidenceSubscribed c = do
1036 heightRef <- liftIO $ newIORef height
1556 heightRef <- liftIO $ newIORef height
1037 innerSubdRef <- liftIO $ newIORef mInnerSubd
1557 innerSubdRef <- liftIO $ newIORef mInnerSubd
1038 scheduleClear innerSubdRef
1558 scheduleClear innerSubdRef
1039− subscribersRef <- liftIO $ newIORef []
1559+ weakSelf <- liftIO $ newIORef $ error "getCoincidenceSubscribed: weakSelf not yet implemented"
1560+ (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupCoincidenceSubscribed
1040 let subscribed = CoincidenceSubscribed
1561 let subscribed = CoincidenceSubscribed
1562+ { coincidenceSubscribedCachedSubscribed = coincidenceSubscribed c
1041− { coincidenceSubscribedOccurrence = occRef
1563+ , coincidenceSubscribedOccurrence = occRef
1042 , coincidenceSubscribedHeight = heightRef
1564 , coincidenceSubscribedHeight = heightRef
1043− , coincidenceSubscribedSubscribers = subscribersRef
1565+ , coincidenceSubscribedSubscribers = subs
1044 , coincidenceSubscribedOuter = subOuter
1566 , coincidenceSubscribedOuter = subOuter
1045− , coincidenceSubscribedOuterParent = outerSubd
1567+ , coincidenceSubscribedOuterParent = outerSubscription
1046 , coincidenceSubscribedInnerParent = innerSubdRef
1568 , coincidenceSubscribedInnerParent = innerSubdRef
1569+ , coincidenceSubscribedWeakSelf = weakSelf
1047#ifdef DEBUG_NODEIDS
1570#ifdef DEBUG_NODEIDS
1048 , coincidenceSubscribedNodeId = unsafeNodeId c
1571 , coincidenceSubscribedNodeId = unsafeNodeId c
1049#endif
1572#endif
1050 }
1573 }
1574+ liftIO $ writeIORef weakSelf =<< mkWeakPtrWithDebug subscribed "CoincidenceSubscribed"
1051 liftIO $ writeIORef subscribedRef subscribed
1575 liftIO $ writeIORef subscribedRef subscribed
1052 liftIO $ writeIORef (coincidenceSubscribed c) $ Just subscribed
1576 liftIO $ writeIORef (coincidenceSubscribed c) $ Just subscribed
1053− return subscribed
1577+ return (slnForSub, subscribed)
1578+
1579+cleanupCoincidenceSubscribed :: CoincidenceSubscribed a -> IO ()
1580+cleanupCoincidenceSubscribed subscribed = do
1581+ unsubscribe $ coincidenceSubscribedOuterParent subscribed
1582+ writeIORef (coincidenceSubscribedCachedSubscribed subscribed) Nothing
1583+
1584+{-# INLINE subscribeCoincidenceSubscribed #-}
1585+subscribeCoincidenceSubscribed :: CoincidenceSubscribed a -> Subscriber a -> IO (SubscriberListTicket a)
1586+subscribeCoincidenceSubscribed subscribed sub = WeakBag.insert sub (coincidenceSubscribedSubscribers subscribed) (coincidenceSubscribedWeakSelf subscribed) cleanupCoincidenceSubscribed
1054
1587
1588+{-# INLINE merge #-}
1055−merge :: GCompare k => DMap k Event -> Event (DMap k Identity)
1589+merge :: GCompare k => Dynamic R.PatchDMap (DMap k Event) -> Event (DMap k Identity)
1056merge m = EventMerge $ Merge
1590merge m = EventMerge $ Merge
1057 { mergeParents = m
1591 { mergeParents = m
1058 , mergeSubscribed = unsafeNewIORef m Nothing
1592 , mergeSubscribed = unsafeNewIORef m Nothing
@@ -1068,55 +1602,101 @@ fan e =
1068 }
1602 }
1069 in EventSelector $ \k -> EventFan k f
1603 in EventSelector $ \k -> EventFan k f
1070
1604
1605+{- SPECIALIZE runHoldInits :: IORef [SomeHoldInit] -> IORef [SomeMergeInit] -> EventM x () #-}
1606+--runHoldInits :: (CanSubscribe x m, Defer SomeMergeUpdate m) => IORef [SomeHoldInit] -> IORef [SomeMergeInit] -> m ()
1607+runHoldInits :: IORef [SomeHoldInit] -> IORef [SomeMergeInit] -> EventM x ()
1608+runHoldInits holdInitRef mergeInitRef = do
1609+ holdInits <- liftIO $ readIORef holdInitRef
1610+ mergeInits <- liftIO $ readIORef mergeInitRef
1611+ if null holdInits && null mergeInits then return () else do
1612+ liftIO $ writeIORef holdInitRef []
1613+ liftIO $ writeIORef mergeInitRef []
1614+ mapM_ initHold holdInits
1615+ mapM_ initMerge mergeInits
1616+ runHoldInits holdInitRef mergeInitRef
1617+
1618+{- SPECIALIZE initHold :: SomeHoldInit -> EventM x () #-}
1619+--initHold :: CanSubscribe x m => SomeHoldInit -> m ()
1620+initHold :: SomeHoldInit -> EventM x ()
1621+initHold (SomeHoldInit h) = void $ getHoldEventSubscription h
1622+
1623+{- SPECIALIZE initMerge :: SomeMergeInit -> EventM x () #-}
1624+--initMerge :: (CanSubscribe x m, Defer SomeMergeUpdate m) => SomeMergeInit -> m ()
1625+initMerge :: SomeMergeInit -> EventM x ()
1626+initMerge (SomeMergeInit subscribed changed) = do
1627+ changeSub <- liftIO $ newSubscriberMergeChange subscribed
1628+ (_, changeSubd) <- subscribe changed changeSub
1629+ change <- liftIO $ readEventSubscribed changeSubd
1630+ forM_ change $ \c -> defer $ SomeMergeUpdate c subscribed
1631+ liftIO $ writeIORef (mergeSubscribedChange subscribed) (changeSub, changeSubd)
1632+
1071-- | Run an event action outside of a frame
1633-- | Run an event action outside of a frame
1072−runFrame :: EventM a -> IO a
1634+runFrame :: EventM x a -> SpiderHost x a --TODO: This function also needs to hold the mutex
1073−runFrame a = do
1635+runFrame a = SpiderHost $ ask >>= \spiderEnv -> lift $ do
1636+ -- Clear out pending unsubscriptions; these will need to happen eventually anyway, and might cause us a lot of extra work during the frame, so get rid of them now
1637+ pendingCleanups <- atomicModifyIORef (_spiderEnv_cleanups spiderEnv) $ \x -> ([], x)
1638+ {-# SCC "cleanups" #-} sequence_ pendingCleanups
1074 toAssignRef <- newIORef [] -- This should only actually get used when events are firing
1639 toAssignRef <- newIORef [] -- This should only actually get used when events are firing
1075 holdInitRef <- newIORef []
1640 holdInitRef <- newIORef []
1641+ mergeUpdateRef <- newIORef []
1642+ mergeInitRef <- newIORef []
1076− heightRef <- newIORef 0
1643+ heightRef <- newIORef zeroHeight
1077 toClearRef <- newIORef []
1644 toClearRef <- newIORef []
1078 toClearRootRef <- newIORef []
1645 toClearRootRef <- newIORef []
1079 coincidenceInfosRef <- newIORef []
1646 coincidenceInfosRef <- newIORef []
1080 delayedRef <- liftIO $ newIORef IntMap.empty
1647 delayedRef <- liftIO $ newIORef IntMap.empty
1081− result <- flip runEventM (EventEnv toAssignRef holdInitRef toClearRef toClearRootRef heightRef coincidenceInfosRef delayedRef) $ do
1648+ let env = EventEnv spiderEnv toAssignRef holdInitRef mergeUpdateRef mergeInitRef toClearRef toClearRootRef heightRef coincidenceInfosRef delayedRef
1082− result <- a
1083− let runHoldInits = do
1649+ let go = do
1084− holdInits <- liftIO $ readIORef holdInitRef
1650+ result <- a
1085− if null holdInits then return () else do
1086− liftIO $ writeIORef holdInitRef []
1087− forM_ holdInits $ \(SomeHoldInit e h) -> subscribeHold e h
1088− runHoldInits
1089− runHoldInits -- This must happen before doing the assignments, in case subscribing a Hold causes existing Holds to be read by the newly-propagated events
1651+ runHoldInits holdInitRef mergeInitRef -- This must happen before doing the assignments, in case subscribing a Hold causes existing Holds to be read by the newly-propagated events
1090− return result
1652+ return result
1653+ result <- runEventM go env
1091 toClear <- readIORef toClearRef
1654 toClear <- readIORef toClearRef
1092− forM_ toClear $ \(SomeMaybeIORef ref) -> writeIORef ref Nothing
1655+ forM_ toClear $ \(SomeClear ref) -> {-# SCC "clear" #-} writeIORef ref Nothing
1093 toClearRoot <- readIORef toClearRootRef
1656 toClearRoot <- readIORef toClearRootRef
1094− forM_ toClearRoot $ \(SomeDMapIORef ref) -> writeIORef ref DMap.empty
1657+ forM_ toClearRoot $ \(SomeRootClear ref) -> {-# SCC "rootClear" #-} writeIORef ref DMap.empty
1095 toAssign <- readIORef toAssignRef
1658 toAssign <- readIORef toAssignRef
1096 toReconnectRef <- newIORef []
1659 toReconnectRef <- newIORef []
1097− forM_ toAssign $ \(SomeAssignment h v) -> do
1098− writeIORef (holdValue h) v
1099− writeIORef (holdInvalidators h) =<< invalidate toReconnectRef =<< readIORef (holdInvalidators h)
1100 coincidenceInfos <- readIORef coincidenceInfosRef
1660 coincidenceInfos <- readIORef coincidenceInfosRef
1101− forM_ coincidenceInfos $ \(SomeCoincidenceInfo wsubInner subInner mcs) -> do
1661+ forM_ toAssign $ \(SomeAssignment vRef iRef v) -> {-# SCC "assignment" #-} do
1102− touch subInner
1662+ writeIORef vRef v
1103− finalize wsubInner
1663+ when debugInvalidate $ putStrLn $ "Invalidating Hold"
1104− mapM_ invalidateCoincidenceHeight mcs
1664+ writeIORef iRef =<< invalidate toReconnectRef =<< readIORef iRef
1665+ mergeUpdates <- readIORef mergeUpdateRef
1666+ writeIORef mergeUpdateRef []
1667+ let updateMerge :: SomeMergeUpdate -> IO [SomeEventSubscription]
1668+ updateMerge (SomeMergeUpdate (R.PatchDMap p) m) = do
1669+ oldParents <- readIORef $ mergeSubscribedParents m
1670+ let f (subscriptionsToKill, ps) (k :=> Compose me) = do
1671+ (mOldSubd, newPs) <- case me of
1672+ Nothing -> return $ DMap.updateLookupWithKey (\_ _ -> Nothing) k ps
1673+ Just e -> do
1674+ s <- liftIO $ newSubscriberMerge k m
1675+ subscription <- subscribe e s
1676+ let newParent = MergeSubscribedParent subscription s
1677+ return $ DMap.insertLookupWithKey' (\_ new _ -> new) k newParent ps
1678+ liftIO $ invalidateMergeHeight k m
1679+ return (maybeToList (SomeEventSubscription . mergeSubscribedParentSubscription <$> mOldSubd) ++ subscriptionsToKill, newPs)
1680+ (subscriptionsToKill, newParents) <- flip runEventM env $ foldM f ([], oldParents) $ DMap.toList p --TODO: I think this runEventM is OK, since no events are firing at this time, but it might not be
1681+ writeIORef (mergeSubscribedParents m) $! newParents
1682+ return subscriptionsToKill
1683+ mergeSubscriptionsToKill <- concat <$> mapM updateMerge mergeUpdates
1105 toReconnect <- readIORef toReconnectRef
1684 toReconnect <- readIORef toReconnectRef
1106− forM_ toReconnect $ \(SomeSwitchSubscribed subscribed) -> do
1685+ switchSubscriptionsToKill <- forM toReconnect $ \(SomeSwitchSubscribed subscribed) -> {-# SCC "switchSubscribed" #-} do
1107− wsub <- readIORef $ switchSubscribedSelfWeak subscribed
1686+ oldSubscription <- readIORef $ switchSubscribedCurrentParent subscribed
1108− finalize wsub
1109 wi <- readIORef $ switchSubscribedOwnWeakInvalidator subscribed
1687 wi <- readIORef $ switchSubscribedOwnWeakInvalidator subscribed
1688+ when debugInvalidate $ putStrLn $ "Finalizing invalidator for Switch" <> showNodeId subscribed
1110 finalize wi
1689 finalize wi
1111 i <- evaluate $ switchSubscribedOwnInvalidator subscribed
1690 i <- evaluate $ switchSubscribedOwnInvalidator subscribed
1112 wi' <- mkWeakPtrWithDebug i "wi'"
1691 wi' <- mkWeakPtrWithDebug i "wi'"
1692+ writeIORef (switchSubscribedOwnWeakInvalidator subscribed) wi'
1113 writeIORef (switchSubscribedBehaviorParents subscribed) []
1693 writeIORef (switchSubscribedBehaviorParents subscribed) []
1694+ writeIORef holdInitRef [] --TODO: Should we reuse this?
1114− e <- runBehaviorM (readBehaviorTracked (switchSubscribedParent subscribed)) (Just (wi', switchSubscribedBehaviorParents subscribed))
1695+ e <- runBehaviorM (readBehaviorTracked (switchSubscribedParent subscribed)) (Just (wi', switchSubscribedBehaviorParents subscribed)) holdInitRef
1696+ runEventM (runHoldInits holdInitRef mergeInitRef) env --TODO: Is this actually OK? It seems like it should be, since we know that no events are firing at this point, but it still seems inelegant
1115 --TODO: Make sure we touch the pieces of the SwitchSubscribed at the appropriate times
1697 --TODO: Make sure we touch the pieces of the SwitchSubscribed at the appropriate times
1116− sub <- evaluate $ switchSubscribedSelf subscribed -- Must be done strictly, or the weak pointer will refer to a useless thunk
1698+ sub <- newSubscriberSwitch subscribed
1117− wsub' <- mkWeakPtrWithDebug sub "wsub'"
1118− writeIORef (switchSubscribedSelfWeak subscribed) wsub'
1119− subd' <- runFrame $ subscribe e $ WeakSubscriberSimple wsub' --TODO: Assert that the event isn't firing --TODO: This should not loop because none of the events should be firing, but still, it is inefficient
1699+ subscription@(_, subd') <- runReaderT (unSpiderHost (runFrame ({-# SCC "subscribeSwitch" #-} subscribe e sub))) spiderEnv --TODO: Assert that the event isn't firing --TODO: This should not loop because none of the events should be firing, but still, it is inefficient
1120 {-
1700 {-
1121 stackTrace <- liftIO $ liftM renderStack $ ccsToStrings =<< (getCCSOf $! switchSubscribedParent subscribed)
1701 stackTrace <- liftIO $ liftM renderStack $ ccsToStrings =<< (getCCSOf $! switchSubscribedParent subscribed)
1122 liftIO $ putStrLn $ (++stackTrace) $ "subd' subscribed to " ++ case e of
1702 liftIO $ putStrLn $ (++stackTrace) $ "subd' subscribed to " ++ case e of
@@ -1124,111 +1704,152 @@ runFrame a = do
1124 EventNever -> "EventNever"
1704 EventNever -> "EventNever"
1125 _ -> "something else"
1705 _ -> "something else"
1126 -}
1706 -}
1127− writeIORef (switchSubscribedCurrentParent subscribed) subd'
1707+ writeIORef (switchSubscribedCurrentParent subscribed) subscription
1128 parentHeight <- readIORef $ eventSubscribedHeightRef subd'
1708 parentHeight <- readIORef $ eventSubscribedHeightRef subd'
1129 myHeight <- readIORef $ switchSubscribedHeight subscribed
1709 myHeight <- readIORef $ switchSubscribedHeight subscribed
1130− if parentHeight == myHeight then return () else do
1710+ when (parentHeight /= myHeight) $ do
1131 writeIORef (switchSubscribedHeight subscribed) parentHeight
1711 writeIORef (switchSubscribedHeight subscribed) parentHeight
1132− mapM_ invalidateSubscriberHeight =<< readIORef (switchSubscribedSubscribers subscribed)
1712+ WeakBag.traverse (switchSubscribedSubscribers subscribed) invalidateSubscriberHeight
1713+ return $ SomeEventSubscription oldSubscription
1714+ forM_ coincidenceInfos $ \(SomeResetCoincidence subscription mcs) -> do
1715+ unsubscribe subscription
1716+ mapM_ invalidateCoincidenceHeight mcs
1717+ forM_ mergeSubscriptionsToKill $ \(SomeEventSubscription oldSubscription) -> liftIO $ unsubscribe oldSubscription
1718+ forM_ switchSubscriptionsToKill $ \(SomeEventSubscription oldSubscription) -> liftIO $ unsubscribe oldSubscription
1133− forM_ coincidenceInfos $ \(SomeCoincidenceInfo _ _ mcs) -> mapM_ recalculateCoincidenceHeight mcs
1719+ forM_ coincidenceInfos $ \(SomeResetCoincidence _ mcs) -> mapM_ recalculateCoincidenceHeight mcs
1720+ forM_ mergeUpdates $ \(SomeMergeUpdate _ m) -> recalculateMergeHeight m
1134 forM_ toReconnect $ \(SomeSwitchSubscribed subscribed) -> do
1721 forM_ toReconnect $ \(SomeSwitchSubscribed subscribed) -> do
1135− mapM_ recalculateSubscriberHeight =<< readIORef (switchSubscribedSubscribers subscribed)
1722+ WeakBag.traverse (switchSubscribedSubscribers subscribed) recalculateSubscriberHeight
1136 return result
1723 return result
1137
1724
1138−invalidHeight :: Int
1725+newtype Height = Height { unHeight :: Int } deriving (Show, Read, Eq, Ord, Bounded)
1726+
1727+{-# INLINE zeroHeight #-}
1728+zeroHeight :: Height
1729+zeroHeight = Height 0
1730+
1139−invalidHeight = -1000
1731+{-# INLINE invalidHeight #-}
1140−
1732+invalidHeight :: Height
1141−invalidateSubscriberHeight :: WeakSubscriber a -> IO ()
1733+invalidHeight = Height (-1000)
1142−invalidateSubscriberHeight ws = do
1734+
1143− ms <- deRefWeakSubscriber ws
1735+-- | An invalid height that is currently being traversed, e.g. by walkInvalidHeightParents
1144− case ms of
1736+{-# INLINE invalidHeightBeingTraversed #-}
1145− Nothing -> return () --TODO: cleanup?
1737+invalidHeightBeingTraversed :: Height
1146− Just s -> case s of
1738+invalidHeightBeingTraversed = Height (-1001)
1739+
1740+{-# INLINE succHeight #-}
1741+succHeight :: Height -> Height
1742+succHeight h@(Height a) =
1743+ if h == invalidHeight
1744+ then invalidHeight
1745+ else Height $ succ a
1746+
1747+-- Get the maximum height; if either of the inputs is invalid, the output will also be invalid
1748+{-# INLINE maxHeight #-}
1749+maxHeight :: Height -> Height -> Height
1750+maxHeight ha@(Height a) hb@(Height b) =
1751+ if ha == invalidHeight || hb == invalidHeight
1752+ then invalidHeight
1753+ else Height $ max a b
1754+
1755+invalidateSubscriberHeight :: Subscriber a -> IO ()
1756+invalidateSubscriberHeight s = case s of
1147− SubscriberPush _ subscribed -> do
1757+ SubscriberPush _ subscribed -> do
1148− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberPush" <> showNodeId subscribed
1758+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberPush" <> showNodeId subscribed
1149− mapM_ invalidateSubscriberHeight =<< readIORef (pushSubscribedSubscribers subscribed)
1759+ WeakBag.traverse (pushSubscribedSubscribers subscribed) invalidateSubscriberHeight
1150− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberPush" <> showNodeId subscribed <> " done"
1760+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberPush" <> showNodeId subscribed <> " done"
1151− SubscriberMerge _ subscribed -> do
1761+ SubscriberMerge k subscribed -> do
1152− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberMerge" <> showNodeId subscribed
1762+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberMerge" <> showNodeId subscribed
1153− oldHeight <- readIORef $ mergeSubscribedHeight subscribed
1763+ invalidateMergeHeight k subscribed
1154− when (oldHeight /= invalidHeight) $ do
1764+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberMerge" <> showNodeId subscribed <> " done"
1155− writeIORef (mergeSubscribedHeight subscribed) $ invalidHeight
1765+ SubscriberMergeChange _ -> return () -- Doesn't affect the height of the merge, because its changes are delayed
1156− mapM_ invalidateSubscriberHeight =<< readIORef (mergeSubscribedSubscribers subscribed)
1157− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberMerge" <> showNodeId subscribed <> " done"
1158− SubscriberFan subscribed -> do
1766+ SubscriberFan subscribed -> do
1159− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed
1767+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed
1160− subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1768+ subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1161− forM_ (DMap.toList subscribers) $ ((\(FanSubscriberKey _ :=> Identity v) -> mapM_ invalidateSubscriberHeight v) :: DSum (FanSubscriberKey k) Identity -> IO ())
1769+ forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse (_fanSubscribedChildren_list v) invalidateSubscriberHeight
1162− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"
1770+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"
1163− SubscriberHold _ -> return ()
1771+ SubscriberHold _ -> return ()
1772+ SubscriberHoldIdentity _ -> return ()
1164− SubscriberSwitch subscribed -> do
1773+ SubscriberSwitch subscribed -> do
1165− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed
1774+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed
1166− oldHeight <- readIORef $ switchSubscribedHeight subscribed
1775+ oldHeight <- readIORef $ switchSubscribedHeight subscribed
1167− when (oldHeight /= invalidHeight) $ do
1776+ when (oldHeight /= invalidHeight) $ do
1168− writeIORef (switchSubscribedHeight subscribed) $ invalidHeight
1777+ writeIORef (switchSubscribedHeight subscribed) invalidHeight
1169− mapM_ invalidateSubscriberHeight =<< readIORef (switchSubscribedSubscribers subscribed)
1778+ WeakBag.traverse (switchSubscribedSubscribers subscribed) invalidateSubscriberHeight
1170− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"
1779+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"
1171− SubscriberCoincidenceOuter subscribed -> do
1780+ SubscriberCoincidenceOuter subscribed -> do
1172− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed
1781+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed
1173− invalidateCoincidenceHeight subscribed
1782+ invalidateCoincidenceHeight subscribed
1174− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed <> " done"
1783+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed <> " done"
1175− SubscriberCoincidenceInner subscribed -> do
1784+ SubscriberCoincidenceInner subscribed -> do
1176− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed
1785+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed
1177− invalidateCoincidenceHeight subscribed
1786+ invalidateCoincidenceHeight subscribed
1178− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done"
1787+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done"
1788+ SubscriberHandle -> return ()
1789+
1790+--TODO: Actually use the key
1791+invalidateMergeHeight :: k a -> MergeSubscribed k -> IO ()
1792+invalidateMergeHeight _ subscribed = do
1793+ oldHeight <- readIORef $ mergeSubscribedHeight subscribed
1794+ when (oldHeight /= invalidHeight) $ do
1795+ writeIORef (mergeSubscribedHeight subscribed) invalidHeight
1796+ WeakBag.traverse (mergeSubscribedSubscribers subscribed) invalidateSubscriberHeight
1797+
1798+recalculateMergeHeight :: MergeSubscribed k -> IO ()
1799+recalculateMergeHeight subscribed = do
1800+ oldHeight <- readIORef $ mergeSubscribedHeight subscribed
1801+ when (oldHeight == invalidHeight) $ do
1802+ height <- calculateMergeHeight subscribed
1803+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: height: " <> show height
1804+ when (height /= invalidHeight) $ do -- If height == invalidHeight, that means some of the prereqs have not yet been recomputed; when they do recompute, they'll catch this node again --TODO: this is O(n*m), where n is the number of children of this noe and m is the number that have been invalidated
1805+ writeIORef (mergeSubscribedHeight subscribed) height
1806+ WeakBag.traverse (mergeSubscribedSubscribers subscribed) recalculateSubscriberHeight
1179
1807
1180invalidateCoincidenceHeight :: CoincidenceSubscribed a -> IO ()
1808invalidateCoincidenceHeight :: CoincidenceSubscribed a -> IO ()
1181invalidateCoincidenceHeight subscribed = do
1809invalidateCoincidenceHeight subscribed = do
1182 oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed
1810 oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed
1183 when (oldHeight /= invalidHeight) $ do
1811 when (oldHeight /= invalidHeight) $ do
1184− writeIORef (coincidenceSubscribedHeight subscribed) $ invalidHeight
1812+ writeIORef (coincidenceSubscribedHeight subscribed) invalidHeight
1185− mapM_ invalidateSubscriberHeight =<< readIORef (coincidenceSubscribedSubscribers subscribed)
1813+ WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) invalidateSubscriberHeight
1186
1814
1187--TODO: The recalculation algorithm seems a bit funky; make sure it doesn't miss stuff or hit stuff twice; also, it should probably be lazy
1815--TODO: The recalculation algorithm seems a bit funky; make sure it doesn't miss stuff or hit stuff twice; also, it should probably be lazy
1188
1816
1189−recalculateSubscriberHeight :: WeakSubscriber a -> IO ()
1817+recalculateSubscriberHeight :: Subscriber a -> IO ()
1190−recalculateSubscriberHeight ws = do
1818+recalculateSubscriberHeight s = case s of
1191− ms <- deRefWeakSubscriber ws
1192− case ms of
1193− Nothing -> return () --TODO: cleanup?
1194− Just s -> case s of
1195− SubscriberPush _ subscribed -> do
1819+ SubscriberPush _ subscribed -> do
1196− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberPush" <> showNodeId subscribed
1820+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberPush" <> showNodeId subscribed
1197− mapM_ recalculateSubscriberHeight =<< readIORef (pushSubscribedSubscribers subscribed)
1821+ WeakBag.traverse (pushSubscribedSubscribers subscribed) recalculateSubscriberHeight
1198− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberPush" <> showNodeId subscribed <> " done"
1822+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberPush" <> showNodeId subscribed <> " done"
1199− SubscriberMerge _ subscribed -> do
1823+ SubscriberMerge _ subscribed -> do
1200− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberMerge" <> showNodeId subscribed
1824+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberMerge" <> showNodeId subscribed
1201− oldHeight <- readIORef $ mergeSubscribedHeight subscribed
1825+ recalculateMergeHeight subscribed
1202− when (oldHeight == invalidHeight) $ do
1203− height <- calculateMergeHeight subscribed
1204− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: height: " <> show height
1826+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberMerge" <> showNodeId subscribed <> " done"
1205− when (height /= invalidHeight) $ do -- If height == invalidHeight, that means some of the prereqs have not yet been recomputed; when they do recompute, they'll catch this node again --TODO: this is O(n*m), where n is the number of children of this noe and m is the number that have been invalidated
1827+ SubscriberMergeChange _ -> return ()
1206− writeIORef (mergeSubscribedHeight subscribed) height
1207− mapM_ recalculateSubscriberHeight =<< readIORef (mergeSubscribedSubscribers subscribed)
1208− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberMerge" <> showNodeId subscribed <> " done"
1209− SubscriberFan subscribed -> do
1828+ SubscriberFan subscribed -> do
1210− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed
1829+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed
1211− subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1830+ subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1212− forM_ (DMap.toList subscribers) $ ((\(FanSubscriberKey _ :=> Identity v) -> mapM_ recalculateSubscriberHeight v) :: DSum (FanSubscriberKey k) Identity -> IO ())
1831+ forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse (_fanSubscribedChildren_list v) recalculateSubscriberHeight
1213− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"
1832+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"
1214− SubscriberHold _ -> return ()
1833+ SubscriberHold _ -> return ()
1834+ SubscriberHoldIdentity _ -> return ()
1215− SubscriberSwitch subscribed -> do
1835+ SubscriberSwitch subscribed -> do
1216− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed
1836+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed
1217− oldHeight <- readIORef $ switchSubscribedHeight subscribed
1837+ oldHeight <- readIORef $ switchSubscribedHeight subscribed
1218− when (oldHeight == invalidHeight) $ do
1838+ when (oldHeight == invalidHeight) $ do
1219− height <- calculateSwitchHeight subscribed
1839+ height <- calculateSwitchHeight subscribed
1220− when (height /= invalidHeight) $ do
1840+ when (height /= invalidHeight) $ do
1221− writeIORef (switchSubscribedHeight subscribed) height
1841+ writeIORef (switchSubscribedHeight subscribed) height
1222− mapM_ recalculateSubscriberHeight =<< readIORef (switchSubscribedSubscribers subscribed)
1842+ WeakBag.traverse (switchSubscribedSubscribers subscribed) recalculateSubscriberHeight
1223− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"
1843+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"
1224− SubscriberCoincidenceOuter subscribed -> do
1844+ SubscriberCoincidenceOuter subscribed -> do
1225− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed
1845+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed
1226− void $ recalculateCoincidenceHeight subscribed
1846+ recalculateCoincidenceHeight subscribed
1227− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed <> " done"
1847+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed <> " done"
1228− SubscriberCoincidenceInner subscribed -> do
1848+ SubscriberCoincidenceInner subscribed -> do
1229− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed
1849+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed
1230− void $ recalculateCoincidenceHeight subscribed
1850+ recalculateCoincidenceHeight subscribed
1231− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done"
1851+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done"
1852+ SubscriberHandle -> return ()
1232
1853
1233recalculateCoincidenceHeight :: CoincidenceSubscribed a -> IO ()
1854recalculateCoincidenceHeight :: CoincidenceSubscribed a -> IO ()
1234recalculateCoincidenceHeight subscribed = do
1855recalculateCoincidenceHeight subscribed = do
@@ -1237,49 +1858,26 @@ recalculateCoincidenceHeight subscribed = do
1237 height <- calculateCoincidenceHeight subscribed
1858 height <- calculateCoincidenceHeight subscribed
1238 when (height /= invalidHeight) $ do
1859 when (height /= invalidHeight) $ do
1239 writeIORef (coincidenceSubscribedHeight subscribed) height
1860 writeIORef (coincidenceSubscribedHeight subscribed) height
1240− mapM_ recalculateSubscriberHeight =<< readIORef (coincidenceSubscribedSubscribers subscribed) --TODO: This should probably be mandatory, just like with the merge and switch ones
1861+ WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) recalculateSubscriberHeight --TODO: This should probably be mandatory, just like with the merge and switch ones
1241
1862
1242−calculateMergeHeight :: MergeSubscribed k -> IO Int
1863+calculateMergeHeight :: MergeSubscribed k -> IO Height
1243−calculateMergeHeight subscribed = if DMap.null (mergeSubscribedParents subscribed) then return 0 else do
1864+calculateMergeHeight subscribed = do
1865+ parents <- readIORef $ mergeSubscribedParents subscribed
1866+ if DMap.null parents then return zeroHeight else do
1244− heights <- forM (DMap.toList $ mergeSubscribedParents subscribed) $ \(_ :=> es) -> do
1867+ heights <- forM (DMap.toList parents) $ \(_ :=> es) -> do
1245− readIORef $ eventSubscribedHeightRef es
1868+ readIORef $ eventSubscribedHeightRef $ snd $ mergeSubscribedParentSubscription es
1246− return $ if any (== invalidHeight) heights then invalidHeight else succ $ Prelude.maximum heights --TODO: Replace 'any' with invalidHeight-preserving 'maximum'
1869+ return $ succHeight $ foldr maxHeight zeroHeight heights
1247
1870
1248−calculateSwitchHeight :: SwitchSubscribed a -> IO Int
1871+calculateSwitchHeight :: SwitchSubscribed a -> IO Height
1249−calculateSwitchHeight subscribed = readIORef . eventSubscribedHeightRef =<< readIORef (switchSubscribedCurrentParent subscribed)
1872+calculateSwitchHeight subscribed = readIORef . eventSubscribedHeightRef . snd =<< readIORef (switchSubscribedCurrentParent subscribed)
1250
1873
1251−calculateCoincidenceHeight :: CoincidenceSubscribed a -> IO Int
1874+calculateCoincidenceHeight :: CoincidenceSubscribed a -> IO Height
1252calculateCoincidenceHeight subscribed = do
1875calculateCoincidenceHeight subscribed = do
1253− outerHeight <- readIORef $ eventSubscribedHeightRef $ coincidenceSubscribedOuterParent subscribed
1876+ outerHeight <- readIORef $ eventSubscribedHeightRef $ snd $ coincidenceSubscribedOuterParent subscribed
1254− innerHeight <- maybe (return 0) (readIORef . eventSubscribedHeightRef) =<< readIORef (coincidenceSubscribedInnerParent subscribed)
1877+ innerHeight <- maybe (return zeroHeight) (readIORef . eventSubscribedHeightRef) =<< readIORef (coincidenceSubscribedInnerParent subscribed)
1255 return $ if outerHeight == invalidHeight || innerHeight == invalidHeight then invalidHeight else max outerHeight innerHeight
1878 return $ if outerHeight == invalidHeight || innerHeight == invalidHeight then invalidHeight else max outerHeight innerHeight
1256
1879
1257−{-
1258−recalculateEventSubscribedHeight :: EventSubscribed a -> IO Int
1259−recalculateEventSubscribedHeight es = case es of
1260− EventSubscribedRoot _ -> return 0
1261− EventSubscribedNever -> return 0
1262− EventSubscribedPush subscribed -> recalculateEventSubscribedHeight $ pushSubscribedParent subscribed
1263− EventSubscribedMerge subscribed -> do
1264− oldHeight <- readIORef $ mergeSubscribedHeight subscribed
1265− if oldHeight /= invalidHeight then return oldHeight else do
1266− height <- calculateMergeHeight subscribed
1267− writeIORef (mergeSubscribedHeight subscribed) height
1268− return height
1269− EventSubscribedFan _ subscribed -> recalculateEventSubscribedHeight $ fanSubscribedParent subscribed
1270− EventSubscribedSwitch subscribed -> do
1271− oldHeight <- readIORef $ switchSubscribedHeight subscribed
1272− if oldHeight /= invalidHeight then return oldHeight else do
1273− height <- calculateSwitchHeight subscribed
1274− writeIORef (switchSubscribedHeight subscribed) height
1275− return height
1276− EventSubscribedCoincidence subscribed -> recalculateCoincidenceHeight subscribed
1277−-}
1278−
1279−data SomeSwitchSubscribed = forall a. SomeSwitchSubscribed (SwitchSubscribed a)
1880+data SomeSwitchSubscribed = forall a. SomeSwitchSubscribed {-# NOUNPACK #-} (SwitchSubscribed a)
1280−
1281−debugInvalidate :: Bool
1282−debugInvalidate = False
1283
1881
1284invalidate :: IORef [SomeSwitchSubscribed] -> WeakList Invalidator -> IO (WeakList Invalidator)
1882invalidate :: IORef [SomeSwitchSubscribed] -> WeakList Invalidator -> IO (WeakList Invalidator)
1285invalidate toReconnectRef wis = do
1883invalidate toReconnectRef wis = do
@@ -1287,19 +1885,19 @@ invalidate toReconnectRef wis = do
1287 mi <- deRefWeak wi
1885 mi <- deRefWeak wi
1288 case mi of
1886 case mi of
1289 Nothing -> do
1887 Nothing -> do
1290− when debugInvalidate $ liftIO $ putStrLn "invalidate Dead"
1888+ traceInvalidate "invalidate Dead"
1291 return () --TODO: Should we clean this up here?
1889 return () --TODO: Should we clean this up here?
1292 Just i -> do
1890 Just i -> do
1293 finalize wi -- Once something's invalidated, it doesn't need to hang around; this will change when some things are strict
1891 finalize wi -- Once something's invalidated, it doesn't need to hang around; this will change when some things are strict
1294 case i of
1892 case i of
1295 InvalidatorPull p -> do
1893 InvalidatorPull p -> do
1296− when debugInvalidate $ liftIO $ putStrLn "invalidate Pull"
1894+ traceInvalidate $ "invalidate: Pull" <> showNodeId p
1297 mVal <- readIORef $ pullValue p
1895 mVal <- readIORef $ pullValue p
1298 forM_ mVal $ \val -> do
1896 forM_ mVal $ \val -> do
1299 writeIORef (pullValue p) Nothing
1897 writeIORef (pullValue p) Nothing
1300 writeIORef (pullSubscribedInvalidators val) =<< invalidate toReconnectRef =<< readIORef (pullSubscribedInvalidators val)
1898 writeIORef (pullSubscribedInvalidators val) =<< invalidate toReconnectRef =<< readIORef (pullSubscribedInvalidators val)
1301 InvalidatorSwitch subscribed -> do
1899 InvalidatorSwitch subscribed -> do
1302− when debugInvalidate $ liftIO $ putStrLn "invalidate Switch"
1900+ traceInvalidate $ "invalidate: Switch" <> showNodeId subscribed
1303 modifyIORef' toReconnectRef (SomeSwitchSubscribed subscribed :)
1901 modifyIORef' toReconnectRef (SomeSwitchSubscribed subscribed :)
1304 return [] -- Since we always finalize everything, always return an empty list --TODO: There are some things that will need to be re-subscribed every time; we should try to avoid finalizing them
1902 return [] -- Since we always finalize everything, always return an empty list --TODO: There are some things that will need to be re-subscribed every time; we should try to avoid finalizing them
1305
1903
@@ -1307,83 +1905,220 @@ invalidate toReconnectRef wis = do
1307-- Reflex integration
1905-- Reflex integration
1308--------------------------------------------------------------------------------
1906--------------------------------------------------------------------------------
1309
1907
1310−data Spider
1908+type Spider = SpiderEnv Global
1311
1909
1312−instance R.Reflex Spider where
1910+data Global
1313− newtype Behavior Spider a = SpiderBehavior { unSpiderBehavior :: Behavior a }
1911+
1314− newtype Event Spider a = SpiderEvent { unSpiderEvent :: Event a }
1912+{-# NOINLINE globalSpiderEnv #-}
1315− type PullM Spider = BehaviorM
1913+globalSpiderEnv :: SpiderEnv Global
1316− type PushM Spider = EventM
1914+globalSpiderEnv = unsafePerformIO unsafeNewSpiderEnv
1317− {-# INLINE never #-}
1318− {-# INLINE constant #-}
1319− never = SpiderEvent EventNever
1320− constant = SpiderBehavior . BehaviorConst
1321− push f = SpiderEvent. push f . unSpiderEvent
1322− pull = SpiderBehavior . pull
1323− merge = SpiderEvent . merge . (unsafeCoerce :: DMap k (R.Event Spider) -> DMap k Event)
1324− fan e = R.EventSelector $ SpiderEvent . select (fan (unSpiderEvent e))
1325− switch = SpiderEvent . switch . (unsafeCoerce :: Behavior (R.Event Spider a) -> Behavior (Event a)) . unSpiderBehavior
1326− coincidence = SpiderEvent . coincidence . (unsafeCoerce :: Event (R.Event Spider a) -> Event (Event a)) . unSpiderEvent
1327
1915
1328−instance R.MonadSample Spider SpiderHost where
1916+type role SpiderEnv nominal
1329− {-# INLINE sample #-}
1917+data SpiderEnv x = SpiderEnv
1330− sample = SpiderHost . readBehavior . unSpiderBehavior
1918+ { _spiderEnv_toUnsubscribe :: !(IORef [SomeEventSubscription])
1919+ , _spiderEnv_lock :: !(MVar ())
1920+ , _spiderEnv_cleanups :: !(IORef [IO ()])
1921+#ifdef DEBUG
1922+ , _spiderEnv_depth :: !(IORef Int)
1923+#endif
1924+ }
1331
1925
1332−instance R.MonadHold Spider SpiderHost where
1926+instance GEq SpiderEnv where
1333− hold v0 = SpiderHost . liftM SpiderBehavior . runFrame . hold v0 . unSpiderEvent
1927+ a `geq` b = if _spiderEnv_toUnsubscribe a == _spiderEnv_toUnsubscribe b
1928+ then Just $ unsafeCoerce Refl -- This unsafeCoerce is safe because the same SpiderEnv can't have two different 'x' arguments
1929+ else Nothing
1334
1930
1335−instance R.MonadSample Spider BehaviorM where
1931+unsafeNewSpiderEnv :: forall x. IO (SpiderEnv x)
1336− {-# INLINE sample #-}
1932+unsafeNewSpiderEnv = do
1337− sample = readBehaviorTracked . unSpiderBehavior
1933+ toUnsubscribe <- newIORef []
1934+ lock <- newMVar ()
1935+ cleanups <- newIORef []
1936+#ifdef DEBUG
1937+ depthRef <- newIORef 0
1938+#endif
1939+ return $ SpiderEnv
1940+ { _spiderEnv_toUnsubscribe = toUnsubscribe
1941+ , _spiderEnv_lock = lock
1942+ , _spiderEnv_cleanups = cleanups
1943+#ifdef DEBUG
1944+ , _spiderEnv_depth = depthRef
1945+#endif
1946+ }
1338
1947
1339−instance R.MonadSample Spider EventM where
1948+newSpiderEnv :: IO (Some SpiderEnv)
1340− {-# INLINE sample #-}
1949+newSpiderEnv = Some.This <$> unsafeNewSpiderEnv
1341− sample = liftIO . readBehavior . unSpiderBehavior
1342
1950
1343−instance R.MonadHold Spider EventM where
1951+newtype SpiderPullM x a = SpiderPullM { runSpiderPullM :: BehaviorM a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
1344− {-# INLINE hold #-}
1345− hold v0 e = SpiderBehavior <$> hold v0 (unSpiderEvent e)
1346
1952
1347−data RootTrigger a = forall k. GCompare k => RootTrigger (IORef [WeakSubscriber a], IORef (DMap k Identity), k a)
1953+newtype SpiderPushM x a = SpiderPushM { runSpiderPushM :: ComputeM a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
1348−newtype SpiderEventHandle a = SpiderEventHandle { unEventHandle :: Event a }
1349
1954
1955+instance R.Reflex (SpiderEnv x) where
1956+ newtype Behavior (SpiderEnv x) a = SpiderBehavior { unSpiderBehavior :: Behavior a }
1957+ newtype Event (SpiderEnv x) a = SpiderEvent { unSpiderEvent :: Event a }
1958+ newtype Dynamic (SpiderEnv x) a = SpiderDynamic { unSpiderDynamic :: Dynamic Identity a } deriving (Functor, Applicative, Monad)
1959+ newtype Incremental (SpiderEnv x) p a = SpiderIncremental { unSpiderIncremental :: Dynamic p a }
1960+ type PullM (SpiderEnv x) = SpiderPullM x
1961+ type PushM (SpiderEnv x) = SpiderPushM x
1962+ {-# INLINABLE never #-}
1963+ never = SpiderEvent EventNever
1964+ {-# INLINABLE constant #-}
1965+ constant = SpiderBehavior . BehaviorConst
1966+ {-# INLINABLE push #-}
1967+ push f = SpiderEvent . push (coerce f) . unSpiderEvent
1968+ {-# INLINABLE pull #-}
1969+ pull = SpiderBehavior . pull . coerce
1970+ {-# INLINABLE merge #-}
1971+ merge = SpiderEvent . merge . DynamicConst . (unsafeCoerce :: DMap k (R.Event (SpiderEnv x)) -> DMap k Event)
1972+ {-# INLINABLE fan #-}
1973+ fan e = R.EventSelector $ SpiderEvent . select (fan (unSpiderEvent e))
1974+ {-# INLINABLE switch #-}
1975+ switch = SpiderEvent . switch . (unsafeCoerce :: Behavior (R.Event (SpiderEnv x) a) -> Behavior (Event a)) . unSpiderBehavior
1976+ {-# INLINABLE coincidence #-}
1977+ coincidence = SpiderEvent . coincidence . (unsafeCoerce :: Event (R.Event (SpiderEnv x) a) -> Event (Event a)) . unSpiderEvent
1978+ {-# INLINABLE current #-}
1979+ current = SpiderBehavior . current . unSpiderDynamic
1980+ {-# INLINABLE updated #-}
1981+ updated = SpiderEvent . fmap runIdentity . updated . unSpiderDynamic
1982+ {-# INLINABLE unsafeBuildDynamic #-}
1983+ unsafeBuildDynamic readV0 v' = SpiderDynamic $ DynamicDynIdentity $ unsafeDyn (coerce readV0) $ addIdentity $ unSpiderEvent v'
1984+ {-# INLINABLE unsafeBuildIncremental #-}
1985+ unsafeBuildIncremental readV0 dv = SpiderIncremental $ DynamicDyn $ unsafeDyn (coerce readV0) $ unSpiderEvent dv
1986+ {-# INLINABLE mergeIncremental #-}
1987+ mergeIncremental = SpiderEvent . merge . (unsafeCoerce :: Dynamic R.PatchDMap (DMap k (R.Event (SpiderEnv x))) -> Dynamic R.PatchDMap (DMap k Event)) . unSpiderIncremental
1988+ {-# INLINABLE currentIncremental #-}
1989+ currentIncremental = SpiderBehavior . current . unSpiderIncremental
1990+ {-# INLINABLE updatedIncremental #-}
1991+ updatedIncremental = SpiderEvent . updated . unSpiderIncremental
1992+ {-# INLINABLE incrementalToDynamic #-}
1993+ incrementalToDynamic (SpiderIncremental i) = SpiderDynamic $ DynamicDynIdentity $ unsafeDyn (readBehaviorUntracked $ current i) $ flip push (updated i) $ \p -> do
1994+ c <- readBehaviorUntracked $ current i
1995+ return $ fmap Identity $ R.apply p c --TODO: Avoid the redundant 'apply'
1996+
1997+instance R.MonadSample (SpiderEnv x) (EventM x) where
1998+ {-# INLINABLE sample #-}
1999+ sample (SpiderBehavior b) = readBehaviorUntracked b
2000+
2001+instance R.MonadHold (SpiderEnv x) (EventM x) where
2002+ {-# INLINABLE hold #-}
2003+ hold = holdSpiderEventM
2004+ {-# INLINABLE holdDyn #-}
2005+ holdDyn = holdDynSpiderEventM
2006+ {-# INLINABLE holdIncremental #-}
2007+ holdIncremental = holdIncrementalSpiderEventM
2008+
2009+holdSpiderEventM :: a -> R.Event (SpiderEnv x) a -> EventM x (R.Behavior (SpiderEnv x) a)
2010+holdSpiderEventM v0 e = liftM (SpiderBehavior . BehaviorHoldIdentity) $ hold v0 $ addIdentity $ unSpiderEvent e
2011+
2012+holdDynSpiderEventM :: a -> R.Event (SpiderEnv x) a -> EventM x (R.Dynamic (SpiderEnv x) a)
2013+holdDynSpiderEventM v0 e = liftM (SpiderDynamic . DynamicHoldIdentity) $ hold v0 $ addIdentity $ unSpiderEvent e
2014+
2015+holdIncrementalSpiderEventM :: R.Patch p => a -> R.Event (SpiderEnv x) (p a) -> EventM x (R.Incremental (SpiderEnv x) p a)
2016+holdIncrementalSpiderEventM v0 e = liftM (SpiderIncremental . DynamicHold) $ hold v0 $ unSpiderEvent e
2017+
2018+instance R.MonadHold (SpiderEnv x) (SpiderHost x) where
2019+ {-# INLINABLE hold #-}
2020+ hold v0 e = R.runHostFrame $ R.hold v0 e
2021+ {-# INLINABLE holdDyn #-}
2022+ holdDyn v0 e = R.runHostFrame $ R.holdDyn v0 e
2023+ {-# INLINABLE holdIncremental #-}
2024+ holdIncremental v0 e = R.runHostFrame $ R.holdIncremental v0 e
2025+
2026+instance R.MonadSample (SpiderEnv x) (SpiderHost x) where
2027+ {-# INLINABLE sample #-}
2028+ sample = runFrame . readBehaviorUntracked . unSpiderBehavior
2029+
2030+instance R.MonadSample (SpiderEnv x) (SpiderPullM x) where
2031+ {-# INLINABLE sample #-}
2032+ sample = coerce . readBehaviorTracked . unSpiderBehavior
2033+
2034+instance R.MonadSample (SpiderEnv x) (SpiderPushM x) where
2035+ {-# INLINABLE sample #-}
2036+ sample (SpiderBehavior b) = SpiderPushM $ readBehaviorUntracked b
2037+
2038+instance R.MonadHold (SpiderEnv x) (SpiderPushM x) where
2039+ {-# INLINABLE hold #-}
2040+ hold v0 e = R.current <$> R.holdDyn v0 e
2041+ {-# INLINABLE holdDyn #-}
2042+ holdDyn v0 (SpiderEvent e) = SpiderPushM $ liftM (SpiderDynamic . DynamicHoldIdentity) $ hold v0 $ addIdentity e
2043+ {-# INLINABLE holdIncremental #-}
2044+ holdIncremental v0 (SpiderEvent e) = SpiderPushM $ liftM (SpiderIncremental . DynamicHold) $ hold v0 e
2045+
2046+data RootTrigger a = forall k. GCompare k => RootTrigger (SubscriberList a, IORef (DMap k Identity), k a)
2047+newtype SpiderEventHandle a = SpiderEventHandle { unSpiderEventHandle :: EventSubscription a }
2048+
1350−instance R.MonadSubscribeEvent Spider SpiderHostFrame where
2049+instance R.MonadSubscribeEvent (SpiderEnv x) (SpiderHostFrame x) where
2050+ {-# INLINABLE subscribeEvent #-}
1351 subscribeEvent e = SpiderHostFrame $ do
2051 subscribeEvent e = SpiderHostFrame $ do
1352− _ <- getEventSubscribed $ unSpiderEvent e --TODO: The result of this should actually be used
2052+ subscription <- subscribe (unSpiderEvent e) SubscriberHandle --TODO: Unsubscribe eventually (manually and/or with weak ref)
1353− return $ SpiderEventHandle (unSpiderEvent e)
2053+ return $ SpiderEventHandle subscription
1354−
2054+
1355−instance R.ReflexHost Spider where
2055+instance R.ReflexHost (SpiderEnv x) where
1356− type EventTrigger Spider = RootTrigger
2056+ type EventTrigger (SpiderEnv x) = RootTrigger
1357− type EventHandle Spider = SpiderEventHandle
2057+ type EventHandle (SpiderEnv x) = SpiderEventHandle
1358− type HostFrame Spider = SpiderHostFrame
2058+ type HostFrame (SpiderEnv x) = SpiderHostFrame x
1359−
2059+
1360−instance R.MonadReadEvent Spider ReadPhase where
2060+instance R.MonadReadEvent (SpiderEnv x) (ReadPhase x) where
1361− {-# INLINE readEvent #-}
2061+ {-# INLINABLE readEvent #-}
1362− readEvent = ReadPhase . liftM (fmap return) . readEvent . unEventHandle
2062+ readEvent h = ReadPhase $ liftM (fmap return) $ liftIO $ do
1363−
2063+ let (sln, subscribed) = unSpiderEventHandle h
2064+ result <- readEventSubscribed subscribed
2065+ touch sln
2066+ return result
2067+
1364−instance MonadRef EventM where
2068+instance MonadRef (EventM x) where
1365− type Ref EventM = Ref IO
2069+ type Ref (EventM x) = Ref IO
1366− {-# INLINE newRef #-}
2070+ {-# INLINABLE newRef #-}
1367− {-# INLINE readRef #-}
2071+ {-# INLINABLE readRef #-}
1368− {-# INLINE writeRef #-}
2072+ {-# INLINABLE writeRef #-}
1369 newRef = liftIO . newRef
2073 newRef = liftIO . newRef
1370 readRef = liftIO . readRef
2074 readRef = liftIO . readRef
1371 writeRef r a = liftIO $ writeRef r a
2075 writeRef r a = liftIO $ writeRef r a
1372
2076
1373−instance MonadAtomicRef EventM where
2077+instance MonadAtomicRef (EventM x) where
1374− {-# INLINE atomicModifyRef #-}
2078+ {-# INLINABLE atomicModifyRef #-}
1375 atomicModifyRef r f = liftIO $ atomicModifyRef r f
2079 atomicModifyRef r f = liftIO $ atomicModifyRef r f
1376
2080
1377−newtype SpiderHost a = SpiderHost { runSpiderHost :: IO a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)
2081+newtype SpiderHost x a = SpiderHost { unSpiderHost :: ReaderT (SpiderEnv x) IO a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
1378−
2082+
2083+instance Monad (SpiderHost x) where
2084+ {-# INLINABLE (>>=) #-}
2085+ SpiderHost x >>= f = SpiderHost $ x >>= unSpiderHost . f
2086+ {-# INLINABLE (>>) #-}
2087+ SpiderHost x >> SpiderHost y = SpiderHost $ x >> y
2088+ {-# INLINABLE return #-}
2089+ return x = SpiderHost $ return x
2090+ {-# INLINABLE fail #-}
2091+ fail s = SpiderHost $ fail s
2092+
2093+runSpiderHost :: SpiderHost Global a -> IO a
2094+runSpiderHost (SpiderHost a) = runReaderT a globalSpiderEnv
2095+
1379−newtype SpiderHostFrame a = SpiderHostFrame { runSpiderHostFrame :: EventM a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)
2096+newtype SpiderHostFrame x a = SpiderHostFrame { runSpiderHostFrame :: EventM x a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
1380−
2097+
2098+instance Monad (SpiderHostFrame x) where
2099+ {-# INLINABLE (>>=) #-}
2100+ SpiderHostFrame x >>= f = SpiderHostFrame $ x >>= runSpiderHostFrame . f
2101+ {-# INLINABLE (>>) #-}
2102+ SpiderHostFrame x >> SpiderHostFrame y = SpiderHostFrame $ x >> y
2103+ {-# INLINABLE return #-}
2104+ return x = SpiderHostFrame $ return x
2105+ {-# INLINABLE fail #-}
2106+ fail s = SpiderHostFrame $ fail s
2107+
1381−instance R.MonadSample Spider SpiderHostFrame where
2108+instance R.MonadSample (SpiderEnv x) (SpiderHostFrame x) where
1382− sample = SpiderHostFrame . R.sample --TODO: This can cause problems with laziness, so we should get rid of it if we can
2109+ sample = SpiderHostFrame . readBehaviorUntracked . unSpiderBehavior --TODO: This can cause problems with laziness, so we should get rid of it if we can
1383−
2110+
2111+addIdentity :: Event a -> Event (Identity a)
2112+--addIdentity = fmap Identity
2113+addIdentity = unsafeCoerce
2114+
1384−instance R.MonadHold Spider SpiderHostFrame where
2115+instance R.MonadHold (SpiderEnv x) (SpiderHostFrame x) where
1385− {-# INLINE hold #-}
2116+ {-# INLINABLE hold #-}
1386− hold v0 e = SpiderHostFrame $ R.hold v0 e
2117+ hold v0 e = SpiderHostFrame $ liftM (SpiderBehavior . BehaviorHoldIdentity) $ hold v0 $ addIdentity $ unSpiderEvent e
2118+ {-# INLINABLE holdDyn #-}
2119+ holdDyn v0 e = SpiderHostFrame $ liftM (SpiderDynamic . DynamicHoldIdentity) $ hold v0 $ addIdentity $ unSpiderEvent e
2120+ {-# INLINABLE holdIncremental #-}
2121+ holdIncremental v0 e = SpiderHostFrame $ liftM (SpiderIncremental . DynamicHold) $ hold v0 $ unSpiderEvent e
1387
2122
1388newEventWithTriggerIO :: forall a. (RootTrigger a -> IO (IO ())) -> IO (Event a)
2123newEventWithTriggerIO :: forall a. (RootTrigger a -> IO (IO ())) -> IO (Event a)
1389newEventWithTriggerIO f = do
2124newEventWithTriggerIO f = do
@@ -1401,44 +2136,60 @@ newFanEventWithTriggerIO f = do
1401 }
2136 }
1402 return $ EventSelector $ \k -> EventRoot k r
2137 return $ EventSelector $ \k -> EventRoot k r
1403
2138
1404−instance R.MonadReflexCreateTrigger Spider SpiderHost where
2139+instance R.MonadReflexCreateTrigger (SpiderEnv x) (SpiderHost x) where
1405− newEventWithTrigger = SpiderHost . liftM SpiderEvent . newEventWithTriggerIO
2140+ newEventWithTrigger = SpiderHost . lift . liftM SpiderEvent . newEventWithTriggerIO
1406− newFanEventWithTrigger f = SpiderHost $ do
2141+ newFanEventWithTrigger f = SpiderHost $ lift $ do
1407 es <- newFanEventWithTriggerIO f
2142 es <- newFanEventWithTriggerIO f
1408 return $ R.EventSelector $ SpiderEvent . select es
2143 return $ R.EventSelector $ SpiderEvent . select es
1409
2144
1410−instance R.MonadReflexCreateTrigger Spider SpiderHostFrame where
2145+instance R.MonadReflexCreateTrigger (SpiderEnv x) (SpiderHostFrame x) where
1411 newEventWithTrigger = SpiderHostFrame . EventM . liftIO . liftM SpiderEvent . newEventWithTriggerIO
2146 newEventWithTrigger = SpiderHostFrame . EventM . liftIO . liftM SpiderEvent . newEventWithTriggerIO
1412 newFanEventWithTrigger f = SpiderHostFrame $ EventM $ liftIO $ do
2147 newFanEventWithTrigger f = SpiderHostFrame $ EventM $ liftIO $ do
1413 es <- newFanEventWithTriggerIO f
2148 es <- newFanEventWithTriggerIO f
1414 return $ R.EventSelector $ SpiderEvent . select es
2149 return $ R.EventSelector $ SpiderEvent . select es
1415
2150
1416−instance R.MonadSubscribeEvent Spider SpiderHost where
2151+instance R.MonadSubscribeEvent (SpiderEnv x) (SpiderHost x) where
1417− subscribeEvent e = SpiderHost $ do
2152+ {-# INLINABLE subscribeEvent #-}
2153+ subscribeEvent = subscribeEventSpiderHost
2154+
2155+subscribeEventSpiderHost :: R.Event (SpiderEnv x) a -> SpiderHost x (R.EventHandle (SpiderEnv x) a)
2156+subscribeEventSpiderHost e = do
1418− _ <- runFrame $ getEventSubscribed $ unSpiderEvent e --TODO: The result of this should actually be used
2157+ subscription <- runFrame $ getEventSubscribed (unSpiderEvent e) SubscriberHandle --TODO: Unsubscribe eventually (manually and/or with weak ref)
1419− return $ SpiderEventHandle (unSpiderEvent e)
2158+ return $ SpiderEventHandle subscription
2159+
2160+newtype ReadPhase x a = ReadPhase { runReadPhase :: ResultM x a } deriving (Functor, Applicative, Monad, MonadFix)
2161+
2162+instance R.MonadSample (SpiderEnv x) (ReadPhase x) where
2163+ {-# INLINABLE sample #-}
2164+ sample = ReadPhase . R.sample
1420
2165
1421−newtype ReadPhase a = ReadPhase { runReadPhase :: ResultM a } deriving (Functor, Applicative, Monad, MonadFix, R.MonadSample Spider, R.MonadHold Spider)
2166+instance R.MonadHold (SpiderEnv x) (ReadPhase x) where
2167+ {-# INLINABLE hold #-}
2168+ hold v0 e = ReadPhase $ R.hold v0 e
2169+ {-# INLINABLE holdDyn #-}
2170+ holdDyn v0 e = ReadPhase $ R.holdDyn v0 e
2171+ {-# INLINABLE holdIncremental #-}
2172+ holdIncremental v0 e = ReadPhase $ R.holdIncremental v0 e
1422
2173
1423−instance R.MonadReflexHost Spider SpiderHost where
2174+instance R.MonadReflexHost (SpiderEnv x) (SpiderHost x) where
1424− type ReadPhase SpiderHost = ReadPhase
2175+ type ReadPhase (SpiderHost x) = ReadPhase x
1425− fireEventsAndRead es (ReadPhase a) = SpiderHost $ run es a
2176+ fireEventsAndRead es (ReadPhase a) = run es a
1426− runHostFrame = SpiderHost . runFrame . runSpiderHostFrame
2177+ runHostFrame = runFrame . runSpiderHostFrame
1427
2178
1428−instance MonadRef SpiderHost where
2179+instance MonadRef (SpiderHost x) where
1429− type Ref SpiderHost = Ref IO
2180+ type Ref (SpiderHost x) = Ref IO
1430 newRef = SpiderHost . newRef
2181 newRef = SpiderHost . newRef
1431 readRef = SpiderHost . readRef
2182 readRef = SpiderHost . readRef
1432 writeRef r = SpiderHost . writeRef r
2183 writeRef r = SpiderHost . writeRef r
1433
2184
1434−instance MonadAtomicRef SpiderHost where
2185+instance MonadAtomicRef (SpiderHost x) where
1435 atomicModifyRef r = SpiderHost . atomicModifyRef r
2186 atomicModifyRef r = SpiderHost . atomicModifyRef r
1436
2187
1437−instance MonadRef SpiderHostFrame where
2188+instance MonadRef (SpiderHostFrame x) where
1438− type Ref SpiderHostFrame = Ref IO
2189+ type Ref (SpiderHostFrame x) = Ref IO
1439 newRef = SpiderHostFrame . newRef
2190 newRef = SpiderHostFrame . newRef
1440 readRef = SpiderHostFrame . readRef
2191 readRef = SpiderHostFrame . readRef
1441 writeRef r = SpiderHostFrame . writeRef r
2192 writeRef r = SpiderHostFrame . writeRef r
1442
2193
1443−instance MonadAtomicRef SpiderHostFrame where
2194+instance MonadAtomicRef (SpiderHostFrame x) where
1444 atomicModifyRef r = SpiderHostFrame . atomicModifyRef r
2195 atomicModifyRef r = SpiderHostFrame . atomicModifyRef r
test/Reflex/Bench/Focused.hs+2−1
@@ -26,6 +26,7 @@ import Data.List.Split
26import Data.Word
26import Data.Word
27import Data.Monoid
27import Data.Monoid
28
28
29+import Control.DeepSeq
29
30
30import Prelude hiding (sum, concat)
31import Prelude hiding (sum, concat)
31
32
@@ -244,7 +245,7 @@ subscribing n frames =
244 ]
245 ]
245
246
246 where
247 where
247− testSub :: (Eq a, Show a) => String -> (forall t n. (Reflex t, MonadHold t n, MonadFix n) => Event t Word -> n (Event t a)) -> (String, TestCase)
248+ testSub :: (Eq a, Show a, NFData a) => String -> (forall t n. (Reflex t, MonadHold t n, MonadFix n) => Event t Word -> n (Event t a)) -> (String, TestCase)
248 testSub name test = testE name (switches frames test)
249 testSub name test = testE name (switches frames test)
249
250
250-- Set of benchmark to test specifically merging dynamic collections
251-- Set of benchmark to test specifically merging dynamic collections
test/Reflex/Plan/Pure.hs+2
@@ -31,6 +31,8 @@ liftPlan = PurePlan . lift
31
31
32instance MonadHold (Pure Int) PurePlan where
32instance MonadHold (Pure Int) PurePlan where
33 hold initial = liftPlan . hold initial
33 hold initial = liftPlan . hold initial
34+ holdDyn initial = liftPlan . holdDyn initial
35+ holdIncremental initial = liftPlan . holdIncremental initial
34
36
35instance MonadSample (Pure Int) PurePlan where
37instance MonadSample (Pure Int) PurePlan where
36 sample = liftPlan . sample
38 sample = liftPlan . sample
test/Reflex/Plan/Reflex.hs+13−8
@@ -9,6 +9,7 @@ module Reflex.Plan.Reflex
9
9
10
10
11 , readSchedule
11 , readSchedule
12+ , readSchedule_
12 , testSchedule
13 , testSchedule
13 , readEvent'
14 , readEvent'
14 , makeDense
15 , makeDense
@@ -37,6 +38,8 @@ import Control.Monad.Ref
37import Data.IntMap.Strict (IntMap)
38import Data.IntMap.Strict (IntMap)
38import Data.IORef
39import Data.IORef
39import System.Mem
40import System.Mem
41+import Control.Exception
42+import Control.DeepSeq
40
43
41-- Note: this import must come last to silence warnings from AMP
44-- Note: this import must come last to silence warnings from AMP
42import Prelude
45import Prelude
@@ -75,7 +78,7 @@ instance (ReflexHost t, MonadRef (HostFrame t), Ref (HostFrame t) ~ Ref IO) => T
75firingTrigger :: (MonadReflexHost t m, MonadIORef m) => Firing t -> m (Maybe (DSum (EventTrigger t) Identity))
78firingTrigger :: (MonadReflexHost t m, MonadIORef m) => Firing t -> m (Maybe (DSum (EventTrigger t) Identity))
76firingTrigger (Firing ref a) = fmap (:=> Identity a) <$> readRef ref
79firingTrigger (Firing ref a) = fmap (:=> Identity a) <$> readRef ref
77
80
78−runPlan :: (MonadReflexHost t m, MonadIORef m) => Plan t a -> m (a, Schedule t)
81+runPlan :: (MonadReflexHost t m) => Plan t a -> m (a, Schedule t)
79runPlan (Plan p) = runHostFrame $ runStateT p mempty
82runPlan (Plan p) = runHostFrame $ runStateT p mempty
80
83
81
84
@@ -90,29 +93,31 @@ makeDense s = fromMaybe (emptyRange 0) $ do
90-- For the purposes of testing, we add in a zero frame and extend one frame (to observe changes to behaviors
93-- For the purposes of testing, we add in a zero frame and extend one frame (to observe changes to behaviors
91-- after the last event)
94-- after the last event)
92-- performGC is called at each frame to test for GC issues
95-- performGC is called at each frame to test for GC issues
93−testSchedule :: (MonadReflexHost t m, MonadIORef m) => Schedule t -> ReadPhase m a -> m (IntMap a)
96+testSchedule :: (MonadReflexHost t m, MonadIORef m, NFData a) => Schedule t -> ReadPhase m a -> m (IntMap a)
94testSchedule schedule readResult = IntMap.traverseWithKey (\t occs -> liftIO performGC *> triggerFrame readResult t occs) (makeDense schedule)
97testSchedule schedule readResult = IntMap.traverseWithKey (\t occs -> liftIO performGC *> triggerFrame readResult t occs) (makeDense schedule)
95
98
96−readSchedule :: (MonadReflexHost t m, MonadIORef m) => Schedule t -> ReadPhase m a -> m (IntMap a)
99+readSchedule :: (MonadReflexHost t m, MonadIORef m, NFData a) => Schedule t -> ReadPhase m a -> m (IntMap a)
97readSchedule schedule readResult = IntMap.traverseWithKey (triggerFrame readResult) schedule
100readSchedule schedule readResult = IntMap.traverseWithKey (triggerFrame readResult) schedule
98
101
102+readSchedule_ :: (MonadReflexHost t m, MonadIORef m, NFData a) => Schedule t -> ReadPhase m a -> m ()
103+readSchedule_ schedule readResult = mapM_ (uncurry $ triggerFrame readResult) $ IntMap.toList schedule
104+
99−triggerFrame :: (MonadReflexHost t m, MonadIORef m) => ReadPhase m a -> Int -> [Firing t] -> m a
105+triggerFrame :: (MonadReflexHost t m, MonadIORef m, NFData a) => ReadPhase m a -> Int -> [Firing t] -> m a
100triggerFrame readResult _ occs = do
106triggerFrame readResult _ occs = do
101 triggers <- catMaybes <$> traverse firingTrigger occs
107 triggers <- catMaybes <$> traverse firingTrigger occs
102− fireEventsAndRead triggers readResult
108+ liftIO . evaluate . force =<< fireEventsAndRead triggers readResult
103−
104
109
105readEvent' :: MonadReadEvent t m => EventHandle t a -> m (Maybe a)
110readEvent' :: MonadReadEvent t m => EventHandle t a -> m (Maybe a)
106readEvent' = readEvent >=> sequenceA
111readEvent' = readEvent >=> sequenceA
107
112
108
113
109-- Convenience functions for running tests producing Events/Behaviors
114-- Convenience functions for running tests producing Events/Behaviors
110−runTestB :: (MonadReflexHost t m, MonadIORef m) => Plan t (Behavior t a) -> m (IntMap a)
115+runTestB :: (MonadReflexHost t m, MonadIORef m, NFData a) => Plan t (Behavior t a) -> m (IntMap a)
111runTestB p = do
116runTestB p = do
112 (b, s) <- runPlan p
117 (b, s) <- runPlan p
113 testSchedule s $ sample b
118 testSchedule s $ sample b
114
119
115−runTestE :: (MonadReflexHost t m, MonadIORef m) => Plan t (Event t a) -> m (IntMap (Maybe a))
120+runTestE :: (MonadReflexHost t m, MonadIORef m, NFData a) => Plan t (Event t a) -> m (IntMap (Maybe a))
116runTestE p = do
121runTestE p = do
117 (e, s) <- runPlan p
122 (e, s) <- runPlan p
118 h <- subscribeEvent e
123 h <- subscribeEvent e
test/Reflex/Pure.hs+85−5
@@ -4,7 +4,13 @@ of Reflex should produce the same results as this implementation, although perfo
4and laziness/strictness may differ.
4and laziness/strictness may differ.
5-}
5-}
6
6
7−{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, EmptyDataDecls, InstanceSigs #-}
7+{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, EmptyDataDecls, InstanceSigs, FlexibleInstances, ScopedTypeVariables #-}
8+
9+-- There are two expected orphan instances in this module:
10+-- * MonadSample (Pure t) ((->) t)
11+-- * MonadHold (Pure t) ((->) t)
12+{-# OPTIONS_GHC -fno-warn-orphans #-}
13+
8module Reflex.Pure where
14module Reflex.Pure where
9
15
10import Reflex.Class
16import Reflex.Class
@@ -13,6 +19,8 @@ import Data.Functor.Identity
13import Data.MemoTrie
19import Data.MemoTrie
14import Data.Dependent.Map (DMap, GCompare)
20import Data.Dependent.Map (DMap, GCompare)
15import qualified Data.Dependent.Map as DMap
21import qualified Data.Dependent.Map as DMap
22+import Control.Monad
23+import Data.Monoid
16
24
17data Pure t
25data Pure t
18
26
@@ -22,7 +30,9 @@ data Pure t
22instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where
30instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where
23
31
24 newtype Behavior (Pure t) a = Behavior { unBehavior :: t -> a }
32 newtype Behavior (Pure t) a = Behavior { unBehavior :: t -> a }
25− newtype Event (Pure t) a = Event { unEvent :: t -> Maybe a }
33+ newtype Event (Pure t) a = Event { unEvent :: t -> Maybe a }
34+ newtype Dynamic (Pure t) a = Dynamic { unDynamic :: t -> (a, Maybe a) }
35+ newtype Incremental (Pure t) p a = Incremental { unIncremental :: t -> (a, Maybe (p a)) }
26
36
27 type PushM (Pure t) = (->) t
37 type PushM (Pure t) = (->) t
28 type PullM (Pure t) = (->) t
38 type PullM (Pure t) = (->) t
@@ -39,7 +49,8 @@ instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where
39 pull :: PullM (Pure t) a -> Behavior (Pure t) a
49 pull :: PullM (Pure t) a -> Behavior (Pure t) a
40 pull = Behavior . memo
50 pull = Behavior . memo
41
51
52+ -- [UNUSED_CONSTRAINT]: The following type signature for merge will produce a warning because the GCompare instance is not used; however, removing the GCompare instance produces a different warning, due to that constraint being present in the original class definition
42− merge :: GCompare k => DMap k (Event (Pure t)) -> Event (Pure t) (DMap k Identity)
53+ --merge :: GCompare k => DMap k (Event (Pure t)) -> Event (Pure t) (DMap k Identity)
43 merge events = Event $ memo $ \t ->
54 merge events = Event $ memo $ \t ->
44 let currentOccurrences = unwrapDMapMaybe (($ t) . unEvent) events
55 let currentOccurrences = unwrapDMapMaybe (($ t) . unEvent) events
45 in if DMap.null currentOccurrences
56 in if DMap.null currentOccurrences
@@ -55,7 +66,56 @@ instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where
55 coincidence :: Event (Pure t) (Event (Pure t) a) -> Event (Pure t) a
66 coincidence :: Event (Pure t) (Event (Pure t) a) -> Event (Pure t) a
56 coincidence e = Event $ memo $ \t -> unEvent e t >>= \o -> unEvent o t
67 coincidence e = Event $ memo $ \t -> unEvent e t >>= \o -> unEvent o t
57
68
69+ current :: Dynamic (Pure t) a -> Behavior (Pure t) a
70+ current d = Behavior $ \t -> fst $ unDynamic d t
71+
72+ updated :: Dynamic (Pure t) a -> Event (Pure t) a
73+ updated d = Event $ \t -> snd $ unDynamic d t
74+
75+ unsafeBuildDynamic :: PullM (Pure t) a -> Event (Pure t) a -> Dynamic (Pure t) a
76+ unsafeBuildDynamic readV0 v' = Dynamic $ \t -> (readV0 t, unEvent v' t)
77+
78+ -- See UNUSED_CONSTRAINT, above.
79+ --unsafeBuildIncremental :: Patch p => PullM (Pure t) a -> Event (Pure t) (p a) -> Incremental (Pure t) p a
80+ unsafeBuildIncremental readV0 p = Incremental $ \t -> (readV0 t, unEvent p t)
81+
82+ mergeIncremental (Incremental f) = Event $ \t ->
83+ let results = DMap.mapMaybeWithKey (\_ (Event e) -> Identity <$> e t) $ fst $ f t
84+ in if DMap.null results
85+ then Nothing
86+ else Just results
87+
88+ currentIncremental (Incremental f) = Behavior $ \t -> fst $ f t
89+
90+ updatedIncremental (Incremental f) = Event $ \t -> snd $ f t
91+
92+ incrementalToDynamic (Incremental f) = Dynamic $ \t ->
93+ let (old, mPatch) = f t
94+ e = case mPatch of
95+ Nothing -> Nothing
96+ Just patch -> apply patch old
97+ in (old, e)
98+
99+instance Functor (Dynamic (Pure t)) where
100+ fmap f d = Dynamic $ \t -> let (cur, upd) = unDynamic d t
101+ in (f cur, fmap f upd)
102+
103+instance Applicative (Dynamic (Pure t)) where
104+ pure a = Dynamic $ \_ -> (a, Nothing)
105+ (<*>) = ap
106+
107+instance Monad (Dynamic (Pure t)) where
108+ return = pure
109+ (x :: Dynamic (Pure t) a) >>= (f :: a -> Dynamic (Pure t) b) = Dynamic $ \t ->
110+ let (curX :: a, updX :: Maybe a) = unDynamic x t
111+ (cur :: b, updOuter :: Maybe b) = unDynamic (f curX) t
112+ (updInner :: Maybe b, updBoth :: Maybe b) = case updX of
113+ Nothing -> (Nothing, Nothing)
114+ Just nextX -> let (c, u) = unDynamic (f nextX) t
115+ in (Just c, u)
116+ in (cur, getFirst $ mconcat $ map First [updBoth, updOuter, updInner])
117+
58−instance Ord t => MonadSample (Pure t) ((->) t) where
118+instance MonadSample (Pure t) ((->) t) where
59
119
60 sample :: Behavior (Pure t) a -> (t -> a)
120 sample :: Behavior (Pure t) a -> (t -> a)
61 sample = unBehavior
121 sample = unBehavior
@@ -72,4 +132,24 @@ instance (Enum t, HasTrie t, Ord t) => MonadHold (Pure t) ((->) t) where
72 else let lastTime = pred sampleTime
132 else let lastTime = pred sampleTime
73 in case unEvent e lastTime of
133 in case unEvent e lastTime of
74 Nothing -> f lastTime
134 Nothing -> f lastTime
75− Just x -> x
135+ Just x -> x
136+
137+ holdDyn :: a -> Event (Pure t) a -> (t -> (Dynamic (Pure t) a))
138+ holdDyn initialValue e initialTime =
139+ let Behavior f = hold initialValue e initialTime
140+ in Dynamic $ \t -> (f t, unEvent e t)
141+
142+ holdIncremental :: Patch p => a -> Event (Pure t) (p a) -> (t -> (Incremental (Pure t) p a))
143+ holdIncremental initialValue e initialTime = Incremental $ \t -> (f t, unEvent e t)
144+ where f = memo $ \sampleTime ->
145+ -- Really, the sampleTime should never be prior to the initialTime,
146+ -- because that would mean the Behavior is being sampled before being created.
147+ if sampleTime <= initialTime
148+ then initialValue
149+ else let lastTime = pred sampleTime
150+ lastValue = f lastTime
151+ in case unEvent e lastTime of
152+ Nothing -> lastValue
153+ Just x -> case apply x lastValue of
154+ Nothing -> lastValue
155+ Just v' -> v'
test/Reflex/Test/Micro.hs+9−50
@@ -5,7 +5,6 @@ module Reflex.Test.Micro (testCases) where
5import Reflex
5import Reflex
6import Reflex.TestPlan
6import Reflex.TestPlan
7
7
8−import Data.Word
9import Control.Monad
8import Control.Monad
10import Control.Applicative
9import Control.Applicative
11import Data.Char
10import Data.Char
@@ -14,7 +13,6 @@ import Data.Functor.Misc
14
13
15import Data.Foldable
14import Data.Foldable
16
15
17−import Data.Map (Map)
18import qualified Data.Map as Map
16import qualified Data.Map as Map
19
17
20import Prelude
18import Prelude
@@ -22,15 +20,15 @@ import Prelude
22testCases :: [(String, TestCase)]
20testCases :: [(String, TestCase)]
23testCases =
21testCases =
24 [ testB "hold" $ hold "0" =<< events1
22 [ testB "hold" $ hold "0" =<< events1
23+
25 , testB "count" $ do
24 , testB "count" $ do
26− b <- current <$> (count =<< events2)
25+ b <- current <$> (count =<< events2)
27− return $ (+ (0::Int)) <$> b
26+ return $ (+ (0::Int)) <$> b
28
27
29 , testB "pull-1" $ do
28 , testB "pull-1" $ do
30 b <- hold "0" =<< events1
29 b <- hold "0" =<< events1
31 return (id <$> id <$> b)
30 return (id <$> id <$> b)
32
31
33−
34 , testB "pull-2" $ do
32 , testB "pull-2" $ do
35 b1 <- behavior1
33 b1 <- behavior1
36 return (id <$> pull $ liftA2 (<>) (sample b1) (sample b1))
34 return (id <$> pull $ liftA2 (<>) (sample b1) (sample b1))
@@ -41,13 +39,11 @@ testCases =
41 return (id <$> pull $ liftA2 (<>) (sample b1) (sample b2))
39 return (id <$> pull $ liftA2 (<>) (sample b1) (sample b2))
42
40
43 , testB "pull-4" $ do
41 , testB "pull-4" $ do
44− es <- planList ["a", "b", "c"]
42+ es <- planList ["a", "b", "c"]
45− e <- plan [(0, ())]
43+ e <- plan [(0, ())]
46−
47− b <- hold (constant "") $
44+ b <- hold (constant "") $
48− pushAlways (const $ hold "z" es) e
45+ pushAlways (const $ hold "z" es) e
49−
50− return (join b)
46+ return (join b)
51
47
52 , testE "tag-1" $ do
48 , testE "tag-1" $ do
53 b1 <- behavior1
49 b1 <- behavior1
@@ -67,8 +63,8 @@ testCases =
67 , testE "leftmost" $ liftA2 leftmost2 events1 events2
63 , testE "leftmost" $ liftA2 leftmost2 events1 events2
68
64
69 , testE "appendEvents-1" $ liftA2 appendEvents events1 events2
65 , testE "appendEvents-1" $ liftA2 appendEvents events1 events2
70− , testE "appendEvents-2" $ liftA2 appendEvents events3 events2
71
66
67+ , testE "appendEvents-2" $ liftA2 appendEvents events3 events2
72
68
73 , testE "merge-1" $ do
69 , testE "merge-1" $ do
74 e <- events1
70 e <- events1
@@ -77,7 +73,6 @@ testCases =
77 , testE "merge-2" $ do
73 , testE "merge-2" $ do
78 e <- events1
74 e <- events1
79 let m = mergeMap $ Map.fromList [(1::Int, "y" <$ e), (2, "z" <$ e)]
75 let m = mergeMap $ Map.fromList [(1::Int, "y" <$ e), (2, "z" <$ e)]
80−
81 let ee = flip pushAlways e $ const $ return m
76 let ee = flip pushAlways e $ const $ return m
82 return $ coincidence ee
77 return $ coincidence ee
83
78
@@ -85,13 +80,11 @@ testCases =
85 e <- events1
80 e <- events1
86 onceE $ leftmost [e, e]
81 onceE $ leftmost [e, e]
87
82
88−
89 , testE "onceE-2" $ do
83 , testE "onceE-2" $ do
90 e <- events1
84 e <- events1
91 b <- hold never (e <$ e)
85 b <- hold never (e <$ e)
92 onceE $ switch b
86 onceE $ switch b
93
87
94−
95 , testE "switch-1" $ do
88 , testE "switch-1" $ do
96 e <- events1
89 e <- events1
97 b <- hold never (e <$ e)
90 b <- hold never (e <$ e)
@@ -111,7 +104,6 @@ testCases =
111 e <- events1
104 e <- events1
112 switch <$> hold (deep e) (e <$ e)
105 switch <$> hold (deep e) (e <$ e)
113
106
114−
115 , testE "switch-5" $ do
107 , testE "switch-5" $ do
116 e <- events1
108 e <- events1
117 return $ coincidence $ flip pushAlways e $ const $
109 return $ coincidence $ flip pushAlways e $ const $
@@ -122,7 +114,6 @@ testCases =
122 return $ coincidence $ flip pushAlways e $ const $ do
114 return $ coincidence $ flip pushAlways e $ const $ do
123 switch <$> hold ("x" <$ e) (e <$ e)
115 switch <$> hold ("x" <$ e) (e <$ e)
124
116
125−
126 , testE "switchPromptly-1" $ do
117 , testE "switchPromptly-1" $ do
127 e <- events1
118 e <- events1
128 let e' = e <$ e
119 let e' = e <$ e
@@ -246,20 +237,6 @@ testCases =
246 f <- fanMap <$> fmap toMap <$> events1
237 f <- fanMap <$> fmap toMap <$> events1
247 return $ toList <$> mergeList [ select f (Const2 'b'), select f (Const2 'b'), select f (Const2 'e'), select f (Const2 'e') ]
238 return $ toList <$> mergeList [ select f (Const2 'b'), select f (Const2 'b'), select f (Const2 'e'), select f (Const2 'e') ]
248
239
249− -- , testE "switchMerge-1" $ switchMergeMap mempty =<< increasing
250−
251− -- , testE "switchMerge-2" $ do
252− -- e <- eventsFrom 0
253− -- switchMergeMap (Map.singleton 0 e) =<< increasing
254−
255− -- , testE "switchMerge-3" $ do
256− -- es <- eventsMany
257− -- switchMergeMap es =<< increasing
258−
259− -- , testE "switchMerge-4" $ do
260− -- es <- eventsMany
261− -- switchMergeMap es =<< decreasing
262−
263 ] where
240 ] where
264
241
265 events1, events2, events3 :: TestPlan t m => m (Event t String)
242 events1, events2, events3 :: TestPlan t m => m (Event t String)
@@ -268,27 +245,9 @@ testCases =
268
245
269 events3 = liftA2 appendEvents events1 events2
246 events3 = liftA2 appendEvents events1 events2
270
247
271− eventsFrom :: TestPlan t m => Word -> m (Event t Int)
272− eventsFrom n = plan $ zip [n..8] [1..8]
273−
274− increasing :: TestPlan t m => m (Event t (Map Int (Event t Int)))
275− increasing = do
276− es <- mapM eventsFrom [1..8]
277− planList $ zipWith Map.singleton [1..8] es
278−
279− decreasing :: TestPlan t m => m (Event t (Map Int (Event t Int)))
280− decreasing = planList $ zipWith Map.singleton [1..8] (repeat never)
281−
282− eventsMany :: TestPlan t m => m (Map Int (Event t Int))
283− eventsMany = do
284− es <- mapM eventsFrom [8,7..1]
285− return $ Map.fromList $ zip [1..8] es
286−
287−
288 values = "abcde"
248 values = "abcde"
289 toMap str = Map.fromList $ map (\c -> (c, c)) str
249 toMap str = Map.fromList $ map (\c -> (c, c)) str
290
250
291−
292 behavior1, behavior2 :: forall t m. TestPlan t m => m (Behavior t String)
251 behavior1, behavior2 :: forall t m. TestPlan t m => m (Behavior t String)
293 behavior1 = hold "1" =<< events1
252 behavior1 = hold "1" =<< events1
294 behavior2 = hold "2" =<< events2
253 behavior2 = hold "2" =<< events2
test/Reflex/TestPlan.hs+5−4
@@ -13,6 +13,7 @@ module Reflex.TestPlan
13import Reflex.Class
13import Reflex.Class
14import Control.Monad.Fix
14import Control.Monad.Fix
15import Data.Word
15import Data.Word
16+import Control.DeepSeq
16
17
17
18
18import Prelude
19import Prelude
@@ -32,13 +33,13 @@ type TestE a = forall t m. TestPlan t m => m (Event t a)
32type TestB a = forall t m. TestPlan t m => m (Behavior t a)
33type TestB a = forall t m. TestPlan t m => m (Behavior t a)
33
34
34data TestCase where
35data TestCase where
35− TestE :: (Show a, Eq a) => TestE a -> TestCase
36+ TestE :: (Show a, Eq a, NFData a) => TestE a -> TestCase
36− TestB :: (Show a, Eq a) => TestB a -> TestCase
37+ TestB :: (Show a, Eq a, NFData a) => TestB a -> TestCase
37
38
38-- Helpers to declare test cases
39-- Helpers to declare test cases
39−testE :: (Eq a, Show a) => String -> TestE a -> (String, TestCase)
40+testE :: (Eq a, Show a, NFData a) => String -> TestE a -> (String, TestCase)
40testE name test = (name, TestE test)
41testE name test = (name, TestE test)
41
42
42−testB :: (Eq a, Show a) => String -> TestB a -> (String, TestCase)
43+testB :: (Eq a, Show a, NFData a) => String -> TestB a -> (String, TestCase)
43testB name test = (name, TestB test)
44testB name test = (name, TestB test)
44
45