77ee661 · reflex · git.iko.soy

git.iko.soy/reflex

on develop help sign in

Make Event, Behavior, and Dynamic instances of Coercible

77ee661Ryan Trinkle10 years ago

src/Reflex/Class.hs+61−24

compare with develop

unifiedsplit

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

1{-# LANGUAGE CPP #-}

2+{-# LANGUAGE DeriveFunctor #-}

2{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE FlexibleInstances #-}

4{-# LANGUAGE FlexibleInstances #-}

4{-# LANGUAGE FunctionalDependencies #-}

5{-# LANGUAGE FunctionalDependencies #-}

@@ -9,6 +10,7 @@

9{-# LANGUAGE RankNTypes #-}

10{-# LANGUAGE RankNTypes #-}

10{-# LANGUAGE RecursiveDo #-}

11{-# LANGUAGE RecursiveDo #-}

11{-# LANGUAGE ScopedTypeVariables #-}

12{-# LANGUAGE ScopedTypeVariables #-}

13+{-# LANGUAGE StandaloneDeriving #-}

12{-# LANGUAGE TypeFamilies #-}

14{-# LANGUAGE TypeFamilies #-}

13{-# LANGUAGE TypeOperators #-}

15{-# LANGUAGE TypeOperators #-}

14{-# LANGUAGE UndecidableInstances #-}

16{-# LANGUAGE UndecidableInstances #-}

@@ -19,6 +21,9 @@

19module Reflex.Class

21module Reflex.Class

20 ( -- * Primitives

22 ( -- * Primitives

21 Reflex (..)

23 Reflex (..)

24+ , coerceBehavior

25+ , coerceEvent

26+ , coerceDynamic

22 , MonadSample (..)

27 , MonadSample (..)

23 , MonadHold (..)

28 , MonadHold (..)

24 -- ** 'fan'-related types

29 -- ** 'fan'-related types

@@ -26,6 +31,7 @@ module Reflex.Class

26 -- ** 'Incremental'-related types

31 -- ** 'Incremental'-related types

27 , Patch (..)

32 , Patch (..)

28 , PatchDMap (..)

33 , PatchDMap (..)

34+ , ComposeMaybe (..)

29 , PatchMap (..)

35 , PatchMap (..)

30 -- * Convenience functions

36 -- * Convenience functions

31 , constDyn

37 , constDyn

@@ -98,6 +104,7 @@ import Control.Monad.Trans.RWS (RWST ())

98import Control.Monad.Trans.Writer (WriterT ())

104import Control.Monad.Trans.Writer (WriterT ())

99import Data.Align

105import Data.Align

100import Data.Bifunctor

106import Data.Bifunctor

107+import Data.Coerce

101import Data.Dependent.Map (DMap, DSum (..), GCompare (..), GOrdering (..))

108import Data.Dependent.Map (DMap, DSum (..), GCompare (..), GOrdering (..))

102import qualified Data.Dependent.Map as DMap

109import qualified Data.Dependent.Map as DMap

103import Data.Dependent.Sum (ShowTag (..))

110import Data.Dependent.Sum (ShowTag (..))

@@ -105,7 +112,6 @@ import Data.Either

105import Data.Foldable

112import Data.Foldable

106import Data.Functor.Bind hiding (join)

113import Data.Functor.Bind hiding (join)

107import qualified Data.Functor.Bind as Bind

114import qualified Data.Functor.Bind as Bind

108−import Data.Functor.Compose

109import Data.Functor.Constant

115import Data.Functor.Constant

110import Data.Functor.Misc

116import Data.Functor.Misc

111import Data.Functor.Plus

117import Data.Functor.Plus

@@ -120,6 +126,7 @@ import Data.Semigroup (Semigroup, sconcat, stimes, stimesIdempotentMonoid, (<>))

120import Data.String

126import Data.String

121import Data.These

127import Data.These

122import Data.Traversable

128import Data.Traversable

129+import Data.Type.Coercion

123

130

124-- Note: must come last to silence warnings due to AMP on GHC < 7.10

131-- Note: must come last to silence warnings due to AMP on GHC < 7.10

125import Prelude hiding (foldl, mapM, mapM_, sequence, sequence_)

132import Prelude hiding (foldl, mapM, mapM_, sequence, sequence_)

@@ -156,7 +163,7 @@ class ( MonadHold t (PushM t)

156 -- notifications on changes. Basically a combination of a 'Behavior' and an

163 -- notifications on changes. Basically a combination of a 'Behavior' and an

157 -- 'Event', with a rule that the 'Behavior' will change if and only if the

164 -- 'Event', with a rule that the 'Behavior' will change if and only if the

158 -- 'Event' fires.

165 -- 'Event' fires.

159− data Incremental t :: (* -> *) -> * -> *

166+ data Incremental t :: * -> *

160 -- | An 'Event' with no occurrences

167 -- | An 'Event' with no occurrences

161 never :: Event t a

168 never :: Event t a

162 -- | Create a 'Behavior' that always has the given value

169 -- | Create a 'Behavior' that always has the given value

@@ -196,30 +203,59 @@ class ( MonadHold t (PushM t)

196 -- | Create a new 'Incremental'. The given 'PullM''s value must always change

203 -- | Create a new 'Incremental'. The given 'PullM''s value must always change

197 -- in the same way that the accumulated application of patches would change

204 -- in the same way that the accumulated application of patches would change

198 -- that value.

205 -- that value.

199− unsafeBuildIncremental :: Patch p => PullM t a -> Event t (p a) -> Incremental t p a

206+ unsafeBuildIncremental :: Patch p => PullM t (PatchTarget p) -> Event t p -> Incremental t p

200 -- | Create a merge whose parents can change over time

207 -- | Create a merge whose parents can change over time

201− mergeIncremental :: GCompare k => Incremental t PatchDMap (DMap k (Event t)) -> Event t (DMap k Identity)

208+ mergeIncremental :: GCompare k => Incremental t (PatchDMap k (Event t)) -> Event t (DMap k Identity)

202 -- | Extract the 'Behavior' component of an 'Incremental'

209 -- | Extract the 'Behavior' component of an 'Incremental'

203− currentIncremental :: Patch p => Incremental t p a -> Behavior t a

210+ currentIncremental :: Patch p => Incremental t p -> Behavior t (PatchTarget p)

204 -- | Extract the 'Event' component of an 'Incremental'

211 -- | Extract the 'Event' component of an 'Incremental'

205− updatedIncremental :: Patch p => Incremental t p a -> Event t (p a)

212+ updatedIncremental :: Patch p => Incremental t p -> Event t p

206 -- | Convert an 'Incremental' to a 'Dynamic'

213 -- | Convert an 'Incremental' to a 'Dynamic'

207− incrementalToDynamic :: Patch p => Incremental t p a -> Dynamic t a

214+ incrementalToDynamic :: Patch p => Incremental t p -> Dynamic t (PatchTarget p)

215+ -- | Construct a 'Coercion' for a 'Behavior' given an 'Coercion' for its

216+ -- occurrence type

217+ behaviorCoercion :: Coercion a b -> Coercion (Behavior t a) (Behavior t b)

218+ -- | Construct a 'Coercion' for an 'Event' given an 'Coercion' for its

219+ -- occurrence type

220+ eventCoercion :: Coercion a b -> Coercion (Event t a) (Event t b)

221+ -- | Construct a 'Coercion' for a 'Dynamic' given an 'Coercion' for its

222+ -- occurrence type

223+ dynamicCoercion :: Coercion a b -> Coercion (Dynamic t a) (Dynamic t b)

224+

225+-- | Coerce a 'Behavior' between representationally-equivalent value types

226+coerceBehavior :: (Reflex t, Coercible a b) => Behavior t a -> Behavior t b

227+coerceBehavior = coerceWith $ behaviorCoercion Coercion

228+

229+-- | Coerce an 'Event' between representationally-equivalent occurrence types

230+coerceEvent :: (Reflex t, Coercible a b) => Event t a -> Event t b

231+coerceEvent = coerceWith $ eventCoercion Coercion

232+

233+-- | Coerce a 'Dynamic' between representationally-equivalent value types

234+coerceDynamic :: (Reflex t, Coercible a b) => Dynamic t a -> Dynamic t b

235+coerceDynamic = coerceWith $ dynamicCoercion Coercion

208

236

209-- | A 'Patch' type represents a kind of change made to a datastructure.

237-- | A 'Patch' type represents a kind of change made to a datastructure.

210class Patch p where

238class Patch p where

239+ type PatchTarget p :: *

211 -- | Apply the patch @p a@ to the value @a@. If no change is needed, return

240 -- | Apply the patch @p a@ to the value @a@. If no change is needed, return

212 -- 'Nothing'.

241 -- 'Nothing'.

213− apply :: p a -> a -> Maybe a

242+ apply :: p -> PatchTarget p -> Maybe (PatchTarget p)

214

243

244+-- | We can't use @Compose Maybe@ instead of 'ComposeMaybe', because that would

245+-- make the 'f' parameter have a nominal type role. We need f to be

246+-- representational so that we can use safe 'coerce'.

247+newtype ComposeMaybe f a = ComposeMaybe { getComposeMaybe :: Maybe (f a) }

248+

249+deriving instance Functor f => Functor (ComposeMaybe f)

250+

215−instance Patch Identity where

251+instance Patch (Identity a) where

252+ type PatchTarget (Identity a) = a

216 apply (Identity a) _ = Just a

253 apply (Identity a) _ = Just a

217

254

218-- | A set of changes to a 'DMap'. Only DMap types are allowed for @a@.

255-- | A set of changes to a 'DMap'. Only DMap types are allowed for @a@.

219−data PatchDMap a where

220− PatchDMap :: GCompare k => DMap k (Compose Maybe v) -> PatchDMap (DMap k v)

256+newtype PatchDMap k v = PatchDMap (DMap k (ComposeMaybe v))

221

257

222−instance GCompare k => Semigroup (PatchDMap (DMap k v)) where

258+instance GCompare k => Semigroup (PatchDMap k v) where

223 PatchDMap a <> PatchDMap b = PatchDMap $ a `mappend` b --TODO: Add a semigroup instance for DMap

259 PatchDMap a <> PatchDMap b = PatchDMap $ a `mappend` b --TODO: Add a semigroup instance for DMap

224 -- PatchDMap is idempotent, so stimes n is id for every n

260 -- PatchDMap is idempotent, so stimes n is id for every n

225#if MIN_VERSION_semigroups(0,17,0)

261#if MIN_VERSION_semigroups(0,17,0)

@@ -231,22 +267,23 @@ instance GCompare k => Semigroup (PatchDMap (DMap k v)) where

231 GT -> x

267 GT -> x

232#endif

268#endif

233

269

234−instance GCompare k => Monoid (PatchDMap (DMap k v)) where

270+instance GCompare k => Monoid (PatchDMap k v) where

235 mempty = PatchDMap mempty

271 mempty = PatchDMap mempty

236 mappend = (<>)

272 mappend = (<>)

237

273

238−instance Patch PatchDMap where

274+instance GCompare k => Patch (PatchDMap k v) where

275+ type PatchTarget (PatchDMap k v) = DMap k v

239 apply (PatchDMap diff) old = Just $! insertions `DMap.union` (old `DMap.difference` deletions) --TODO: return Nothing sometimes --Note: the strict application here is critical to ensuring that incremental merges don't hold onto all their prerequisite events forever; can we make this more robust?

276 apply (PatchDMap diff) old = Just $! insertions `DMap.union` (old `DMap.difference` deletions) --TODO: return Nothing sometimes --Note: the strict application here is critical to ensuring that incremental merges don't hold onto all their prerequisite events forever; can we make this more robust?

240− where insertions = DMap.mapMaybeWithKey (const $ getCompose) diff

277+ where insertions = DMap.mapMaybeWithKey (const $ getComposeMaybe) diff

241− deletions = DMap.mapMaybeWithKey (const $ nothingToJust . getCompose) diff

278+ deletions = DMap.mapMaybeWithKey (const $ nothingToJust . getComposeMaybe) diff

242 nothingToJust = \case

279 nothingToJust = \case

243 Nothing -> Just $ Constant ()

280 Nothing -> Just $ Constant ()

244 Just _ -> Nothing

281 Just _ -> Nothing

245

282

246−data PatchMap a where

283+newtype PatchMap k v = PatchMap (Map k (Maybe v))

247− PatchMap :: Ord k => Map k (Maybe v) -> PatchMap (Map k v)

248

284

249−instance Patch PatchMap where

285+instance Ord k => Patch (PatchMap k v) where

286+ type PatchTarget (PatchMap k v) = Map k v

250 apply (PatchMap p) old = Just $! insertions `Map.union` (old `Map.difference` deletions) --TODO: return Nothing sometimes --Note: the strict application here is critical to ensuring that incremental merges don't hold onto all their prerequisite events forever; can we make this more robust?

287 apply (PatchMap p) old = Just $! insertions `Map.union` (old `Map.difference` deletions) --TODO: return Nothing sometimes --Note: the strict application here is critical to ensuring that incremental merges don't hold onto all their prerequisite events forever; can we make this more robust?

251 where insertions = Map.mapMaybeWithKey (const id) p

288 where insertions = Map.mapMaybeWithKey (const id) p

252 deletions = Map.mapMaybeWithKey (const nothingToJust) p

289 deletions = Map.mapMaybeWithKey (const nothingToJust) p

@@ -254,7 +291,7 @@ instance Patch PatchMap where

254 Nothing -> Just ()

291 Nothing -> Just ()

255 Just _ -> Nothing

292 Just _ -> Nothing

256

293

257−instance Ord k => Semigroup (PatchMap (Map k v)) where

294+instance Ord k => Semigroup (PatchMap k v) where

258 PatchMap a <> PatchMap b = PatchMap $ a `mappend` b --TODO: Add a semigroup instance for Map

295 PatchMap a <> PatchMap b = PatchMap $ a `mappend` b --TODO: Add a semigroup instance for Map

259 -- PatchMap is idempotent, so stimes n is id for every n

296 -- PatchMap is idempotent, so stimes n is id for every n

260#if MIN_VERSION_semigroups(0,17,0)

297#if MIN_VERSION_semigroups(0,17,0)

@@ -266,7 +303,7 @@ instance Ord k => Semigroup (PatchMap (Map k v)) where

266 GT -> x

303 GT -> x

267#endif

304#endif

268

305

269−instance Ord k => Monoid (PatchMap (Map k v)) where

306+instance Ord k => Monoid (PatchMap k v) where

270 mempty = PatchMap mempty

307 mempty = PatchMap mempty

271 mappend = (<>)

308 mappend = (<>)

272

309

@@ -304,7 +341,7 @@ class MonadSample t m => MonadHold t m where

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

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

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

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

306 -- every time the 'Event' occurs.

343 -- every time the 'Event' occurs.

307− holdIncremental :: Patch p => a -> Event t (p a) -> m (Incremental t p a)

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

308

345

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

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

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

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

@@ -820,14 +857,14 @@ zipListWithEvent f l e = do

820 mapAccumMaybe_ f' l e

857 mapAccumMaybe_ f' l e

821

858

822class (Reflex t, Monad m) => MonadAdjust t m | m -> t where

859class (Reflex t, Monad m) => MonadAdjust t m | m -> t where

823− sequenceDMapWithAdjust :: GCompare k => DMap k m -> Event t (PatchDMap (DMap k m)) -> m (DMap k Identity, Event t (PatchDMap (DMap k Identity)))

860+ sequenceDMapWithAdjust :: GCompare k => DMap k m -> Event t (PatchDMap k m) -> m (DMap k Identity, Event t (PatchDMap k Identity))

824

861

825instance (Reflex t, MonadAdjust t m) => MonadAdjust t (ReaderT r m) where

862instance (Reflex t, MonadAdjust t m) => MonadAdjust t (ReaderT r m) where

826 sequenceDMapWithAdjust dm0 dm' = do

863 sequenceDMapWithAdjust dm0 dm' = do

827 r <- ask

864 r <- ask

828 let loweredDm0 = DMap.map (`runReaderT` r) dm0

865 let loweredDm0 = DMap.map (`runReaderT` r) dm0

829 loweredDm' = ffor dm' $ \(PatchDMap p) -> PatchDMap $

866 loweredDm' = ffor dm' $ \(PatchDMap p) -> PatchDMap $

830− DMap.map (\(Compose mv) -> Compose $ fmap (`runReaderT` r) mv) p

867+ DMap.map (\(ComposeMaybe mv) -> ComposeMaybe $ fmap (`runReaderT` r) mv) p

831 lift $ sequenceDMapWithAdjust loweredDm0 loweredDm'

868 lift $ sequenceDMapWithAdjust loweredDm0 loweredDm'

832

869

833--------------------------------------------------------------------------------

870--------------------------------------------------------------------------------

src/Reflex/DynamicWriter.hs+13−14

@@ -19,7 +19,6 @@ import Control.Monad.Ref

19import Control.Monad.State.Strict

20import Data.Dependent.Map (DMap, DSum (..))

21import Data.Foldable

22−import Data.Functor.Compose

23import Data.Functor.Misc

22import Data.Functor.Misc

24import Data.Map (Map)

23import Data.Map (Map)

25import qualified Data.Map as Map

24import qualified Data.Map as Map

@@ -35,33 +34,33 @@ import Reflex.Host.Class

35instance MonadTrans (DynamicWriterT t w) where

34instance MonadTrans (DynamicWriterT t w) where

36 lift = DynamicWriterT . lift

35 lift = DynamicWriterT . lift

38−mconcatIncremental :: (Reflex t, MonadHold t m, MonadFix m, Monoid v) => Map k v -> Event t (PatchMap (Map k v)) -> m (Dynamic t v)

37+mconcatIncremental :: (Reflex t, MonadHold t m, MonadFix m, Monoid v, Ord k) => Map k v -> Event t (PatchMap k v) -> m (Dynamic t v)

39mconcatIncremental m0 e = do

38mconcatIncremental m0 e = do

40 d <- foldDynMaybe apply m0 e

39 d <- foldDynMaybe apply m0 e

41 return $ fmap (mconcat . Map.elems) d

40 return $ fmap (mconcat . Map.elems) d

43−mapIncrementalMapValuesWithKey :: Reflex t => (k -> v -> v') -> Incremental t PatchMap (Map k v) -> Incremental t PatchMap (Map k v')

42+mapIncrementalMapValuesWithKey :: (Reflex t, Ord k) => (k -> v -> v') -> Incremental t (PatchMap k v) -> Incremental t (PatchMap k v')

44mapIncrementalMapValuesWithKey f = unsafeMapIncremental (Map.mapWithKey f) $ \(PatchMap m) -> PatchMap $ Map.mapWithKey (\k mv -> fmap (f k) mv) m

43mapIncrementalMapValuesWithKey f = unsafeMapIncremental (Map.mapWithKey f) $ \(PatchMap m) -> PatchMap $ Map.mapWithKey (\k mv -> fmap (f k) mv) m

46−mapIncrementalMapValues :: Reflex t => (v -> v') -> Incremental t PatchMap (Map k v) -> Incremental t PatchMap (Map k v')

45+mapIncrementalMapValues :: (Reflex t, Ord k) => (v -> v') -> Incremental t (PatchMap k v) -> Incremental t (PatchMap k v')

47mapIncrementalMapValues f = mapIncrementalMapValuesWithKey $ const f

46mapIncrementalMapValues f = mapIncrementalMapValuesWithKey $ const f

49−unsafeMapIncremental :: (Reflex t, Patch p, Patch p') => (a -> a') -> (p a -> p' a') -> Incremental t p a -> Incremental t p' a'

48+unsafeMapIncremental :: (Reflex t, Patch p, Patch p') => (PatchTarget p -> PatchTarget p') -> (p -> p') -> Incremental t p -> Incremental t p'

50unsafeMapIncremental f g a = unsafeBuildIncremental (fmap f $ sample $ currentIncremental a) $ g <$> updatedIncremental a

49unsafeMapIncremental f g a = unsafeBuildIncremental (fmap f $ sample $ currentIncremental a) $ g <$> updatedIncremental a

52−incrementalExtractFunctorDMap :: Reflex t => Incremental t PatchMap (Map k (f v)) -> Incremental t PatchDMap (DMap (Const2 k v) f)

51+incrementalExtractFunctorDMap :: (Reflex t, Ord k) => Incremental t (PatchMap k (f v)) -> Incremental t (PatchDMap (Const2 k v) f)

53−incrementalExtractFunctorDMap = unsafeMapIncremental mapWithFunctorToDMap $ \(PatchMap m) -> PatchDMap $ mapWithFunctorToDMap $ fmap Compose m

52+incrementalExtractFunctorDMap = unsafeMapIncremental mapWithFunctorToDMap $ \(PatchMap m) -> PatchDMap $ mapWithFunctorToDMap $ fmap ComposeMaybe m

55−mergeIncrementalMap :: (Reflex t, Ord k) => Incremental t PatchMap (Map k (Event t v)) -> Event t (Map k v)

54+mergeIncrementalMap :: (Reflex t, Ord k) => Incremental t (PatchMap k (Event t v)) -> Event t (Map k v)

56mergeIncrementalMap = fmap dmapToMap . mergeIncremental . incrementalExtractFunctorDMap

55mergeIncrementalMap = fmap dmapToMap . mergeIncremental . incrementalExtractFunctorDMap

58−holdIncrementalReplaceableMap :: forall t k v m. (MonadFix m, MonadHold t m, Reflex t, Ord k) => Map k (Replaceable t v) -> Event t (PatchMap (Map k (Replaceable t v))) -> m (Incremental t PatchMap (Map k v))

57+holdIncrementalReplaceableMap :: forall t k v m. (MonadFix m, MonadHold t m, Reflex t, Ord k) => Map k (Replaceable t v) -> Event t (PatchMap k (Replaceable t v)) -> m (Incremental t (PatchMap k v))

59holdIncrementalReplaceableMap m0 m' = do

58holdIncrementalReplaceableMap m0 m' = do

60 rec vals <- holdIncremental m0 $ m' <> valChanges

59 rec vals <- holdIncremental m0 $ m' <> valChanges

61 let valChanges = fmap PatchMap $ mergeIncrementalMap $ mapIncrementalMapValues _replaceable_modify vals

60 let valChanges = fmap PatchMap $ mergeIncrementalMap $ mapIncrementalMapValues _replaceable_modify vals

62 return $ mapIncrementalMapValues _replaceable_value vals

61 return $ mapIncrementalMapValues _replaceable_value vals

64−mergeDynIncremental :: (Reflex t, Ord k) => Incremental t PatchMap (Map k (Dynamic t v)) -> Incremental t PatchMap (Map k v)

63+mergeDynIncremental :: (Reflex t, Ord k) => Incremental t (PatchMap k (Dynamic t v)) -> Incremental t (PatchMap k v)

65mergeDynIncremental a = unsafeBuildIncremental (mapM (sample . current) =<< sample (currentIncremental a)) $ addedAndRemovedValues <> changedValues

64mergeDynIncremental a = unsafeBuildIncremental (mapM (sample . current) =<< sample (currentIncremental a)) $ addedAndRemovedValues <> changedValues

66 where changedValues = fmap (PatchMap . fmap Just) $ mergeIncrementalMap $ mapIncrementalMapValues updated a

65 where changedValues = fmap (PatchMap . fmap Just) $ mergeIncrementalMap $ mapIncrementalMapValues updated a

67 addedAndRemovedValues = flip pushAlways (updatedIncremental a) $ \(PatchMap m) -> PatchMap <$> mapM (mapM (sample . current)) m

66 addedAndRemovedValues = flip pushAlways (updatedIncremental a) $ \(PatchMap m) -> PatchMap <$> mapM (mapM (sample . current)) m

@@ -94,7 +93,7 @@ runDynamicWriterTInternal (DynamicWriterT a) = runStateT a []

94mconcatIncrementalReplaceableDynMap :: forall m t k v.

93mconcatIncrementalReplaceableDynMap :: forall m t k v.

95 (MonadFix m, MonadHold t m, Reflex t, Monoid v, Ord k)

94 (MonadFix m, MonadHold t m, Reflex t, Monoid v, Ord k)

96 => Map k (Replaceable t (Dynamic t v))

95 => Map k (Replaceable t (Dynamic t v))

97− -> Event t (PatchMap (Map k (Replaceable t (Dynamic t v))))

96+ -> Event t (PatchMap k (Replaceable t (Dynamic t v)))

98 -> Event t ()

97 -> Event t ()

99 -> m (Replaceable t (Dynamic t v))

98 -> m (Replaceable t (Dynamic t v))

100mconcatIncrementalReplaceableDynMap m0 m' additionsCeased = do

99mconcatIncrementalReplaceableDynMap m0 m' additionsCeased = do

@@ -160,17 +159,17 @@ instance (MonadAdjust t m, MonadFix m, Monoid w, MonadHold t m, Reflex t) => Mon

160 sequenceDMapWithAdjust (dm0 :: DMap k (DynamicWriterT t w m)) dm' = do

159 sequenceDMapWithAdjust (dm0 :: DMap k (DynamicWriterT t w m)) dm' = do

161 let loweredDm0 = mapKeyValuePairsMonotonic (\(k :=> v) -> WrapArg k :=> fmap DynamicWriterTLoweredResult (runDynamicWriterT v)) dm0

160 let loweredDm0 = mapKeyValuePairsMonotonic (\(k :=> v) -> WrapArg k :=> fmap DynamicWriterTLoweredResult (runDynamicWriterT v)) dm0

162 let loweredDm' = ffor dm' $ \(PatchDMap p) -> PatchDMap $

161 let loweredDm' = ffor dm' $ \(PatchDMap p) -> PatchDMap $

163− mapKeyValuePairsMonotonic (\(k :=> Compose mv) -> WrapArg k :=> Compose (fmap (fmap DynamicWriterTLoweredResult . runDynamicWriterT) mv)) p

162+ mapKeyValuePairsMonotonic (\(k :=> ComposeMaybe mv) -> WrapArg k :=> ComposeMaybe (fmap (fmap DynamicWriterTLoweredResult . runDynamicWriterT) mv)) p

164 (result0, result') <- lift $ sequenceDMapWithAdjust loweredDm0 loweredDm'

163 (result0, result') <- lift $ sequenceDMapWithAdjust loweredDm0 loweredDm'

165 let getValue (DynamicWriterTLoweredResult (v, _)) = v

164 let getValue (DynamicWriterTLoweredResult (v, _)) = v

166 getWritten (DynamicWriterTLoweredResult (_, w)) = w

165 getWritten (DynamicWriterTLoweredResult (_, w)) = w

167 liftedResult0 = mapKeyValuePairsMonotonic (\(WrapArg k :=> Identity r) -> k :=> Identity (getValue r)) result0

166 liftedResult0 = mapKeyValuePairsMonotonic (\(WrapArg k :=> Identity r) -> k :=> Identity (getValue r)) result0

168 liftedResult' = ffor result' $ \(PatchDMap p) -> PatchDMap $

167 liftedResult' = ffor result' $ \(PatchDMap p) -> PatchDMap $

169− mapKeyValuePairsMonotonic (\(WrapArg k :=> Compose mr) -> k :=> Compose (fmap (Identity . getValue . runIdentity) mr)) p

168+ mapKeyValuePairsMonotonic (\(WrapArg k :=> ComposeMaybe mr) -> k :=> ComposeMaybe (fmap (Identity . getValue . runIdentity) mr)) p

170 liftedWritten0 :: DMap (Const2 (Some k) (Dynamic t w)) Identity

169 liftedWritten0 :: DMap (Const2 (Some k) (Dynamic t w)) Identity

171 liftedWritten0 = mapKeyValuePairsMonotonic (\(WrapArg k :=> Identity r) -> Const2 (Some.This k) :=> Identity (getWritten r)) result0

170 liftedWritten0 = mapKeyValuePairsMonotonic (\(WrapArg k :=> Identity r) -> Const2 (Some.This k) :=> Identity (getWritten r)) result0

172 liftedWritten' = ffor result' $ \(PatchDMap p) -> PatchDMap $

171 liftedWritten' = ffor result' $ \(PatchDMap p) -> PatchDMap $

173− mapKeyValuePairsMonotonic (\(WrapArg k :=> Compose mr) -> Const2 (Some.This k) :=> Compose (fmap (Identity . getWritten . runIdentity) mr)) p

172+ mapKeyValuePairsMonotonic (\(WrapArg k :=> ComposeMaybe mr) -> Const2 (Some.This k) :=> ComposeMaybe (fmap (Identity . getWritten . runIdentity) mr)) p

174 --TODO: We should be able to improve the performance here in two ways

173 --TODO: We should be able to improve the performance here in two ways

175 -- 1. Incrementally merging the Dynamics

174 -- 1. Incrementally merging the Dynamics

176 -- 2. Incrementally updating the mconcat of the merged Dynamics

175 -- 2. Incrementally updating the mconcat of the merged Dynamics

src/Reflex/PerformEvent/Base.hs+18−21

@@ -30,7 +30,6 @@ import Data.Coerce

30import Data.Dependent.Map (DMap, GCompare (..), Some)

31import qualified Data.Dependent.Map as DMap

32import Data.Dependent.Sum

33−import Data.Functor.Compose

34import Data.Functor.Misc

33import Data.Functor.Misc

35import Data.Semigroup

34import Data.Semigroup

36import qualified Data.Some as Some

35import qualified Data.Some as Some

@@ -38,8 +37,6 @@ import Data.These

38import Data.Tuple

37import Data.Tuple

39import Data.Unique.Tag

38import Data.Unique.Tag

41−import Unsafe.Coerce

42−

43newtype EventTriggerRef t m a = EventTriggerRef { unEventTriggerRef :: Ref m (Maybe (EventTrigger t a)) }

40newtype EventTriggerRef t m a = EventTriggerRef { unEventTriggerRef :: Ref m (Maybe (EventTrigger t a)) }

45newtype FireCommand t m = FireCommand { runFireCommand :: forall a. [DSum (EventTrigger t) Identity] -> ReadPhase m a -> m [a] } --TODO: The handling of this ReadPhase seems wrong, or at least inelegant; how do we actually make the decision about what order frames run in?

42newtype FireCommand t m = FireCommand { runFireCommand :: forall a. [DSum (EventTrigger t) Identity] -> ReadPhase m a -> m [a] } --TODO: The handling of this ReadPhase seems wrong, or at least inelegant; how do we actually make the decision about what order frames run in?

@@ -65,12 +62,12 @@ instance (ReflexHost t, Ref m ~ Ref IO, PrimMonad (HostFrame t)) => PerformEvent

65 performEvent = PerformEventT . fmap (fmap runIdentity) . requesting

62 performEvent = PerformEventT . fmap (fmap runIdentity) . requesting

67instance (ReflexHost t, PrimMonad (HostFrame t)) => MonadAdjust t (PerformEventT t m) where

64instance (ReflexHost t, PrimMonad (HostFrame t)) => MonadAdjust t (PerformEventT t m) where

68− sequenceDMapWithAdjust outerDm0 outerDm' = PerformEventT $ sequenceDMapWithAdjustRequestTWith f (coerce outerDm0) (unsafeCoerce outerDm') --TODO: Eliminate unsafeCoerce (why doesn't coerce work here, even inside the Event and PatchDMap?)

65+ sequenceDMapWithAdjust (outerDm0 :: DMap k (PerformEventT t m)) outerDm' = PerformEventT $ sequenceDMapWithAdjustRequestTWith f (coerce outerDm0) (coerceEvent outerDm')

69− where f :: DMap k (HostFrame t) -> Event t (PatchDMap (DMap k (HostFrame t))) -> RequestT t (HostFrame t) Identity (HostFrame t) (DMap k Identity, Event t (PatchDMap (DMap k Identity)))

66+ where f :: DMap k' (HostFrame t) -> Event t (PatchDMap k' (HostFrame t)) -> RequestT t (HostFrame t) Identity (HostFrame t) (DMap k' Identity, Event t (PatchDMap k' Identity))

70 f dm0 dm' = do

67 f dm0 dm' = do

71 result0 <- lift $ DMap.traverseWithKey (\_ v -> Identity <$> v) dm0

68 result0 <- lift $ DMap.traverseWithKey (\_ v -> Identity <$> v) dm0

72 result' <- requesting $ ffor dm' $ \(PatchDMap p) -> do

69 result' <- requesting $ ffor dm' $ \(PatchDMap p) -> do

73− PatchDMap <$> DMap.traverseWithKey (\_ (Compose mv) -> Compose <$> mapM (fmap Identity) mv) p

70+ PatchDMap <$> DMap.traverseWithKey (\_ (ComposeMaybe mv) -> ComposeMaybe <$> mapM (fmap Identity) mv) p

74 return (result0, fmap runIdentity result')

71 return (result0, fmap runIdentity result')

76instance ReflexHost t => MonadReflexCreateTrigger t (PerformEventT t m) where

73instance ReflexHost t => MonadReflexCreateTrigger t (PerformEventT t m) where

@@ -170,8 +167,8 @@ instance (Reflex t, PrimMonad m) => MonadRequest t (RequestT t request response

170

167

171data DMapTransform (a :: *) k k' v v' = forall (b :: *). DMapTransform !(k a -> k' b) !(v a -> v' b)

168data DMapTransform (a :: *) k k' v v' = forall (b :: *). DMapTransform !(k a -> k' b) !(v a -> v' b)

172

169

173−mapPatchKeysAndValuesMonotonic :: GCompare k' => (forall a. DMapTransform a k k' v v') -> PatchDMap (DMap k v) -> PatchDMap (DMap k' v')

170+mapPatchKeysAndValuesMonotonic :: (forall a. DMapTransform a k k' v v') -> PatchDMap k v -> PatchDMap k' v'

174−mapPatchKeysAndValuesMonotonic x (PatchDMap p) = PatchDMap $ mapKeyValuePairsMonotonic (\(k :=> Compose mv) -> case x of DMapTransform f g -> f k :=> Compose (fmap g mv)) p

171+mapPatchKeysAndValuesMonotonic x (PatchDMap p) = PatchDMap $ mapKeyValuePairsMonotonic (\(k :=> ComposeMaybe mv) -> case x of DMapTransform f g -> f k :=> ComposeMaybe (fmap g mv)) p

175

172

176mapKeysAndValuesMonotonic :: (forall a. DMapTransform a k k' v v') -> DMap k v -> DMap k' v'

173mapKeysAndValuesMonotonic :: (forall a. DMapTransform a k k' v v') -> DMap k v -> DMap k' v'

177mapKeysAndValuesMonotonic x = mapKeyValuePairsMonotonic $ \(k :=> v) -> case x of

174mapKeysAndValuesMonotonic x = mapKeyValuePairsMonotonic $ \(k :=> v) -> case x of

@@ -191,12 +188,12 @@ instance (Reflex t, MonadAdjust t m, MonadHold t m) => MonadAdjust t (RequestT t

191sequenceDMapWithAdjustRequestTWith :: (GCompare k, Monad m, Reflex t, MonadHold t m)

188sequenceDMapWithAdjustRequestTWith :: (GCompare k, Monad m, Reflex t, MonadHold t m)

192 => (forall k'. GCompare k'

189 => (forall k'. GCompare k'

193 => DMap k' m

190 => DMap k' m

194− -> Event t (PatchDMap (DMap k' m))

191+ -> Event t (PatchDMap k' m)

195− -> RequestT t request response m (DMap k' Identity, Event t (PatchDMap (DMap k' Identity)))

192+ -> RequestT t request response m (DMap k' Identity, Event t (PatchDMap k' Identity))

196 )

193 )

197 -> DMap k (RequestT t request response m)

194 -> DMap k (RequestT t request response m)

198− -> Event t (PatchDMap (DMap k (RequestT t request response m)))

195+ -> Event t (PatchDMap k (RequestT t request response m))

199− -> RequestT t request response m (DMap k Identity, Event t (PatchDMap (DMap k Identity)))

196+ -> RequestT t request response m (DMap k Identity, Event t (PatchDMap k Identity))

200sequenceDMapWithAdjustRequestTWith f (dm0 :: DMap k (RequestT t request response m)) dm' = do

197sequenceDMapWithAdjustRequestTWith f (dm0 :: DMap k (RequestT t request response m)) dm' = do

201 response <- RequestT ask

198 response <- RequestT ask

202 let inputTransform :: forall a. DMapTransform a k (WrapArg ((,) [Event t (DMap (Tag (PrimState m)) request)]) k) (RequestT t request response m) m

199 let inputTransform :: forall a. DMapTransform a k (WrapArg ((,) [Event t (DMap (Tag (PrimState m)) request)]) k) (RequestT t request response m) m

@@ -204,16 +201,16 @@ sequenceDMapWithAdjustRequestTWith f (dm0 :: DMap k (RequestT t request response

204 (children0, children') <- f (mapKeysAndValuesMonotonic inputTransform dm0) $ mapPatchKeysAndValuesMonotonic inputTransform <$> dm'

201 (children0, children') <- f (mapKeysAndValuesMonotonic inputTransform dm0) $ mapPatchKeysAndValuesMonotonic inputTransform <$> dm'

205 let result0 = mapKeyValuePairsMonotonic (\(WrapArg k :=> Identity (_, v)) -> k :=> Identity v) children0

202 let result0 = mapKeyValuePairsMonotonic (\(WrapArg k :=> Identity (_, v)) -> k :=> Identity v) children0

206 result' = ffor children' $ \(PatchDMap p) -> PatchDMap $

203 result' = ffor children' $ \(PatchDMap p) -> PatchDMap $

207− mapKeyValuePairsMonotonic (\(WrapArg k :=> Compose mv) -> k :=> Compose (fmap (Identity . snd . runIdentity) mv)) p

204+ mapKeyValuePairsMonotonic (\(WrapArg k :=> ComposeMaybe mv) -> k :=> ComposeMaybe (fmap (Identity . snd . runIdentity) mv)) p

208 requests0 :: DMap (Const2 (Some k) (DMap (Tag (PrimState m)) request)) (Event t)

205 requests0 :: DMap (Const2 (Some k) (DMap (Tag (PrimState m)) request)) (Event t)

209 requests0 = mapKeyValuePairsMonotonic (\(WrapArg k :=> Identity (r, _)) -> Const2 (Some.This k) :=> mergeWith DMap.union r) children0

206 requests0 = mapKeyValuePairsMonotonic (\(WrapArg k :=> Identity (r, _)) -> Const2 (Some.This k) :=> mergeWith DMap.union r) children0

210− requests' :: Event t (PatchDMap (DMap (Const2 (Some k) (DMap (Tag (PrimState m)) request)) (Event t)))

207+ requests' :: Event t (PatchDMap (Const2 (Some k) (DMap (Tag (PrimState m)) request)) (Event t))

211 requests' = ffor children' $ \(PatchDMap p) -> PatchDMap $

208 requests' = ffor children' $ \(PatchDMap p) -> PatchDMap $

212− mapKeyValuePairsMonotonic (\(WrapArg k :=> Compose mv) -> Const2 (Some.This k) :=> Compose (fmap (mergeWith DMap.union . fst . runIdentity) mv)) p

209+ mapKeyValuePairsMonotonic (\(WrapArg k :=> ComposeMaybe mv) -> Const2 (Some.This k) :=> ComposeMaybe (fmap (mergeWith DMap.union . fst . runIdentity) mv)) p

213 childRequestMap <- holdIncremental requests0 requests'

210 childRequestMap <- holdIncremental requests0 requests'

214 RequestT $ modify $ (:) $ ffor (mergeIncremental childRequestMap) $ \m ->

211 RequestT $ modify $ (:) $ ffor (mergeIncremental childRequestMap) $ \m ->

215 mconcat $ (\(Const2 _ :=> Identity reqs) -> reqs) <$> DMap.toList m

212 mconcat $ (\(Const2 _ :=> Identity reqs) -> reqs) <$> DMap.toList m

216−-- RequestT $ modify $ (:) $ coincidence $ ffor requests' $ \(PatchDMap p) -> mergeWith DMap.union $ catMaybes $ ffor (DMap.toList p) $ \(Const2 _ :=> Compose me) -> me -- We could make it prompt like this, but this seems to be slower than just delaying the PostBuild event to allow this stuff to settle (which is more similar to the previous behavior anyway)

213+-- RequestT $ modify $ (:) $ coincidence $ ffor requests' $ \(PatchDMap p) -> mergeWith DMap.union $ catMaybes $ ffor (DMap.toList p) $ \(Const2 _ :=> ComposeMaybe me) -> me -- We could make it prompt like this, but this seems to be slower than just delaying the PostBuild event to allow this stuff to settle (which is more similar to the previous behavior anyway)

217 return (result0, result')

214 return (result0, result')

218

215

219instance PerformEvent t m => PerformEvent t (RequestT t request response m) where

216instance PerformEvent t m => PerformEvent t (RequestT t request response m) where

@@ -269,20 +266,20 @@ numberWith f t n0 = flip runState n0 $ forM t $ \x -> state $ \n -> (f n x, succ

269{-# INLINABLE mergeSelfDeletingEvents #-}

266{-# INLINABLE mergeSelfDeletingEvents #-}

270mergeSelfDeletingEvents :: forall t m k v. (Ord k, Reflex t, MonadFix m, MonadHold t m)

267mergeSelfDeletingEvents :: forall t m k v. (Ord k, Reflex t, MonadFix m, MonadHold t m)

271 => DMap (Const2 k (These v ())) (Event t)

268 => DMap (Const2 k (These v ())) (Event t)

272− -> Event t (PatchDMap (DMap (Const2 k (These v ())) (Event t)))

269+ -> Event t (PatchDMap (Const2 k (These v ())) (Event t))

273 -> m (Event t [v])

270 -> m (Event t [v])

274mergeSelfDeletingEvents initial eAddNew = do

271mergeSelfDeletingEvents initial eAddNew = do

275− rec events :: Incremental t PatchDMap (DMap (Const2 k (These v ())) (Event t))

272+ rec events :: Incremental t (PatchDMap (Const2 k (These v ())) (Event t))

276 <- holdIncremental initial $ eAddNew <> eDelete --TODO: Eliminate empty firings

273 <- holdIncremental initial $ eAddNew <> eDelete --TODO: Eliminate empty firings

277 let event = mergeWith DMap.union

274 let event = mergeWith DMap.union

278 [ mergeIncremental events

275 [ mergeIncremental events

279− , coincidence $ ffor eAddNew $ \(PatchDMap m) -> merge $ DMap.mapMaybeWithKey (const getCompose) m

276+ , coincidence $ ffor eAddNew $ \(PatchDMap m) -> merge $ DMap.mapMaybeWithKey (const getComposeMaybe) m

280 ]

277 ]

281− eDelete :: Event t (PatchDMap (DMap (Const2 k (These v ())) (Event t)))

278+ eDelete :: Event t (PatchDMap (Const2 k (These v ())) (Event t))

282 eDelete = fforMaybe event $

279 eDelete = fforMaybe event $

283 fmap (PatchDMap . DMap.fromDistinctAscList) .

280 fmap (PatchDMap . DMap.fromDistinctAscList) .

284 (\l -> if null l then Nothing else Just l) .

281 (\l -> if null l then Nothing else Just l) .

285− fmapMaybe (\(Const2 k :=> Identity x) -> (Const2 k :=> Compose Nothing) <$ x ^? there) .

282+ fmapMaybe (\(Const2 k :=> Identity x) -> (Const2 k :=> ComposeMaybe Nothing) <$ x ^? there) .

286 DMap.toList

283 DMap.toList

287 return $ ffor event $

284 return $ ffor event $

288 fmapMaybe (\(Const2 _ :=> Identity x) -> x ^? here) .

285 fmapMaybe (\(Const2 _ :=> Identity x) -> x ^? here) .

src/Reflex/PostBuild/Class.hs+1−2

@@ -16,7 +16,6 @@ import Control.Monad.Reader

16import Control.Monad.Ref

17import Control.Monad.Trans.Control

18import qualified Data.Dependent.Map as DMap

19−import Data.Functor.Compose

20import Reflex.Class

19import Reflex.Class

21import Reflex.Host.Class

20import Reflex.Host.Class

22import Reflex.PerformEvent.Class

21import Reflex.PerformEvent.Class

@@ -100,5 +99,5 @@ instance (Reflex t, MonadHold t m, MonadFix m, MonadAdjust t m, PerformEvent t m

100 rec (result0, result') <- lift $ sequenceDMapWithAdjust loweredDm0 loweredDm'

99 rec (result0, result') <- lift $ sequenceDMapWithAdjust loweredDm0 loweredDm'

101 delayedResult' <- performEvent $ return () <$ result' -- Delaying this result seems to be faster than making RequestT (and thus PerformEvent) more prompt

100 delayedResult' <- performEvent $ return () <$ result' -- Delaying this result seems to be faster than making RequestT (and thus PerformEvent) more prompt

102 let loweredDm' = ffor dm' $ \(PatchDMap p) -> PatchDMap $

101 let loweredDm' = ffor dm' $ \(PatchDMap p) -> PatchDMap $

103− DMap.map (Compose . fmap (\v -> runPostBuildT v =<< headE (void delayedResult')) . getCompose) p --TODO: Avoid doing this headE so many times; once per loweredDm' firing ought to be OK, but it's not totally trivial to do because result' might be firing at the same time, and we don't want *that* to be the postBuild occurrence

102+ DMap.map (ComposeMaybe . fmap (\v -> runPostBuildT v =<< headE (void delayedResult')) . getComposeMaybe) p --TODO: Avoid doing this headE so many times; once per loweredDm' firing ought to be OK, but it's not totally trivial to do because result' might be firing at the same time, and we don't want *that* to be the postBuild occurrence

104 return (result0, result')

103 return (result0, result')

src/Reflex/Pure.hs+6−2

@@ -28,6 +28,7 @@ import Data.Functor.Identity

28import Data.Maybe

29import Data.MemoTrie

30import Data.Monoid

31+import Data.Type.Coercion

31import Reflex.Class

32import Reflex.Class

33data Pure t

34data Pure t

@@ -40,7 +41,7 @@ instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where

40 newtype Behavior (Pure t) a = Behavior { unBehavior :: t -> a }

41 newtype Behavior (Pure t) a = Behavior { unBehavior :: t -> a }

41 newtype Event (Pure t) a = Event { unEvent :: t -> Maybe a }

42 newtype Event (Pure t) a = Event { unEvent :: t -> Maybe a }

42 newtype Dynamic (Pure t) a = Dynamic { unDynamic :: t -> (a, Maybe a) }

43 newtype Dynamic (Pure t) a = Dynamic { unDynamic :: t -> (a, Maybe a) }

43− newtype Incremental (Pure t) p a = Incremental { unIncremental :: t -> (a, Maybe (p a)) }

44+ newtype Incremental (Pure t) p = Incremental { unIncremental :: t -> (PatchTarget p, Maybe p) }

45 type PushM (Pure t) = (->) t

46 type PushM (Pure t) = (->) t

46 type PullM (Pure t) = (->) t

47 type PullM (Pure t) = (->) t

@@ -109,6 +110,9 @@ instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where

109 Nothing -> Nothing

110 Nothing -> Nothing

110 Just patch -> apply patch old

111 Just patch -> apply patch old

111 in (old, e)

112 in (old, e)

113+ behaviorCoercion Coercion = Coercion

114+ eventCoercion Coercion = Coercion

115+ dynamicCoercion Coercion = Coercion

112

116

113instance Functor (Dynamic (Pure t)) where

117instance Functor (Dynamic (Pure t)) where

114 fmap f d = Dynamic $ \t -> let (cur, upd) = unDynamic d t

118 fmap f d = Dynamic $ \t -> let (cur, upd) = unDynamic d t

@@ -152,7 +156,7 @@ instance (Enum t, HasTrie t, Ord t) => MonadHold (Pure t) ((->) t) where

152 let Behavior f = hold initialValue e initialTime

156 let Behavior f = hold initialValue e initialTime

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

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

154

158

155− holdIncremental :: Patch p => a -> Event (Pure t) (p a) -> t -> Incremental (Pure t) p a

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

156 holdIncremental initialValue e initialTime = Incremental $ \t -> (f t, unEvent e t)

160 holdIncremental initialValue e initialTime = Incremental $ \t -> (f t, unEvent e t)

157 where f = memo $ \sampleTime ->

161 where f = memo $ \sampleTime ->

158 -- Really, the sampleTime should never be prior to the initialTime,

162 -- Really, the sampleTime should never be prior to the initialTime,

src/Reflex/Spider/Internal.hs+68−65

@@ -37,7 +37,6 @@ import Data.Dependent.Map (DMap, DSum (..))

37import qualified Data.Dependent.Map as DMap

38import Data.Foldable hiding (concat, elem, sequence_)

39import Data.Function

40−import Data.Functor.Compose

41import Data.Functor.Constant

40import Data.Functor.Constant

42import Data.Functor.Product

41import Data.Functor.Product

43import Data.GADT.Compare

42import Data.GADT.Compare

@@ -51,6 +50,7 @@ import Data.Some (Some)

51import qualified Data.Some as Some

50import qualified Data.Some as Some

52import Data.These

51import Data.These

53import Data.Traversable

52import Data.Traversable

53+import Data.Type.Coercion

54import Data.Word

55import GHC.IORef (IORef (..))

56import GHC.Stack

@@ -215,10 +215,10 @@ eventSwitch !s = Event $ wrap eventSubscribedSwitch $ getSwitchSubscribed s

215eventCoincidence :: Coincidence x a -> Event x a

216eventCoincidence !c = Event $ wrap eventSubscribedCoincidence $ getCoincidenceSubscribed c

217

218−eventHold :: a ~ p b => Hold x p b -> Event x a

218+eventHold :: Hold x p -> Event x p

219eventHold !h = Event $ subscribeHoldEvent h

220

221−eventDyn :: (a ~ p b, R.Patch p) => Dyn x p b -> Event x a

221+eventDyn :: R.Patch p => Dyn x p -> Event x p

222eventDyn !j = Event $ \sub -> getDynHold j >>= \h -> subscribeHoldEvent h sub

223

224{-# INLINE subscribeCoincidenceInner #-}

@@ -272,7 +272,7 @@ newSubscriberPush compute subscribed = return $ Subscriber

272 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberPush" <> showNodeId subscribed <> " done"

273 }

274

275−newSubscriberHold :: R.Patch p => Hold x p a -> IO (Subscriber x (p a))

275+newSubscriberHold :: R.Patch p => Hold x p -> IO (Subscriber x p)

276newSubscriberHold h = return $ Subscriber

277 { subscriberPropagate = {-# SCC "traverseHold" #-} propagateSubscriberHold h

278 , subscriberInvalidateHeight = \_ -> return ()

@@ -318,7 +318,7 @@ newSubscriberMerge k subscribed = return $ Subscriber

318 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberMerge" <> showNodeId subscribed <> " done"

319 }

320

321−newSubscriberMergeChange :: GCompare k => MergeSubscribed x k -> IO (Subscriber x (R.PatchDMap (DMap k (Event x))))

321+newSubscriberMergeChange :: GCompare k => MergeSubscribed x k -> IO (Subscriber x (R.PatchDMap k (Event x)))

322newSubscriberMergeChange subscribed = return $ Subscriber

323 { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do

324 tracePropagate $ "SubscriberMerge" <> showNodeId subscribed

@@ -555,7 +555,7 @@ walkInvalidHeightParents s0 = do

555#endif

556

557{-# INLINE subscribeHoldEvent #-}

558−subscribeHoldEvent :: CanSubscribe x m => Hold x p a -> Subscriber x (p a) -> m (EventSubscription x (p a), Maybe (p a))

558+subscribeHoldEvent :: CanSubscribe x m => Hold x p -> Subscriber x p -> m (EventSubscription x p, Maybe p)

559subscribeHoldEvent = subscribeAndRead . holdEvent

560

561--------------------------------------------------------------------------------

@@ -576,10 +576,10 @@ unsubscribe (EventSubscription msln _) = forM_ msln $ \sln -> WeakBag.remove sln

576

577newtype Behavior x a = Behavior { readBehaviorTracked :: BehaviorM x a }

578

579−behaviorHold :: Hold x p a -> Behavior x a

579+behaviorHold :: Hold x p -> Behavior x (R.PatchTarget p)

580behaviorHold !h = Behavior $ readHoldTracked h

581

582−behaviorHoldIdentity :: Hold x Identity a -> Behavior x a

582+behaviorHoldIdentity :: Hold x (Identity a) -> Behavior x a

583behaviorHoldIdentity = behaviorHold

584

585behaviorConst :: a -> Behavior x a

@@ -612,11 +612,11 @@ behaviorPull !p = Behavior $ do

612 askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :))

613 return a

614

615−behaviorDyn :: R.Patch p => Dyn x p a -> Behavior x a

615+behaviorDyn :: R.Patch p => Dyn x p -> Behavior x (R.PatchTarget p)

616behaviorDyn !d = Behavior $ readHoldTracked =<< getDynHold d

617

618{-# INLINE readHoldTracked #-}

619−readHoldTracked :: Hold x p a -> BehaviorM x a

619+readHoldTracked :: Hold x p -> BehaviorM x (R.PatchTarget p)

620readHoldTracked h = do

621 result <- liftIO $ readIORef $ holdValue h

622 askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (holdInvalidators h) (wi:))

@@ -634,33 +634,33 @@ readBehaviorUntracked b = do

634-- Dynamic

635--------------------------------------------------------------------------------

636

637−data Dynamic x p a = Dynamic

637+data Dynamic x p = Dynamic

638− { dynamicCurrent :: !(Behavior x a)

638+ { dynamicCurrent :: !(Behavior x (R.PatchTarget p))

639− , dynamicUpdated :: !(Event x (p a))

639+ , dynamicUpdated :: !(Event x p)

640 }

641

642−dynamicHold :: Hold x p a -> Dynamic x p a

642+dynamicHold :: Hold x p -> Dynamic x p

643dynamicHold !h = Dynamic

644 { dynamicCurrent = behaviorHold h

645 , dynamicUpdated = eventHold h

646 }

647

648−dynamicHoldIdentity :: Hold x Identity a -> Dynamic x Identity a

648+dynamicHoldIdentity :: Hold x (Identity a) -> Dynamic x (Identity a)

649dynamicHoldIdentity = dynamicHold

650

651−dynamicConst :: a -> Dynamic x p a

651+dynamicConst :: R.PatchTarget p -> Dynamic x p

652dynamicConst !a = Dynamic

653 { dynamicCurrent = behaviorConst a

654 , dynamicUpdated = eventNever

655 }

656

657−dynamicDyn :: R.Patch p => Dyn x p a -> Dynamic x p a

657+dynamicDyn :: R.Patch p => Dyn x p -> Dynamic x p

658dynamicDyn !d = Dynamic

659 { dynamicCurrent = behaviorDyn d

660 , dynamicUpdated = eventDyn d

661 }

662

663−dynamicDynIdentity :: Dyn x Identity a -> Dynamic x Identity a

663+dynamicDynIdentity :: Dyn x (Identity a) -> Dynamic x (Identity a)

664dynamicDynIdentity = dynamicDyn

665

666--------------------------------------------------------------------------------

@@ -671,11 +671,11 @@ dynamicDynIdentity = dynamicDyn

671--representational so we can use coerce

672

673--type role Hold representational

674−data Hold x p a

674+data Hold x p

675− = Hold { holdValue :: !(IORef a)

675+ = Hold { holdValue :: !(IORef (R.PatchTarget p))

676 , holdInvalidators :: !(IORef [Weak (Invalidator x)])

677− , holdEvent :: Event x (p a) -- This must be lazy, or holds cannot be defined before their input Events

677+ , holdEvent :: Event x p -- This must be lazy, or holds cannot be defined before their input Events

678− , holdParent :: !(IORef (Maybe (EventSubscription x (p a)))) -- Keeps its parent alive (will be undefined until the hold is initialized) --TODO: Probably shouldn't be an IORef

678+ , holdParent :: !(IORef (Maybe (EventSubscription x p))) -- Keeps its parent alive (will be undefined until the hold is initialized) --TODO: Probably shouldn't be an IORef

679#ifdef DEBUG_NODEIDS

680 , holdNodeId :: Int

681#endif

@@ -779,9 +779,9 @@ instance Defer (SomeResetCoincidence x) (EventM x) where

779 getDeferralQueue = EventM $ asks eventEnvResetCoincidences

780

781-- Note: hold cannot examine its event until after the phase is over

782−{-# SPECIALIZE hold :: R.Patch p => a -> Event x (p a) -> EventM x (Hold x p a) #-}

782+{-# SPECIALIZE hold :: R.Patch p => R.PatchTarget p -> Event x p -> EventM x (Hold x p) #-}

783−{-# SPECIALIZE hold :: R.Patch p => a -> Event x (p a) -> ComputeM x (Hold x p a) #-}

783+{-# SPECIALIZE hold :: R.Patch p => R.PatchTarget p -> Event x p -> ComputeM x (Hold x p) #-}

784−hold :: (R.Patch p, Defer (SomeHoldInit x) m) => a -> Event x (p a) -> m (Hold x p a)

784+hold :: (R.Patch p, Defer (SomeHoldInit x) m) => R.PatchTarget p -> Event x p -> m (Hold x p)

785hold v0 e = do

786 valRef <- liftIO $ newIORef v0

787 invsRef <- liftIO $ newIORef []

@@ -802,7 +802,7 @@ hold v0 e = do

802 return h

803

804{-# INLINE getHoldEventSubscription #-}

805−getHoldEventSubscription :: forall m p a x. (Defer (SomeAssignment x) m, Defer (SomeHoldInit x) m, Defer SomeClear m, R.Patch p, HasCurrentHeight x m, Defer (SomeMergeInit x) m, Defer (SomeResetCoincidence x) m, HasSpiderTimeline x m, m ~ EventM x) => Hold x p a -> m (EventSubscription x (p a))

805+getHoldEventSubscription :: forall m p x. (Defer (SomeAssignment x) m, Defer (SomeHoldInit x) m, Defer SomeClear m, R.Patch p, HasCurrentHeight x m, Defer (SomeMergeInit x) m, Defer (SomeResetCoincidence x) m, HasSpiderTimeline x m, m ~ EventM x) => Hold x p -> m (EventSubscription x p)

806getHoldEventSubscription h = do

807 ep <- liftIO $ readIORef $ holdParent h

808 case ep of

@@ -843,7 +843,7 @@ instance Monad (BehaviorM x) where

843 fail s = BehaviorM $ fail s

844

845data BehaviorSubscribed x a

846− = forall p. BehaviorSubscribedHold (Hold x p a)

846+ = forall p. BehaviorSubscribedHold (Hold x p)

847 | BehaviorSubscribedPull (PullSubscribed x a)

848

849data SomeBehaviorSubscribed x = forall a. SomeBehaviorSubscribed (BehaviorSubscribed x a)

@@ -887,11 +887,11 @@ data Root x (k :: * -> *)

887 , rootInit :: !(forall a. k a -> RootTrigger x a -> IO (IO ()))

888 }

889

890−data SomeHoldInit x = forall p a. R.Patch p => SomeHoldInit !(Hold x p a)

890+data SomeHoldInit x = forall p. R.Patch p => SomeHoldInit !(Hold x p)

891

892−data SomeMergeUpdate x = forall k. GCompare k => SomeMergeUpdate (R.PatchDMap (DMap k (Event x))) (MergeSubscribed x k)

892+data SomeMergeUpdate x = forall k. GCompare k => SomeMergeUpdate (R.PatchDMap k (Event x)) (MergeSubscribed x k)

893

894−data SomeMergeInit x = forall k. GCompare k => SomeMergeInit !(MergeSubscribed x k) !(Event x (R.PatchDMap (DMap k (Event x))))

894+data SomeMergeInit x = forall k. GCompare k => SomeMergeInit !(MergeSubscribed x k) !(Event x (R.PatchDMap k (Event x)))

895

896data SomeEventSubscription x = forall a. SomeEventSubscription (EventSubscription x a)

897

@@ -980,7 +980,7 @@ data MergeSubscribed x k

980 , mergeSubscribedHeight :: !(IORef Height)

981 , mergeSubscribedHeightBag :: !(IORef HeightBag)

982 , mergeSubscribedSubscribers :: !(WeakBag (Subscriber x (DMap k Identity)))

983− , mergeSubscribedChange :: !(IORef (Subscriber x (R.PatchDMap (DMap k (Event x))), EventSubscribed x (R.PatchDMap (DMap k (Event x)))))

983+ , mergeSubscribedChange :: !(IORef (Subscriber x (R.PatchDMap k (Event x)), EventSubscribed x (R.PatchDMap k (Event x))))

984 , mergeSubscribedParents :: !(IORef (DMap k (MergeSubscribedParent x k)))

985 , mergeSubscribedWeakSelf :: !(IORef (Weak (MergeSubscribed x k)))

986#ifdef DEBUG_NODEIDS

@@ -990,7 +990,7 @@ data MergeSubscribed x k

990

991--TODO: DMap sucks; we should really write something better (with a functor for the value as well as the key)

992data Merge x k

993− = Merge { mergeParents :: !(Dynamic x R.PatchDMap (DMap k (Event x)))

993+ = Merge { mergeParents :: !(Dynamic x (R.PatchDMap k (Event x)))

994 , mergeSubscribed :: !(IORef (Maybe (MergeSubscribed x k)))

995 }

996

@@ -1071,22 +1071,13 @@ instance Align (Event x) where

1071 nil = eventNever

1072 align ea eb = R.fmapMaybe R.dmapToThese $ merge $ dynamicConst $ DMap.fromList [R.LeftTag :=> ea, R.RightTag :=> eb]

1073

1074−newtype Dyn x p a = Dyn { unDyn :: IORef (Either (BehaviorM x a, Event x (p a)) (Hold x p a)) }

1074+newtype Dyn x p = Dyn { unDyn :: IORef (Either (BehaviorM x (R.PatchTarget p), Event x p) (Hold x p)) }

1075

1076−newMapDyn :: (a -> b) -> Dynamic x Identity a -> Dynamic x Identity b

1076+newMapDyn :: (a -> b) -> Dynamic x (Identity a) -> Dynamic x (Identity b)

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

1078

1079−instance Functor (Dynamic x Identity) where

1080− fmap = newMapDyn

1081−

1082−instance Applicative (Dynamic x Identity) where

1083− pure = dynamicConst

1084− (<*>) = zipDynWith ($)

1085− _ *> b = b

1086− a <* _ = a

1087−

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

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

1089−zipDynWith :: (a -> b -> c) -> Dynamic x Identity a -> Dynamic x Identity b -> Dynamic x Identity c

1080+zipDynWith :: (a -> b -> c) -> Dynamic x (Identity a) -> Dynamic x (Identity b) -> Dynamic x (Identity c)

1090zipDynWith f da db =

1081zipDynWith f da db =

1091 let eab = align (dynamicUpdated da) (dynamicUpdated db)

1082 let eab = align (dynamicUpdated da) (dynamicUpdated db)

1092 ec = flip push eab $ \o -> do

1083 ec = flip push eab $ \o -> do

@@ -1101,21 +1092,11 @@ zipDynWith f da db =

1101 return $ Just $ Identity $ f a b

1092 return $ Just $ Identity $ f a b

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

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

1103

1094

1104−instance Monad (Dynamic x Identity) where

1105− {-# INLINE return #-}

1106− return = pure

1107− {-# INLINE (>>=) #-}

1108− x >>= f = dynamicDynIdentity $ newJoinDyn $ newMapDyn f x

1109− {-# INLINE (>>) #-}

1110− _ >> y = y

1111− {-# INLINE fail #-}

1112− fail _ = error "Dynamic does not support 'fail'"

1113−

1114−unsafeDyn :: BehaviorM x a -> Event x (p a) -> Dyn x p a

1095+unsafeDyn :: BehaviorM x (R.PatchTarget p) -> Event x p -> Dyn x p

1115unsafeDyn readV0 v' = Dyn $ unsafeNewIORef x $ Left x

1096unsafeDyn readV0 v' = Dyn $ unsafeNewIORef x $ Left x

1116 where x = (readV0, v')

1097 where x = (readV0, v')

1117

1098

1118−newJoinDyn :: Dynamic x Identity (Dynamic x Identity a) -> Dyn x Identity a

1099+newJoinDyn :: Dynamic x (Identity (Dynamic x (Identity a))) -> Dyn x (Identity a)

1119newJoinDyn d =

1100newJoinDyn d =

1120 let readV0 = readBehaviorTracked . dynamicCurrent =<< readBehaviorTracked (dynamicCurrent d)

1101 let readV0 = readBehaviorTracked . dynamicCurrent =<< readBehaviorTracked (dynamicCurrent d)

1121 eOuter = push (fmap (Just . Identity) . readBehaviorUntracked . dynamicCurrent . runIdentity) $ dynamicUpdated d

1102 eOuter = push (fmap (Just . Identity) . readBehaviorUntracked . dynamicCurrent . runIdentity) $ dynamicUpdated d

@@ -1294,7 +1275,7 @@ listsToForest l = fmap (\(a, l') -> Node a $ listsToForest $ toList l') $ groupB

1294#endif

1275#endif

1295

1276

1296{-# INLINE propagateSubscriberHold #-}

1277{-# INLINE propagateSubscriberHold #-}

1297−propagateSubscriberHold :: R.Patch p => Hold x p a -> p a -> EventM x ()

1278+propagateSubscriberHold :: R.Patch p => Hold x p -> p -> EventM x ()

1298propagateSubscriberHold h a = do

1279propagateSubscriberHold h a = do

1299 {-# SCC "trace" #-} traceMWhen debugPropagate $ liftIO $ do

1280 {-# SCC "trace" #-} traceMWhen debugPropagate $ liftIO $ do

1300 invalidators <- liftIO $ readIORef $ holdInvalidators h

1281 invalidators <- liftIO $ readIORef $ holdInvalidators h

@@ -1333,7 +1314,7 @@ askBehaviorHoldInits = do

1333 return his

1314 return his

1334

1315

1335{-# INLINE getDynHold #-}

1316{-# INLINE getDynHold #-}

1336−getDynHold :: (Defer (SomeHoldInit x) m, R.Patch p) => Dyn x p a -> m (Hold x p a)

1317+getDynHold :: (Defer (SomeHoldInit x) m, R.Patch p) => Dyn x p -> m (Hold x p)

1337getDynHold d = do

1318getDynHold d = do

1338 mh <- liftIO $ readIORef $ unDyn d

1319 mh <- liftIO $ readIORef $ unDyn d

1339 case mh of

1320 case mh of

@@ -1690,7 +1671,7 @@ subscribeCoincidenceSubscribed :: CoincidenceSubscribed x a -> Subscriber x a ->

1690subscribeCoincidenceSubscribed subscribed sub = WeakBag.insert sub (coincidenceSubscribedSubscribers subscribed) (coincidenceSubscribedWeakSelf subscribed) cleanupCoincidenceSubscribed

1671subscribeCoincidenceSubscribed subscribed sub = WeakBag.insert sub (coincidenceSubscribedSubscribers subscribed) (coincidenceSubscribedWeakSelf subscribed) cleanupCoincidenceSubscribed

1691

1672

1692{-# INLINE merge #-}

1673{-# INLINE merge #-}

1693−merge :: GCompare k => Dynamic x R.PatchDMap (DMap k (Event x)) -> Event x (DMap k Identity)

1674+merge :: GCompare k => Dynamic x (R.PatchDMap k (Event x)) -> Event x (DMap k Identity)

1694merge m = eventMerge $ Merge

1675merge m = eventMerge $ Merge

1695 { mergeParents = m

1676 { mergeParents = m

1696 , mergeSubscribed = unsafeNewIORef m Nothing

1677 , mergeSubscribed = unsafeNewIORef m Nothing

@@ -1762,9 +1743,9 @@ runFrame a = SpiderHost $ ask >>= \spiderTimeline -> lift $ do

1762 mergeUpdates <- readIORef mergeUpdateRef

1743 mergeUpdates <- readIORef mergeUpdateRef

1763 writeIORef mergeUpdateRef []

1744 writeIORef mergeUpdateRef []

1764 let updateMerge :: SomeMergeUpdate x -> IO [SomeEventSubscription x]

1745 let updateMerge :: SomeMergeUpdate x -> IO [SomeEventSubscription x]

1765− updateMerge (SomeMergeUpdate (R.PatchDMap p :: R.PatchDMap (DMap k (Event x))) m) = do

1746+ updateMerge (SomeMergeUpdate (R.PatchDMap p :: R.PatchDMap k (Event x)) m) = do

1766 oldParents <- readIORef $ mergeSubscribedParents m

1747 oldParents <- readIORef $ mergeSubscribedParents m

1767− let f (subscriptionsToKill, ps) (k :=> Compose me) = do

1748+ let f (subscriptionsToKill, ps) (k :=> R.ComposeMaybe me) = do

1768 (mOldSubd, newPs) <- case me of

1749 (mOldSubd, newPs) <- case me of

1769 Nothing -> return $ DMap.updateLookupWithKey (\_ _ -> Nothing) k ps

1750 Nothing -> return $ DMap.updateLookupWithKey (\_ _ -> Nothing) k ps

1770 Just e -> do

1751 Just e -> do

@@ -2009,11 +1990,30 @@ newtype SpiderPullM x a = SpiderPullM (BehaviorM x a) deriving (Functor, Applica

2009

1990

2010newtype SpiderPushM x a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)

1991newtype SpiderPushM x a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)

2011

1992

1993+instance Functor (R.Dynamic (SpiderTimeline x)) where

1994+ fmap f = SpiderDynamic . newMapDyn f . unSpiderDynamic

1995+

1996+instance Applicative (R.Dynamic (SpiderTimeline x)) where

1997+ pure = SpiderDynamic . dynamicConst

1998+ SpiderDynamic a <*> SpiderDynamic b = SpiderDynamic $ zipDynWith ($) a b

1999+ _ *> b = b

2000+ a <* _ = a

2001+

2002+instance Monad (R.Dynamic (SpiderTimeline x)) where

2003+ {-# INLINE return #-}

2004+ return = pure

2005+ {-# INLINE (>>=) #-}

2006+ x >>= f = SpiderDynamic $ dynamicDynIdentity $ newJoinDyn $ newMapDyn (unSpiderDynamic . f) $ unSpiderDynamic x

2007+ {-# INLINE (>>) #-}

2008+ _ >> y = y

2009+ {-# INLINE fail #-}

2010+ fail _ = error "Dynamic does not support 'fail'"

2011+

2012instance R.Reflex (SpiderTimeline x) where

2013 newtype Behavior (SpiderTimeline x) a = SpiderBehavior { unSpiderBehavior :: Behavior x a }

2014 newtype Event (SpiderTimeline x) a = SpiderEvent { unSpiderEvent :: Event x a }

2015− newtype Dynamic (SpiderTimeline x) a = SpiderDynamic { unSpiderDynamic :: Dynamic x Identity a } deriving (Functor, Applicative, Monad)

2015+ newtype Dynamic (SpiderTimeline x) a = SpiderDynamic { unSpiderDynamic :: Dynamic x (Identity a) } -- deriving (Functor, Applicative, Monad)

2016− newtype Incremental (SpiderTimeline x) p a = SpiderIncremental { unSpiderIncremental :: Dynamic x p a }

2016+ newtype Incremental (SpiderTimeline x) p = SpiderIncremental { unSpiderIncremental :: Dynamic x p }

2017 type PullM (SpiderTimeline x) = SpiderPullM x

2018 type PushM (SpiderTimeline x) = SpiderPushM x

2019 {-# INLINABLE never #-}

@@ -2041,7 +2041,7 @@ instance R.Reflex (SpiderTimeline x) where

2041 {-# INLINABLE unsafeBuildIncremental #-}

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

2043 {-# INLINABLE mergeIncremental #-}

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

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

2045 {-# INLINABLE currentIncremental #-}

2046 currentIncremental = SpiderBehavior . dynamicCurrent . unSpiderIncremental

2047 {-# INLINABLE updatedIncremental #-}

@@ -2050,6 +2050,9 @@ instance R.Reflex (SpiderTimeline x) where

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

2051 c <- readBehaviorUntracked $ dynamicCurrent i

2052 return $ Identity <$> R.apply p c --TODO: Avoid the redundant 'apply'

2053+ eventCoercion Coercion = Coercion

2054+ behaviorCoercion Coercion = Coercion

2055+ dynamicCoercion = unsafeCoerce --TODO: How can we avoid this unsafeCoerce? This is safe only because we know how Identity works as a Patch instance

2053

2056

2054instance R.MonadSample (SpiderTimeline x) (EventM x) where

2057instance R.MonadSample (SpiderTimeline x) (EventM x) where

2055 {-# INLINABLE sample #-}

2058 {-# INLINABLE sample #-}

@@ -2069,7 +2072,7 @@ holdSpiderEventM v0 e = fmap (SpiderBehavior . behaviorHoldIdentity) $ hold v0 $

2069holdDynSpiderEventM :: a -> R.Event (SpiderTimeline x) a -> EventM x (R.Dynamic (SpiderTimeline x) a)

2072holdDynSpiderEventM :: a -> R.Event (SpiderTimeline x) a -> EventM x (R.Dynamic (SpiderTimeline x) a)

2070holdDynSpiderEventM v0 e = fmap (SpiderDynamic . dynamicHoldIdentity) $ hold v0 $ coerce $ unSpiderEvent e

2073holdDynSpiderEventM v0 e = fmap (SpiderDynamic . dynamicHoldIdentity) $ hold v0 $ coerce $ unSpiderEvent e

2071

2074

2072−holdIncrementalSpiderEventM :: R.Patch p => a -> R.Event (SpiderTimeline x) (p a) -> EventM x (R.Incremental (SpiderTimeline x) p a)

2075+holdIncrementalSpiderEventM :: R.Patch p => R.PatchTarget p -> R.Event (SpiderTimeline x) p -> EventM x (R.Incremental (SpiderTimeline x) p)

2073holdIncrementalSpiderEventM v0 e = fmap (SpiderIncremental . dynamicHold) $ hold v0 $ unSpiderEvent e

2076holdIncrementalSpiderEventM v0 e = fmap (SpiderIncremental . dynamicHold) $ hold v0 $ unSpiderEvent e

2074

2077

2075instance R.MonadHold (SpiderTimeline x) (SpiderHost x) where

2078instance R.MonadHold (SpiderTimeline x) (SpiderHost x) where