git.iko.soy/reflex
on b3ad64a help sign in
90891e1
swap
8 ahead, 338 behind
ChangeLog.md+1−12
since splitsnapshots
unifiedsplit
@@ -16,23 +16,12 @@
16
16
17## 0.6.2.1
17## 0.6.2.1
18
18
19−* Generalize `fan` to `fanG` to take a `DMap` with non-`Identity`
20− functor:
21− * `fan` to `fanG`
22− * `EventSelectorG` for `fanG` result selector.
23−
24−* Reduce the amount of unsafeCoerce in coercing newtypes under Event/Dynamic/Behavior.
25− * Add fused ReaderIO for the purpose of coercion (ReaderT's third argument has nominal role preventing automated coerce)
26− * Add incrementalCoercion/coerceIncremental to go with dynamicCoercion/coerceDynamic
27−
28* Generalize merging functions:
19* Generalize merging functions:
29 `merge` to `mergeG`,
20 `merge` to `mergeG`,
30 `mergeIncremental` to `mergeIncrementalG`,
21 `mergeIncremental` to `mergeIncrementalG`,
22+ `distributeDMapOverDynPure` to `distributeDMapOverDynPureG`,
31 `mergeIncrementalWithMove` to `mergeIncrementalWithMoveG`.
23 `mergeIncrementalWithMove` to `mergeIncrementalWithMoveG`.
32
24
33−* Generalize distribute function:
34− `distributeDMapOverDynPure` to `distributeDMapOverDynPureG`,
35−
36## 0.6.2.0
25## 0.6.2.0
37
26
38* Fix `holdDyn` so that it is lazy in its event argument
27* Fix `holdDyn` so that it is lazy in its event argument
default.nix−1
@@ -23,7 +23,6 @@ mkDerivation {
23 base bifunctors containers deepseq dependent-map dependent-sum
23 base bifunctors containers deepseq dependent-map dependent-sum
24 mtl ref-tf split transformers data-default
24 mtl ref-tf split transformers data-default
25 random time unbounded-delays monoidal-containers witherable
25 random time unbounded-delays monoidal-containers witherable
26− profunctors
27 ] ++ (if ghc.isGhcjs or false then [
26 ] ++ (if ghc.isGhcjs or false then [
28 ghcjs-base
27 ghcjs-base
29 ] else []) ++ (if !useTemplateHaskell then [] else [
28 ] else []) ++ (if !useTemplateHaskell then [] else [
reflex.cabal+2−1
@@ -85,7 +85,6 @@ library
85 monoidal-containers == 0.4.0.0
85 monoidal-containers == 0.4.0.0
86
86
87 exposed-modules:
87 exposed-modules:
88− Control.Monad.ReaderIO
89 Data.AppendMap,
88 Data.AppendMap,
90 Data.FastMutableIntMap,
89 Data.FastMutableIntMap,
91 Data.FastWeakBag,
90 Data.FastWeakBag,
@@ -115,9 +114,11 @@ library
115 Reflex.Patch.Class,
114 Reflex.Patch.Class,
116 Reflex.Patch.DMap,
115 Reflex.Patch.DMap,
117 Reflex.Patch.DMapWithMove,
116 Reflex.Patch.DMapWithMove,
117+ Reflex.Patch.DMapWithReset,
118 Reflex.Patch.IntMap,
118 Reflex.Patch.IntMap,
119 Reflex.Patch.Map,
119 Reflex.Patch.Map,
120 Reflex.Patch.MapWithMove,
120 Reflex.Patch.MapWithMove,
121+ Reflex.Patch.Patchable,
121 Reflex.PerformEvent.Base,
122 Reflex.PerformEvent.Base,
122 Reflex.PerformEvent.Class,
123 Reflex.PerformEvent.Class,
123 Reflex.PostBuild.Base,
124 Reflex.PostBuild.Base,
src/Control/Monad/ReaderIO.hsdeleted−60
@@ -1,60 +0,0 @@
1−{-# language RoleAnnotations #-}
2−{-# language MultiParamTypeClasses #-}
3−{-# language FlexibleInstances #-}
4−{-# language CPP #-}
5−module Control.Monad.ReaderIO
6− (
7− ReaderIO (..)
8− )
9− where
10−
11−import Control.Monad.Fix
12−#if MIN_VERSION_base(4,10,0)
13−import Control.Applicative
14−#endif
15−import Control.Monad
16−import Control.Monad.Reader.Class
17−import Control.Monad.IO.Class
18−
19−-- | An approximate clone of @RIO@ from the @rio@ package, but not based on
20−-- @ReaderT@. The trouble with @ReaderT@ is that its third type argument has a
21−-- @nominal@ role, so we can't coerce through it when it's wrapped in some
22−-- other @data@ type. Ugh.
23−newtype ReaderIO e a = ReaderIO { runReaderIO :: e -> IO a }
24−type role ReaderIO representational representational
25−
26−instance Functor (ReaderIO e) where
27− fmap = liftM
28− {-# INLINE fmap #-}
29− a <$ m = m >> pure a
30− {-# INLINE (<$) #-}
31−
32−instance Applicative (ReaderIO e) where
33− pure a = ReaderIO $ \_ -> pure a
34− {-# INLINE pure #-}
35− (<*>) = ap
36− {-# INLINE (<*>) #-}
37−#if MIN_VERSION_base(4,10,0)
38− liftA2 = liftM2
39− {-# INLINE liftA2 #-}
40−#endif
41− (*>) = (>>)
42− {-# INLINE (*>) #-}
43−
44−instance Monad (ReaderIO e) where
45− ReaderIO q >>= f = ReaderIO $ \e -> q e >>= \a -> runReaderIO (f a) e
46− {-# INLINE (>>=) #-}
47−
48−instance MonadFix (ReaderIO e) where
49− mfix f = ReaderIO $ \e -> mfix $ \r -> runReaderIO (f r) e
50− {-# INLINE mfix #-}
51−
52−instance MonadIO (ReaderIO e) where
53− liftIO m = ReaderIO $ \_ -> m
54− {-# INLINE liftIO #-}
55−
56−instance MonadReader e (ReaderIO e) where
57− ask = ReaderIO pure
58− {-# INLINE ask #-}
59− local f (ReaderIO m) = ReaderIO (m . f)
60− {-# INLINE local #-}
src/Reflex/Class.hs+7−56
@@ -36,12 +36,10 @@ module Reflex.Class
36 , coerceBehavior
36 , coerceBehavior
37 , coerceEvent
37 , coerceEvent
38 , coerceDynamic
38 , coerceDynamic
39− , coerceIncremental
40 , MonadSample (..)
39 , MonadSample (..)
41 , MonadHold (..)
40 , MonadHold (..)
42 -- ** 'fan' related types
41 -- ** 'fan' related types
43 , EventSelector (..)
42 , EventSelector (..)
44− , EventSelectorG (..)
45 , EventSelectorInt (..)
43 , EventSelectorInt (..)
46 -- * Convenience functions
44 -- * Convenience functions
47 , constDyn
45 , constDyn
@@ -65,7 +63,6 @@ module Reflex.Class
65 , alignEventWithMaybe
63 , alignEventWithMaybe
66 -- ** Breaking up 'Event's
64 -- ** Breaking up 'Event's
67 , splitE
65 , splitE
68− , fan
69 , fanEither
66 , fanEither
70 , fanThese
67 , fanThese
71 , fanMap
68 , fanMap
@@ -90,7 +87,6 @@ module Reflex.Class
90 , gate
87 , gate
91 -- ** Combining 'Dynamic's
88 -- ** Combining 'Dynamic's
92 , distributeDMapOverDynPure
89 , distributeDMapOverDynPure
93− , distributeDMapOverDynPureG
94 , distributeListOverDyn
90 , distributeListOverDyn
95 , distributeListOverDynWith
91 , distributeListOverDynWith
96 , zipDyn
92 , zipDyn
@@ -273,16 +269,13 @@ class ( MonadHold t (PushM t)
273 -- | Merge a collection of events; the resulting 'Event' will only occur if at
269 -- | Merge a collection of events; the resulting 'Event' will only occur if at
274 -- least one input event is occurring, and will contain all of the input keys
270 -- least one input event is occurring, and will contain all of the input keys
275 -- that are occurring simultaneously
271 -- that are occurring simultaneously
276−
277− --TODO: Generalize to get rid of DMap use --TODO: Provide a type-level guarantee that the result is not empty
278 mergeG :: GCompare k => (forall a. q a -> Event t (v a))
272 mergeG :: GCompare k => (forall a. q a -> Event t (v a))
279 -> DMap k q -> Event t (DMap k v)
273 -> DMap k q -> Event t (DMap k v)
280−
274+ --TODO: Generalize to get rid of DMap use --TODO: Provide a type-level guarantee that the result is not empty
281 -- | Efficiently fan-out an event to many destinations. You should save the
275 -- | Efficiently fan-out an event to many destinations. You should save the
282− -- result in a @let@-binding, and then repeatedly 'selectG' on the result to
276+ -- result in a @let@-binding, and then repeatedly 'select' on the result to
283 -- create child events
277 -- create child events
284− fanG :: GCompare k => Event t (DMap k v) -> EventSelectorG t k v
278+ fan :: GCompare k => Event t (DMap k Identity) -> EventSelector t k
285−
286 -- | Create an 'Event' that will occur whenever the currently-selected input
279 -- | Create an 'Event' that will occur whenever the currently-selected input
287 -- 'Event' occurs
280 -- 'Event' occurs
288 switch :: Behavior t (Event t a) -> Event t a
281 switch :: Behavior t (Event t a) -> Event t a
@@ -323,25 +316,9 @@ class ( MonadHold t (PushM t)
323 -- | Construct a 'Coercion' for a 'Dynamic' given an 'Coercion' for its
316 -- | Construct a 'Coercion' for a 'Dynamic' given an 'Coercion' for its
324 -- occurrence type
317 -- occurrence type
325 dynamicCoercion :: Coercion a b -> Coercion (Dynamic t a) (Dynamic t b)
318 dynamicCoercion :: Coercion a b -> Coercion (Dynamic t a) (Dynamic t b)
326− -- | Construct a 'Coercion' for an 'Incremental' given 'Coercion's for its
327− -- patch target and patch types.
328− incrementalCoercion
329− :: Coercion (PatchTarget a) (PatchTarget b) -> Coercion a b -> Coercion (Incremental t a) (Incremental t b)
330 mergeIntIncremental :: Incremental t (PatchIntMap (Event t a)) -> Event t (IntMap a)
319 mergeIntIncremental :: Incremental t (PatchIntMap (Event t a)) -> Event t (IntMap a)
331 fanInt :: Event t (IntMap a) -> EventSelectorInt t a
320 fanInt :: Event t (IntMap a) -> EventSelectorInt t a
332
321
333−-- | Efficiently fan-out an event to many destinations. You should save the
334−-- result in a @let@-binding, and then repeatedly 'select' on the result to
335−-- create child events
336−fan :: forall t k. (Reflex t, GCompare k)
337− => Event t (DMap k Identity) -> EventSelector t k
338− --TODO: Can we help enforce the partial application discipline here? The combinator is worthless without it
339−fan e = EventSelector (fixup (selectG (fanG e) :: k a -> Event t (Identity a)) :: forall a. k a -> Event t a)
340− where
341− fixup :: forall a. (k a -> Event t (Identity a)) -> k a -> Event t a
342− fixup = case eventCoercion Coercion :: Coercion (Event t (Identity a)) (Event t a) of
343− Coercion -> coerce
344−
345--TODO: Specialize this so that we can take advantage of knowing that there's no changing going on
322--TODO: Specialize this so that we can take advantage of knowing that there's no changing going on
346-- | Constructs a single 'Event' out of a map of events. The output event may fire with multiple
323-- | Constructs a single 'Event' out of a map of events. The output event may fire with multiple
347-- keys simultaneously.
324-- keys simultaneously.
@@ -360,12 +337,6 @@ coerceEvent = coerceWith $ eventCoercion Coercion
360coerceDynamic :: (Reflex t, Coercible a b) => Dynamic t a -> Dynamic t b
337coerceDynamic :: (Reflex t, Coercible a b) => Dynamic t a -> Dynamic t b
361coerceDynamic = coerceWith $ dynamicCoercion Coercion
338coerceDynamic = coerceWith $ dynamicCoercion Coercion
362
339
363−-- | Coerce an 'Incremental' between representationally-equivalent value types
364−coerceIncremental
365− :: (Reflex t, Coercible a b, Coercible (PatchTarget a) (PatchTarget b))
366− => Incremental t a -> Incremental t b
367−coerceIncremental = coerceWith $ incrementalCoercion Coercion Coercion
368−
369-- | Construct a 'Dynamic' from a 'Behavior' and an 'Event'. The 'Behavior'
340-- | Construct a 'Dynamic' from a 'Behavior' and an 'Event'. The 'Behavior'
370-- __must__ change when and only when the 'Event' fires, such that the
341-- __must__ change when and only when the 'Event' fires, such that the
371-- 'Behavior''s value is always equal to the most recent firing of the 'Event';
342-- 'Behavior''s value is always equal to the most recent firing of the 'Event';
@@ -535,17 +506,6 @@ newtype EventSelector t k = EventSelector
535 select :: forall a. k a -> Event t a
506 select :: forall a. k a -> Event t a
536 }
507 }
537
508
538−newtype EventSelectorG t k v = EventSelectorG
539− { -- | Retrieve the 'Event' for the given key. The type of the 'Event' is
540− -- determined by the type of the key, so this can be used to fan-out
541− -- 'Event's whose sub-'Event's have different types.
542− --
543− -- Using 'EventSelector's and the 'fan' primitive is far more efficient than
544− -- (but equivalent to) using 'mapMaybe' to select only the relevant
545− -- occurrences of an 'Event'.
546− selectG :: forall a. k a -> Event t (v a)
547− }
548−
549-- | Efficiently select an 'Event' keyed on 'Int'. This is more efficient than manually
509-- | Efficiently select an 'Event' keyed on 'Int'. This is more efficient than manually
550-- filtering by key.
510-- filtering by key.
551newtype EventSelectorInt t a = EventSelectorInt { selectInt :: Int -> Event t a }
511newtype EventSelectorInt t a = EventSelectorInt { selectInt :: Int -> Event t a }
@@ -1138,21 +1098,12 @@ instance (Reflex t, Monoid a) => Monoid (Dynamic t a) where
1138-- 'Dynamic' 'DMap'. Its implementation is more efficient than doing the same
1098-- 'Dynamic' 'DMap'. Its implementation is more efficient than doing the same
1139-- through the use of multiple uses of 'zipDynWith' or 'Applicative' operators.
1099-- through the use of multiple uses of 'zipDynWith' or 'Applicative' operators.
1140distributeDMapOverDynPure :: forall t k. (Reflex t, GCompare k) => DMap k (Dynamic t) -> Dynamic t (DMap k Identity)
1100distributeDMapOverDynPure :: forall t k. (Reflex t, GCompare k) => DMap k (Dynamic t) -> Dynamic t (DMap k Identity)
1141−distributeDMapOverDynPure = distributeDMapOverDynPureG coerceDynamic
1101+distributeDMapOverDynPure dm = case DMap.toList dm of
1142−
1143−-- | This function converts a 'DMap' whose elements are 'Dynamic's into a
1144−-- 'Dynamic' 'DMap'. Its implementation is more efficient than doing the same
1145−-- through the use of multiple uses of 'zipDynWith' or 'Applicative' operators.
1146−distributeDMapOverDynPureG
1147− :: forall t k q v. (Reflex t, GCompare k)
1148− => (forall a. q a -> Dynamic t (v a))
1149− -> DMap k q -> Dynamic t (DMap k v)
1150−distributeDMapOverDynPureG nt dm = case DMap.toList dm of
1151 [] -> constDyn DMap.empty
1102 [] -> constDyn DMap.empty
1152− [k :=> v] -> DMap.singleton k <$> nt v
1103+ [k :=> v] -> fmap (DMap.singleton k . Identity) v
1153 _ ->
1104 _ ->
1154− let getInitial = DMap.traverseWithKey (\_ -> sample . current . nt) dm
1105+ let getInitial = DMap.traverseWithKey (\_ -> fmap Identity . sample . current) dm
1155− edmPre = mergeG getCompose $ DMap.map (Compose . updated . nt) dm
1106+ edmPre = merge $ DMap.map updated dm
1156 result = unsafeBuildDynamic getInitial $ flip pushAlways edmPre $ \news -> do
1107 result = unsafeBuildDynamic getInitial $ flip pushAlways edmPre $ \news -> do
1157 olds <- sample $ current result
1108 olds <- sample $ current result
1158 return $ DMap.unionWithKey (\_ _ new -> new) olds news
1109 return $ DMap.unionWithKey (\_ _ new -> new) olds news
src/Reflex/Patch/DMapWithReset.hsnew file+120
@@ -0,0 +1,120 @@
1+{-# LANGUAGE FlexibleContexts #-}
2+{-# LANGUAGE FlexibleInstances #-}
3+{-# LANGUAGE LambdaCase #-}
4+{-# LANGUAGE MultiParamTypeClasses #-}
5+{-# LANGUAGE PolyKinds #-}
6+{-# LANGUAGE Rank2Types #-}
7+{-# LANGUAGE ScopedTypeVariables #-}
8+{-# LANGUAGE StandaloneDeriving #-}
9+{-# LANGUAGE TypeApplications #-}
10+{-# LANGUAGE TypeFamilies #-}
11+{-# LANGUAGE UndecidableInstances #-}
12+
13+{-# OPTIONS_GHC -Wall #-}
14+
15+-- | 'Patch'es on 'DMap' that consist only of insertions (or overwrites) and deletions.
16+module Reflex.Patch.DMapWithReset where
17+
18+import Reflex.Patch.Class
19+
20+import Data.Dependent.Map (DMap, GCompare (..))
21+import qualified Data.Dependent.Map as DMap
22+import Data.Semigroup (Semigroup (..))
23+import Data.Constraint.Extras
24+
25+-- | A set of changes to a 'DMap'. Any element may be inserted/updated or deleted.
26+-- Insertions are represented as @'ComposeMaybe' (Just value)@,
27+-- while deletions are represented as @'ComposeMaybe' Nothing@.
28+newtype PatchDMapWithReset k p = PatchDMapWithReset { unPatchDMapWithReset :: DMap k (By p) }
29+
30+-- | Holds the information about each key: where its new value should come from,
31+-- and where its old value should go to
32+data By p a
33+ = By_Insert (PatchTarget (p a)) -- ^ Insert the given value here
34+ | By_Delete -- ^ Delete the existing value, if any, from here
35+ | By_Patch (p a) -- ^ Patch the value here with the given patch
36+
37+instance (Semigroup (p a), Patch (p a)) => Semigroup (By p a) where
38+ x@(By_Insert _) <> _ = x
39+ By_Delete <> _ = By_Delete
40+ By_Patch x <> By_Insert y = By_Insert (applyAlways x y)
41+ By_Patch x <> By_Patch y = By_Patch (x <> y)
42+ By_Patch _ <> By_Delete = By_Delete
43+
44+instance (Monoid (p a), Patch (p a)) => Monoid (By p a) where
45+ mappend = (<>)
46+ mempty = By_Patch mempty
47+
48+instance
49+ ( GCompare k
50+ , Has' Semigroup k p
51+ , Has' Patch k p
52+ )
53+ => Semigroup (PatchDMapWithReset k p) where
54+ PatchDMapWithReset xs <> PatchDMapWithReset ys = PatchDMapWithReset $ DMap.unionWithKey
55+ (\k -> has' @Patch @p k
56+ $ has' @Semigroup @p k
57+ $ (<>)) xs ys
58+
59+instance
60+ ( GCompare k
61+ , Has' Semigroup k p
62+ , Has' Patch k p
63+ )
64+ => Monoid (PatchDMapWithReset k p) where
65+ mappend = (<>)
66+ mempty = PatchDMapWithReset DMap.empty
67+
68+class (Patch (p a), PatchTarget (p a) ~ Patches1LocallyTarget p a) => Patches1Locally p a where
69+ type Patches1LocallyTarget p :: k -> *
70+
71+data These1 f g x
72+ = This1 (f x)
73+ | That1 (g x)
74+ | These1 (f x) (g x)
75+
76+mergeWithKey
77+ :: forall k v1 v2 v.
78+ (GCompare k)
79+ => (forall x. k x -> v1 x -> Maybe (v x))
80+ -> (forall x. k x -> v2 x -> Maybe (v x))
81+ -> (forall x. k x -> v1 x -> v2 x -> Maybe (v x))
82+ -> DMap k v1 -> DMap k v2 -> DMap k v
83+mergeWithKey f g fg = \xs ys -> DMap.mapMaybeWithKey onlyThat $ DMap.unionWithKey doIt (DMap.map This1 xs) (DMap.map That1 ys)
84+ where
85+ doIt _ (This1 xs) (That1 ys) = These1 xs ys
86+ doIt _ _ _ = error "mergeWithKey misalligned keys"
87+
88+ onlyThat :: forall x. k x -> These1 v1 v2 x -> Maybe (v x)
89+ onlyThat k = \case
90+ This1 xs -> f k xs
91+ That1 ys -> g k ys
92+ These1 xs ys -> fg k xs ys
93+{-# INLINE mergeWithKey #-}
94+
95+-- | Apply the insertions or deletions to a given 'DMap'.
96+instance (GCompare k, Has (Patches1Locally p) k) => Patch (PatchDMapWithReset k p) where
97+
98+ type PatchTarget (PatchDMapWithReset k p) = DMap k (Patches1LocallyTarget p)
99+
100+ apply = go
101+ where
102+ go :: PatchDMapWithReset k p -> DMap k (Patches1LocallyTarget p) -> Maybe (DMap k (Patches1LocallyTarget p))
103+ go (PatchDMapWithReset diff) old = Just $! mergeWithKey (\_ -> Just) inserts updates old diff
104+ where
105+ updates :: forall x. k x -> Patches1LocallyTarget p x -> By p x -> Maybe (Patches1LocallyTarget p x)
106+ updates k ys = has @(Patches1Locally p) k $ \case
107+ By_Insert x -> Just x
108+ By_Delete -> Nothing
109+ By_Patch x -> Just $ applyAlways x ys
110+
111+ inserts :: forall x. k x -> By p x -> Maybe (Patches1LocallyTarget p x)
112+ inserts k = has @(Patches1Locally p) k $ \case
113+ By_Insert x -> Just x
114+ By_Delete -> Nothing
115+ By_Patch _ -> Nothing
116+
117+deriving instance (Patch (p a), Eq (p a), Eq (PatchTarget (p a))) => Eq (By p a)
118+deriving instance (Patch (p a), Show (p a), Show (PatchTarget (p a))) => Show (By p a)
119+deriving instance (Eq (DMap k (By p))) => Eq (PatchDMapWithReset k p)
120+deriving instance (Show (DMap k (By p))) => Show (PatchDMapWithReset k p)
src/Reflex/Patch/Patchable.hsnew file+44
@@ -0,0 +1,44 @@
1+{-# LANGUAGE DeriveGeneric #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE LambdaCase #-}
4+{-# LANGUAGE StandaloneDeriving #-}
5+{-# LANGUAGE TypeFamilies #-}
6+
7+-- The derived instances are undecidable in the case of a pathological instance like
8+-- instance Patch x where
9+-- type PatchTarget x = Patchable x
10+{-# LANGUAGE UndecidableInstances #-}
11+
12+module Reflex.Patch.Patchable where
13+
14+-- import Data.Aeson
15+import GHC.Generics
16+import Reflex.Patch
17+
18+-- | Like SemiMap/PartialMap but for anything patchable
19+data Patchable p
20+ = Patchable_Patch p
21+ | Patchable_Complete (PatchTarget p)
22+ deriving (Generic)
23+
24+completePatchable :: Patchable p -> Maybe (PatchTarget p)
25+completePatchable = \case
26+ Patchable_Complete t -> Just t
27+ Patchable_Patch _ -> Nothing
28+
29+deriving instance (Eq p, Eq (PatchTarget p)) => Eq (Patchable p)
30+deriving instance (Ord p, Ord (PatchTarget p)) => Ord (Patchable p)
31+deriving instance (Show p, Show (PatchTarget p)) => Show (Patchable p)
32+deriving instance (Read p, Read (PatchTarget p)) => Read (Patchable p)
33+-- instance (ToJSON p, ToJSON (PatchTarget p)) => ToJSON (Patchable p)
34+-- instance (FromJSON p, FromJSON (PatchTarget p)) => FromJSON (Patchable p)
35+
36+instance (Monoid p, Patch p) => Monoid (Patchable p) where
37+ mempty = Patchable_Patch mempty
38+ mappend = (<>)
39+
40+instance (Semigroup p, Patch p) => Semigroup (Patchable p) where
41+ (<>) = curry $ \case
42+ (Patchable_Patch a, Patchable_Patch b) -> Patchable_Patch $ a <> b
43+ (Patchable_Patch a, Patchable_Complete b) -> Patchable_Complete $ applyAlways a b
44+ (Patchable_Complete a, _) -> Patchable_Complete a
src/Reflex/Profiled.hs+8−12
@@ -9,7 +9,6 @@
9{-# LANGUAGE TypeFamilies #-}
9{-# LANGUAGE TypeFamilies #-}
10{-# LANGUAGE UndecidableInstances #-}
10{-# LANGUAGE UndecidableInstances #-}
11{-# LANGUAGE PolyKinds #-}
11{-# LANGUAGE PolyKinds #-}
12−{-# LANGUAGE TypeApplications #-}
13{-# LANGUAGE RankNTypes #-}
12{-# LANGUAGE RankNTypes #-}
14-- |
13-- |
15-- Module:
14-- Module:
@@ -136,11 +135,11 @@ instance Reflex t => Reflex (ProfiledTimeline t) where
136 push f (Event_Profiled e) = coerce $ push (coerce f) $ profileEvent e -- Profile before rather than after; this way fanout won't count against us
135 push f (Event_Profiled e) = coerce $ push (coerce f) $ profileEvent e -- Profile before rather than after; this way fanout won't count against us
137 pushCheap f (Event_Profiled e) = coerce $ pushCheap (coerce f) $ profileEvent e
136 pushCheap f (Event_Profiled e) = coerce $ pushCheap (coerce f) $ profileEvent e
138 pull = Behavior_Profiled . pull . coerce
137 pull = Behavior_Profiled . pull . coerce
139− fanG (Event_Profiled e) = EventSelectorG $ coerce $ selectG (fanG $ profileEvent e)
140 mergeG :: forall (k :: z -> *) q v. GCompare k
138 mergeG :: forall (k :: z -> *) q v. GCompare k
141 => (forall a. q a -> Event (ProfiledTimeline t) (v a))
139 => (forall a. q a -> Event (ProfiledTimeline t) (v a))
142 -> DMap k q -> Event (ProfiledTimeline t) (DMap k v)
140 -> DMap k q -> Event (ProfiledTimeline t) (DMap k v)
143 mergeG nt = Event_Profiled #. mergeG (coerce nt)
141 mergeG nt = Event_Profiled #. mergeG (coerce nt)
142+ fan (Event_Profiled e) = EventSelector $ coerce $ select (fan $ profileEvent e)
144 switch (Behavior_Profiled b) = coerce $ profileEvent $ switch (coerceBehavior b)
143 switch (Behavior_Profiled b) = coerce $ profileEvent $ switch (coerceBehavior b)
145 coincidence (Event_Profiled e) = coerce $ profileEvent $ coincidence (coerceEvent e)
144 coincidence (Event_Profiled e) = coerce $ profileEvent $ coincidence (coerceEvent e)
146 current (Dynamic_Profiled d) = coerce $ current d
145 current (Dynamic_Profiled d) = coerce $ current d
@@ -152,16 +151,13 @@ instance Reflex t => Reflex (ProfiledTimeline t) where
152 currentIncremental (Incremental_Profiled i) = coerce $ currentIncremental i
151 currentIncremental (Incremental_Profiled i) = coerce $ currentIncremental i
153 updatedIncremental (Incremental_Profiled i) = coerce $ profileEvent $ updatedIncremental i
152 updatedIncremental (Incremental_Profiled i) = coerce $ profileEvent $ updatedIncremental i
154 incrementalToDynamic (Incremental_Profiled i) = coerce $ incrementalToDynamic i
153 incrementalToDynamic (Incremental_Profiled i) = coerce $ incrementalToDynamic i
155− behaviorCoercion c =
154+ behaviorCoercion (c :: Coercion a b) = case behaviorCoercion c :: Coercion (Behavior t a) (Behavior t b) of
156− Coercion `trans` behaviorCoercion @t c `trans` Coercion
155+ Coercion -> unsafeCoerce (Coercion :: Coercion (Behavior (ProfiledTimeline t) a) (Behavior (ProfiledTimeline t) a)) --TODO: Figure out how to make this typecheck without the unsafeCoerce
157− eventCoercion c =
156+ eventCoercion (c :: Coercion a b) = case eventCoercion c :: Coercion (Event t a) (Event t b) of
158− Coercion `trans` eventCoercion @t c `trans` Coercion
157+ Coercion -> unsafeCoerce (Coercion :: Coercion (Event (ProfiledTimeline t) a) (Event (ProfiledTimeline t) a)) --TODO: Figure out how to make this typecheck without the unsafeCoerce
159− dynamicCoercion c =
158+ dynamicCoercion (c :: Coercion a b) = case dynamicCoercion c :: Coercion (Dynamic t a) (Dynamic t b) of
160− Coercion `trans` dynamicCoercion @t c `trans` Coercion
159+ Coercion -> unsafeCoerce (Coercion :: Coercion (Dynamic (ProfiledTimeline t) a) (Dynamic (ProfiledTimeline t) a)) --TODO: Figure out how to make this typecheck without the unsafeCoerce
161− incrementalCoercion c d =
162− Coercion `trans` incrementalCoercion @t c d `trans` Coercion
163− mergeIntIncremental = Event_Profiled . mergeIntIncremental .
160+ mergeIntIncremental = Event_Profiled . mergeIntIncremental . (unsafeCoerce :: Incremental (ProfiledTimeline t) (PatchIntMap (Event (ProfiledTimeline t) a)) -> Incremental t (PatchIntMap (Event t a)))
164− coerceWith (Coercion `trans` incrementalCoercion Coercion Coercion `trans` Coercion)
165 fanInt (Event_Profiled e) = coerce $ fanInt $ profileEvent e
161 fanInt (Event_Profiled e) = coerce $ fanInt $ profileEvent e
166
162
167deriving instance Functor (Dynamic t) => Functor (Dynamic (ProfiledTimeline t))
163deriving instance Functor (Dynamic t) => Functor (Dynamic (ProfiledTimeline t))
src/Reflex/Pure.hs+3−5
@@ -7,7 +7,6 @@
7{-# LANGUAGE TypeFamilies #-}
7{-# LANGUAGE TypeFamilies #-}
8{-# LANGUAGE RankNTypes #-}
8{-# LANGUAGE RankNTypes #-}
9{-# LANGUAGE PolyKinds #-}
9{-# LANGUAGE PolyKinds #-}
10−
11#ifdef USE_REFLEX_OPTIMIZER
10#ifdef USE_REFLEX_OPTIMIZER
12{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
11{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
13#endif
12#endif
@@ -34,6 +33,7 @@ module Reflex.Pure
34import Control.Monad
33import Control.Monad
35import Data.Dependent.Map (DMap, GCompare)
34import Data.Dependent.Map (DMap, GCompare)
36import qualified Data.Dependent.Map as DMap
35import qualified Data.Dependent.Map as DMap
36+import Data.Functor.Identity
37import Data.IntMap (IntMap)
37import Data.IntMap (IntMap)
38import qualified Data.IntMap as IntMap
38import qualified Data.IntMap as IntMap
39import Data.Maybe
39import Data.Maybe
@@ -88,9 +88,8 @@ instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where
88 then Nothing
88 then Nothing
89 else Just currentOccurrences
89 else Just currentOccurrences
90
90
91−-- The instance signature doeesn't compile, leave commented for documentation
92−-- fanG :: GCompare k => Event (Pure t) (DMap k v) -> EventSelectorG (Pure t) k v
91+ fan :: GCompare k => Event (Pure t) (DMap k Identity) -> EventSelector (Pure t) k
93− fanG e = EventSelectorG $ \k -> Event $ \t -> unEvent e t >>= DMap.lookup k
92+ fan e = EventSelector $ \k -> Event $ \t -> unEvent e t >>= fmap runIdentity . DMap.lookup k
94
93
95 switch :: Behavior (Pure t) (Event (Pure t) a) -> Event (Pure t) a
94 switch :: Behavior (Pure t) (Event (Pure t) a) -> Event (Pure t) a
96 switch b = Event $ memo $ \t -> unEvent (unBehavior b t) t
95 switch b = Event $ memo $ \t -> unEvent (unBehavior b t) t
@@ -129,7 +128,6 @@ instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where
129 behaviorCoercion Coercion = Coercion
128 behaviorCoercion Coercion = Coercion
130 eventCoercion Coercion = Coercion
129 eventCoercion Coercion = Coercion
131 dynamicCoercion Coercion = Coercion
130 dynamicCoercion Coercion = Coercion
132− incrementalCoercion Coercion Coercion = Coercion
133
131
134 fanInt e = EventSelectorInt $ \k -> Event $ \t -> unEvent e t >>= IntMap.lookup k
132 fanInt e = EventSelectorInt $ \k -> Event $ \t -> unEvent e t >>= IntMap.lookup k
135
133
src/Reflex/Spider/Internal.hs+114−141
@@ -17,10 +17,7 @@
17{-# LANGUAGE TypeOperators #-}
17{-# LANGUAGE TypeOperators #-}
18{-# LANGUAGE UndecidableInstances #-}
18{-# LANGUAGE UndecidableInstances #-}
19{-# LANGUAGE PolyKinds #-}
19{-# LANGUAGE PolyKinds #-}
20−{-# LANGUAGE DeriveFunctor #-}
21−{-# LANGUAGE StandaloneDeriving #-}
22{-# LANGUAGE InstanceSigs #-}
20{-# LANGUAGE InstanceSigs #-}
23−
24#ifdef USE_REFLEX_OPTIMIZER
21#ifdef USE_REFLEX_OPTIMIZER
25{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
22{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
26#endif
23#endif
@@ -38,10 +35,7 @@ import Control.Monad hiding (forM, forM_, mapM, mapM_)
38import Control.Monad.Exception
35import Control.Monad.Exception
39import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_)
36import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_)
40import Control.Monad.Primitive
37import Control.Monad.Primitive
41−--import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_)
38+import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_)
42−import Control.Monad.Reader.Class
43−import Control.Monad.IO.Class
44−import Control.Monad.ReaderIO
45import Control.Monad.Ref
39import Control.Monad.Ref
46import Data.Align
40import Data.Align
47import Data.Coerce
41import Data.Coerce
@@ -211,6 +205,12 @@ nextNodeIdRef = unsafePerformIO $ newIORef 1
211
205
212newNodeId :: IO Int
206newNodeId :: IO Int
213newNodeId = atomicModifyIORef' nextNodeIdRef $ \n -> (succ n, n)
207newNodeId = atomicModifyIORef' nextNodeIdRef $ \n -> (succ n, n)
208+
209+{-# NOINLINE unsafeNodeId #-}
210+unsafeNodeId :: a -> Int
211+unsafeNodeId a = unsafePerformIO $ do
212+ touch a
213+ newNodeId
214#endif
214#endif
215
215
216--------------------------------------------------------------------------------
216--------------------------------------------------------------------------------
@@ -314,10 +314,9 @@ cacheEvent e =
314#else
314#else
315 Event $
315 Event $
316#endif
316#endif
317− unsafePerformIO $ do
318− mSubscribedRef :: IORef (FastWeak (CacheSubscribed x a))
317+ let mSubscribedRef :: IORef (FastWeak (CacheSubscribed x a))
319− <- newIORef emptyFastWeak
318+ !mSubscribedRef = unsafeNewIORef e emptyFastWeak
320− pure $ \sub -> {-# SCC "cacheEvent" #-} do
319+ in \sub -> {-# SCC "cacheEvent" #-} do
321#ifdef DEBUG_TRACE_EVENTS
320#ifdef DEBUG_TRACE_EVENTS
322 unless (BS8.null callSite) $ liftIO $ BS8.hPutStrLn stderr callSite
321 unless (BS8.null callSite) $ liftIO $ BS8.hPutStrLn stderr callSite
323#endif
322#endif
@@ -383,7 +382,7 @@ eventRoot !k !r = Event $ wrap eventSubscribedRoot $ liftIO . getRootSubscribed
383eventNever :: Event x a
382eventNever :: Event x a
384eventNever = Event $ \_ -> return (EventSubscription (return ()) eventSubscribedNever, Nothing)
383eventNever = Event $ \_ -> return (EventSubscription (return ()) eventSubscribedNever, Nothing)
385
384
386−eventFan :: (GCompare k, HasSpiderTimeline x) => k a -> Fan x k v -> Event x (v a)
385+eventFan :: (GCompare k, HasSpiderTimeline x) => k a -> Fan x k -> Event x a
387eventFan !k !f = Event $ wrap eventSubscribedFan $ getFanSubscribed k f
386eventFan !k !f = Event $ wrap eventSubscribedFan $ getFanSubscribed k f
388
387
389eventSwitch :: HasSpiderTimeline x => Switch x a -> Event x a
388eventSwitch :: HasSpiderTimeline x => Switch x a -> Event x a
@@ -435,14 +434,14 @@ newSubscriberHold h = return $ Subscriber
435 , subscriberRecalculateHeight = \_ -> return ()
434 , subscriberRecalculateHeight = \_ -> return ()
436 }
435 }
437
436
438−newSubscriberFan :: forall x k v. (HasSpiderTimeline x, GCompare k) => FanSubscribed x k v -> IO (Subscriber x (DMap k v))
437+newSubscriberFan :: forall x k. (HasSpiderTimeline x, GCompare k) => FanSubscribed x k -> IO (Subscriber x (DMap k Identity))
439newSubscriberFan subscribed = return $ Subscriber
438newSubscriberFan subscribed = return $ Subscriber
440 { subscriberPropagate = \a -> {-# SCC "traverseFan" #-} do
439 { subscriberPropagate = \a -> {-# SCC "traverseFan" #-} do
441 subs <- liftIO $ readIORef $ fanSubscribedSubscribers subscribed
440 subs <- liftIO $ readIORef $ fanSubscribedSubscribers subscribed
442 tracePropagate (Proxy :: Proxy x) $ "SubscriberFan" <> showNodeId subscribed <> ": " ++ show (DMap.size subs) ++ " keys subscribed, " ++ show (DMap.size a) ++ " keys firing"
441 tracePropagate (Proxy :: Proxy x) $ "SubscriberFan" <> showNodeId subscribed <> ": " ++ show (DMap.size subs) ++ " keys subscribed, " ++ show (DMap.size a) ++ " keys firing"
443 liftIO $ writeIORef (fanSubscribedOccurrence subscribed) $ Just a
442 liftIO $ writeIORef (fanSubscribedOccurrence subscribed) $ Just a
444 scheduleClear $ fanSubscribedOccurrence subscribed
443 scheduleClear $ fanSubscribedOccurrence subscribed
445− let f _ (Pair v subsubs) = do
444+ let f _ (Pair (Identity v) subsubs) = do
446 propagate v $ _fanSubscribedChildren_list subsubs
445 propagate v $ _fanSubscribedChildren_list subsubs
447 return $ Constant ()
446 return $ Constant ()
448 _ <- DMap.traverseWithKey f $ DMap.intersectionWithKey (\_ -> Pair) a subs --TODO: Would be nice to have DMap.traverse_
447 _ <- DMap.traverseWithKey f $ DMap.intersectionWithKey (\_ -> Pair) a subs --TODO: Would be nice to have DMap.traverse_
@@ -558,11 +557,6 @@ propagateFast a subscribers = withIncreasedDepth $ do
558toAny :: a -> Any
557toAny :: a -> Any
559toAny = unsafeCoerce
558toAny = unsafeCoerce
560
559
561−-- Why do we use Any here, instead of just giving eventSubscribedRetained an
562−-- existential type? Sadly, GHC does not currently know how to unbox types
563−-- with existentially quantified fields. So instead we just coerce values
564−-- to type Any on the way in. Since we never coerce them back, this is
565−-- perfectly safe.
566data EventSubscribed x = EventSubscribed
560data EventSubscribed x = EventSubscribed
567 { eventSubscribedHeightRef :: {-# UNPACK #-} !(IORef Height)
561 { eventSubscribedHeightRef :: {-# UNPACK #-} !(IORef Height)
568 , eventSubscribedRetained :: {-# NOUNPACK #-} !Any
562 , eventSubscribedRetained :: {-# NOUNPACK #-} !Any
@@ -595,7 +589,7 @@ eventSubscribedNever = EventSubscribed
595#endif
589#endif
596 }
590 }
597
591
598−eventSubscribedFan :: FanSubscribed x k v -> EventSubscribed x
592+eventSubscribedFan :: FanSubscribed x k -> EventSubscribed x
599eventSubscribedFan !subscribed = EventSubscribed
593eventSubscribedFan !subscribed = EventSubscribed
600 { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ fanSubscribedParent subscribed
594 { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ fanSubscribedParent subscribed
601 , eventSubscribedRetained = toAny subscribed
595 , eventSubscribedRetained = toAny subscribed
@@ -686,7 +680,7 @@ behaviorPull !p = Behavior $ do
686 wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorPull"
680 wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorPull"
687 parentsRef <- liftIO $ newIORef []
681 parentsRef <- liftIO $ newIORef []
688 holdInits <- askBehaviorHoldInits
682 holdInits <- askBehaviorHoldInits
689− a <- liftIO $ runReaderIO (unBehaviorM $ pullCompute p) (Just (wi, parentsRef), holdInits)
683+ a <- liftIO $ runReaderT (unBehaviorM $ pullCompute p) (Just (wi, parentsRef), holdInits)
690 invsRef <- liftIO . newIORef . maybeToList =<< askInvalidator
684 invsRef <- liftIO . newIORef . maybeToList =<< askInvalidator
691 parents <- liftIO $ readIORef parentsRef
685 parents <- liftIO $ readIORef parentsRef
692 let subscribed = PullSubscribed
686 let subscribed = PullSubscribed
@@ -721,46 +715,42 @@ readBehaviorUntracked b = do
721-- Dynamic
715-- Dynamic
722--------------------------------------------------------------------------------
716--------------------------------------------------------------------------------
723
717
724−type DynamicS x p = Dynamic x (PatchTarget p) p
725−
726−data Dynamic x target p = Dynamic
718+data Dynamic x p = Dynamic
727− { dynamicCurrent :: !(Behavior x target)
719+ { dynamicCurrent :: !(Behavior x (PatchTarget p))
728 , dynamicUpdated :: Event x p -- This must be lazy; see the comment on holdEvent --TODO: Would this let us eliminate `Dyn`?
720 , dynamicUpdated :: Event x p -- This must be lazy; see the comment on holdEvent --TODO: Would this let us eliminate `Dyn`?
729 }
721 }
730
722
731−deriving instance (HasSpiderTimeline x) => Functor (Dynamic x target)
732−
733−
734−
735−
736−dynamicHold :: Hold x p -> DynamicS x p
723+dynamicHold :: Hold x p -> Dynamic x p
737dynamicHold !h = Dynamic
724dynamicHold !h = Dynamic
738 { dynamicCurrent = behaviorHold h
725 { dynamicCurrent = behaviorHold h
739 , dynamicUpdated = eventHold h
726 , dynamicUpdated = eventHold h
740 }
727 }
741
728
742−dynamicHoldIdentity :: Hold x (Identity a) -> DynamicS x (Identity a)
729+dynamicHoldIdentity :: Hold x (Identity a) -> Dynamic x (Identity a)
743dynamicHoldIdentity = dynamicHold
730dynamicHoldIdentity = dynamicHold
744
731
745−dynamicConst :: PatchTarget p -> DynamicS x p
732+dynamicConst :: PatchTarget p -> Dynamic x p
746dynamicConst !a = Dynamic
733dynamicConst !a = Dynamic
747 { dynamicCurrent = behaviorConst a
734 { dynamicCurrent = behaviorConst a
748 , dynamicUpdated = eventNever
735 , dynamicUpdated = eventNever
749 }
736 }
750
737
751−dynamicDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> DynamicS x p
738+dynamicDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> Dynamic x p
752dynamicDyn !d = Dynamic
739dynamicDyn !d = Dynamic
753 { dynamicCurrent = behaviorDyn d
740 { dynamicCurrent = behaviorDyn d
754 , dynamicUpdated = eventDyn d
741 , dynamicUpdated = eventDyn d
755 }
742 }
756
743
757−dynamicDynIdentity :: HasSpiderTimeline x => Dyn x (Identity a) -> DynamicS x (Identity a)
744+dynamicDynIdentity :: HasSpiderTimeline x => Dyn x (Identity a) -> Dynamic x (Identity a)
758dynamicDynIdentity = dynamicDyn
745dynamicDynIdentity = dynamicDyn
759
746
760--------------------------------------------------------------------------------
747--------------------------------------------------------------------------------
761-- Combinators
748-- Combinators
762--------------------------------------------------------------------------------
749--------------------------------------------------------------------------------
763
750
751+--TODO: Figure out why certain things are not 'representational', then make them
752+--representational so we can use coerce
753+
764--type role Hold representational
754--type role Hold representational
765data Hold x p
755data Hold x p
766 = Hold { holdValue :: !(IORef (PatchTarget p))
756 = Hold { holdValue :: !(IORef (PatchTarget p))
@@ -781,25 +771,20 @@ globalSpiderTimelineEnv = unsafePerformIO unsafeNewSpiderTimelineEnv
781
771
782-- | Stores all global data relevant to a particular Spider timeline; only one
772-- | Stores all global data relevant to a particular Spider timeline; only one
783-- value should exist for each type @x@
773-- value should exist for each type @x@
784−newtype SpiderTimelineEnv x = STE {unSTE :: SpiderTimelineEnv' x}
785−-- We implement SpiderTimelineEnv with a newtype wrapper so
786−-- we can get the coercions we want safely.
787−type role SpiderTimelineEnv nominal
788−
789−data SpiderTimelineEnv' x = SpiderTimelineEnv
774+data SpiderTimelineEnv x = SpiderTimelineEnv
790 { _spiderTimeline_lock :: {-# UNPACK #-} !(MVar ())
775 { _spiderTimeline_lock :: {-# UNPACK #-} !(MVar ())
791 , _spiderTimeline_eventEnv :: {-# UNPACK #-} !(EventEnv x)
776 , _spiderTimeline_eventEnv :: {-# UNPACK #-} !(EventEnv x)
792#ifdef DEBUG
777#ifdef DEBUG
793 , _spiderTimeline_depth :: {-# UNPACK #-} !(IORef Int)
778 , _spiderTimeline_depth :: {-# UNPACK #-} !(IORef Int)
794#endif
779#endif
795 }
780 }
796−type role SpiderTimelineEnv' phantom
781+type role SpiderTimelineEnv nominal
797
782
798instance Eq (SpiderTimelineEnv x) where
783instance Eq (SpiderTimelineEnv x) where
799 _ == _ = True -- Since only one exists of each type
784 _ == _ = True -- Since only one exists of each type
800
785
801instance GEq SpiderTimelineEnv where
786instance GEq SpiderTimelineEnv where
802− a `geq` b = if _spiderTimeline_lock (unSTE a) == _spiderTimeline_lock (unSTE b)
787+ a `geq` b = if _spiderTimeline_lock a == _spiderTimeline_lock b
803 then Just $ unsafeCoerce Refl -- This unsafeCoerce is safe because the same SpiderTimelineEnv can't have two different 'x' arguments
788 then Just $ unsafeCoerce Refl -- This unsafeCoerce is safe because the same SpiderTimelineEnv can't have two different 'x' arguments
804 else Nothing
789 else Nothing
805
790
@@ -822,7 +807,7 @@ runEventM :: EventM x a -> IO a
822runEventM = unEventM
807runEventM = unEventM
823
808
824asksEventEnv :: forall x a. HasSpiderTimeline x => (EventEnv x -> a) -> EventM x a
809asksEventEnv :: forall x a. HasSpiderTimeline x => (EventEnv x -> a) -> EventM x a
825−asksEventEnv f = return $ f $ _spiderTimeline_eventEnv (unSTE (spiderTimeline :: SpiderTimelineEnv x))
810+asksEventEnv f = return $ f $ _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimelineEnv x)
826
811
827class MonadIO m => Defer a m where
812class MonadIO m => Defer a m where
828 getDeferralQueue :: m (IORef [a])
813 getDeferralQueue :: m (IORef [a])
@@ -960,9 +945,9 @@ getHoldEventSubscription h = do
960
945
961type BehaviorEnv x = (Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]), IORef [SomeHoldInit x])
946type BehaviorEnv x = (Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]), IORef [SomeHoldInit x])
962
947
948+--type role BehaviorM representational
963-- BehaviorM can sample behaviors
949-- BehaviorM can sample behaviors
964−newtype BehaviorM x a = BehaviorM { unBehaviorM :: ReaderIO (BehaviorEnv x) a }
950+newtype BehaviorM x a = BehaviorM { unBehaviorM :: ReaderT (BehaviorEnv x) IO a } deriving (Functor, Applicative, MonadIO, MonadFix)
965− deriving (Functor, Applicative, MonadIO, MonadFix, MonadReader (BehaviorEnv x))
966
951
967instance Monad (BehaviorM x) where
952instance Monad (BehaviorM x) where
968 {-# INLINE (>>=) #-}
953 {-# INLINE (>>=) #-}
@@ -1013,7 +998,7 @@ data RootSubscribed x a = forall k. GCompare k => RootSubscribed
1013#endif
998#endif
1014 }
999 }
1015
1000
1016−data Root x k
1001+data Root x (k :: * -> *)
1017 = Root { rootOccurrence :: !(IORef (DMap k Identity)) -- The currently-firing occurrence of this event
1002 = Root { rootOccurrence :: !(IORef (DMap k Identity)) -- The currently-firing occurrence of this event
1018 , rootSubscribed :: !(IORef (DMap k (RootSubscribed x)))
1003 , rootSubscribed :: !(IORef (DMap k (RootSubscribed x)))
1019 , rootInit :: !(forall a. k a -> RootTrigger x a -> IO (IO ()))
1004 , rootInit :: !(forall a. k a -> RootTrigger x a -> IO (IO ()))
@@ -1083,25 +1068,25 @@ heightBagVerify b@(HeightBag s c) = if
1083heightBagVerify = id
1068heightBagVerify = id
1084#endif
1069#endif
1085
1070
1086−data FanSubscribedChildren x k v a = FanSubscribedChildren
1071+data FanSubscribedChildren (x :: *) k a = FanSubscribedChildren
1087− { _fanSubscribedChildren_list :: !(WeakBag (Subscriber x (v a)))
1072+ { _fanSubscribedChildren_list :: !(WeakBag (Subscriber x a))
1088− , _fanSubscribedChildren_self :: {-# NOUNPACK #-} !(k a, FanSubscribed x k v)
1073+ , _fanSubscribedChildren_self :: {-# NOUNPACK #-} !(k a, FanSubscribed x k)
1089− , _fanSubscribedChildren_weakSelf :: !(IORef (Weak (k a, FanSubscribed x k v)))
1074+ , _fanSubscribedChildren_weakSelf :: !(IORef (Weak (k a, FanSubscribed x k)))
1090 }
1075 }
1091
1076
1092−data FanSubscribed x k v
1077+data FanSubscribed (x :: *) k
1093− = FanSubscribed { fanSubscribedCachedSubscribed :: !(IORef (Maybe (FanSubscribed x k v)))
1078+ = FanSubscribed { fanSubscribedCachedSubscribed :: !(IORef (Maybe (FanSubscribed x k)))
1094− , fanSubscribedOccurrence :: !(IORef (Maybe (DMap k v)))
1079+ , fanSubscribedOccurrence :: !(IORef (Maybe (DMap k Identity)))
1095− , fanSubscribedSubscribers :: !(IORef (DMap k (FanSubscribedChildren x k v))) -- This DMap should never be empty
1080+ , fanSubscribedSubscribers :: !(IORef (DMap k (FanSubscribedChildren x k))) -- This DMap should never be empty
1096 , fanSubscribedParent :: !(EventSubscription x)
1081 , fanSubscribedParent :: !(EventSubscription x)
1097#ifdef DEBUG_NODEIDS
1082#ifdef DEBUG_NODEIDS
1098 , fanSubscribedNodeId :: Int
1083 , fanSubscribedNodeId :: Int
1099#endif
1084#endif
1100 }
1085 }
1101
1086
1102−data Fan x k v
1087+data Fan x k
1103− = Fan { fanParent :: !(Event x (DMap k v))
1088+ = Fan { fanParent :: !(Event x (DMap k Identity))
1104− , fanSubscribed :: !(IORef (Maybe (FanSubscribed x k v)))
1089+ , fanSubscribed :: !(IORef (Maybe (FanSubscribed x k)))
1105 }
1090 }
1106
1091
1107data SwitchSubscribed x a
1092data SwitchSubscribed x a
@@ -1179,11 +1164,11 @@ data DynType x p = UnsafeDyn !(BehaviorM x (PatchTarget p), Event x p)
1179
1164
1180newtype Dyn (x :: Type) p = Dyn { unDyn :: IORef (DynType x p) }
1165newtype Dyn (x :: Type) p = Dyn { unDyn :: IORef (DynType x p) }
1181
1166
1182−newMapDyn :: HasSpiderTimeline x => (a -> b) -> DynamicS x (Identity a) -> DynamicS x (Identity b)
1167+newMapDyn :: HasSpiderTimeline x => (a -> b) -> Dynamic x (Identity a) -> Dynamic x (Identity b)
1183newMapDyn f d = dynamicDynIdentity $ unsafeBuildDynamic (fmap f $ readBehaviorTracked $ dynamicCurrent d) (Identity . f . runIdentity <$> dynamicUpdated d)
1168newMapDyn f d = dynamicDynIdentity $ unsafeBuildDynamic (fmap f $ readBehaviorTracked $ dynamicCurrent d) (Identity . f . runIdentity <$> dynamicUpdated d)
1184
1169
1185--TODO: Avoid the duplication between this and R.zipDynWith
1170--TODO: Avoid the duplication between this and R.zipDynWith
1186−zipDynWith :: HasSpiderTimeline x => (a -> b -> c) -> DynamicS x (Identity a) -> DynamicS x (Identity b) -> DynamicS x (Identity c)
1171+zipDynWith :: HasSpiderTimeline x => (a -> b -> c) -> Dynamic x (Identity a) -> Dynamic x (Identity b) -> Dynamic x (Identity c)
1187zipDynWith f da db =
1172zipDynWith f da db =
1188 let eab = align (dynamicUpdated da) (dynamicUpdated db)
1173 let eab = align (dynamicUpdated da) (dynamicUpdated db)
1189 ec = flip push eab $ \o -> do
1174 ec = flip push eab $ \o -> do
@@ -1206,12 +1191,18 @@ buildDynamic readV0 v' = do
1206 return d
1191 return d
1207
1192
1208unsafeBuildDynamic :: BehaviorM x (PatchTarget p) -> Event x p -> Dyn x p
1193unsafeBuildDynamic :: BehaviorM x (PatchTarget p) -> Event x p -> Dyn x p
1209−unsafeBuildDynamic readV0 v' =
1194+unsafeBuildDynamic readV0 v' = Dyn $ unsafeNewIORef x $ UnsafeDyn x
1210− Dyn $ unsafePerformIO $ newIORef $ UnsafeDyn (readV0, v')
1195+ where x = (readV0, v')
1211
1196
1212-- ResultM can read behaviors and events
1197-- ResultM can read behaviors and events
1213type ResultM = EventM
1198type ResultM = EventM
1214
1199
1200+{-# NOINLINE unsafeNewIORef #-}
1201+unsafeNewIORef :: a -> b -> IORef b
1202+unsafeNewIORef a b = unsafePerformIO $ do
1203+ touch a
1204+ newIORef b
1205+
1215instance HasSpiderTimeline x => Functor (Event x) where
1206instance HasSpiderTimeline x => Functor (Event x) where
1216 fmap f = push $ return . Just . f
1207 fmap f = push $ return . Just . f
1217
1208
@@ -1224,42 +1215,33 @@ push f e = cacheEvent (pushCheap f e)
1224
1215
1225{-# INLINABLE pull #-}
1216{-# INLINABLE pull #-}
1226pull :: BehaviorM x a -> Behavior x a
1217pull :: BehaviorM x a -> Behavior x a
1227−pull a = unsafePerformIO $ do
1218+pull a = behaviorPull $ Pull
1228− ref <- newIORef Nothing
1219+ { pullCompute = a
1220+ , pullValue = unsafeNewIORef a Nothing
1229#ifdef DEBUG_NODEIDS
1221#ifdef DEBUG_NODEIDS
1230− nid <- newNodeId
1222+ , pullNodeId = unsafeNodeId a
1231#endif
1223#endif
1232− pure $ behaviorPull $ Pull
1233− { pullCompute = a
1234− , pullValue = ref
1235−#ifdef DEBUG_NODEIDS
1236− , pullNodeId = nid
1237−#endif
1238− }
1224+ }
1239
1225
1240{-# INLINABLE switch #-}
1226{-# INLINABLE switch #-}
1241switch :: HasSpiderTimeline x => Behavior x (Event x a) -> Event x a
1227switch :: HasSpiderTimeline x => Behavior x (Event x a) -> Event x a
1242−switch a = unsafePerformIO $ do
1243− ref <- newIORef Nothing
1244− pure $ eventSwitch $ Switch
1228+switch a = eventSwitch $ Switch
1245− { switchParent = a
1229+ { switchParent = a
1246− , switchSubscribed = ref
1230+ , switchSubscribed = unsafeNewIORef a Nothing
1247− }
1231+ }
1248
1232
1249coincidence :: HasSpiderTimeline x => Event x (Event x a) -> Event x a
1233coincidence :: HasSpiderTimeline x => Event x (Event x a) -> Event x a
1250−coincidence a = unsafePerformIO $ do
1251− ref <- newIORef Nothing
1252− pure $ eventCoincidence $ Coincidence
1234+coincidence a = eventCoincidence $ Coincidence
1253− { coincidenceParent = a
1235+ { coincidenceParent = a
1254− , coincidenceSubscribed = ref
1236+ , coincidenceSubscribed = unsafeNewIORef a Nothing
1255− }
1237+ }
1256
1238
1257-- Propagate the given event occurrence; before cleaning up, run the given action, which may read the state of events and behaviors
1239-- Propagate the given event occurrence; before cleaning up, run the given action, which may read the state of events and behaviors
1258run :: forall x b. HasSpiderTimeline x => [DSum (RootTrigger x) Identity] -> ResultM x b -> SpiderHost x b
1240run :: forall x b. HasSpiderTimeline x => [DSum (RootTrigger x) Identity] -> ResultM x b -> SpiderHost x b
1259run roots after = do
1241run roots after = do
1260 tracePropagate (Proxy :: Proxy x) $ "Running an event frame with " <> show (length roots) <> " events"
1242 tracePropagate (Proxy :: Proxy x) $ "Running an event frame with " <> show (length roots) <> " events"
1261 let t = spiderTimeline :: SpiderTimelineEnv x
1243 let t = spiderTimeline :: SpiderTimelineEnv x
1262− result <- SpiderHost $ withMVar (_spiderTimeline_lock (unSTE t)) $ \_ -> unSpiderHost $ runFrame $ do
1244+ result <- SpiderHost $ withMVar (_spiderTimeline_lock t) $ \_ -> unSpiderHost $ runFrame $ do
1263 rootsToPropagate <- forM roots $ \r@(RootTrigger (_, occRef, k) :=> a) -> do
1245 rootsToPropagate <- forM roots $ \r@(RootTrigger (_, occRef, k) :=> a) -> do
1264 occBefore <- liftIO $ do
1246 occBefore <- liftIO $ do
1265 occBefore <- readIORef occRef
1247 occBefore <- readIORef occRef
@@ -1323,9 +1305,9 @@ type WeakList a = [Weak a]
1323withIncreasedDepth :: CanTrace x m => m a -> m a
1305withIncreasedDepth :: CanTrace x m => m a -> m a
1324withIncreasedDepth a = do
1306withIncreasedDepth a = do
1325 spiderTimeline <- askSpiderTimelineEnv
1307 spiderTimeline <- askSpiderTimelineEnv
1326− liftIO $ modifyIORef' (_spiderTimeline_depth (unSTE spiderTimeline)) succ
1308+ liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) succ
1327 result <- a
1309 result <- a
1328− liftIO $ modifyIORef' (_spiderTimeline_depth (unSTE spiderTimeline)) pred
1310+ liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) pred
1329 return result
1311 return result
1330#else
1312#else
1331withIncreasedDepth :: m a -> m a
1313withIncreasedDepth :: m a -> m a
@@ -1352,7 +1334,7 @@ traceMWhen _ b getMessage = when b $ do
1352 message <- getMessage
1334 message <- getMessage
1353#ifdef DEBUG
1335#ifdef DEBUG
1354 spiderTimeline <- askSpiderTimelineEnv
1336 spiderTimeline <- askSpiderTimelineEnv
1355− d <- liftIO $ readIORef $ _spiderTimeline_depth $ unSTE spiderTimeline
1337+ d <- liftIO $ readIORef $ _spiderTimeline_depth spiderTimeline
1356#else
1338#else
1357 let d = 0
1339 let d = 0
1358#endif
1340#endif
@@ -1393,25 +1375,25 @@ propagateSubscriberHold h a = do
1393data SomeResetCoincidence x = forall a. SomeResetCoincidence !(EventSubscription x) !(Maybe (CoincidenceSubscribed x a)) -- The CoincidenceSubscriber will be present only if heights need to be reset
1375data SomeResetCoincidence x = forall a. SomeResetCoincidence !(EventSubscription x) !(Maybe (CoincidenceSubscribed x a)) -- The CoincidenceSubscriber will be present only if heights need to be reset
1394
1376
1395runBehaviorM :: BehaviorM x a -> Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]) -> IORef [SomeHoldInit x] -> IO a
1377runBehaviorM :: BehaviorM x a -> Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]) -> IORef [SomeHoldInit x] -> IO a
1396−runBehaviorM a mwi holdInits = runReaderIO (unBehaviorM a) (mwi, holdInits)
1378+runBehaviorM a mwi holdInits = runReaderT (unBehaviorM a) (mwi, holdInits)
1397
1379
1398askInvalidator :: BehaviorM x (Maybe (Weak (Invalidator x)))
1380askInvalidator :: BehaviorM x (Maybe (Weak (Invalidator x)))
1399askInvalidator = do
1381askInvalidator = do
1400− (!m, _) <- ask
1382+ (!m, _) <- BehaviorM ask
1401 case m of
1383 case m of
1402 Nothing -> return Nothing
1384 Nothing -> return Nothing
1403 Just (!wi, _) -> return $ Just wi
1385 Just (!wi, _) -> return $ Just wi
1404
1386
1405askParentsRef :: BehaviorM x (Maybe (IORef [SomeBehaviorSubscribed x]))
1387askParentsRef :: BehaviorM x (Maybe (IORef [SomeBehaviorSubscribed x]))
1406askParentsRef = do
1388askParentsRef = do
1407− (!m, _) <- ask
1389+ (!m, _) <- BehaviorM ask
1408 case m of
1390 case m of
1409 Nothing -> return Nothing
1391 Nothing -> return Nothing
1410 Just (_, !p) -> return $ Just p
1392 Just (_, !p) -> return $ Just p
1411
1393
1412askBehaviorHoldInits :: BehaviorM x (IORef [SomeHoldInit x])
1394askBehaviorHoldInits :: BehaviorM x (IORef [SomeHoldInit x])
1413askBehaviorHoldInits = do
1395askBehaviorHoldInits = do
1414− (_, !his) <- ask
1396+ (_, !his) <- BehaviorM ask
1415 return his
1397 return his
1416
1398
1417{-# INLINE getDynHold #-}
1399{-# INLINE getDynHold #-}
@@ -1456,9 +1438,6 @@ getRootSubscribed k r sub = do
1456 when debugPropagate $ putStrLn $ "getRootSubscribed: calling rootInit"
1438 when debugPropagate $ putStrLn $ "getRootSubscribed: calling rootInit"
1457 uninit <- rootInit r k $ RootTrigger (subs, rootOccurrence r, k)
1439 uninit <- rootInit r k $ RootTrigger (subs, rootOccurrence r, k)
1458 writeIORef uninitRef $! uninit
1440 writeIORef uninitRef $! uninit
1459−#ifdef DEBUG_NODEIDS
1460− nid <- newNodeId
1461−#endif
1462 let !subscribed = RootSubscribed
1441 let !subscribed = RootSubscribed
1463 { rootSubscribedKey = k
1442 { rootSubscribedKey = k
1464 , rootSubscribedCachedSubscribed = cached
1443 , rootSubscribedCachedSubscribed = cached
@@ -1467,7 +1446,7 @@ getRootSubscribed k r sub = do
1467 , rootSubscribedUninit = uninit
1446 , rootSubscribedUninit = uninit
1468 , rootSubscribedWeakSelf = weakSelf
1447 , rootSubscribedWeakSelf = weakSelf
1469#ifdef DEBUG_NODEIDS
1448#ifdef DEBUG_NODEIDS
1470− , rootSubscribedNodeId = nid
1449+ , rootSubscribedNodeId = unsafeNodeId (k, r, subs)
1471#endif
1450#endif
1472 }
1451 }
1473 -- If we die at the same moment that all our children die, they will
1452 -- If we die at the same moment that all our children die, they will
@@ -1516,10 +1495,16 @@ newFanInt = do
1516 , _fanInt_occRef = occRef
1495 , _fanInt_occRef = occRef
1517 }
1496 }
1518
1497
1498+{-# NOINLINE unsafeNewFanInt #-}
1499+unsafeNewFanInt :: b -> FanInt x a
1500+unsafeNewFanInt b = unsafePerformIO $ do
1501+ touch b
1502+ newFanInt
1503+
1519fanInt :: HasSpiderTimeline x => Event x (IntMap a) -> EventSelectorInt x a
1504fanInt :: HasSpiderTimeline x => Event x (IntMap a) -> EventSelectorInt x a
1520−fanInt p = unsafePerformIO $ do
1505+fanInt p =
1521− self <- newFanInt
1506+ let self = unsafeNewFanInt p
1522− pure $ EventSelectorInt $ \k -> Event $ \sub -> do
1507+ in EventSelectorInt $ \k -> Event $ \sub -> do
1523 isEmpty <- liftIO $ FastMutableIntMap.isEmpty (_fanInt_subscribers self)
1508 isEmpty <- liftIO $ FastMutableIntMap.isEmpty (_fanInt_subscribers self)
1524 when isEmpty $ do -- This is the first subscriber, so we need to subscribe to our input
1509 when isEmpty $ do -- This is the first subscriber, so we need to subscribe to our input
1525 (subscription, parentOcc) <- subscribeAndRead p $ Subscriber
1510 (subscription, parentOcc) <- subscribeAndRead p $ Subscriber
@@ -1555,7 +1540,7 @@ fanInt p = unsafePerformIO $ do
1555 return (EventSubscription (FastWeakBag.remove t) $! EventSubscribed heightRef $! toAny (_fanInt_subscriptionRef self, t), IntMap.lookup k currentOcc)
1540 return (EventSubscription (FastWeakBag.remove t) $! EventSubscribed heightRef $! toAny (_fanInt_subscriptionRef self, t), IntMap.lookup k currentOcc)
1556
1541
1557{-# INLINABLE getFanSubscribed #-}
1542{-# INLINABLE getFanSubscribed #-}
1558−getFanSubscribed :: (HasSpiderTimeline x, GCompare k) => k a -> Fan x k v -> Subscriber x (v a) -> EventM x (WeakBagTicket, FanSubscribed x k v, Maybe (v a))
1543+getFanSubscribed :: (HasSpiderTimeline x, GCompare k) => k a -> Fan x k -> Subscriber x a -> EventM x (WeakBagTicket, FanSubscribed x k, Maybe a)
1559getFanSubscribed k f sub = do
1544getFanSubscribed k f sub = do
1560 mSubscribed <- liftIO $ readIORef $ fanSubscribed f
1545 mSubscribed <- liftIO $ readIORef $ fanSubscribed f
1561 case mSubscribed of
1546 case mSubscribed of
@@ -1573,16 +1558,13 @@ getFanSubscribed k f sub = do
1573 subscribersRef <- liftIO $ newIORef $ error "getFanSubscribed: subscribersRef not yet initialized"
1558 subscribersRef <- liftIO $ newIORef $ error "getFanSubscribed: subscribersRef not yet initialized"
1574 occRef <- liftIO $ newIORef parentOcc
1559 occRef <- liftIO $ newIORef parentOcc
1575 when (isJust parentOcc) $ scheduleClear occRef
1560 when (isJust parentOcc) $ scheduleClear occRef
1576−#ifdef DEBUG_NODEIDS
1577− nid <- liftIO newNodeId
1578−#endif
1579 let subscribed = FanSubscribed
1561 let subscribed = FanSubscribed
1580 { fanSubscribedCachedSubscribed = fanSubscribed f
1562 { fanSubscribedCachedSubscribed = fanSubscribed f
1581 , fanSubscribedOccurrence = occRef
1563 , fanSubscribedOccurrence = occRef
1582 , fanSubscribedParent = subscription
1564 , fanSubscribedParent = subscription
1583 , fanSubscribedSubscribers = subscribersRef
1565 , fanSubscribedSubscribers = subscribersRef
1584#ifdef DEBUG_NODEIDS
1566#ifdef DEBUG_NODEIDS
1585− , fanSubscribedNodeId = nid
1567+ , fanSubscribedNodeId = unsafeNodeId f
1586#endif
1568#endif
1587 }
1569 }
1588 let !self = (k, subscribed)
1570 let !self = (k, subscribed)
@@ -1592,7 +1574,7 @@ getFanSubscribed k f sub = do
1592 liftIO $ writeIORef (fanSubscribed f) $ Just subscribed
1574 liftIO $ writeIORef (fanSubscribed f) $ Just subscribed
1593 return (slnForSub, subscribed, coerce $ DMap.lookup k =<< parentOcc)
1575 return (slnForSub, subscribed, coerce $ DMap.lookup k =<< parentOcc)
1594
1576
1595−cleanupFanSubscribed :: GCompare k => (k a, FanSubscribed x k v) -> IO ()
1577+cleanupFanSubscribed :: GCompare k => (k a, FanSubscribed x k) -> IO ()
1596cleanupFanSubscribed (k, subscribed) = do
1578cleanupFanSubscribed (k, subscribed) = do
1597 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1579 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1598 let reducedSubscribers = DMap.delete k subscribers
1580 let reducedSubscribers = DMap.delete k subscribers
@@ -1604,7 +1586,7 @@ cleanupFanSubscribed (k, subscribed) = do
1604 else writeIORef (fanSubscribedSubscribers subscribed) $! reducedSubscribers
1586 else writeIORef (fanSubscribedSubscribers subscribed) $! reducedSubscribers
1605
1587
1606{-# INLINE subscribeFanSubscribed #-}
1588{-# INLINE subscribeFanSubscribed #-}
1607−subscribeFanSubscribed :: GCompare k => k a -> FanSubscribed x k v -> Subscriber x (v a) -> IO WeakBagTicket
1589+subscribeFanSubscribed :: GCompare k => k a -> FanSubscribed x k -> Subscriber x a -> IO WeakBagTicket
1608subscribeFanSubscribed k subscribed sub = do
1590subscribeFanSubscribed k subscribed sub = do
1609 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1591 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1610 case DMap.lookup k subscribers of
1592 case DMap.lookup k subscribers of
@@ -1642,9 +1624,6 @@ getSwitchSubscribed s sub = do
1642 when (isJust parentOcc) $ scheduleClear occRef
1624 when (isJust parentOcc) $ scheduleClear occRef
1643 weakSelf <- liftIO $ newIORef $ error "getSwitchSubscribed: weakSelf not yet initialized"
1625 weakSelf <- liftIO $ newIORef $ error "getSwitchSubscribed: weakSelf not yet initialized"
1644 (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupSwitchSubscribed
1626 (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupSwitchSubscribed
1645−#ifdef DEBUG_NODEIDS
1646− nid <- liftIO newNodeId
1647−#endif
1648 let !subscribed = SwitchSubscribed
1627 let !subscribed = SwitchSubscribed
1649 { switchSubscribedCachedSubscribed = switchSubscribed s
1628 { switchSubscribedCachedSubscribed = switchSubscribed s
1650 , switchSubscribedOccurrence = occRef
1629 , switchSubscribedOccurrence = occRef
@@ -1657,7 +1636,7 @@ getSwitchSubscribed s sub = do
1657 , switchSubscribedCurrentParent = subscriptionRef
1636 , switchSubscribedCurrentParent = subscriptionRef
1658 , switchSubscribedWeakSelf = weakSelf
1637 , switchSubscribedWeakSelf = weakSelf
1659#ifdef DEBUG_NODEIDS
1638#ifdef DEBUG_NODEIDS
1660− , switchSubscribedNodeId = nid
1639+ , switchSubscribedNodeId = unsafeNodeId s
1661#endif
1640#endif
1662 }
1641 }
1663 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "switchSubscribedWeakSelf"
1642 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "switchSubscribedWeakSelf"
@@ -1702,9 +1681,6 @@ getCoincidenceSubscribed c sub = do
1702 scheduleClear innerSubdRef
1681 scheduleClear innerSubdRef
1703 weakSelf <- liftIO $ newIORef $ error "getCoincidenceSubscribed: weakSelf not yet implemented"
1682 weakSelf <- liftIO $ newIORef $ error "getCoincidenceSubscribed: weakSelf not yet implemented"
1704 (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupCoincidenceSubscribed
1683 (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupCoincidenceSubscribed
1705−#ifdef DEBUG_NODEIDS
1706− nid <- liftIO newNodeId
1707−#endif
1708 let subscribed = CoincidenceSubscribed
1684 let subscribed = CoincidenceSubscribed
1709 { coincidenceSubscribedCachedSubscribed = coincidenceSubscribed c
1685 { coincidenceSubscribedCachedSubscribed = coincidenceSubscribed c
1710 , coincidenceSubscribedOccurrence = occRef
1686 , coincidenceSubscribedOccurrence = occRef
@@ -1715,7 +1691,7 @@ getCoincidenceSubscribed c sub = do
1715 , coincidenceSubscribedInnerParent = innerSubdRef
1691 , coincidenceSubscribedInnerParent = innerSubdRef
1716 , coincidenceSubscribedWeakSelf = weakSelf
1692 , coincidenceSubscribedWeakSelf = weakSelf
1717#ifdef DEBUG_NODEIDS
1693#ifdef DEBUG_NODEIDS
1718− , coincidenceSubscribedNodeId = nid
1694+ , coincidenceSubscribedNodeId = unsafeNodeId c
1719#endif
1695#endif
1720 }
1696 }
1721 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "CoincidenceSubscribed"
1697 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "CoincidenceSubscribed"
@@ -1735,20 +1711,20 @@ subscribeCoincidenceSubscribed subscribed sub = WeakBag.insert sub (coincidenceS
1735{-# INLINE mergeG #-}
1711{-# INLINE mergeG #-}
1736mergeG :: forall k q x v. (HasSpiderTimeline x, GCompare k)
1712mergeG :: forall k q x v. (HasSpiderTimeline x, GCompare k)
1737 => (forall a. q a -> Event x (v a))
1713 => (forall a. q a -> Event x (v a))
1738− -> DynamicS x (PatchDMap k q) -> Event x (DMap k v)
1714+ -> Dynamic x (PatchDMap k q) -> Event x (DMap k v)
1739mergeG nt d = cacheEvent (mergeCheap nt d)
1715mergeG nt d = cacheEvent (mergeCheap nt d)
1740
1716
1741{-# INLINE mergeWithMove #-}
1717{-# INLINE mergeWithMove #-}
1742mergeWithMove :: forall k v q x. (HasSpiderTimeline x, GCompare k)
1718mergeWithMove :: forall k v q x. (HasSpiderTimeline x, GCompare k)
1743 => (forall a. q a -> Event x (v a))
1719 => (forall a. q a -> Event x (v a))
1744− -> DynamicS x (PatchDMapWithMove k q) -> Event x (DMap k v)
1720+ -> Dynamic x (PatchDMapWithMove k q) -> Event x (DMap k v)
1745mergeWithMove nt d = cacheEvent (mergeCheapWithMove nt d)
1721mergeWithMove nt d = cacheEvent (mergeCheapWithMove nt d)
1746
1722
1747{-# INLINE [1] mergeCheap #-}
1723{-# INLINE [1] mergeCheap #-}
1748mergeCheap
1724mergeCheap
1749 :: forall k x q v. (HasSpiderTimeline x, GCompare k)
1725 :: forall k x q v. (HasSpiderTimeline x, GCompare k)
1750 => (forall a. q a -> Event x (v a))
1726 => (forall a. q a -> Event x (v a))
1751− -> DynamicS x (PatchDMap k q)
1727+ -> Dynamic x (PatchDMap k q)
1752 -> Event x (DMap k v)
1728 -> Event x (DMap k v)
1753mergeCheap nt = mergeGCheap' getInitialSubscribers updateMe destroy
1729mergeCheap nt = mergeGCheap' getInitialSubscribers updateMe destroy
1754 where
1730 where
@@ -1788,7 +1764,7 @@ mergeCheap nt = mergeGCheap' getInitialSubscribers updateMe destroy
1788{-# INLINE [1] mergeCheapWithMove #-}
1764{-# INLINE [1] mergeCheapWithMove #-}
1789mergeCheapWithMove :: forall k x v q. (HasSpiderTimeline x, GCompare k)
1765mergeCheapWithMove :: forall k x v q. (HasSpiderTimeline x, GCompare k)
1790 => (forall a. q a -> Event x (v a))
1766 => (forall a. q a -> Event x (v a))
1791− -> DynamicS x (PatchDMapWithMove k q)
1767+ -> Dynamic x (PatchDMapWithMove k q)
1792 -> Event x (DMap k v)
1768 -> Event x (DMap k v)
1793mergeCheapWithMove nt = mergeGCheap' getInitialSubscribers updateMe destroy
1769mergeCheapWithMove nt = mergeGCheap' getInitialSubscribers updateMe destroy
1794 where
1770 where
@@ -1936,7 +1912,7 @@ updateMerge m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m)
1936
1912
1937{-# INLINE mergeGCheap' #-}
1913{-# INLINE mergeGCheap' #-}
1938mergeGCheap' :: forall k v x p s q. (HasSpiderTimeline x, GCompare k, PatchTarget p ~ DMap k q)
1914mergeGCheap' :: forall k v x p s q. (HasSpiderTimeline x, GCompare k, PatchTarget p ~ DMap k q)
1939− => MergeInitFunc k v q x s -> MergeUpdateFunc k v x p s -> MergeDestroyFunc k s -> DynamicS x p -> Event x (DMap k v)
1915+ => MergeInitFunc k v q x s -> MergeUpdateFunc k v x p s -> MergeDestroyFunc k s -> Dynamic x p -> Event x (DMap k v)
1940mergeGCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do
1916mergeGCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do
1941 initialParents <- readBehaviorUntracked $ dynamicCurrent d
1917 initialParents <- readBehaviorUntracked $ dynamicCurrent d
1942 accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized"
1918 accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized"
@@ -1985,11 +1961,11 @@ mergeGCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do
1985 , occ
1961 , occ
1986 )
1962 )
1987
1963
1988−mergeInt :: forall x a. (HasSpiderTimeline x) => DynamicS x (PatchIntMap (Event x a)) -> Event x (IntMap a)
1964+mergeInt :: forall x a. (HasSpiderTimeline x) => Dynamic x (PatchIntMap (Event x a)) -> Event x (IntMap a)
1989mergeInt = cacheEvent . mergeIntCheap
1965mergeInt = cacheEvent . mergeIntCheap
1990
1966
1991{-# INLINABLE mergeIntCheap #-}
1967{-# INLINABLE mergeIntCheap #-}
1992−mergeIntCheap :: forall x a. (HasSpiderTimeline x) => DynamicS x (PatchIntMap (Event x a)) -> Event x (IntMap a)
1968+mergeIntCheap :: forall x a. (HasSpiderTimeline x) => Dynamic x (PatchIntMap (Event x a)) -> Event x (IntMap a)
1993mergeIntCheap d = Event $ \sub -> do
1969mergeIntCheap d = Event $ \sub -> do
1994 initialParents <- readBehaviorUntracked $ dynamicCurrent d
1970 initialParents <- readBehaviorUntracked $ dynamicCurrent d
1995 accum <- liftIO $ FastMutableIntMap.newEmpty
1971 accum <- liftIO $ FastMutableIntMap.newEmpty
@@ -2086,16 +2062,14 @@ mergeIntCheap d = Event $ \sub -> do
2086 )
2062 )
2087
2063
2088newtype EventSelector x k = EventSelector { select :: forall a. k a -> Event x a }
2064newtype EventSelector x k = EventSelector { select :: forall a. k a -> Event x a }
2089−newtype EventSelectorG x k v = EventSelectorG { selectG :: forall a. k a -> Event x (v a) }
2090
2065
2091−fanG :: (HasSpiderTimeline x, GCompare k) => Event x (DMap k v) -> EventSelectorG x k v
2066+fan :: (HasSpiderTimeline x, GCompare k) => Event x (DMap k Identity) -> EventSelector x k
2092−fanG e = unsafePerformIO $ do
2067+fan e =
2093− ref <- newIORef Nothing
2094 let f = Fan
2068 let f = Fan
2095 { fanParent = e
2069 { fanParent = e
2096− , fanSubscribed = ref
2070+ , fanSubscribed = unsafeNewIORef e Nothing
2097 }
2071 }
2098− pure $ EventSelectorG $ \k -> eventFan k f
2072+ in EventSelector $ \k -> eventFan k f
2099
2073
2100runHoldInits :: HasSpiderTimeline x => IORef [SomeHoldInit x] -> IORef [SomeDynInit x] -> IORef [SomeMergeInit x] -> EventM x ()
2074runHoldInits :: HasSpiderTimeline x => IORef [SomeHoldInit x] -> IORef [SomeDynInit x] -> IORef [SomeMergeInit x] -> EventM x ()
2101runHoldInits holdInitRef dynInitRef mergeInitRef = do
2075runHoldInits holdInitRef dynInitRef mergeInitRef = do
@@ -2149,7 +2123,7 @@ clearEventEnv (EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeI
2149-- | Run an event action outside of a frame
2123-- | Run an event action outside of a frame
2150runFrame :: forall x a. HasSpiderTimeline x => EventM x a -> SpiderHost x a --TODO: This function also needs to hold the mutex
2124runFrame :: forall x a. HasSpiderTimeline x => EventM x a -> SpiderHost x a --TODO: This function also needs to hold the mutex
2151runFrame a = SpiderHost $ do
2125runFrame a = SpiderHost $ do
2152− let env = _spiderTimeline_eventEnv $ unSTE (spiderTimeline :: SpiderTimelineEnv x)
2126+ let env = _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimelineEnv x)
2153 let go = do
2127 let go = do
2154 result <- a
2128 result <- a
2155 runHoldInits (eventEnvHoldInits env) (eventEnvDynInits env) (eventEnvMergeInits env) -- This must happen before doing the assignments, in case subscribing a Hold causes existing Holds to be read by the newly-propagated events
2129 runHoldInits (eventEnvHoldInits env) (eventEnvDynInits env) (eventEnvMergeInits env) -- This must happen before doing the assignments, in case subscribing a Hold causes existing Holds to be read by the newly-propagated events
@@ -2360,7 +2334,7 @@ instance HasSpiderTimeline x => Monad (Reflex.Class.Dynamic (SpiderTimeline x))
2360 fail _ = error "Dynamic does not support 'fail'"
2334 fail _ = error "Dynamic does not support 'fail'"
2361
2335
2362{-# INLINABLE newJoinDyn #-}
2336{-# INLINABLE newJoinDyn #-}
2363−newJoinDyn :: HasSpiderTimeline x => DynamicS x (Identity (DynamicS x (Identity a))) -> Reflex.Spider.Internal.Dyn x (Identity a)
2337+newJoinDyn :: HasSpiderTimeline x => Reflex.Spider.Internal.Dynamic x (Identity (Reflex.Spider.Internal.Dynamic x (Identity a))) -> Reflex.Spider.Internal.Dyn x (Identity a)
2364newJoinDyn d =
2338newJoinDyn d =
2365 let readV0 = readBehaviorTracked . dynamicCurrent =<< readBehaviorTracked (dynamicCurrent d)
2339 let readV0 = readBehaviorTracked . dynamicCurrent =<< readBehaviorTracked (dynamicCurrent d)
2366 eOuter = Reflex.Spider.Internal.push (fmap (Just . Identity) . readBehaviorUntracked . dynamicCurrent . runIdentity) $ dynamicUpdated d
2340 eOuter = Reflex.Spider.Internal.push (fmap (Just . Identity) . readBehaviorUntracked . dynamicCurrent . runIdentity) $ dynamicUpdated d
@@ -2510,7 +2484,7 @@ unsafeNewSpiderTimelineEnv = do
2510#ifdef DEBUG
2484#ifdef DEBUG
2511 depthRef <- newIORef 0
2485 depthRef <- newIORef 0
2512#endif
2486#endif
2513− return $ STE $ SpiderTimelineEnv
2487+ return $ SpiderTimelineEnv
2514 { _spiderTimeline_lock = lock
2488 { _spiderTimeline_lock = lock
2515 , _spiderTimeline_eventEnv = env
2489 , _spiderTimeline_eventEnv = env
2516#ifdef DEBUG
2490#ifdef DEBUG
@@ -2526,13 +2500,13 @@ data LocalSpiderTimeline (x :: Type) s
2526
2500
2527instance Reifies s (SpiderTimelineEnv x) =>
2501instance Reifies s (SpiderTimelineEnv x) =>
2528 HasSpiderTimeline (LocalSpiderTimeline x s) where
2502 HasSpiderTimeline (LocalSpiderTimeline x s) where
2529− spiderTimeline = localSpiderTimeline Proxy $ reflect (Proxy :: Proxy s)
2503+ spiderTimeline = localSpiderTimeline (Proxy :: Proxy s) $ reflect (Proxy :: Proxy s)
2530
2504
2531localSpiderTimeline
2505localSpiderTimeline
2532− :: proxy s
2506+ :: Proxy s
2533 -> SpiderTimelineEnv x
2507 -> SpiderTimelineEnv x
2534 -> SpiderTimelineEnv (LocalSpiderTimeline x s)
2508 -> SpiderTimelineEnv (LocalSpiderTimeline x s)
2535−localSpiderTimeline _ = coerce
2509+localSpiderTimeline _ = unsafeCoerce
2536
2510
2537-- | Pass a new timeline to the given function.
2511-- | Pass a new timeline to the given function.
2538withSpiderTimeline :: (forall x. HasSpiderTimeline x => SpiderTimelineEnv x -> IO r) -> IO r
2512withSpiderTimeline :: (forall x. HasSpiderTimeline x => SpiderTimelineEnv x -> IO r) -> IO r
@@ -2550,8 +2524,8 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
2550 {-# SPECIALIZE instance R.Reflex (SpiderTimeline Global) #-}
2524 {-# SPECIALIZE instance R.Reflex (SpiderTimeline Global) #-}
2551 newtype Behavior (SpiderTimeline x) a = SpiderBehavior { unSpiderBehavior :: Behavior x a }
2525 newtype Behavior (SpiderTimeline x) a = SpiderBehavior { unSpiderBehavior :: Behavior x a }
2552 newtype Event (SpiderTimeline x) a = SpiderEvent { unSpiderEvent :: Event x a }
2526 newtype Event (SpiderTimeline x) a = SpiderEvent { unSpiderEvent :: Event x a }
2553− newtype Dynamic (SpiderTimeline x) a = SpiderDynamic { unSpiderDynamic :: DynamicS x (Identity a) } -- deriving (Functor, Applicative, Monad)
2527+ newtype Dynamic (SpiderTimeline x) a = SpiderDynamic { unSpiderDynamic :: Dynamic x (Identity a) } -- deriving (Functor, Applicative, Monad)
2554− newtype Incremental (SpiderTimeline x) p = SpiderIncremental { unSpiderIncremental :: DynamicS x p }
2528+ newtype Incremental (SpiderTimeline x) p = SpiderIncremental { unSpiderIncremental :: Dynamic x p }
2555 type PullM (SpiderTimeline x) = SpiderPullM x
2529 type PullM (SpiderTimeline x) = SpiderPullM x
2556 type PushM (SpiderTimeline x) = SpiderPushM x
2530 type PushM (SpiderTimeline x) = SpiderPushM x
2557 {-# INLINABLE never #-}
2531 {-# INLINABLE never #-}
@@ -2564,8 +2538,6 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
2564 pushCheap f = SpiderEvent . pushCheap (coerce f) . unSpiderEvent
2538 pushCheap f = SpiderEvent . pushCheap (coerce f) . unSpiderEvent
2565 {-# INLINABLE pull #-}
2539 {-# INLINABLE pull #-}
2566 pull = SpiderBehavior . pull . coerce
2540 pull = SpiderBehavior . pull . coerce
2567− {-# INLINABLE fanG #-}
2568− fanG e = R.EventSelectorG $ SpiderEvent . selectG (fanG (unSpiderEvent e))
2569 {-# INLINABLE mergeG #-}
2541 {-# INLINABLE mergeG #-}
2570 mergeG
2542 mergeG
2571 :: forall (k :: k2 -> *) q (v :: k2 -> *). GCompare k
2543 :: forall (k :: k2 -> *) q (v :: k2 -> *). GCompare k
@@ -2573,6 +2545,8 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
2573 -> DMap k q
2545 -> DMap k q
2574 -> R.Event (SpiderTimeline x) (DMap k v)
2546 -> R.Event (SpiderTimeline x) (DMap k v)
2575 mergeG nt = SpiderEvent . mergeG (unSpiderEvent #. nt) . dynamicConst
2547 mergeG nt = SpiderEvent . mergeG (unSpiderEvent #. nt) . dynamicConst
2548+ {-# INLINABLE fan #-}
2549+ fan e = R.EventSelector $ SpiderEvent . select (fan (unSpiderEvent e))
2576 {-# INLINABLE switch #-}
2550 {-# INLINABLE switch #-}
2577 switch = SpiderEvent . switch . (coerce :: Behavior x (R.Event (SpiderTimeline x) a) -> Behavior x (Event x a)) . unSpiderBehavior
2551 switch = SpiderEvent . switch . (coerce :: Behavior x (R.Event (SpiderTimeline x) a) -> Behavior x (Event x a)) . unSpiderBehavior
2578 {-# INLINABLE coincidence #-}
2552 {-# INLINABLE coincidence #-}
@@ -2580,7 +2554,7 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
2580 {-# INLINABLE current #-}
2554 {-# INLINABLE current #-}
2581 current = SpiderBehavior . dynamicCurrent . unSpiderDynamic
2555 current = SpiderBehavior . dynamicCurrent . unSpiderDynamic
2582 {-# INLINABLE updated #-}
2556 {-# INLINABLE updated #-}
2583− updated = SpiderEvent #. dynamicUpdated .# fmap coerce . unSpiderDynamic
2557+ updated = coerce $ SpiderEvent . dynamicUpdated . unSpiderDynamic
2584 {-# INLINABLE unsafeBuildDynamic #-}
2558 {-# INLINABLE unsafeBuildDynamic #-}
2585 unsafeBuildDynamic readV0 v' = SpiderDynamic $ dynamicDynIdentity $ unsafeBuildDynamic (coerce readV0) $ coerce $ unSpiderEvent v'
2559 unsafeBuildDynamic readV0 v' = SpiderDynamic $ dynamicDynIdentity $ unsafeBuildDynamic (coerce readV0) $ coerce $ unSpiderEvent v'
2586 {-# INLINABLE unsafeBuildIncremental #-}
2560 {-# INLINABLE unsafeBuildIncremental #-}
@@ -2599,10 +2573,9 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
2599 return $ Identity <$> apply p c --TODO: Avoid the redundant 'apply'
2573 return $ Identity <$> apply p c --TODO: Avoid the redundant 'apply'
2600 eventCoercion Coercion = Coercion
2574 eventCoercion Coercion = Coercion
2601 behaviorCoercion Coercion = Coercion
2575 behaviorCoercion Coercion = Coercion
2602− dynamicCoercion Coercion = Coercion
2576+ dynamicCoercion = unsafeCoerce --TODO: How can we avoid this unsafeCoerce? This is safe only because we know how Identity works as a Patch instance
2603− incrementalCoercion Coercion Coercion = Coercion
2604 {-# INLINABLE mergeIntIncremental #-}
2577 {-# INLINABLE mergeIntIncremental #-}
2605− mergeIntIncremental = SpiderEvent . mergeInt . coerce
2578+ mergeIntIncremental = SpiderEvent . mergeInt . (unsafeCoerce :: Dynamic x (PatchIntMap (R.Event (SpiderTimeline x) a)) -> Dynamic x (PatchIntMap (Event x a))) . unSpiderIncremental
2606 {-# INLINABLE fanInt #-}
2579 {-# INLINABLE fanInt #-}
2607 fanInt e = R.EventSelectorInt $ SpiderEvent . selectInt (fanInt (unSpiderEvent e))
2580 fanInt e = R.EventSelectorInt $ SpiderEvent . selectInt (fanInt (unSpiderEvent e))
2608
2581
test/GC.hs+2−2
@@ -56,8 +56,8 @@ hostPerf ref = S.runSpiderHost $ do
56 { S.subscriberPropagate = S.subscriberPropagate sub
56 { S.subscriberPropagate = S.subscriberPropagate sub
57 }
57 }
58 return (s, o))
58 return (s, o))
59− $ runIdentity . runIdentity <$> S.selectG
59+ $ runIdentity <$> S.select
60− (S.fanG $ S.pushCheap (return . Just . mapKeyValuePairsMonotonic (\(t :=> e) -> WrapArg t :=> Identity e)) response)
60+ (S.fan $ S.pushCheap (return . Just . mapKeyValuePairsMonotonic (\(t :=> e) -> WrapArg t :=> Identity e)) response)
61 (WrapArg Request)
61 (WrapArg Request)
62 return $ alignWith (mergeThese (<>))
62 return $ alignWith (mergeThese (<>))
63 (flip S.pushCheap eadd $ \_ -> return $ Just $ DMap.singleton Request $ do
63 (flip S.pushCheap eadd $ \_ -> return $ Just $ DMap.singleton Request $ do
test/Reflex/Bench/Focused.hs−12
@@ -130,16 +130,6 @@ mapDynChain = iterM (return . fmap (+1))
130joinDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)
130joinDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)
131joinDynChain = iterM (\d -> return $ join $ fmap (const d) d)
131joinDynChain = iterM (\d -> return $ join $ fmap (const d) d)
132
132
133−holdDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)
134−holdDynChain = iterM (\d -> sample (current d) >>= flip holdDyn (updated d))
135−
136−buildDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)
137−buildDynChain = iterM (\d -> do
138− let b = fmap (+1) (current d)
139− e = fmap (*2) (updated d)
140− buildDynamic (sample b) e)
141−
142−
143combineDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)
133combineDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)
144combineDynChain = iterM (\d -> return $ zipDynWith (+) d d)
134combineDynChain = iterM (\d -> return $ zipDynWith (+) d d)
145
135
@@ -318,8 +308,6 @@ dynamics :: Word -> [(String, TestCase)]
318dynamics n =
308dynamics n =
319 [ testE "mapDynChain" $ fmap updated $ mapDynChain n =<< d
309 [ testE "mapDynChain" $ fmap updated $ mapDynChain n =<< d
320 , testE "joinDynChain" $ fmap updated $ joinDynChain n =<< d
310 , testE "joinDynChain" $ fmap updated $ joinDynChain n =<< d
321− , testE "holdDynChain" $ fmap updated $ holdDynChain n =<< d
322− , testE "buildDynChain" $ fmap updated $ buildDynChain n =<< d
323 , testE "combineDynChain" $ fmap updated $ combineDynChain n =<< d
311 , testE "combineDynChain" $ fmap updated $ combineDynChain n =<< d
324 , testE "dense mergeTree" $ fmap (updated . mergeTreeDyn 8) dense
312 , testE "dense mergeTree" $ fmap (updated . mergeTreeDyn 8) dense
325 , testE "sparse mergeTree" $ fmap (updated . mergeTreeDyn 8) sparse
313 , testE "sparse mergeTree" $ fmap (updated . mergeTreeDyn 8) sparse