77ee661 · reflex · git.iko.soy

git.iko.soy/reflex

Make Event, Behavior, and Dynamic instances of Coercible

commit77ee66118e7e9a06d9120abba69e12e40dd73c54 authorRyan Trinkle <ryan.trinkle@gmail.com> dateMon 3 Oct 2016, 10:12 (10 years ago) parentbd9f2c5

6 files changed+167−128

compare with develop

unifiedsplit

src/Reflex/Class.hs+61−24 src/Reflex/DynamicWriter.hs+13−14 src/Reflex/PerformEvent/Base.hs+18−21 src/Reflex/PostBuild/Class.hs+1−2 src/Reflex/Pure.hs+6−2 src/Reflex/Spider/Internal.hs+68−65

src/Reflex/Class.hs+61−24

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

11{-# LANGUAGE CPP #-}

2+{-# LANGUAGE DeriveFunctor #-}

23{-# LANGUAGE FlexibleContexts #-}

34{-# LANGUAGE FlexibleInstances #-}

45{-# LANGUAGE FunctionalDependencies #-}

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

910{-# LANGUAGE RankNTypes #-}

1011{-# LANGUAGE RecursiveDo #-}

1112{-# LANGUAGE ScopedTypeVariables #-}

13+{-# LANGUAGE StandaloneDeriving #-}

1214{-# LANGUAGE TypeFamilies #-}

1315{-# LANGUAGE TypeOperators #-}

1416{-# LANGUAGE UndecidableInstances #-}

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

1921module Reflex.Class

2022 ( -- * Primitives

2123 Reflex (..)

24+ , coerceBehavior

25+ , coerceEvent

26+ , coerceDynamic

2227 , MonadSample (..)

2328 , MonadHold (..)

2429 -- ** 'fan'-related types

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

2631 -- ** 'Incremental'-related types

2732 , Patch (..)

2833 , PatchDMap (..)

34+ , ComposeMaybe (..)

2935 , PatchMap (..)

3036 -- * Convenience functions

3137 , constDyn

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

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

99105import Data.Align

100106import Data.Bifunctor

107+import Data.Coerce

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

102109import qualified Data.Dependent.Map as DMap

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

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

105112import Data.Foldable

106113import Data.Functor.Bind hiding (join)

107114import qualified Data.Functor.Bind as Bind

108−import Data.Functor.Compose

109115import Data.Functor.Constant

110116import Data.Functor.Misc

111117import Data.Functor.Plus

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

120126import Data.String

121127import Data.These

122128import Data.Traversable

129+import Data.Type.Coercion

123130

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

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

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

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

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

158165 -- 'Event' fires.

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

166+ data Incremental t :: * -> *

160167 -- | An 'Event' with no occurrences

161168 never :: Event t a

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

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

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

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

198205 -- 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

200207 -- | 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)

202209 -- | 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)

204211 -- | 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

206213 -- | 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

208236

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

210238class Patch p where

239+ type PatchTarget p :: *

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

212241 -- 'Nothing'.

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

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

214243

215−instance Patch Identity where

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+

251+instance Patch (Identity a) where

252+ type PatchTarget (Identity a) = a

216253 apply (Identity a) _ = Just a

217254

218255-- | 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))

221257

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

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

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

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

225261#if MIN_VERSION_semigroups(0,17,0)

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

231267 GT -> x

232268#endif

233269

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

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

235271 mempty = PatchDMap mempty

236272 mappend = (<>)

237273

238−instance Patch PatchDMap where

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

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

239276 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

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

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

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

242279 nothingToJust = \case

243280 Nothing -> Just $ Constant ()

244281 Just _ -> Nothing

245282

246−data PatchMap a where

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

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

248284

249−instance Patch PatchMap where

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

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

250287 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?

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

252289 deletions = Map.mapMaybeWithKey (const nothingToJust) p

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

254291 Nothing -> Just ()

255292 Just _ -> Nothing

256293

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

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

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

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

260297#if MIN_VERSION_semigroups(0,17,0)

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

266303 GT -> x

267304#endif

268305

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

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

270307 mempty = PatchMap mempty

271308 mappend = (<>)

272309

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

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

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

306343 -- 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)

308345

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

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

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

820857 mapAccumMaybe_ f' l e

821858

822859class (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))

824861

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

826863 sequenceDMapWithAdjust dm0 dm' = do

827864 r <- ask

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

829866 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

831868 lift $ sequenceDMapWithAdjust loweredDm0 loweredDm'

832869

833870--------------------------------------------------------------------------------

src/Reflex/DynamicWriter.hs+13−14

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

1919import Control.Monad.State.Strict

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

2121import Data.Foldable

22−import Data.Functor.Compose

2322import Data.Functor.Misc

2423import Data.Map (Map)

2524import qualified Data.Map as Map

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

3534instance MonadTrans (DynamicWriterT t w) where

3635 lift = DynamicWriterT . lift

3736

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)

3938mconcatIncremental m0 e = do

4039 d <- foldDynMaybe apply m0 e

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

4241

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')

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

4544

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')

4746mapIncrementalMapValues f = mapIncrementalMapValuesWithKey $ const f

4847

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'

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

5150

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

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

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

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

5453

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)

5655mergeIncrementalMap = fmap dmapToMap . mergeIncremental . incrementalExtractFunctorDMap

5756

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))

5958holdIncrementalReplaceableMap m0 m' = do

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

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

6261 return $ mapIncrementalMapValues _replaceable_value vals

6362

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)

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

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

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

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

9493mconcatIncrementalReplaceableDynMap :: forall m t k v.

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

9695 => 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)))

9897 -> Event t ()

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

10099mconcatIncrementalReplaceableDynMap m0 m' additionsCeased = do

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

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

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

162161 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

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

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

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

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

168167 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

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

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

172171 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

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

175174 -- 1. Incrementally merging the Dynamics

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

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

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

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

3131import qualified Data.Dependent.Map as DMap

3232import Data.Dependent.Sum

33−import Data.Functor.Compose

3433import Data.Functor.Misc

3534import Data.Semigroup

3635import qualified Data.Some as Some

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

3837import Data.Tuple

3938import Data.Unique.Tag

4039

41−import Unsafe.Coerce

42−

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

4441

4542newtype 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

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

6663

6764instance (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?)

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)))

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

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))

7067 f dm0 dm' = do

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

7269 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

7471 return (result0, fmap runIdentity result')

7572

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

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

170167

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

172169

173−mapPatchKeysAndValuesMonotonic :: GCompare k' => (forall a. DMapTransform a k k' v v') -> PatchDMap (DMap k v) -> PatchDMap (DMap 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

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

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

175172

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

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

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

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

192189 => (forall k'. GCompare k'

193190 => DMap k' m

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

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

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

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

196193 )

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

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

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

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

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

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

201198 response <- RequestT ask

202199 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

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

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

206203 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

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

209206 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))

211208 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

213210 childRequestMap <- holdIncremental requests0 requests'

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

215212 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)

217214 return (result0, result')

218215

219216instance 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

269266{-# INLINABLE mergeSelfDeletingEvents #-}

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

271268 => 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))

273270 -> m (Event t [v])

274271mergeSelfDeletingEvents 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))

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

277274 let event = mergeWith DMap.union

278275 [ 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

280277 ]

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

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

282279 eDelete = fforMaybe event $

283280 fmap (PatchDMap . DMap.fromDistinctAscList) .

284281 (\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) .

286283 DMap.toList

287284 return $ ffor event $

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

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

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

1616import Control.Monad.Ref

1717import Control.Monad.Trans.Control

1818import qualified Data.Dependent.Map as DMap

19−import Data.Functor.Compose

2019import Reflex.Class

2120import Reflex.Host.Class

2221import Reflex.PerformEvent.Class

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

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

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

102101 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

104103 return (result0, result')

src/Reflex/Pure.hs+6−2

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

2828import Data.Maybe

2929import Data.MemoTrie

3030import Data.Monoid

31+import Data.Type.Coercion

3132import Reflex.Class

3233

3334data Pure t

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

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

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

4243 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) }

4445

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

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

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

109110 Nothing -> Nothing

110111 Just patch -> apply patch old

111112 in (old, e)

113+ behaviorCoercion Coercion = Coercion

114+ eventCoercion Coercion = Coercion

115+ dynamicCoercion Coercion = Coercion

112116

113117instance Functor (Dynamic (Pure t)) where

114118 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

152156 let Behavior f = hold initialValue e initialTime

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

154158

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

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

157161 where f = memo $ \sampleTime ->

158162 -- 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 (..))

3737import qualified Data.Dependent.Map as DMap

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

3939import Data.Function

40−import Data.Functor.Compose

4140import Data.Functor.Constant

4241import Data.Functor.Product

4342import Data.GADT.Compare

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

5150import qualified Data.Some as Some

5251import Data.These

5352import Data.Traversable

53+import Data.Type.Coercion

5454import Data.Word

5555import GHC.IORef (IORef (..))

5656import GHC.Stack

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

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

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

217217

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

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

219219eventHold !h = Event $ subscribeHoldEvent h

220220

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

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

223223

224224{-# INLINE subscribeCoincidenceInner #-}

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

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

273273 }

274274

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)

276276newSubscriberHold h = return $ Subscriber

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

278278 , subscriberInvalidateHeight = \_ -> return ()

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

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

319319 }

320320

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)))

322322newSubscriberMergeChange subscribed = return $ Subscriber

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

324324 tracePropagate $ "SubscriberMerge" <> showNodeId subscribed

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

555555#endif

556556

557557{-# 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)

559559subscribeHoldEvent = subscribeAndRead . holdEvent

560560

561561--------------------------------------------------------------------------------

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

576576

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

578578

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

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

580580behaviorHold !h = Behavior $ readHoldTracked h

581581

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

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

583583behaviorHoldIdentity = behaviorHold

584584

585585behaviorConst :: a -> Behavior x a

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

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

613613 return a

614614

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)

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

617617

618618{-# INLINE readHoldTracked #-}

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

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

620620readHoldTracked h = do

621621 result <- liftIO $ readIORef $ holdValue h

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

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

634634-- Dynamic

635635--------------------------------------------------------------------------------

636636

637−data Dynamic x p a = Dynamic

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

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

637+data Dynamic x p = Dynamic

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

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

640640 }

641641

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

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

643643dynamicHold !h = Dynamic

644644 { dynamicCurrent = behaviorHold h

645645 , dynamicUpdated = eventHold h

646646 }

647647

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

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

649649dynamicHoldIdentity = dynamicHold

650650

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

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

652652dynamicConst !a = Dynamic

653653 { dynamicCurrent = behaviorConst a

654654 , dynamicUpdated = eventNever

655655 }

656656

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

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

658658dynamicDyn !d = Dynamic

659659 { dynamicCurrent = behaviorDyn d

660660 , dynamicUpdated = eventDyn d

661661 }

662662

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

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

664664dynamicDynIdentity = dynamicDyn

665665

666666--------------------------------------------------------------------------------

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

671671--representational so we can use coerce

672672

673673--type role Hold representational

674−data Hold x p a

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

674+data Hold x p

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

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

677− , holdEvent :: Event x (p a) -- 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

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))) -- Keeps its parent alive (will be undefined until the hold is initialized) --TODO: Probably shouldn't be an IORef

679679#ifdef DEBUG_NODEIDS

680680 , holdNodeId :: Int

681681#endif

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

779779 getDeferralQueue = EventM $ asks eventEnvResetCoincidences

780780

781781-- 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) #-}

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

784−hold :: (R.Patch p, Defer (SomeHoldInit x) m) => a -> Event x (p a) -> m (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 => R.PatchTarget p -> Event x p -> ComputeM x (Hold x p) #-}

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

785785hold v0 e = do

786786 valRef <- liftIO $ newIORef v0

787787 invsRef <- liftIO $ newIORef []

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

802802 return h

803803

804804{-# 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)

806806getHoldEventSubscription h = do

807807 ep <- liftIO $ readIORef $ holdParent h

808808 case ep of

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

843843 fail s = BehaviorM $ fail s

844844

845845data BehaviorSubscribed x a

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

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

847847 | BehaviorSubscribedPull (PullSubscribed x a)

848848

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

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

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

888888 }

889889

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)

891891

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)

893893

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)))

895895

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

897897

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

980980 , mergeSubscribedHeight :: !(IORef Height)

981981 , mergeSubscribedHeightBag :: !(IORef HeightBag)

982982 , 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))))

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

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

986986#ifdef DEBUG_NODEIDS

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

990990

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

992992data Merge x k

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

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

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

995995 }

996996

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

10711071 nil = eventNever

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

10731073

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)) }

10751075

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

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

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

10781078

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−

10881079--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)

10901081zipDynWith f da db =

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

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

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

11011092 return $ Just $ Identity $ f a b

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

11031094

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

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

11161097 where x = (readV0, v')

11171098

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)

11191100newJoinDyn d =

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

11211102 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

12941275#endif

12951276

12961277{-# 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 ()

12981279propagateSubscriberHold h a = do

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

13001281 invalidators <- liftIO $ readIORef $ holdInvalidators h

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

13331314 return his

13341315

13351316{-# 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)

13371318getDynHold d = do

13381319 mh <- liftIO $ readIORef $ unDyn d

13391320 case mh of

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

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

16911672

16921673{-# 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)

16941675merge m = eventMerge $ Merge

16951676 { mergeParents = m

16961677 , mergeSubscribed = unsafeNewIORef m Nothing

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

17621743 mergeUpdates <- readIORef mergeUpdateRef

17631744 writeIORef mergeUpdateRef []

17641745 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

17661747 oldParents <- readIORef $ mergeSubscribedParents m

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

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

17681749 (mOldSubd, newPs) <- case me of

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

17701751 Just e -> do

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

20091990

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

20111992

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+

20122012instance R.Reflex (SpiderTimeline x) where

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

20142014 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)

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

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

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

20172017 type PullM (SpiderTimeline x) = SpiderPullM x

20182018 type PushM (SpiderTimeline x) = SpiderPushM x

20192019 {-# INLINABLE never #-}

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

20412041 {-# INLINABLE unsafeBuildIncremental #-}

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

20432043 {-# 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

20452045 {-# INLINABLE currentIncremental #-}

20462046 currentIncremental = SpiderBehavior . dynamicCurrent . unSpiderIncremental

20472047 {-# INLINABLE updatedIncremental #-}

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

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

20512051 c <- readBehaviorUntracked $ dynamicCurrent i

20522052 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

20532056

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

20552058 {-# INLINABLE sample #-}

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

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

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

20712074

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)

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

20742077

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