973759c · reflex · git.iko.soy

git.iko.soy/reflex

Add buildDynamic

* Replace uniqDyn* with holdUniqDyn* * Reincarnate CrossImpl

commit973759c7236e0bc710b87dc732a5f0575e653462 authorRyan Trinkle <ryan.trinkle@gmail.com> dateFri 26 May 2017, 15:47 (9 years ago) parent2fe0f56

10 files changed+155−40

compare with develop

unifiedsplit

reflex.cabal+15 src/Reflex/Class.hs+17−4 src/Reflex/Dynamic.hs+45−11 src/Reflex/Dynamic/Uniq.hs+2−2 src/Reflex/PerformEvent/Base.hs+2 src/Reflex/Pure.hs+5−3 src/Reflex/Spider/Internal.hs+47−19 src/Reflex/Spider/SpiderTimeline.include.hs+14−1 test/Reflex/Plan/Pure.hs+1 test/Reflex/Test/CrossImpl.hs+7

reflex.cabal+15

@@ -153,6 +153,21 @@ test-suite semantics

153153 if flag(specialize-to-spidertimeline-global)

154154 buildable: False

155155

156+test-suite CrossImpl

157+ type: exitcode-stdio-1.0

158+ main-is: Reflex/Test/CrossImpl.hs

159+ hs-source-dirs: test

160+ ghc-options: -O2 -Wall -rtsopts -main-is Reflex.Test.CrossImpl.test

161+ build-depends:

162+ base,

163+ containers,

164+ dependent-map,

165+ mtl,

166+ ref-tf,

167+ reflex

168+ if flag(specialize-to-spidertimeline-global)

169+ buildable: False

170+

156171test-suite hlint

157172 type: exitcode-stdio-1.0

158173 main-is: hlint.hs

src/Reflex/Class.hs+17−4

@@ -1,4 +1,5 @@

11{-# LANGUAGE CPP #-}

2+{-# LANGUAGE DefaultSignatures #-}

23{-# LANGUAGE FlexibleContexts #-}

34{-# LANGUAGE FlexibleInstances #-}

45{-# LANGUAGE FunctionalDependencies #-}

@@ -187,7 +188,7 @@ import Reflex.Spider.Internal (EventM, Global, HasSpiderTimeline, SpiderHost (..

187188 SpiderPullM, SpiderPushM (..), behaviorHoldIdentity, dynamicConst,

188189 dynamicCurrent, dynamicDynIdentity, dynamicHold, dynamicHoldIdentity,

189190 dynamicUpdated, newMapDyn, readBehaviorTracked, readBehaviorUntracked,

190− runFrame, runSpiderHostFrame, unsafeDyn)

191+ runFrame, runSpiderHostFrame)

191192import qualified Reflex.Spider.Internal

192193import qualified Reflex.Spider.Internal as S

193194import Unsafe.Coerce

@@ -350,9 +351,9 @@ current = SpiderBehavior . S.dynamicCurrent . unSpiderDynamic

350351{-# INLINE updated #-}

351352updated = coerceEvent . SpiderEvent . dynamicUpdated . unSpiderDynamic

352353{-# INLINE unsafeBuildDynamic #-}

353−unsafeBuildDynamic readV0 v' = SpiderDynamic $ dynamicDynIdentity $ unsafeDyn (coerce readV0) $ coerce $ unSpiderEvent v'

354+unsafeBuildDynamic readV0 v' = SpiderDynamic $ dynamicDynIdentity $ S.unsafeBuildDynamic (coerce readV0) $ coerce $ unSpiderEvent v'

354355{-# INLINE unsafeBuildIncremental #-}

355−unsafeBuildIncremental readV0 dv = SpiderIncremental $ S.dynamicDyn $ unsafeDyn (coerce readV0) $ unSpiderEvent dv

356+unsafeBuildIncremental readV0 dv = SpiderIncremental $ S.dynamicDyn $ S.unsafeBuildDynamic (coerce readV0) $ unSpiderEvent dv

356357{-# INLINE mergeIncremental #-}

357358mergeIncremental = SpiderEvent . S.merge . (unsafeCoerce :: S.Dynamic x (PatchDMap k (Event (SpiderTimeline x))) -> S.Dynamic x (PatchDMap k (S.Event x))) . unSpiderIncremental

358359{-# INLINE mergeIncrementalWithMove #-}

@@ -362,7 +363,7 @@ currentIncremental = SpiderBehavior . dynamicCurrent . unSpiderIncremental

362363{-# INLINE updatedIncremental #-}

363364updatedIncremental = SpiderEvent . dynamicUpdated . unSpiderIncremental

364365{-# INLINE incrementalToDynamic #-}

365−incrementalToDynamic (SpiderIncremental i) = SpiderDynamic $ dynamicDynIdentity $ unsafeDyn (readBehaviorUntracked $ dynamicCurrent i) $ flip S.push (dynamicUpdated i) $ \p -> do

366+incrementalToDynamic (SpiderIncremental i) = SpiderDynamic $ dynamicDynIdentity $ S.unsafeBuildDynamic (readBehaviorUntracked $ dynamicCurrent i) $ flip S.push (dynamicUpdated i) $ \p -> do

366367 c <- readBehaviorUntracked $ dynamicCurrent i

367368 return $ Identity <$> apply p c

368369eventCoercion Coercion = Coercion

@@ -414,12 +415,21 @@ class MonadSample t m => MonadHold t m where

414415 -- the 'Behavior', it will see the _old_ value of the 'Behavior', not the new

415416 -- one.

416417 hold :: a -> Event t a -> m (Behavior t a)

418+ default hold :: (m ~ f m', MonadTrans f, MonadHold t m') => a -> Event t a -> m (Behavior t a)

419+ hold v0 = lift . hold v0

417420 -- | Create a 'Dynamic' value using the given initial value that changes every

418421 -- time the 'Event' occurs.

419422 holdDyn :: a -> Event t a -> m (Dynamic t a)

423+ default holdDyn :: (m ~ f m', MonadTrans f, MonadHold t m') => a -> Event t a -> m (Dynamic t a)

424+ holdDyn v0 = lift . holdDyn v0

420425 -- | Create an 'Incremental' value using the given initial value that changes

421426 -- every time the 'Event' occurs.

422427 holdIncremental :: Patch p => PatchTarget p -> Event t p -> m (Incremental t p)

428+ default holdIncremental :: (Patch p, m ~ f m', MonadTrans f, MonadHold t m') => PatchTarget p -> Event t p -> m (Incremental t p)

429+ holdIncremental v0 = lift . holdIncremental v0

430+ buildDynamic :: PullM t a -> Event t a -> m (Dynamic t a)

431+ default buildDynamic :: (m ~ f m', MonadTrans f, MonadHold t m') => PullM t a -> Event t a -> m (Dynamic t a)

432+ buildDynamic getV0 = lift . buildDynamic getV0

423433

424434-- | An 'EventSelector' allows you to efficiently 'select' an 'Event' based on a

425435-- key. This is much more efficient than filtering for each key with

@@ -446,6 +456,7 @@ instance MonadHold t m => MonadHold t (ReaderT r m) where

446456 hold a0 = lift . hold a0

447457 holdDyn a0 = lift . holdDyn a0

448458 holdIncremental a0 = lift . holdIncremental a0

459+ buildDynamic a0 = lift . buildDynamic a0

449460

450461instance (MonadSample t m, Monoid r) => MonadSample t (WriterT r m) where

451462 sample = lift . sample

@@ -454,6 +465,7 @@ instance (MonadHold t m, Monoid r) => MonadHold t (WriterT r m) where

454465 hold a0 = lift . hold a0

455466 holdDyn a0 = lift . holdDyn a0

456467 holdIncremental a0 = lift . holdIncremental a0

468+ buildDynamic a0 = lift . buildDynamic a0

457469

458470instance MonadSample t m => MonadSample t (StateT s m) where

459471 sample = lift . sample

@@ -462,6 +474,7 @@ instance MonadHold t m => MonadHold t (StateT s m) where

462474 hold a0 = lift . hold a0

463475 holdDyn a0 = lift . holdDyn a0

464476 holdIncremental a0 = lift . holdIncremental a0

477+ buildDynamic a0 = lift . buildDynamic a0

465478

466479instance MonadSample t m => MonadSample t (ExceptT e m) where

467480 sample = lift . sample

src/Reflex/Dynamic.hs+45−11

@@ -8,6 +8,7 @@

88{-# LANGUAGE NoMonomorphismRestriction #-}

99{-# LANGUAGE PolyKinds #-}

1010{-# LANGUAGE RankNTypes #-}

11+{-# LANGUAGE RecursiveDo #-}

1112{-# LANGUAGE ScopedTypeVariables #-}

1213{-# LANGUAGE StandaloneDeriving #-}

1314{-# LANGUAGE TypeFamilies #-}

@@ -25,8 +26,6 @@ module Reflex.Dynamic

2526 , updated

2627 , holdDyn

2728 , constDyn

28− , uniqDyn

29− , uniqDynBy

3029 , count

3130 , toggle

3231 , switchPromptlyDyn

@@ -34,6 +33,10 @@ module Reflex.Dynamic

3433 , attachPromptlyDyn

3534 , attachPromptlyDynWith

3635 , attachPromptlyDynWithMaybe

36+ , scanDyn

37+ , scanDynMaybe

38+ , holdUniqDyn

39+ , holdUniqDynBy

3740 , foldDyn

3841 , foldDynM

3942 , foldDynMaybe

@@ -78,6 +81,8 @@ module Reflex.Dynamic

7881 , nubDyn

7982 , splitDyn

8083 , tagDyn

84+ , uniqDyn

85+ , uniqDynBy

8186 ) where

8287

8388import Prelude hiding (mapM, mapM_)

@@ -102,16 +107,29 @@ import Debug.Trace

102107

103108-- | Create a new 'Dynamic' that only signals changes if the values actually

104109-- changed.

105−uniqDyn :: (Reflex t, Eq a) => Dynamic t a -> Dynamic t a

106−uniqDyn = uniqDynBy (==)

110+holdUniqDyn :: (Reflex t, MonadHold t m, MonadFix m, Eq a) => Dynamic t a -> m (Dynamic t a)

111+holdUniqDyn = holdUniqDynBy (==)

107112

108113-- | Create a new 'Dynamic' that changes only when the underlying 'Dynamic'

109114-- changes and the given function returns 'False' when given both the old and

110115-- the new values.

111−uniqDynBy :: Reflex t => (a -> a -> Bool) -> Dynamic t a -> Dynamic t a

112−uniqDynBy eq d =

113− let e' = attachWithMaybe (\x x' -> if x' `eq` x then Nothing else Just x') (current d) (updated d)

114− in unsafeDynamic (current d) e'

116+holdUniqDynBy :: (Reflex t, MonadHold t m, MonadFix m) => (a -> a -> Bool) -> Dynamic t a -> m (Dynamic t a)

117+holdUniqDynBy eq = scanDynMaybe id (\new old -> if new `eq` old then Nothing else Just new)

118+

119+-- | Create a 'Dynamic' that accumulates values from another 'Dynamic'. This

120+-- function does not force its input 'Dynamic' until the output 'Dynamic' is

121+-- forced.

122+scanDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b) -> (a -> b -> b) -> Dynamic t a -> m (Dynamic t b)

123+scanDyn z f = scanDynMaybe z (\a b -> Just $ f a b)

124+

125+-- | Like 'scanDyn', but the the accumulator function may decline to update the

126+-- result 'Dynamic''s value.

127+scanDynMaybe :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b) -> (a -> b -> Maybe b) -> Dynamic t a -> m (Dynamic t b)

128+scanDynMaybe z f d = do

129+ rec d' <- buildDynamic (z <$> sample (current d)) $ flip push (updated d) $ \a -> do

130+ b <- sample $ current d'

131+ return $ f a b

132+ return d'

115133

116134-- | Create a 'Dynamic' using the initial value and change it each time the

117135-- 'Event' occurs using a folding function on the previous value and the value

@@ -594,8 +612,24 @@ attachDynWithMaybe = attachPromptlyDynWithMaybe

594612joinDyn :: Reflex t => Dynamic t (Dynamic t a) -> Dynamic t a

595613joinDyn = join

596614

597−-- | 'nubDyn''s behavior is not quite analogous to 'nub''s behavior, so it has

598−-- been renamed to 'uniqDyn'

599−{-# DEPRECATED nubDyn "Use 'uniqDyn' instead" #-}

615+-- | WARNING: This function is only pure if @a@'s 'Eq' instance tests

616+-- representational equality. Use 'holdUniqDyn' instead, which is pure in all

617+-- circumstances. Also, note that, unlike 'nub', this function does not prevent

618+-- all recurrences of a value, only consecutive recurrences.

619+{-# DEPRECATED nubDyn "Use 'holdUniqDyn' instead; note that it returns a MonadHold action rather than a pure Dynamic" #-}

600620nubDyn :: (Reflex t, Eq a) => Dynamic t a -> Dynamic t a

601621nubDyn = uniqDyn

622+

623+-- | WARNING: This function is only pure if @a@'s 'Eq' instance tests

624+-- representational equality. Use 'holdUniqDyn' instead, which is pure in all

625+-- circumstances.

626+{-# DEPRECATED uniqDyn "Use 'holdUniqDyn' instead; note that it returns a MonadHold action rather than a pure Dynamic" #-}

627+uniqDyn :: (Reflex t, Eq a) => Dynamic t a -> Dynamic t a

628+uniqDyn = uniqDynBy (==)

629+

630+-- | WARNING: This function is impure. Use 'holdUniqDynBy' instead.

631+{-# DEPRECATED uniqDynBy "Use 'holdUniqDynBy' instead; note that it returns a MonadHold action rather than a pure Dynamic" #-}

632+uniqDynBy :: Reflex t => (a -> a -> Bool) -> Dynamic t a -> Dynamic t a

633+uniqDynBy eq d =

634+ let e' = attachWithMaybe (\x x' -> if x' `eq` x then Nothing else Just x') (current d) (updated d)

635+ in unsafeDynamic (current d) e'

src/Reflex/Dynamic/Uniq.hs+2−2

@@ -17,7 +17,6 @@ module Reflex.Dynamic.Uniq

1717import Control.Applicative (Applicative (..))

1818import GHC.Exts

1919import Reflex.Class

20−import Reflex.Dynamic

2120

2221-- | A 'Dynamic' whose 'updated' 'Event' will never fire with the same value as

2322-- the 'current' 'Behavior''s contents. In order to maintain this constraint,

@@ -47,7 +46,7 @@ uniqDynamic d = UniqDynamic $ unsafeBuildDynamic (sample $ current d) $ flip pus

4746-- instance, but can be equal by pointer equality. This may cause 'UniqDynamic'

4847-- to lose changes from NaN to NaN.

4948fromUniqDynamic :: (Reflex t, Eq a) => UniqDynamic t a -> Dynamic t a

50−fromUniqDynamic (UniqDynamic d) = uniqDynBy superEq d

49+fromUniqDynamic (UniqDynamic d) = unsafeDynamic (current d) e'

5150 where

5251 -- Only consider values different if they fail both pointer equality /and/

5352 -- 'Eq' equality. This is to make things a bit more deterministic in the

@@ -57,6 +56,7 @@ fromUniqDynamic (UniqDynamic d) = uniqDynBy superEq d

5756 -- nonequal by pointer quality. I suspect that it is impossible to make the

5857 -- behavior deterministic in this case.

5958 superEq a b = a `unsafePtrEq` b || a == b

59+ e' = attachWithMaybe (\x x' -> if x' `superEq` x then Nothing else Just x') (current d) (updated d)

6060

6161-- | Create a UniqDynamic without uniqing it on creation. This will be slightly

6262-- faster than uniqDynamic when used with a Dynamic whose values are always (or

src/Reflex/PerformEvent/Base.hs+2

@@ -142,6 +142,8 @@ instance (ReflexHost t, MonadHold t m) => MonadHold t (PerformEventT t m) where

142142 holdDyn v0 v' = PerformEventT $ lift $ holdDyn v0 v'

143143 {-# INLINABLE holdIncremental #-}

144144 holdIncremental v0 v' = PerformEventT $ lift $ holdIncremental v0 v'

145+ {-# INLINABLE buildDynamic #-}

146+ buildDynamic getV0 v' = PerformEventT $ lift $ buildDynamic getV0 v'

145147

146148instance (MonadRef (HostFrame t), ReflexHost t) => MonadRef (PerformEventT t m) where

147149 type Ref (PerformEventT t m) = Ref (HostFrame t)

src/Reflex/Pure.hs+5−3

@@ -169,9 +169,11 @@ instance (Enum t, HasTrie t, Ord t) => MonadHold (Pure t) ((->) t) where

169169 else let lastTime = pred sampleTime

170170 in fromMaybe (f lastTime) $ unEvent e lastTime

171171

172− holdDyn :: a -> Event (Pure t) a -> t -> Dynamic (Pure t) a

173− holdDyn initialValue e initialTime =

174− let Behavior f = hold initialValue e initialTime

172+ holdDyn v0 = buildDynamic (return v0)

173+

174+ buildDynamic :: (t -> a) -> Event (Pure t) a -> t -> Dynamic (Pure t) a

175+ buildDynamic initialValue e initialTime =

176+ let Behavior f = hold (initialValue initialTime) e initialTime

175177 in Dynamic $ \t -> (f t, unEvent e t)

176178

177179 holdIncremental :: Patch p => PatchTarget p -> Event (Pure t) p -> t -> Incremental (Pure t) p

src/Reflex/Spider/Internal.hs+47−19

@@ -747,6 +747,7 @@ instance GEq SpiderTimelineEnv where

747747data EventEnv x

748748 = EventEnv { eventEnvAssignments :: !(IORef [SomeAssignment x]) -- Needed for Subscribe

749749 , eventEnvHoldInits :: !(IORef [SomeHoldInit x]) -- Needed for Subscribe

750+ , eventEnvDynInits :: !(IORef [SomeDynInit x])

750751 , eventEnvMergeUpdates :: !(IORef [SomeMergeUpdate x])

751752 , eventEnvMergeInits :: !(IORef [SomeMergeInit x]) -- Needed for Subscribe

752753 , eventEnvClears :: !(IORef [SomeClear]) -- Needed for Subscribe

@@ -780,6 +781,10 @@ instance HasSpiderTimeline x => Defer (SomeHoldInit x) (EventM x) where

780781 {-# INLINE getDeferralQueue #-}

781782 getDeferralQueue = asksEventEnv eventEnvHoldInits

782783

784+instance HasSpiderTimeline x => Defer (SomeDynInit x) (EventM x) where

785+ {-# INLINE getDeferralQueue #-}

786+ getDeferralQueue = asksEventEnv eventEnvDynInits

787+

783788instance Defer (SomeHoldInit x) (BehaviorM x) where

784789 {-# INLINE getDeferralQueue #-}

785790 getDeferralQueue = BehaviorM $ asks snd

@@ -952,6 +957,8 @@ data Root x (k :: * -> *)

952957

953958data SomeHoldInit x = forall p. Patch p => SomeHoldInit !(Hold x p)

954959

960+data SomeDynInit x = forall p. Patch p => SomeDynInit !(Dyn x p)

961+

955962data SomeMergeUpdate x = SomeMergeUpdate

956963 { _someMergeUpdate_update :: !(EventM x [EventSubscription x])

957964 , _someMergeUpdate_invalidateHeight :: !(IO ())

@@ -963,14 +970,20 @@ newtype SomeMergeInit x = SomeMergeInit { unSomeMergeInit :: EventM x () }

963970-- EventM can do everything BehaviorM can, plus create holds

964971newtype EventM x a = EventM { unEventM :: 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

965972

966−newtype ComputeM x a = ComputeM (ReaderT (IORef [SomeHoldInit x]) IO a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)

973+newtype ComputeM x a = ComputeM (ReaderT (IORef [SomeHoldInit x], IORef [SomeDynInit x]) IO a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)

967974

968975instance Defer (SomeHoldInit x) (ComputeM x) where

969− getDeferralQueue = ComputeM ask

976+ getDeferralQueue = ComputeM $ asks fst

977+

978+instance Defer (SomeDynInit x) (ComputeM x) where

979+ getDeferralQueue = ComputeM $ asks snd

970980

971981{-# INLINABLE runComputeM #-}

972−runComputeM :: Defer (SomeHoldInit x) m => ComputeM x a -> m a

973−runComputeM (ComputeM a) = liftIO . runReaderT a =<< getDeferralQueue

982+runComputeM :: (Defer (SomeHoldInit x) m, Defer (SomeDynInit x) m) => ComputeM x a -> m a

983+runComputeM (ComputeM a) = do

984+ holds <- getDeferralQueue

985+ dyns <- getDeferralQueue

986+ liftIO $ runReaderT a (holds, dyns)

974987

975988newtype MergeSubscribedParent x a = MergeSubscribedParent { unMergeSubscribedParent :: EventSubscription x }

976989

@@ -1103,7 +1116,7 @@ instance HasSpiderTimeline x => Align (Event x) where

11031116newtype Dyn x p = Dyn { unDyn :: IORef (Either (BehaviorM x (PatchTarget p), Event x p) (Hold x p)) }

11041117

11051118newMapDyn :: HasSpiderTimeline x => (a -> b) -> Dynamic x (Identity a) -> Dynamic x (Identity b)

1106−newMapDyn f d = dynamicDynIdentity $ unsafeDyn (fmap f $ readBehaviorTracked $ dynamicCurrent d) (Identity . f . runIdentity <$> dynamicUpdated d)

1119+newMapDyn f d = dynamicDynIdentity $ unsafeBuildDynamic (fmap f $ readBehaviorTracked $ dynamicCurrent d) (Identity . f . runIdentity <$> dynamicUpdated d)

11071120

11081121--TODO: Avoid the duplication between this and R.zipDynWith

11091122zipDynWith :: HasSpiderTimeline x => (a -> b -> c) -> Dynamic x (Identity a) -> Dynamic x (Identity b) -> Dynamic x (Identity c)

@@ -1119,10 +1132,17 @@ zipDynWith f da db =

11191132 return (a, b)

11201133 These (Identity a) (Identity b) -> return (a, b)

11211134 return $ Just $ Identity $ f a b

1122− in dynamicDynIdentity $ unsafeDyn (f <$> readBehaviorUntracked (dynamicCurrent da) <*> readBehaviorUntracked (dynamicCurrent db)) ec

1135+ in dynamicDynIdentity $ unsafeBuildDynamic (f <$> readBehaviorUntracked (dynamicCurrent da) <*> readBehaviorUntracked (dynamicCurrent db)) ec

1136+

1137+buildDynamic :: (Defer (SomeDynInit x) m, Patch p) => BehaviorM x (PatchTarget p) -> Event x p -> m (Dyn x p)

1138+buildDynamic readV0 v' = do

1139+ result <- liftIO $ newIORef $ Left (readV0, v')

1140+ let !d = Dyn result

1141+ defer $ SomeDynInit d

1142+ return d

11231143

1124−unsafeDyn :: BehaviorM x (PatchTarget p) -> Event x p -> Dyn x p

1125−unsafeDyn readV0 v' = Dyn $ unsafeNewIORef x $ Left x

1144+unsafeBuildDynamic :: BehaviorM x (PatchTarget p) -> Event x p -> Dyn x p

1145+unsafeBuildDynamic readV0 v' = Dyn $ unsafeNewIORef x $ Left x

11261146 where x = (readV0, v')

11271147

11281148-- ResultM can read behaviors and events

@@ -1796,24 +1816,31 @@ fan e =

17961816 }

17971817 in EventSelector $ \k -> eventFan k f

17981818

1799−runHoldInits :: HasSpiderTimeline x => IORef [SomeHoldInit x] -> IORef [SomeMergeInit x] -> EventM x ()

1800−runHoldInits holdInitRef mergeInitRef = do

1819+runHoldInits :: HasSpiderTimeline x => IORef [SomeHoldInit x] -> IORef [SomeDynInit x] -> IORef [SomeMergeInit x] -> EventM x ()

1820+runHoldInits holdInitRef dynInitRef mergeInitRef = do

18011821 holdInits <- liftIO $ readIORef holdInitRef

1822+ dynInits <- liftIO $ readIORef dynInitRef

18021823 mergeInits <- liftIO $ readIORef mergeInitRef

1803− unless (null holdInits && null mergeInits) $ do

1824+ unless (null holdInits && null dynInits && null mergeInits) $ do

18041825 liftIO $ writeIORef holdInitRef []

1826+ liftIO $ writeIORef dynInitRef []

18051827 liftIO $ writeIORef mergeInitRef []

18061828 mapM_ initHold holdInits

1829+ mapM_ initDyn dynInits

18071830 mapM_ unSomeMergeInit mergeInits

1808− runHoldInits holdInitRef mergeInitRef

1831+ runHoldInits holdInitRef dynInitRef mergeInitRef

18091832

18101833initHold :: HasSpiderTimeline x => SomeHoldInit x -> EventM x ()

18111834initHold (SomeHoldInit h) = void $ getHoldEventSubscription h

18121835

1836+initDyn :: HasSpiderTimeline x => SomeDynInit x -> EventM x ()

1837+initDyn (SomeDynInit d) = void $ getDynHold d

1838+

18131839newEventEnv :: IO (EventEnv x)

18141840newEventEnv = do

18151841 toAssignRef <- newIORef [] -- This should only actually get used when events are firing

18161842 holdInitRef <- newIORef []

1843+ dynInitRef <- newIORef []

18171844 mergeUpdateRef <- newIORef []

18181845 mergeInitRef <- newIORef []

18191846 heightRef <- newIORef zeroHeight

@@ -1821,12 +1848,13 @@ newEventEnv = do

18211848 toClearRootRef <- newIORef []

18221849 coincidenceInfosRef <- newIORef []

18231850 delayedRef <- newIORef IntMap.empty

1824− return $ EventEnv toAssignRef holdInitRef mergeUpdateRef mergeInitRef toClearRef toClearRootRef heightRef coincidenceInfosRef delayedRef

1851+ return $ EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeInitRef toClearRef toClearRootRef heightRef coincidenceInfosRef delayedRef

18251852

18261853clearEventEnv :: EventEnv x -> IO ()

1827−clearEventEnv (EventEnv toAssignRef holdInitRef mergeUpdateRef mergeInitRef toClearRef toClearRootRef heightRef coincidenceInfosRef delayedRef) = do

1854+clearEventEnv (EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeInitRef toClearRef toClearRootRef heightRef coincidenceInfosRef delayedRef) = do

18281855 writeIORef toAssignRef []

18291856 writeIORef holdInitRef []

1857+ writeIORef dynInitRef []

18301858 writeIORef mergeUpdateRef []

18311859 writeIORef mergeInitRef []

18321860 writeIORef heightRef zeroHeight

@@ -1841,7 +1869,7 @@ runFrame a = SpiderHost $ ask >>= \_ -> lift $ do

18411869 let env = _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimelineEnv x)

18421870 let go = do

18431871 result <- a

1844− runHoldInits (eventEnvHoldInits 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

1872+ 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

18451873 return result

18461874 result <- runEventM go

18471875 toClear <- readIORef $ eventEnvClears env

@@ -1873,7 +1901,7 @@ runFrame a = SpiderHost $ ask >>= \_ -> lift $ do

18731901 writeIORef (switchSubscribedBehaviorParents subscribed) []

18741902 writeIORef (eventEnvHoldInits env) [] --TODO: Should we reuse this?

18751903 e <- runBehaviorM (readBehaviorTracked (switchSubscribedParent subscribed)) (Just (wi', switchSubscribedBehaviorParents subscribed)) $ eventEnvHoldInits env

1876− runEventM $ runHoldInits (eventEnvHoldInits env) (eventEnvMergeInits 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

1904+ runEventM $ runHoldInits (eventEnvHoldInits env) (eventEnvDynInits env) (eventEnvMergeInits 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

18771905 --TODO: Make sure we touch the pieces of the SwitchSubscribed at the appropriate times

18781906 sub <- newSubscriberSwitch subscribed

18791907 subscription <- runReaderT (unSpiderHost (runFrame ({-# SCC "subscribeSwitch" #-} subscribe e sub))) spiderTimeline --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

@@ -2074,9 +2102,9 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where

20742102 {-# INLINABLE updated #-}

20752103 updated = coerce $ SpiderEvent . dynamicUpdated . unSpiderDynamic

20762104 {-# INLINABLE unsafeBuildDynamic #-}

2077− unsafeBuildDynamic readV0 v' = SpiderDynamic $ dynamicDynIdentity $ unsafeDyn (coerce readV0) $ coerce $ unSpiderEvent v'

2105+ unsafeBuildDynamic readV0 v' = SpiderDynamic $ dynamicDynIdentity $ unsafeBuildDynamic (coerce readV0) $ coerce $ unSpiderEvent v'

20782106 {-# INLINABLE unsafeBuildIncremental #-}

2079− unsafeBuildIncremental readV0 dv = SpiderIncremental $ dynamicDyn $ unsafeDyn (coerce readV0) $ unSpiderEvent dv

2107+ unsafeBuildIncremental readV0 dv = SpiderIncremental $ dynamicDyn $ unsafeBuildDynamic (coerce readV0) $ unSpiderEvent dv

20802108 {-# INLINABLE mergeIncremental #-}

20812109 mergeIncremental = SpiderEvent . merge . (unsafeCoerce :: Dynamic x (PatchDMap k (R.Event (SpiderTimeline x))) -> Dynamic x (PatchDMap k (Event x))) . unSpiderIncremental

20822110 {-# INLINABLE mergeIncrementalWithMove #-}

@@ -2086,7 +2114,7 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where

20862114 {-# INLINABLE updatedIncremental #-}

20872115 updatedIncremental = SpiderEvent . dynamicUpdated . unSpiderIncremental

20882116 {-# INLINABLE incrementalToDynamic #-}

2089− incrementalToDynamic (SpiderIncremental i) = SpiderDynamic $ dynamicDynIdentity $ unsafeDyn (readBehaviorUntracked $ dynamicCurrent i) $ flip push (dynamicUpdated i) $ \p -> do

2117+ incrementalToDynamic (SpiderIncremental i) = SpiderDynamic $ dynamicDynIdentity $ unsafeBuildDynamic (readBehaviorUntracked $ dynamicCurrent i) $ flip push (dynamicUpdated i) $ \p -> do

20902118 c <- readBehaviorUntracked $ dynamicCurrent i

20912119 return $ Identity <$> apply p c --TODO: Avoid the redundant 'apply'

20922120 eventCoercion Coercion = Coercion

src/Reflex/Spider/SpiderTimeline.include.hs+14−1

@@ -16,6 +16,8 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Event

1616 holdDyn = holdDynSpiderEventM

1717 {-# INLINABLE holdIncremental #-}

1818 holdIncremental = holdIncrementalSpiderEventM

19+ {-# INLINABLE buildDynamic #-}

20+ buildDynamic = buildDynamicSpiderEventM

1921

2022instance (

2123#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

@@ -40,6 +42,8 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Spide

4042 holdDyn v0 (SpiderEvent e) = SpiderPushM $ fmap (SpiderDynamic . dynamicHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce e

4143 {-# INLINABLE holdIncremental #-}

4244 holdIncremental v0 (SpiderEvent e) = SpiderPushM $ SpiderIncremental . dynamicHold <$> Reflex.Spider.Internal.hold v0 e

45+ {-# INLINABLE buildDynamic #-}

46+ buildDynamic getV0 (SpiderEvent e) = SpiderPushM $ fmap (SpiderDynamic . dynamicDynIdentity) $ Reflex.Spider.Internal.buildDynamic (coerce getV0) $ coerce e

4347

4448instance HasSpiderTimeline x => Monad (Reflex.Class.Dynamic (SpiderTimeline x)) where

4549 {-# INLINE return #-}

@@ -58,7 +62,7 @@ newJoinDyn d =

5862 eInner = Reflex.Spider.Internal.switch $ dynamicUpdated <$> dynamicCurrent d

5963 eBoth = Reflex.Spider.Internal.coincidence $ dynamicUpdated . runIdentity <$> dynamicUpdated d

6064 v' = unSpiderEvent $ Reflex.Class.leftmost $ map SpiderEvent [eBoth, eOuter, eInner]

61− in unsafeDyn readV0 v'

65+ in Reflex.Spider.Internal.unsafeBuildDynamic readV0 v'

6266

6367instance HasSpiderTimeline x => Functor (Reflex.Class.Dynamic (SpiderTimeline x)) where

6468 fmap f = SpiderDynamic . newMapDyn f . unSpiderDynamic

@@ -78,6 +82,9 @@ holdDynSpiderEventM v0 e = fmap (SpiderDynamic . dynamicHoldIdentity) $ Reflex.S

7882holdIncrementalSpiderEventM :: (HasSpiderTimeline x, Patch p) => PatchTarget p -> Reflex.Class.Event (SpiderTimeline x) p -> EventM x (Reflex.Class.Incremental (SpiderTimeline x) p)

7983holdIncrementalSpiderEventM v0 e = fmap (SpiderIncremental . dynamicHold) $ Reflex.Spider.Internal.hold v0 $ unSpiderEvent e

8084

85+buildDynamicSpiderEventM :: HasSpiderTimeline x => SpiderPullM x a -> Reflex.Class.Event (SpiderTimeline x) a -> EventM x (Reflex.Class.Dynamic (SpiderTimeline x) a)

86+buildDynamicSpiderEventM getV0 e = fmap (SpiderDynamic . dynamicDynIdentity) $ Reflex.Spider.Internal.buildDynamic (coerce getV0) $ coerce $ unSpiderEvent e

87+

8188instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (SpiderHost x) where

8289 {-# INLINABLE hold #-}

8390 hold v0 e = runFrame . runSpiderHostFrame $ Reflex.Class.hold v0 e

@@ -85,6 +92,8 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Spide

8592 holdDyn v0 e = runFrame . runSpiderHostFrame $ Reflex.Class.holdDyn v0 e

8693 {-# INLINABLE holdIncremental #-}

8794 holdIncremental v0 e = runFrame . runSpiderHostFrame $ Reflex.Class.holdIncremental v0 e

95+ {-# INLINABLE buildDynamic #-}

96+ buildDynamic getV0 e = runFrame . runSpiderHostFrame $ Reflex.Class.buildDynamic getV0 e

8897

8998instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHostFrame x) where

9099 sample = SpiderHostFrame . readBehaviorUntracked . unSpiderBehavior --TODO: This can cause problems with laziness, so we should get rid of it if we can

@@ -96,6 +105,8 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Spide

96105 holdDyn v0 e = SpiderHostFrame $ fmap (SpiderDynamic . dynamicHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce $ unSpiderEvent e

97106 {-# INLINABLE holdIncremental #-}

98107 holdIncremental v0 e = SpiderHostFrame $ fmap (SpiderIncremental . dynamicHold) $ Reflex.Spider.Internal.hold v0 $ unSpiderEvent e

108+ {-# INLINABLE buildDynamic #-}

109+ buildDynamic getV0 e = SpiderHostFrame $ fmap (SpiderDynamic . dynamicDynIdentity) $ Reflex.Spider.Internal.buildDynamic (coerce getV0) $ coerce $ unSpiderEvent e

99110

100111instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHost x) where

101112 {-# INLINABLE sample #-}

@@ -112,6 +123,8 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Refle

112123 holdDyn v0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.holdDyn v0 e

113124 {-# INLINABLE holdIncremental #-}

114125 holdIncremental v0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.holdIncremental v0 e

126+ {-# INLINABLE buildDynamic #-}

127+ buildDynamic getV0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.buildDynamic getV0 e

115128

116129--------------------------------------------------------------------------------

117130-- Deprecated items

test/Reflex/Plan/Pure.hs+1

@@ -39,6 +39,7 @@ instance MonadHold (Pure Int) PurePlan where

3939 hold initial = liftPlan . hold initial

4040 holdDyn initial = liftPlan . holdDyn initial

4141 holdIncremental initial = liftPlan . holdIncremental initial

42+ buildDynamic getInitial = liftPlan . buildDynamic getInitial

4243

4344instance MonadSample (Pure Int) PurePlan where

4445 sample = liftPlan . sample

test/Reflex/Test/CrossImpl.hs+7

@@ -7,6 +7,7 @@

77{-# LANGUAGE MultiParamTypeClasses #-}

88{-# LANGUAGE NoMonomorphismRestriction #-}

99{-# LANGUAGE RankNTypes #-}

10+{-# LANGUAGE RecursiveDo #-}

1011{-# LANGUAGE ScopedTypeVariables #-}

1112{-# LANGUAGE TypeFamilies #-}

1213{-# LANGUAGE TypeOperators #-}

@@ -228,10 +229,16 @@ testCases =

228229 let eInner = switch bd

229230 e' = leftmost [eOuter, eInner]

230231 return (b, e')

232+ , (,) "holdUniqDyn-laziness" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList (zip [1 :: Int ..] [1 :: Int, 2, 2, 3, 3, 3, 4, 4, 4, 4])) $ \(_, e :: Event t Int) -> do

233+ rec result <- holdUniqDyn d

234+ d <- holdDyn (0 :: Int) e

235+ return (current result, updated result)

236+ {-

231237 , (,) "mergeIncrementalWithMove" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, PatchDMapWithMove.moveDMapKey LeftTag RightTag), (2, mempty)]) $ \(b, e :: Event t (PatchDMapWithMove (EitherTag () ()) (Const2 () ()))) -> do

232238 x <- holdIncremental (DMap.singleton LeftTag $ void e) $ PatchDMapWithMove.mapPatchDMapWithMove (\(Const2 _) -> void e) <$> e

233239 let e' = mergeIncrementalWithMove x :: Event t (DMap (EitherTag () ()) Identity)

234240 return (b, e')

241+ -}

235242 ]

236243

237244splitRecombineEvent :: Reflex t => Event t a -> Event t String