develop...13237c3 · reflex

git.iko.soy/reflex

12 files changed+367−432

since splitsnapshots

unifiedsplit

ChangeLog.md+1−12 default.nix−1 reflex.cabal+2−1 src/Control/Monad/ReaderIO.hs−60 src/Reflex/Class.hs+9−86 src/Reflex/Patch/DMapWithReset.hs+120 src/Reflex/Patch/Patchable.hs+44 src/Reflex/Profiled.hs+13−21 src/Reflex/Pure.hs+13−21 src/Reflex/Spider/Internal.hs+162−214 test/GC.hs+3−4 test/Reflex/Bench/Focused.hs−12

ChangeLog.md+1−12

@@ -16,23 +16,12 @@

1616

1717## 0.6.2.1

1818

19−* Generalize `fan` to `fanG` to take a `DMap` with non-`Identity`

20− functor:

21− * `fan` to `fanG`

22− * `EventSelectorG` for `fanG` result selector.

23−

24−* Reduce the amount of unsafeCoerce in coercing newtypes under Event/Dynamic/Behavior.

25− * Add fused ReaderIO for the purpose of coercion (ReaderT's third argument has nominal role preventing automated coerce)

26− * Add incrementalCoercion/coerceIncremental to go with dynamicCoercion/coerceDynamic

27−

2819* Generalize merging functions:

2920 `merge` to `mergeG`,

3021 `mergeIncremental` to `mergeIncrementalG`,

22+ `distributeDMapOverDynPure` to `distributeDMapOverDynPureG`,

3123 `mergeIncrementalWithMove` to `mergeIncrementalWithMoveG`.

3224

33−* Generalize distribute function:

34− `distributeDMapOverDynPure` to `distributeDMapOverDynPureG`,

35−

3625## 0.6.2.0

3726

3827* Fix `holdDyn` so that it is lazy in its event argument

default.nix−1

@@ -23,7 +23,6 @@ mkDerivation {

2323 base bifunctors containers deepseq dependent-map dependent-sum

2424 mtl ref-tf split transformers data-default

2525 random time unbounded-delays monoidal-containers witherable

26− profunctors

2726 ] ++ (if ghc.isGhcjs or false then [

2827 ghcjs-base

2928 ] else []) ++ (if !useTemplateHaskell then [] else [

reflex.cabal+2−1

@@ -85,7 +85,6 @@ library

8585 monoidal-containers == 0.4.0.0

8686

8787 exposed-modules:

88− Control.Monad.ReaderIO

8988 Data.AppendMap,

9089 Data.FastMutableIntMap,

9190 Data.FastWeakBag,

@@ -115,9 +114,11 @@ library

115114 Reflex.Patch.Class,

116115 Reflex.Patch.DMap,

117116 Reflex.Patch.DMapWithMove,

117+ Reflex.Patch.DMapWithReset,

118118 Reflex.Patch.IntMap,

119119 Reflex.Patch.Map,

120120 Reflex.Patch.MapWithMove,

121+ Reflex.Patch.Patchable,

121122 Reflex.PerformEvent.Base,

122123 Reflex.PerformEvent.Class,

123124 Reflex.PostBuild.Base,

src/Control/Monad/ReaderIO.hsdeleted−60

@@ -1,60 +0,0 @@

1−{-# language RoleAnnotations #-}

2−{-# language MultiParamTypeClasses #-}

3−{-# language FlexibleInstances #-}

4−{-# language CPP #-}

5−module Control.Monad.ReaderIO

6− (

7− ReaderIO (..)

8− )

9− where

10−

11−import Control.Monad.Fix

12−#if MIN_VERSION_base(4,10,0)

13−import Control.Applicative

14−#endif

15−import Control.Monad

16−import Control.Monad.Reader.Class

17−import Control.Monad.IO.Class

18−

19−-- | An approximate clone of @RIO@ from the @rio@ package, but not based on

20−-- @ReaderT@. The trouble with @ReaderT@ is that its third type argument has a

21−-- @nominal@ role, so we can't coerce through it when it's wrapped in some

22−-- other @data@ type. Ugh.

23−newtype ReaderIO e a = ReaderIO { runReaderIO :: e -> IO a }

24−type role ReaderIO representational representational

25−

26−instance Functor (ReaderIO e) where

27− fmap = liftM

28− {-# INLINE fmap #-}

29− a <$ m = m >> pure a

30− {-# INLINE (<$) #-}

31−

32−instance Applicative (ReaderIO e) where

33− pure a = ReaderIO $ \_ -> pure a

34− {-# INLINE pure #-}

35− (<*>) = ap

36− {-# INLINE (<*>) #-}

37−#if MIN_VERSION_base(4,10,0)

38− liftA2 = liftM2

39− {-# INLINE liftA2 #-}

40−#endif

41− (*>) = (>>)

42− {-# INLINE (*>) #-}

43−

44−instance Monad (ReaderIO e) where

45− ReaderIO q >>= f = ReaderIO $ \e -> q e >>= \a -> runReaderIO (f a) e

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

47−

48−instance MonadFix (ReaderIO e) where

49− mfix f = ReaderIO $ \e -> mfix $ \r -> runReaderIO (f r) e

50− {-# INLINE mfix #-}

51−

52−instance MonadIO (ReaderIO e) where

53− liftIO m = ReaderIO $ \_ -> m

54− {-# INLINE liftIO #-}

55−

56−instance MonadReader e (ReaderIO e) where

57− ask = ReaderIO pure

58− {-# INLINE ask #-}

59− local f (ReaderIO m) = ReaderIO (m . f)

60− {-# INLINE local #-}

src/Reflex/Class.hs+9−86

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

1616{-# LANGUAGE TypeFamilies #-}

1717{-# LANGUAGE TypeOperators #-}

1818{-# LANGUAGE UndecidableInstances #-}

19−{-# LANGUAGE Trustworthy #-}

2019#ifdef USE_REFLEX_OPTIMIZER

2120{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}

2221#endif

@@ -36,21 +35,16 @@ module Reflex.Class

3635 , coerceBehavior

3736 , coerceEvent

3837 , coerceDynamic

39− , coerceIncremental

4038 , MonadSample (..)

4139 , MonadHold (..)

4240 -- ** 'fan' related types

4341 , EventSelector (..)

44− , EventSelectorG (..)

4542 , EventSelectorInt (..)

4643 -- * Convenience functions

4744 , constDyn

4845 , pushAlways

4946 -- ** Combining 'Event's

5047 , leftmost

51− , merge

52− , mergeIncremental

53− , mergeIncrementalWithMove

5448 , mergeMap

5549 , mergeIntMap

5650 , mergeMapIncremental

@@ -65,7 +59,6 @@ module Reflex.Class

6559 , alignEventWithMaybe

6660 -- ** Breaking up 'Event's

6761 , splitE

68− , fan

6962 , fanEither

7063 , fanThese

7164 , fanMap

@@ -90,7 +83,6 @@ module Reflex.Class

9083 , gate

9184 -- ** Combining 'Dynamic's

9285 , distributeDMapOverDynPure

93− , distributeDMapOverDynPureG

9486 , distributeListOverDyn

9587 , distributeListOverDynWith

9688 , zipDyn

@@ -273,16 +265,11 @@ class ( MonadHold t (PushM t)

273265 -- | Merge a collection of events; the resulting 'Event' will only occur if at

274266 -- least one input event is occurring, and will contain all of the input keys

275267 -- that are occurring simultaneously

276−

277− --TODO: Generalize to get rid of DMap use --TODO: Provide a type-level guarantee that the result is not empty

278− mergeG :: GCompare k => (forall a. q a -> Event t (v a))

279− -> DMap k q -> Event t (DMap k v)

280−

268+ merge :: GCompare k => DMap k (Event t) -> Event t (DMap k Identity) --TODO: Generalize to get rid of DMap use --TODO: Provide a type-level guarantee that the result is not empty

281269 -- | Efficiently fan-out an event to many destinations. You should save the

282− -- result in a @let@-binding, and then repeatedly 'selectG' on the result to

270+ -- result in a @let@-binding, and then repeatedly 'select' on the result to

283271 -- create child events

284− fanG :: GCompare k => Event t (DMap k v) -> EventSelectorG t k v

285−

272+ fan :: GCompare k => Event t (DMap k Identity) -> EventSelector t k

286273 -- | Create an 'Event' that will occur whenever the currently-selected input

287274 -- 'Event' occurs

288275 switch :: Behavior t (Event t a) -> Event t a

@@ -300,14 +287,9 @@ class ( MonadHold t (PushM t)

300287 -- that value.

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

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

303− mergeIncrementalG :: GCompare k

304− => (forall a. q a -> Event t (v a))

305− -> Incremental t (PatchDMap k q)

306− -> Event t (DMap k v)

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

307291 -- | Experimental: Create a merge whose parents can change over time; changing the key of an Event is more efficient than with mergeIncremental

308− mergeIncrementalWithMoveG :: GCompare k

309− => (forall a. q a -> Event t (v a))

310− -> Incremental t (PatchDMapWithMove k q) -> Event t (DMap k v)

292+ mergeIncrementalWithMove :: GCompare k => Incremental t (PatchDMapWithMove k (Event t)) -> Event t (DMap k Identity)

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

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

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

@@ -323,25 +305,9 @@ class ( MonadHold t (PushM t)

323305 -- | Construct a 'Coercion' for a 'Dynamic' given an 'Coercion' for its

324306 -- occurrence type

325307 dynamicCoercion :: Coercion a b -> Coercion (Dynamic t a) (Dynamic t b)

326− -- | Construct a 'Coercion' for an 'Incremental' given 'Coercion's for its

327− -- patch target and patch types.

328− incrementalCoercion

329− :: Coercion (PatchTarget a) (PatchTarget b) -> Coercion a b -> Coercion (Incremental t a) (Incremental t b)

330308 mergeIntIncremental :: Incremental t (PatchIntMap (Event t a)) -> Event t (IntMap a)

331309 fanInt :: Event t (IntMap a) -> EventSelectorInt t a

332310

333−-- | Efficiently fan-out an event to many destinations. You should save the

334−-- result in a @let@-binding, and then repeatedly 'select' on the result to

335−-- create child events

336−fan :: forall t k. (Reflex t, GCompare k)

337− => Event t (DMap k Identity) -> EventSelector t k

338− --TODO: Can we help enforce the partial application discipline here? The combinator is worthless without it

339−fan e = EventSelector (fixup (selectG (fanG e) :: k a -> Event t (Identity a)) :: forall a. k a -> Event t a)

340− where

341− fixup :: forall a. (k a -> Event t (Identity a)) -> k a -> Event t a

342− fixup = case eventCoercion Coercion :: Coercion (Event t (Identity a)) (Event t a) of

343− Coercion -> coerce

344−

345311--TODO: Specialize this so that we can take advantage of knowing that there's no changing going on

346312-- | Constructs a single 'Event' out of a map of events. The output event may fire with multiple

347313-- keys simultaneously.

@@ -360,12 +326,6 @@ coerceEvent = coerceWith $ eventCoercion Coercion

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

361327coerceDynamic = coerceWith $ dynamicCoercion Coercion

362328

363−-- | Coerce an 'Incremental' between representationally-equivalent value types

364−coerceIncremental

365− :: (Reflex t, Coercible a b, Coercible (PatchTarget a) (PatchTarget b))

366− => Incremental t a -> Incremental t b

367−coerceIncremental = coerceWith $ incrementalCoercion Coercion Coercion

368−

369329-- | Construct a 'Dynamic' from a 'Behavior' and an 'Event'. The 'Behavior'

370330-- __must__ change when and only when the 'Event' fires, such that the

371331-- 'Behavior''s value is always equal to the most recent firing of the 'Event';

@@ -535,17 +495,6 @@ newtype EventSelector t k = EventSelector

535495 select :: forall a. k a -> Event t a

536496 }

537497

538−newtype EventSelectorG t k v = EventSelectorG

539− { -- | Retrieve the 'Event' for the given key. The type of the 'Event' is

540− -- determined by the type of the key, so this can be used to fan-out

541− -- 'Event's whose sub-'Event's have different types.

542− --

543− -- Using 'EventSelector's and the 'fan' primitive is far more efficient than

544− -- (but equivalent to) using 'mapMaybe' to select only the relevant

545− -- occurrences of an 'Event'.

546− selectG :: forall a. k a -> Event t (v a)

547− }

548−

549498-- | Efficiently select an 'Event' keyed on 'Int'. This is more efficient than manually

550499-- filtering by key.

551500newtype EventSelectorInt t a = EventSelectorInt { selectInt :: Int -> Event t a }

@@ -1138,21 +1087,12 @@ instance (Reflex t, Monoid a) => Monoid (Dynamic t a) where

11381087-- 'Dynamic' 'DMap'. Its implementation is more efficient than doing the same

11391088-- through the use of multiple uses of 'zipDynWith' or 'Applicative' operators.

11401089distributeDMapOverDynPure :: forall t k. (Reflex t, GCompare k) => DMap k (Dynamic t) -> Dynamic t (DMap k Identity)

1141−distributeDMapOverDynPure = distributeDMapOverDynPureG coerceDynamic

1142−

1143−-- | This function converts a 'DMap' whose elements are 'Dynamic's into a

1144−-- 'Dynamic' 'DMap'. Its implementation is more efficient than doing the same

1145−-- through the use of multiple uses of 'zipDynWith' or 'Applicative' operators.

1146−distributeDMapOverDynPureG

1147− :: forall t k q v. (Reflex t, GCompare k)

1148− => (forall a. q a -> Dynamic t (v a))

1149− -> DMap k q -> Dynamic t (DMap k v)

1150−distributeDMapOverDynPureG nt dm = case DMap.toList dm of

1090+distributeDMapOverDynPure dm = case DMap.toList dm of

11511091 [] -> constDyn DMap.empty

1152− [k :=> v] -> DMap.singleton k <$> nt v

1092+ [k :=> v] -> fmap (DMap.singleton k . Identity) v

11531093 _ ->

1154− let getInitial = DMap.traverseWithKey (\_ -> sample . current . nt) dm

1155− edmPre = mergeG getCompose $ DMap.map (Compose . updated . nt) dm

1094+ let getInitial = DMap.traverseWithKey (\_ -> fmap Identity . sample . current) dm

1095+ edmPre = merge $ DMap.map updated dm

11561096 result = unsafeBuildDynamic getInitial $ flip pushAlways edmPre $ \news -> do

11571097 olds <- sample $ current result

11581098 return $ DMap.unionWithKey (\_ _ new -> new) olds news

@@ -1625,23 +1565,6 @@ fmapCheap f = pushCheap $ return . Just . f

16251565tagCheap :: Reflex t => Behavior t b -> Event t a -> Event t b

16261566tagCheap b = pushAlwaysCheap $ \_ -> sample b

16271567

1628−-- | Merge a collection of events; the resulting 'Event' will only occur if at

1629−-- least one input event is occurring, and will contain all of the input keys

1630−-- that are occurring simultaneously

1631−merge :: (Reflex t, GCompare k) => DMap k (Event t) -> Event t (DMap k Identity)

1632−merge = mergeG coerceEvent

1633−{-# INLINE merge #-}

1634−

1635−-- | Create a merge whose parents can change over time

1636−mergeIncremental :: (Reflex t, GCompare k)

1637− => Incremental t (PatchDMap k (Event t)) -> Event t (DMap k Identity)

1638−mergeIncremental = mergeIncrementalG coerceEvent

1639−

1640−-- | Experimental: Create a merge whose parents can change over time; changing the key of an Event is more efficient than with mergeIncremental

1641−mergeIncrementalWithMove :: (Reflex t, GCompare k)

1642− => Incremental t (PatchDMapWithMove k (Event t)) -> Event t (DMap k Identity)

1643−mergeIncrementalWithMove = mergeIncrementalWithMoveG coerceEvent

1644−

16451568-- | A "cheap" version of 'mergeWithCheap'. See the performance note on 'pushCheap'.

16461569{-# INLINE mergeWithCheap #-}

16471570mergeWithCheap :: Reflex t => (a -> a -> a) -> [Event t a] -> Event t a

src/Reflex/Patch/DMapWithReset.hsnew file+120

@@ -0,0 +1,120 @@

1+{-# LANGUAGE FlexibleContexts #-}

2+{-# LANGUAGE FlexibleInstances #-}

3+{-# LANGUAGE LambdaCase #-}

4+{-# LANGUAGE MultiParamTypeClasses #-}

5+{-# LANGUAGE PolyKinds #-}

6+{-# LANGUAGE Rank2Types #-}

7+{-# LANGUAGE ScopedTypeVariables #-}

8+{-# LANGUAGE StandaloneDeriving #-}

9+{-# LANGUAGE TypeApplications #-}

10+{-# LANGUAGE TypeFamilies #-}

11+{-# LANGUAGE UndecidableInstances #-}

12+

13+{-# OPTIONS_GHC -Wall #-}

14+

15+-- | 'Patch'es on 'DMap' that consist only of insertions (or overwrites) and deletions.

16+module Reflex.Patch.DMapWithReset where

17+

18+import Reflex.Patch.Class

19+

20+import Data.Dependent.Map (DMap, GCompare (..))

21+import qualified Data.Dependent.Map as DMap

22+import Data.Semigroup (Semigroup (..))

23+import Data.Constraint.Extras

24+

25+-- | A set of changes to a 'DMap'. Any element may be inserted/updated or deleted.

26+-- Insertions are represented as @'ComposeMaybe' (Just value)@,

27+-- while deletions are represented as @'ComposeMaybe' Nothing@.

28+newtype PatchDMapWithReset k p = PatchDMapWithReset { unPatchDMapWithReset :: DMap k (By p) }

29+

30+-- | Holds the information about each key: where its new value should come from,

31+-- and where its old value should go to

32+data By p a

33+ = By_Insert (PatchTarget (p a)) -- ^ Insert the given value here

34+ | By_Delete -- ^ Delete the existing value, if any, from here

35+ | By_Patch (p a) -- ^ Patch the value here with the given patch

36+

37+instance (Semigroup (p a), Patch (p a)) => Semigroup (By p a) where

38+ x@(By_Insert _) <> _ = x

39+ By_Delete <> _ = By_Delete

40+ By_Patch x <> By_Insert y = By_Insert (applyAlways x y)

41+ By_Patch x <> By_Patch y = By_Patch (x <> y)

42+ By_Patch _ <> By_Delete = By_Delete

43+

44+instance (Monoid (p a), Patch (p a)) => Monoid (By p a) where

45+ mappend = (<>)

46+ mempty = By_Patch mempty

47+

48+instance

49+ ( GCompare k

50+ , Has' Semigroup k p

51+ , Has' Patch k p

52+ )

53+ => Semigroup (PatchDMapWithReset k p) where

54+ PatchDMapWithReset xs <> PatchDMapWithReset ys = PatchDMapWithReset $ DMap.unionWithKey

55+ (\k -> has' @Patch @p k

56+ $ has' @Semigroup @p k

57+ $ (<>)) xs ys

58+

59+instance

60+ ( GCompare k

61+ , Has' Semigroup k p

62+ , Has' Patch k p

63+ )

64+ => Monoid (PatchDMapWithReset k p) where

65+ mappend = (<>)

66+ mempty = PatchDMapWithReset DMap.empty

67+

68+class (Patch (p a), PatchTarget (p a) ~ Patches1LocallyTarget p a) => Patches1Locally p a where

69+ type Patches1LocallyTarget p :: k -> *

70+

71+data These1 f g x

72+ = This1 (f x)

73+ | That1 (g x)

74+ | These1 (f x) (g x)

75+

76+mergeWithKey

77+ :: forall k v1 v2 v.

78+ (GCompare k)

79+ => (forall x. k x -> v1 x -> Maybe (v x))

80+ -> (forall x. k x -> v2 x -> Maybe (v x))

81+ -> (forall x. k x -> v1 x -> v2 x -> Maybe (v x))

82+ -> DMap k v1 -> DMap k v2 -> DMap k v

83+mergeWithKey f g fg = \xs ys -> DMap.mapMaybeWithKey onlyThat $ DMap.unionWithKey doIt (DMap.map This1 xs) (DMap.map That1 ys)

84+ where

85+ doIt _ (This1 xs) (That1 ys) = These1 xs ys

86+ doIt _ _ _ = error "mergeWithKey misalligned keys"

87+

88+ onlyThat :: forall x. k x -> These1 v1 v2 x -> Maybe (v x)

89+ onlyThat k = \case

90+ This1 xs -> f k xs

91+ That1 ys -> g k ys

92+ These1 xs ys -> fg k xs ys

93+{-# INLINE mergeWithKey #-}

94+

95+-- | Apply the insertions or deletions to a given 'DMap'.

96+instance (GCompare k, Has (Patches1Locally p) k) => Patch (PatchDMapWithReset k p) where

97+

98+ type PatchTarget (PatchDMapWithReset k p) = DMap k (Patches1LocallyTarget p)

99+

100+ apply = go

101+ where

102+ go :: PatchDMapWithReset k p -> DMap k (Patches1LocallyTarget p) -> Maybe (DMap k (Patches1LocallyTarget p))

103+ go (PatchDMapWithReset diff) old = Just $! mergeWithKey (\_ -> Just) inserts updates old diff

104+ where

105+ updates :: forall x. k x -> Patches1LocallyTarget p x -> By p x -> Maybe (Patches1LocallyTarget p x)

106+ updates k ys = has @(Patches1Locally p) k $ \case

107+ By_Insert x -> Just x

108+ By_Delete -> Nothing

109+ By_Patch x -> Just $ applyAlways x ys

110+

111+ inserts :: forall x. k x -> By p x -> Maybe (Patches1LocallyTarget p x)

112+ inserts k = has @(Patches1Locally p) k $ \case

113+ By_Insert x -> Just x

114+ By_Delete -> Nothing

115+ By_Patch _ -> Nothing

116+

117+deriving instance (Patch (p a), Eq (p a), Eq (PatchTarget (p a))) => Eq (By p a)

118+deriving instance (Patch (p a), Show (p a), Show (PatchTarget (p a))) => Show (By p a)

119+deriving instance (Eq (DMap k (By p))) => Eq (PatchDMapWithReset k p)

120+deriving instance (Show (DMap k (By p))) => Show (PatchDMapWithReset k p)

src/Reflex/Patch/Patchable.hsnew file+44

@@ -0,0 +1,44 @@

1+{-# LANGUAGE DeriveGeneric #-}

2+{-# LANGUAGE FlexibleContexts #-}

3+{-# LANGUAGE LambdaCase #-}

4+{-# LANGUAGE StandaloneDeriving #-}

5+{-# LANGUAGE TypeFamilies #-}

7+-- The derived instances are undecidable in the case of a pathological instance like

8+-- instance Patch x where

9+-- type PatchTarget x = Patchable x

10+{-# LANGUAGE UndecidableInstances #-}

11+

12+module Reflex.Patch.Patchable where

13+

14+-- import Data.Aeson

15+import GHC.Generics

16+import Reflex.Patch

17+

18+-- | Like SemiMap/PartialMap but for anything patchable

19+data Patchable p

20+ = Patchable_Patch p

21+ | Patchable_Complete (PatchTarget p)

22+ deriving (Generic)

23+

24+completePatchable :: Patchable p -> Maybe (PatchTarget p)

25+completePatchable = \case

26+ Patchable_Complete t -> Just t

27+ Patchable_Patch _ -> Nothing

28+

29+deriving instance (Eq p, Eq (PatchTarget p)) => Eq (Patchable p)

30+deriving instance (Ord p, Ord (PatchTarget p)) => Ord (Patchable p)

31+deriving instance (Show p, Show (PatchTarget p)) => Show (Patchable p)

32+deriving instance (Read p, Read (PatchTarget p)) => Read (Patchable p)

33+-- instance (ToJSON p, ToJSON (PatchTarget p)) => ToJSON (Patchable p)

34+-- instance (FromJSON p, FromJSON (PatchTarget p)) => FromJSON (Patchable p)

35+

36+instance (Monoid p, Patch p) => Monoid (Patchable p) where

37+ mempty = Patchable_Patch mempty

38+ mappend = (<>)

39+

40+instance (Semigroup p, Patch p) => Semigroup (Patchable p) where

41+ (<>) = curry $ \case

42+ (Patchable_Patch a, Patchable_Patch b) -> Patchable_Patch $ a <> b

43+ (Patchable_Patch a, Patchable_Complete b) -> Patchable_Complete $ applyAlways a b

44+ (Patchable_Complete a, _) -> Patchable_Complete a

src/Reflex/Profiled.hs+13−21

@@ -8,9 +8,6 @@

88{-# LANGUAGE StandaloneDeriving #-}

99{-# LANGUAGE TypeFamilies #-}

1010{-# LANGUAGE UndecidableInstances #-}

11−{-# LANGUAGE PolyKinds #-}

12−{-# LANGUAGE TypeApplications #-}

13−{-# LANGUAGE RankNTypes #-}

1411-- |

1512-- Module:

1613-- Reflex.Profiled

@@ -19,6 +16,7 @@

1916-- profiling/cost-center information.

2017module Reflex.Profiled where

2118

19+import Control.Lens hiding (children)

2220import Control.Monad

2321import Control.Monad.Exception

2422import Control.Monad.Fix

@@ -35,7 +33,6 @@ import Data.Map (Map)

3533import qualified Data.Map.Strict as Map

3634import Data.Monoid ((<>))

3735import Data.Ord

38−import Data.Profunctor.Unsafe ((#.))

3936import qualified Data.Semigroup as S

4037import Data.Type.Coercion

4138import Foreign.Ptr

@@ -136,32 +133,27 @@ instance Reflex t => Reflex (ProfiledTimeline t) where

136133 push f (Event_Profiled e) = coerce $ push (coerce f) $ profileEvent e -- Profile before rather than after; this way fanout won't count against us

137134 pushCheap f (Event_Profiled e) = coerce $ pushCheap (coerce f) $ profileEvent e

138135 pull = Behavior_Profiled . pull . coerce

139− fanG (Event_Profiled e) = EventSelectorG $ coerce $ selectG (fanG $ profileEvent e)

140− mergeG :: forall (k :: z -> *) q v. GCompare k

141− => (forall a. q a -> Event (ProfiledTimeline t) (v a))

142− -> DMap k q -> Event (ProfiledTimeline t) (DMap k v)

143− mergeG nt = Event_Profiled #. mergeG (coerce nt)

136+ merge :: forall k. GCompare k => DMap k (Event (ProfiledTimeline t)) -> Event (ProfiledTimeline t) (DMap k Identity)

137+ merge = Event_Profiled . merge . (unsafeCoerce :: DMap k (Event (ProfiledTimeline t)) -> DMap k (Event t))

138+ fan (Event_Profiled e) = EventSelector $ coerce $ select (fan $ profileEvent e)

144139 switch (Behavior_Profiled b) = coerce $ profileEvent $ switch (coerceBehavior b)

145140 coincidence (Event_Profiled e) = coerce $ profileEvent $ coincidence (coerceEvent e)

146141 current (Dynamic_Profiled d) = coerce $ current d

147142 updated (Dynamic_Profiled d) = coerce $ profileEvent $ updated d

148143 unsafeBuildDynamic (ProfiledM a0) (Event_Profiled a') = coerce $ unsafeBuildDynamic a0 a'

149144 unsafeBuildIncremental (ProfiledM a0) (Event_Profiled a') = coerce $ unsafeBuildIncremental a0 a'

150− mergeIncrementalG nt = (Event_Profiled . coerce) #. mergeIncrementalG nt

151− mergeIncrementalWithMoveG nt = (Event_Profiled . coerce) #. mergeIncrementalWithMoveG nt

145+ mergeIncremental = Event_Profiled . mergeIncremental . (unsafeCoerce :: Incremental (ProfiledTimeline t) (PatchDMap k (Event (ProfiledTimeline t))) -> Incremental t (PatchDMap k (Event t)))

146+ mergeIncrementalWithMove = Event_Profiled . mergeIncrementalWithMove . (unsafeCoerce :: Incremental (ProfiledTimeline t) (PatchDMapWithMove k (Event (ProfiledTimeline t))) -> Incremental t (PatchDMapWithMove k (Event t)))

152147 currentIncremental (Incremental_Profiled i) = coerce $ currentIncremental i

153148 updatedIncremental (Incremental_Profiled i) = coerce $ profileEvent $ updatedIncremental i

154149 incrementalToDynamic (Incremental_Profiled i) = coerce $ incrementalToDynamic i

155− behaviorCoercion c =

156− Coercion `trans` behaviorCoercion @t c `trans` Coercion

157− eventCoercion c =

158− Coercion `trans` eventCoercion @t c `trans` Coercion

159− dynamicCoercion c =

160− Coercion `trans` dynamicCoercion @t c `trans` Coercion

161− incrementalCoercion c d =

162− Coercion `trans` incrementalCoercion @t c d `trans` Coercion

163− mergeIntIncremental = Event_Profiled . mergeIntIncremental .

164− coerceWith (Coercion `trans` incrementalCoercion Coercion Coercion `trans` Coercion)

150+ behaviorCoercion (c :: Coercion a b) = case behaviorCoercion c :: Coercion (Behavior t a) (Behavior t b) of

151+ Coercion -> unsafeCoerce (Coercion :: Coercion (Behavior (ProfiledTimeline t) a) (Behavior (ProfiledTimeline t) a)) --TODO: Figure out how to make this typecheck without the unsafeCoerce

152+ eventCoercion (c :: Coercion a b) = case eventCoercion c :: Coercion (Event t a) (Event t b) of

153+ Coercion -> unsafeCoerce (Coercion :: Coercion (Event (ProfiledTimeline t) a) (Event (ProfiledTimeline t) a)) --TODO: Figure out how to make this typecheck without the unsafeCoerce

154+ dynamicCoercion (c :: Coercion a b) = case dynamicCoercion c :: Coercion (Dynamic t a) (Dynamic t b) of

155+ Coercion -> unsafeCoerce (Coercion :: Coercion (Dynamic (ProfiledTimeline t) a) (Dynamic (ProfiledTimeline t) a)) --TODO: Figure out how to make this typecheck without the unsafeCoerce

156+ mergeIntIncremental = Event_Profiled . mergeIntIncremental . (unsafeCoerce :: Incremental (ProfiledTimeline t) (PatchIntMap (Event (ProfiledTimeline t) a)) -> Incremental t (PatchIntMap (Event t a)))

165157 fanInt (Event_Profiled e) = coerce $ fanInt $ profileEvent e

166158

167159deriving instance Functor (Dynamic t) => Functor (Dynamic (ProfiledTimeline t))

src/Reflex/Pure.hs+13−21

@@ -5,9 +5,6 @@

55{-# LANGUAGE MultiParamTypeClasses #-}

66{-# LANGUAGE ScopedTypeVariables #-}

77{-# LANGUAGE TypeFamilies #-}

8−{-# LANGUAGE RankNTypes #-}

9−{-# LANGUAGE PolyKinds #-}

10−

118#ifdef USE_REFLEX_OPTIMIZER

129{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}

1310#endif

@@ -34,6 +31,7 @@ module Reflex.Pure

3431import Control.Monad

3532import Data.Dependent.Map (DMap, GCompare)

3633import qualified Data.Dependent.Map as DMap

34+import Data.Functor.Identity

3735import Data.IntMap (IntMap)

3836import qualified Data.IntMap as IntMap

3937import Data.Maybe

@@ -41,11 +39,10 @@ import Data.MemoTrie

4139import Data.Monoid

4240import Data.Type.Coercion

4341import Reflex.Class

44−import Data.Kind (Type)

4542

4643-- | A completely pure-functional 'Reflex' timeline, identifying moments in time

4744-- with the type @/t/@.

48−data Pure (t :: Type)

45+data Pure t

4946

5047-- | The 'Enum' instance of @/t/@ must be dense: for all @/x :: t/@, there must not exist

5148-- any @/y :: t/@ such that @/'pred' x < y < x/@. The 'HasTrie' instance will be used

@@ -78,19 +75,17 @@ instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where

7875 -- [UNUSED_CONSTRAINT]: The following type signature for merge will produce a

7976 -- warning because the GCompare instance is not used; however, removing the

8077 -- GCompare instance produces a different warning, due to that constraint

81− -- being present in the original class definition.

78+ -- being present in the original class definition

8279

83− --mergeG :: GCompare k => (forall a. q a -> Event (Pure t) (v a))

84− -- -> DMap k q -> Event (Pure t) (DMap k v)

85− mergeG nt events = Event $ memo $ \t ->

86− let currentOccurrences = DMap.mapMaybeWithKey (\_ q -> case nt q of Event a -> a t) events

80+ --merge :: GCompare k => DMap k (Event (Pure t)) -> Event (Pure t) (DMap k Identity)

81+ merge events = Event $ memo $ \t ->

82+ let currentOccurrences = DMap.mapMaybeWithKey (\_ (Event a) -> Identity <$> a t) events

8783 in if DMap.null currentOccurrences

8884 then Nothing

8985 else Just currentOccurrences

9086

91−-- The instance signature doeesn't compile, leave commented for documentation

92−-- fanG :: GCompare k => Event (Pure t) (DMap k v) -> EventSelectorG (Pure t) k v

93− fanG e = EventSelectorG $ \k -> Event $ \t -> unEvent e t >>= DMap.lookup k

87+ fan :: GCompare k => Event (Pure t) (DMap k Identity) -> EventSelector (Pure t) k

88+ fan e = EventSelector $ \k -> Event $ \t -> unEvent e t >>= fmap runIdentity . DMap.lookup k

9489

9590 switch :: Behavior (Pure t) (Event (Pure t) a) -> Event (Pure t) a

9691 switch b = Event $ memo $ \t -> unEvent (unBehavior b t) t

@@ -113,8 +108,8 @@ instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where

113108 --a) -> Incremental (Pure t) p a

114109 unsafeBuildIncremental readV0 p = Incremental $ \t -> (readV0 t, unEvent p t)

115110

116− mergeIncrementalG = mergeIncrementalImpl

117− mergeIncrementalWithMoveG = mergeIncrementalImpl

111+ mergeIncremental = mergeIncrementalImpl

112+ mergeIncrementalWithMove = mergeIncrementalImpl

118113

119114 currentIncremental i = Behavior $ \t -> fst $ unIncremental i t

120115

@@ -129,17 +124,14 @@ instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where

129124 behaviorCoercion Coercion = Coercion

130125 eventCoercion Coercion = Coercion

131126 dynamicCoercion Coercion = Coercion

132− incrementalCoercion Coercion Coercion = Coercion

133127

134128 fanInt e = EventSelectorInt $ \k -> Event $ \t -> unEvent e t >>= IntMap.lookup k

135129

136130 mergeIntIncremental = mergeIntIncrementalImpl

137131

138−mergeIncrementalImpl :: (PatchTarget p ~ DMap k q, GCompare k)

139− => (forall a. q a -> Event (Pure t) (v a))

140− -> Incremental (Pure t) p -> Event (Pure t) (DMap k v)

141−mergeIncrementalImpl nt i = Event $ \t ->

142− let results = DMap.mapMaybeWithKey (\_ q -> case nt q of Event e -> e t) $ fst $ unIncremental i t

132+mergeIncrementalImpl :: (PatchTarget p ~ DMap k (Event (Pure t)), GCompare k) => Incremental (Pure t) p -> Event (Pure t) (DMap k Identity)

133+mergeIncrementalImpl i = Event $ \t ->

134+ let results = DMap.mapMaybeWithKey (\_ (Event e) -> Identity <$> e t) $ fst $ unIncremental i t

143135 in if DMap.null results

144136 then Nothing

145137 else Just results

src/Reflex/Spider/Internal.hs+162−214

@@ -16,15 +16,9 @@

1616{-# LANGUAGE TypeFamilies #-}

1717{-# LANGUAGE TypeOperators #-}

1818{-# LANGUAGE UndecidableInstances #-}

19−{-# LANGUAGE PolyKinds #-}

20−{-# LANGUAGE DeriveFunctor #-}

21−{-# LANGUAGE StandaloneDeriving #-}

22−{-# LANGUAGE InstanceSigs #-}

23−

2419#ifdef USE_REFLEX_OPTIMIZER

2520{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}

2621#endif

27−{-# OPTIONS_GHC -Wunused-binds #-}

2822-- | This module is the implementation of the 'Spider' 'Reflex' engine. It uses

2923-- a graph traversal algorithm to propagate 'Event's and 'Behavior's.

3024module Reflex.Spider.Internal (module Reflex.Spider.Internal) where

@@ -38,10 +32,7 @@ import Control.Monad hiding (forM, forM_, mapM, mapM_)

3832import Control.Monad.Exception

3933import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_)

4034import Control.Monad.Primitive

41−--import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_)

42−import Control.Monad.Reader.Class

43−import Control.Monad.IO.Class

44−import Control.Monad.ReaderIO

35+import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_)

4536import Control.Monad.Ref

4637import Data.Align

4738import Data.Coerce

@@ -57,7 +48,6 @@ import Data.GADT.Compare

5748import Data.IntMap.Strict (IntMap)

5849import qualified Data.IntMap.Strict as IntMap

5950import Data.IORef

60−import Data.Kind (Type)

6151import Data.Maybe hiding (mapMaybe)

6252import Data.Monoid ((<>))

6353import Data.Proxy

@@ -94,7 +84,6 @@ import qualified Data.FastWeakBag as FastWeakBag

9484import Data.Reflection

9585import Data.Some (Some(Some))

9686import Data.Type.Coercion

97−import Data.Profunctor.Unsafe ((#.), (.#))

9887import Data.WeakBag (WeakBag, WeakBagTicket, _weakBag_children)

9988import qualified Data.WeakBag as WeakBag

10089import qualified Reflex.Class

@@ -211,6 +200,12 @@ nextNodeIdRef = unsafePerformIO $ newIORef 1

211200

212201newNodeId :: IO Int

213202newNodeId = atomicModifyIORef' nextNodeIdRef $ \n -> (succ n, n)

203+

204+{-# NOINLINE unsafeNodeId #-}

205+unsafeNodeId :: a -> Int

206+unsafeNodeId a = unsafePerformIO $ do

207+ touch a

208+ newNodeId

214209#endif

215210

216211--------------------------------------------------------------------------------

@@ -314,10 +309,9 @@ cacheEvent e =

314309#else

315310 Event $

316311#endif

317− unsafePerformIO $ do

318− mSubscribedRef :: IORef (FastWeak (CacheSubscribed x a))

319− <- newIORef emptyFastWeak

320− pure $ \sub -> {-# SCC "cacheEvent" #-} do

312+ let mSubscribedRef :: IORef (FastWeak (CacheSubscribed x a))

313+ !mSubscribedRef = unsafeNewIORef e emptyFastWeak

314+ in \sub -> {-# SCC "cacheEvent" #-} do

321315#ifdef DEBUG_TRACE_EVENTS

322316 unless (BS8.null callSite) $ liftIO $ BS8.hPutStrLn stderr callSite

323317#endif

@@ -383,7 +377,7 @@ eventRoot !k !r = Event $ wrap eventSubscribedRoot $ liftIO . getRootSubscribed

383377eventNever :: Event x a

384378eventNever = Event $ \_ -> return (EventSubscription (return ()) eventSubscribedNever, Nothing)

385379

386−eventFan :: (GCompare k, HasSpiderTimeline x) => k a -> Fan x k v -> Event x (v a)

380+eventFan :: (GCompare k, HasSpiderTimeline x) => k a -> Fan x k -> Event x a

387381eventFan !k !f = Event $ wrap eventSubscribedFan $ getFanSubscribed k f

388382

389383eventSwitch :: HasSpiderTimeline x => Switch x a -> Event x a

@@ -435,14 +429,14 @@ newSubscriberHold h = return $ Subscriber

435429 , subscriberRecalculateHeight = \_ -> return ()

436430 }

437431

438−newSubscriberFan :: forall x k v. (HasSpiderTimeline x, GCompare k) => FanSubscribed x k v -> IO (Subscriber x (DMap k v))

432+newSubscriberFan :: forall x k. (HasSpiderTimeline x, GCompare k) => FanSubscribed x k -> IO (Subscriber x (DMap k Identity))

439433newSubscriberFan subscribed = return $ Subscriber

440434 { subscriberPropagate = \a -> {-# SCC "traverseFan" #-} do

441435 subs <- liftIO $ readIORef $ fanSubscribedSubscribers subscribed

442436 tracePropagate (Proxy :: Proxy x) $ "SubscriberFan" <> showNodeId subscribed <> ": " ++ show (DMap.size subs) ++ " keys subscribed, " ++ show (DMap.size a) ++ " keys firing"

443437 liftIO $ writeIORef (fanSubscribedOccurrence subscribed) $ Just a

444438 scheduleClear $ fanSubscribedOccurrence subscribed

445− let f _ (Pair v subsubs) = do

439+ let f _ (Pair (Identity v) subsubs) = do

446440 propagate v $ _fanSubscribedChildren_list subsubs

447441 return $ Constant ()

448442 _ <- DMap.traverseWithKey f $ DMap.intersectionWithKey (\_ -> Pair) a subs --TODO: Would be nice to have DMap.traverse_

@@ -558,11 +552,6 @@ propagateFast a subscribers = withIncreasedDepth $ do

558552toAny :: a -> Any

559553toAny = unsafeCoerce

560554

561−-- Why do we use Any here, instead of just giving eventSubscribedRetained an

562−-- existential type? Sadly, GHC does not currently know how to unbox types

563−-- with existentially quantified fields. So instead we just coerce values

564−-- to type Any on the way in. Since we never coerce them back, this is

565−-- perfectly safe.

566555data EventSubscribed x = EventSubscribed

567556 { eventSubscribedHeightRef :: {-# UNPACK #-} !(IORef Height)

568557 , eventSubscribedRetained :: {-# NOUNPACK #-} !Any

@@ -595,7 +584,7 @@ eventSubscribedNever = EventSubscribed

595584#endif

596585 }

597586

598−eventSubscribedFan :: FanSubscribed x k v -> EventSubscribed x

587+eventSubscribedFan :: FanSubscribed x k -> EventSubscribed x

599588eventSubscribedFan !subscribed = EventSubscribed

600589 { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ fanSubscribedParent subscribed

601590 , eventSubscribedRetained = toAny subscribed

@@ -686,7 +675,7 @@ behaviorPull !p = Behavior $ do

686675 wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorPull"

687676 parentsRef <- liftIO $ newIORef []

688677 holdInits <- askBehaviorHoldInits

689− a <- liftIO $ runReaderIO (unBehaviorM $ pullCompute p) (Just (wi, parentsRef), holdInits)

678+ a <- liftIO $ runReaderT (unBehaviorM $ pullCompute p) (Just (wi, parentsRef), holdInits)

690679 invsRef <- liftIO . newIORef . maybeToList =<< askInvalidator

691680 parents <- liftIO $ readIORef parentsRef

692681 let subscribed = PullSubscribed

@@ -721,46 +710,42 @@ readBehaviorUntracked b = do

721710-- Dynamic

722711--------------------------------------------------------------------------------

723712

724−type DynamicS x p = Dynamic x (PatchTarget p) p

725−

726−data Dynamic x target p = Dynamic

727− { dynamicCurrent :: !(Behavior x target)

713+data Dynamic x p = Dynamic

714+ { dynamicCurrent :: !(Behavior x (PatchTarget p))

728715 , dynamicUpdated :: Event x p -- This must be lazy; see the comment on holdEvent --TODO: Would this let us eliminate `Dyn`?

729716 }

730717

731−deriving instance (HasSpiderTimeline x) => Functor (Dynamic x target)

732−

733−

734−

735−

736−dynamicHold :: Hold x p -> DynamicS x p

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

737719dynamicHold !h = Dynamic

738720 { dynamicCurrent = behaviorHold h

739721 , dynamicUpdated = eventHold h

740722 }

741723

742−dynamicHoldIdentity :: Hold x (Identity a) -> DynamicS x (Identity a)

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

743725dynamicHoldIdentity = dynamicHold

744726

745−dynamicConst :: PatchTarget p -> DynamicS x p

727+dynamicConst :: PatchTarget p -> Dynamic x p

746728dynamicConst !a = Dynamic

747729 { dynamicCurrent = behaviorConst a

748730 , dynamicUpdated = eventNever

749731 }

750732

751−dynamicDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> DynamicS x p

733+dynamicDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> Dynamic x p

752734dynamicDyn !d = Dynamic

753735 { dynamicCurrent = behaviorDyn d

754736 , dynamicUpdated = eventDyn d

755737 }

756738

757−dynamicDynIdentity :: HasSpiderTimeline x => Dyn x (Identity a) -> DynamicS x (Identity a)

739+dynamicDynIdentity :: HasSpiderTimeline x => Dyn x (Identity a) -> Dynamic x (Identity a)

758740dynamicDynIdentity = dynamicDyn

759741

760742--------------------------------------------------------------------------------

761743-- Combinators

762744--------------------------------------------------------------------------------

763745

746+--TODO: Figure out why certain things are not 'representational', then make them

747+--representational so we can use coerce

748+

764749--type role Hold representational

765750data Hold x p

766751 = Hold { holdValue :: !(IORef (PatchTarget p))

@@ -781,25 +766,20 @@ globalSpiderTimelineEnv = unsafePerformIO unsafeNewSpiderTimelineEnv

781766

782767-- | Stores all global data relevant to a particular Spider timeline; only one

783768-- value should exist for each type @x@

784−newtype SpiderTimelineEnv x = STE {unSTE :: SpiderTimelineEnv' x}

785−-- We implement SpiderTimelineEnv with a newtype wrapper so

786−-- we can get the coercions we want safely.

787−type role SpiderTimelineEnv nominal

788−

789−data SpiderTimelineEnv' x = SpiderTimelineEnv

769+data SpiderTimelineEnv x = SpiderTimelineEnv

790770 { _spiderTimeline_lock :: {-# UNPACK #-} !(MVar ())

791771 , _spiderTimeline_eventEnv :: {-# UNPACK #-} !(EventEnv x)

792772#ifdef DEBUG

793773 , _spiderTimeline_depth :: {-# UNPACK #-} !(IORef Int)

794774#endif

795775 }

796−type role SpiderTimelineEnv' phantom

776+type role SpiderTimelineEnv nominal

797777

798778instance Eq (SpiderTimelineEnv x) where

799779 _ == _ = True -- Since only one exists of each type

800780

801781instance GEq SpiderTimelineEnv where

802− a `geq` b = if _spiderTimeline_lock (unSTE a) == _spiderTimeline_lock (unSTE b)

782+ a `geq` b = if _spiderTimeline_lock a == _spiderTimeline_lock b

803783 then Just $ unsafeCoerce Refl -- This unsafeCoerce is safe because the same SpiderTimelineEnv can't have two different 'x' arguments

804784 else Nothing

805785

@@ -822,7 +802,7 @@ runEventM :: EventM x a -> IO a

822802runEventM = unEventM

823803

824804asksEventEnv :: forall x a. HasSpiderTimeline x => (EventEnv x -> a) -> EventM x a

825−asksEventEnv f = return $ f $ _spiderTimeline_eventEnv (unSTE (spiderTimeline :: SpiderTimelineEnv x))

805+asksEventEnv f = return $ f $ _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimelineEnv x)

826806

827807class MonadIO m => Defer a m where

828808 getDeferralQueue :: m (IORef [a])

@@ -960,9 +940,9 @@ getHoldEventSubscription h = do

960940

961941type BehaviorEnv x = (Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]), IORef [SomeHoldInit x])

962942

943+--type role BehaviorM representational

963944-- BehaviorM can sample behaviors

964−newtype BehaviorM x a = BehaviorM { unBehaviorM :: ReaderIO (BehaviorEnv x) a }

965− deriving (Functor, Applicative, MonadIO, MonadFix, MonadReader (BehaviorEnv x))

945+newtype BehaviorM x a = BehaviorM { unBehaviorM :: ReaderT (BehaviorEnv x) IO a } deriving (Functor, Applicative, MonadIO, MonadFix)

966946

967947instance Monad (BehaviorM x) where

968948 {-# INLINE (>>=) #-}

@@ -1013,7 +993,7 @@ data RootSubscribed x a = forall k. GCompare k => RootSubscribed

1013993#endif

1014994 }

1015995

1016−data Root x k

996+data Root x (k :: * -> *)

1017997 = Root { rootOccurrence :: !(IORef (DMap k Identity)) -- The currently-firing occurrence of this event

1018998 , rootSubscribed :: !(IORef (DMap k (RootSubscribed x)))

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

@@ -1083,25 +1063,25 @@ heightBagVerify b@(HeightBag s c) = if

10831063heightBagVerify = id

10841064#endif

10851065

1086−data FanSubscribedChildren x k v a = FanSubscribedChildren

1087− { _fanSubscribedChildren_list :: !(WeakBag (Subscriber x (v a)))

1088− , _fanSubscribedChildren_self :: {-# NOUNPACK #-} !(k a, FanSubscribed x k v)

1089− , _fanSubscribedChildren_weakSelf :: !(IORef (Weak (k a, FanSubscribed x k v)))

1066+data FanSubscribedChildren (x :: *) k a = FanSubscribedChildren

1067+ { _fanSubscribedChildren_list :: !(WeakBag (Subscriber x a))

1068+ , _fanSubscribedChildren_self :: {-# NOUNPACK #-} !(k a, FanSubscribed x k)

1069+ , _fanSubscribedChildren_weakSelf :: !(IORef (Weak (k a, FanSubscribed x k)))

10901070 }

10911071

1092−data FanSubscribed x k v

1093− = FanSubscribed { fanSubscribedCachedSubscribed :: !(IORef (Maybe (FanSubscribed x k v)))

1094− , fanSubscribedOccurrence :: !(IORef (Maybe (DMap k v)))

1095− , fanSubscribedSubscribers :: !(IORef (DMap k (FanSubscribedChildren x k v))) -- This DMap should never be empty

1072+data FanSubscribed (x :: *) k

1073+ = FanSubscribed { fanSubscribedCachedSubscribed :: !(IORef (Maybe (FanSubscribed x k)))

1074+ , fanSubscribedOccurrence :: !(IORef (Maybe (DMap k Identity)))

1075+ , fanSubscribedSubscribers :: !(IORef (DMap k (FanSubscribedChildren x k))) -- This DMap should never be empty

10961076 , fanSubscribedParent :: !(EventSubscription x)

10971077#ifdef DEBUG_NODEIDS

10981078 , fanSubscribedNodeId :: Int

10991079#endif

11001080 }

11011081

1102−data Fan x k v

1103− = Fan { fanParent :: !(Event x (DMap k v))

1104− , fanSubscribed :: !(IORef (Maybe (FanSubscribed x k v)))

1082+data Fan x k

1083+ = Fan { fanParent :: !(Event x (DMap k Identity))

1084+ , fanSubscribed :: !(IORef (Maybe (FanSubscribed x k)))

11051085 }

11061086

11071087data SwitchSubscribed x a

@@ -1163,8 +1143,7 @@ instance HasSpiderTimeline x => Align (Event x) where

11631143#if MIN_VERSION_these(0, 8, 0)

11641144instance HasSpiderTimeline x => Semialign (Event x) where

11651145#endif

1166− align ea eb = mapMaybe dmapToThese $ mergeG coerce $ dynamicConst $

1167− DMap.fromDistinctAscList [LeftTag :=> ea, RightTag :=> eb]

1146+ align ea eb = mapMaybe dmapToThese $ merge $ dynamicConst $ DMap.fromDistinctAscList [LeftTag :=> ea, RightTag :=> eb]

11681147

11691148#ifdef MIN_VERSION_semialign

11701149#if MIN_VERSION_semialign(1,1,0)

@@ -1177,13 +1156,13 @@ data DynType x p = UnsafeDyn !(BehaviorM x (PatchTarget p), Event x p)

11771156 | BuildDyn !(EventM x (PatchTarget p), Event x p)

11781157 | HoldDyn !(Hold x p)

11791158

1180−newtype Dyn (x :: Type) p = Dyn { unDyn :: IORef (DynType x p) }

1159+newtype Dyn x p = Dyn { unDyn :: IORef (DynType x p) }

11811160

1182−newMapDyn :: HasSpiderTimeline x => (a -> b) -> DynamicS x (Identity a) -> DynamicS x (Identity b)

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

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

11841163

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

1186−zipDynWith :: HasSpiderTimeline x => (a -> b -> c) -> DynamicS x (Identity a) -> DynamicS x (Identity b) -> DynamicS x (Identity c)

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

11871166zipDynWith f da db =

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

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

@@ -1206,12 +1185,18 @@ buildDynamic readV0 v' = do

12061185 return d

12071186

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

1209−unsafeBuildDynamic readV0 v' =

1210− Dyn $ unsafePerformIO $ newIORef $ UnsafeDyn (readV0, v')

1188+unsafeBuildDynamic readV0 v' = Dyn $ unsafeNewIORef x $ UnsafeDyn x

1189+ where x = (readV0, v')

12111190

12121191-- ResultM can read behaviors and events

12131192type ResultM = EventM

12141193

1194+{-# NOINLINE unsafeNewIORef #-}

1195+unsafeNewIORef :: a -> b -> IORef b

1196+unsafeNewIORef a b = unsafePerformIO $ do

1197+ touch a

1198+ newIORef b

1199+

12151200instance HasSpiderTimeline x => Functor (Event x) where

12161201 fmap f = push $ return . Just . f

12171202

@@ -1224,42 +1209,33 @@ push f e = cacheEvent (pushCheap f e)

12241209

12251210{-# INLINABLE pull #-}

12261211pull :: BehaviorM x a -> Behavior x a

1227−pull a = unsafePerformIO $ do

1228− ref <- newIORef Nothing

1229−#ifdef DEBUG_NODEIDS

1230− nid <- newNodeId

1231−#endif

1232− pure $ behaviorPull $ Pull

1233− { pullCompute = a

1234− , pullValue = ref

1212+pull a = behaviorPull $ Pull

1213+ { pullCompute = a

1214+ , pullValue = unsafeNewIORef a Nothing

12351215#ifdef DEBUG_NODEIDS

1236− , pullNodeId = nid

1216+ , pullNodeId = unsafeNodeId a

12371217#endif

1238− }

1218+ }

12391219

12401220{-# INLINABLE switch #-}

12411221switch :: HasSpiderTimeline x => Behavior x (Event x a) -> Event x a

1242−switch a = unsafePerformIO $ do

1243− ref <- newIORef Nothing

1244− pure $ eventSwitch $ Switch

1245− { switchParent = a

1246− , switchSubscribed = ref

1247− }

1222+switch a = eventSwitch $ Switch

1223+ { switchParent = a

1224+ , switchSubscribed = unsafeNewIORef a Nothing

1225+ }

12481226

12491227coincidence :: HasSpiderTimeline x => Event x (Event x a) -> Event x a

1250−coincidence a = unsafePerformIO $ do

1251− ref <- newIORef Nothing

1252− pure $ eventCoincidence $ Coincidence

1253− { coincidenceParent = a

1254− , coincidenceSubscribed = ref

1255− }

1228+coincidence a = eventCoincidence $ Coincidence

1229+ { coincidenceParent = a

1230+ , coincidenceSubscribed = unsafeNewIORef a Nothing

1231+ }

12561232

12571233-- Propagate the given event occurrence; before cleaning up, run the given action, which may read the state of events and behaviors

12581234run :: forall x b. HasSpiderTimeline x => [DSum (RootTrigger x) Identity] -> ResultM x b -> SpiderHost x b

12591235run roots after = do

12601236 tracePropagate (Proxy :: Proxy x) $ "Running an event frame with " <> show (length roots) <> " events"

12611237 let t = spiderTimeline :: SpiderTimelineEnv x

1262− result <- SpiderHost $ withMVar (_spiderTimeline_lock (unSTE t)) $ \_ -> unSpiderHost $ runFrame $ do

1238+ result <- SpiderHost $ withMVar (_spiderTimeline_lock t) $ \_ -> unSpiderHost $ runFrame $ do

12631239 rootsToPropagate <- forM roots $ \r@(RootTrigger (_, occRef, k) :=> a) -> do

12641240 occBefore <- liftIO $ do

12651241 occBefore <- readIORef occRef

@@ -1323,9 +1299,9 @@ type WeakList a = [Weak a]

13231299withIncreasedDepth :: CanTrace x m => m a -> m a

13241300withIncreasedDepth a = do

13251301 spiderTimeline <- askSpiderTimelineEnv

1326− liftIO $ modifyIORef' (_spiderTimeline_depth (unSTE spiderTimeline)) succ

1302+ liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) succ

13271303 result <- a

1328− liftIO $ modifyIORef' (_spiderTimeline_depth (unSTE spiderTimeline)) pred

1304+ liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) pred

13291305 return result

13301306#else

13311307withIncreasedDepth :: m a -> m a

@@ -1352,7 +1328,7 @@ traceMWhen _ b getMessage = when b $ do

13521328 message <- getMessage

13531329#ifdef DEBUG

13541330 spiderTimeline <- askSpiderTimelineEnv

1355− d <- liftIO $ readIORef $ _spiderTimeline_depth $ unSTE spiderTimeline

1331+ d <- liftIO $ readIORef $ _spiderTimeline_depth spiderTimeline

13561332#else

13571333 let d = 0

13581334#endif

@@ -1393,25 +1369,25 @@ propagateSubscriberHold h a = do

13931369data SomeResetCoincidence x = forall a. SomeResetCoincidence !(EventSubscription x) !(Maybe (CoincidenceSubscribed x a)) -- The CoincidenceSubscriber will be present only if heights need to be reset

13941370

13951371runBehaviorM :: BehaviorM x a -> Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]) -> IORef [SomeHoldInit x] -> IO a

1396−runBehaviorM a mwi holdInits = runReaderIO (unBehaviorM a) (mwi, holdInits)

1372+runBehaviorM a mwi holdInits = runReaderT (unBehaviorM a) (mwi, holdInits)

13971373

13981374askInvalidator :: BehaviorM x (Maybe (Weak (Invalidator x)))

13991375askInvalidator = do

1400− (!m, _) <- ask

1376+ (!m, _) <- BehaviorM ask

14011377 case m of

14021378 Nothing -> return Nothing

14031379 Just (!wi, _) -> return $ Just wi

14041380

14051381askParentsRef :: BehaviorM x (Maybe (IORef [SomeBehaviorSubscribed x]))

14061382askParentsRef = do

1407− (!m, _) <- ask

1383+ (!m, _) <- BehaviorM ask

14081384 case m of

14091385 Nothing -> return Nothing

14101386 Just (_, !p) -> return $ Just p

14111387

14121388askBehaviorHoldInits :: BehaviorM x (IORef [SomeHoldInit x])

14131389askBehaviorHoldInits = do

1414− (_, !his) <- ask

1390+ (_, !his) <- BehaviorM ask

14151391 return his

14161392

14171393{-# INLINE getDynHold #-}

@@ -1456,9 +1432,6 @@ getRootSubscribed k r sub = do

14561432 when debugPropagate $ putStrLn $ "getRootSubscribed: calling rootInit"

14571433 uninit <- rootInit r k $ RootTrigger (subs, rootOccurrence r, k)

14581434 writeIORef uninitRef $! uninit

1459−#ifdef DEBUG_NODEIDS

1460− nid <- newNodeId

1461−#endif

14621435 let !subscribed = RootSubscribed

14631436 { rootSubscribedKey = k

14641437 , rootSubscribedCachedSubscribed = cached

@@ -1467,7 +1440,7 @@ getRootSubscribed k r sub = do

14671440 , rootSubscribedUninit = uninit

14681441 , rootSubscribedWeakSelf = weakSelf

14691442#ifdef DEBUG_NODEIDS

1470− , rootSubscribedNodeId = nid

1443+ , rootSubscribedNodeId = unsafeNodeId (k, r, subs)

14711444#endif

14721445 }

14731446 -- If we die at the same moment that all our children die, they will

@@ -1516,10 +1489,16 @@ newFanInt = do

15161489 , _fanInt_occRef = occRef

15171490 }

15181491

1492+{-# NOINLINE unsafeNewFanInt #-}

1493+unsafeNewFanInt :: b -> FanInt x a

1494+unsafeNewFanInt b = unsafePerformIO $ do

1495+ touch b

1496+ newFanInt

1497+

15191498fanInt :: HasSpiderTimeline x => Event x (IntMap a) -> EventSelectorInt x a

1520−fanInt p = unsafePerformIO $ do

1521− self <- newFanInt

1522− pure $ EventSelectorInt $ \k -> Event $ \sub -> do

1499+fanInt p =

1500+ let self = unsafeNewFanInt p

1501+ in EventSelectorInt $ \k -> Event $ \sub -> do

15231502 isEmpty <- liftIO $ FastMutableIntMap.isEmpty (_fanInt_subscribers self)

15241503 when isEmpty $ do -- This is the first subscriber, so we need to subscribe to our input

15251504 (subscription, parentOcc) <- subscribeAndRead p $ Subscriber

@@ -1555,7 +1534,7 @@ fanInt p = unsafePerformIO $ do

15551534 return (EventSubscription (FastWeakBag.remove t) $! EventSubscribed heightRef $! toAny (_fanInt_subscriptionRef self, t), IntMap.lookup k currentOcc)

15561535

15571536{-# INLINABLE getFanSubscribed #-}

1558−getFanSubscribed :: (HasSpiderTimeline x, GCompare k) => k a -> Fan x k v -> Subscriber x (v a) -> EventM x (WeakBagTicket, FanSubscribed x k v, Maybe (v a))

1537+getFanSubscribed :: (HasSpiderTimeline x, GCompare k) => k a -> Fan x k -> Subscriber x a -> EventM x (WeakBagTicket, FanSubscribed x k, Maybe a)

15591538getFanSubscribed k f sub = do

15601539 mSubscribed <- liftIO $ readIORef $ fanSubscribed f

15611540 case mSubscribed of

@@ -1573,16 +1552,13 @@ getFanSubscribed k f sub = do

15731552 subscribersRef <- liftIO $ newIORef $ error "getFanSubscribed: subscribersRef not yet initialized"

15741553 occRef <- liftIO $ newIORef parentOcc

15751554 when (isJust parentOcc) $ scheduleClear occRef

1576−#ifdef DEBUG_NODEIDS

1577− nid <- liftIO newNodeId

1578−#endif

15791555 let subscribed = FanSubscribed

15801556 { fanSubscribedCachedSubscribed = fanSubscribed f

15811557 , fanSubscribedOccurrence = occRef

15821558 , fanSubscribedParent = subscription

15831559 , fanSubscribedSubscribers = subscribersRef

15841560#ifdef DEBUG_NODEIDS

1585− , fanSubscribedNodeId = nid

1561+ , fanSubscribedNodeId = unsafeNodeId f

15861562#endif

15871563 }

15881564 let !self = (k, subscribed)

@@ -1592,7 +1568,7 @@ getFanSubscribed k f sub = do

15921568 liftIO $ writeIORef (fanSubscribed f) $ Just subscribed

15931569 return (slnForSub, subscribed, coerce $ DMap.lookup k =<< parentOcc)

15941570

1595−cleanupFanSubscribed :: GCompare k => (k a, FanSubscribed x k v) -> IO ()

1571+cleanupFanSubscribed :: GCompare k => (k a, FanSubscribed x k) -> IO ()

15961572cleanupFanSubscribed (k, subscribed) = do

15971573 subscribers <- readIORef $ fanSubscribedSubscribers subscribed

15981574 let reducedSubscribers = DMap.delete k subscribers

@@ -1604,7 +1580,7 @@ cleanupFanSubscribed (k, subscribed) = do

16041580 else writeIORef (fanSubscribedSubscribers subscribed) $! reducedSubscribers

16051581

16061582{-# INLINE subscribeFanSubscribed #-}

1607−subscribeFanSubscribed :: GCompare k => k a -> FanSubscribed x k v -> Subscriber x (v a) -> IO WeakBagTicket

1583+subscribeFanSubscribed :: GCompare k => k a -> FanSubscribed x k -> Subscriber x a -> IO WeakBagTicket

16081584subscribeFanSubscribed k subscribed sub = do

16091585 subscribers <- readIORef $ fanSubscribedSubscribers subscribed

16101586 case DMap.lookup k subscribers of

@@ -1642,9 +1618,6 @@ getSwitchSubscribed s sub = do

16421618 when (isJust parentOcc) $ scheduleClear occRef

16431619 weakSelf <- liftIO $ newIORef $ error "getSwitchSubscribed: weakSelf not yet initialized"

16441620 (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupSwitchSubscribed

1645−#ifdef DEBUG_NODEIDS

1646− nid <- liftIO newNodeId

1647−#endif

16481621 let !subscribed = SwitchSubscribed

16491622 { switchSubscribedCachedSubscribed = switchSubscribed s

16501623 , switchSubscribedOccurrence = occRef

@@ -1657,7 +1630,7 @@ getSwitchSubscribed s sub = do

16571630 , switchSubscribedCurrentParent = subscriptionRef

16581631 , switchSubscribedWeakSelf = weakSelf

16591632#ifdef DEBUG_NODEIDS

1660− , switchSubscribedNodeId = nid

1633+ , switchSubscribedNodeId = unsafeNodeId s

16611634#endif

16621635 }

16631636 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "switchSubscribedWeakSelf"

@@ -1702,9 +1675,6 @@ getCoincidenceSubscribed c sub = do

17021675 scheduleClear innerSubdRef

17031676 weakSelf <- liftIO $ newIORef $ error "getCoincidenceSubscribed: weakSelf not yet implemented"

17041677 (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupCoincidenceSubscribed

1705−#ifdef DEBUG_NODEIDS

1706− nid <- liftIO newNodeId

1707−#endif

17081678 let subscribed = CoincidenceSubscribed

17091679 { coincidenceSubscribedCachedSubscribed = coincidenceSubscribed c

17101680 , coincidenceSubscribedOccurrence = occRef

@@ -1715,7 +1685,7 @@ getCoincidenceSubscribed c sub = do

17151685 , coincidenceSubscribedInnerParent = innerSubdRef

17161686 , coincidenceSubscribedWeakSelf = weakSelf

17171687#ifdef DEBUG_NODEIDS

1718− , coincidenceSubscribedNodeId = nid

1688+ , coincidenceSubscribedNodeId = unsafeNodeId c

17191689#endif

17201690 }

17211691 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "CoincidenceSubscribed"

@@ -1732,34 +1702,26 @@ cleanupCoincidenceSubscribed subscribed = do

17321702subscribeCoincidenceSubscribed :: CoincidenceSubscribed x a -> Subscriber x a -> IO WeakBagTicket

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

17341704

1735−{-# INLINE mergeG #-}

1736−mergeG :: forall k q x v. (HasSpiderTimeline x, GCompare k)

1737− => (forall a. q a -> Event x (v a))

1738− -> DynamicS x (PatchDMap k q) -> Event x (DMap k v)

1739−mergeG nt d = cacheEvent (mergeCheap nt d)

1705+{-# INLINE merge #-}

1706+merge :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMap k (Event x)) -> Event x (DMap k Identity)

1707+merge d = cacheEvent (mergeCheap d)

17401708

17411709{-# INLINE mergeWithMove #-}

1742−mergeWithMove :: forall k v q x. (HasSpiderTimeline x, GCompare k)

1743− => (forall a. q a -> Event x (v a))

1744− -> DynamicS x (PatchDMapWithMove k q) -> Event x (DMap k v)

1745−mergeWithMove nt d = cacheEvent (mergeCheapWithMove nt d)

1710+mergeWithMove :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMapWithMove k (Event x)) -> Event x (DMap k Identity)

1711+mergeWithMove d = cacheEvent (mergeCheapWithMove d)

17461712

17471713{-# INLINE [1] mergeCheap #-}

1748−mergeCheap

1749− :: forall k x q v. (HasSpiderTimeline x, GCompare k)

1750− => (forall a. q a -> Event x (v a))

1751− -> DynamicS x (PatchDMap k q)

1752− -> Event x (DMap k v)

1753−mergeCheap nt = mergeGCheap' getInitialSubscribers updateMe destroy

1714+mergeCheap :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMap k (Event x)) -> Event x (DMap k Identity)

1715+mergeCheap = mergeCheap' getInitialSubscribers updateMe destroy

17541716 where

1755− updateMe :: MergeUpdateFunc k v x (PatchDMap k q) (MergeSubscribedParent x)

1717+ updateMe :: MergeUpdateFunc k x (PatchDMap k (Event x)) (MergeSubscribedParent x)

17561718 updateMe subscriber heightBagRef oldParents (PatchDMap p) = do

17571719 let f (subscriptionsToKill, ps) (k :=> ComposeMaybe me) = do

17581720 (mOldSubd, newPs) <- case me of

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

17601722 Just e -> do

17611723 let s = subscriber $ return k

1762− subscription@(EventSubscription _ subd) <- subscribe (nt e) s

1724+ subscription@(EventSubscription _ subd) <- subscribe e s

17631725 newParentHeight <- liftIO $ getEventSubscribedHeight subd

17641726 let newParent = MergeSubscribedParent subscription

17651727 liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight

@@ -1769,33 +1731,28 @@ mergeCheap nt = mergeGCheap' getInitialSubscribers updateMe destroy

17691731 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight

17701732 return (maybeToList (unMergeSubscribedParent <$> mOldSubd) ++ subscriptionsToKill, newPs)

17711733 foldM f ([], oldParents) $ DMap.toList p

1772−

1773− getInitialSubscribers :: MergeInitFunc k v q x (MergeSubscribedParent x)

1734+ getInitialSubscribers :: MergeInitFunc k x (MergeSubscribedParent x)

17741735 getInitialSubscribers initialParents subscriber = do

17751736 subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do

17761737 let s = subscriber $ return k

1777− (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead (nt e) s

1738+ (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead e s

17781739 height <- liftIO $ getEventSubscribedHeight parentSubd

1779− return (fmap (k :=>) parentOcc, height, k :=> MergeSubscribedParent subscription)

1740+ return (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> MergeSubscribedParent subscription)

17801741 return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers

17811742 , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here

17821743 , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers

17831744 )

1784−

17851745 destroy :: MergeDestroyFunc k (MergeSubscribedParent x)

17861746 destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParent sub) -> unsubscribe sub

17871747

17881748{-# INLINE [1] mergeCheapWithMove #-}

1789−mergeCheapWithMove :: forall k x v q. (HasSpiderTimeline x, GCompare k)

1790− => (forall a. q a -> Event x (v a))

1791− -> DynamicS x (PatchDMapWithMove k q)

1792− -> Event x (DMap k v)

1793−mergeCheapWithMove nt = mergeGCheap' getInitialSubscribers updateMe destroy

1749+mergeCheapWithMove :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMapWithMove k (Event x)) -> Event x (DMap k Identity)

1750+mergeCheapWithMove = mergeCheap' getInitialSubscribers updateMe destroy

17941751 where

1795− updateMe :: MergeUpdateFunc k v x (PatchDMapWithMove k q) (MergeSubscribedParentWithMove x k)

1752+ updateMe :: MergeUpdateFunc k x (PatchDMapWithMove k (Event x)) (MergeSubscribedParentWithMove x k)

17961753 updateMe subscriber heightBagRef oldParents p = do

17971754 -- Prepare new parents for insertion

1798− let subscribeParent :: forall a. k a -> Event x (v a) -> EventM x (MergeSubscribedParentWithMove x k a)

1755+ let subscribeParent :: forall a. k a -> Event x a -> EventM x (MergeSubscribedParentWithMove x k a)

17991756 subscribeParent k e = do

18001757 keyRef <- liftIO $ newIORef k

18011758 let s = subscriber $ liftIO $ readIORef keyRef

@@ -1804,9 +1761,9 @@ mergeCheapWithMove nt = mergeGCheap' getInitialSubscribers updateMe destroy

18041761 newParentHeight <- getEventSubscribedHeight subd

18051762 modifyIORef' heightBagRef $ heightBagAdd newParentHeight

18061763 return $ MergeSubscribedParentWithMove subscription keyRef

1807− p' <- PatchDMapWithMove.traversePatchDMapWithMoveWithKey (\k q -> subscribeParent k (nt q)) p

1764+ p' <- PatchDMapWithMove.traversePatchDMapWithMoveWithKey subscribeParent p

18081765 -- Collect old parents for deletion and update the keys of moved parents

1809− let moveOrDelete :: forall a. k a -> PatchDMapWithMove.NodeInfo k q a -> MergeSubscribedParentWithMove x k a -> Constant (EventM x (Maybe (EventSubscription x))) a

1766+ let moveOrDelete :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Event x) a -> MergeSubscribedParentWithMove x k a -> Constant (EventM x (Maybe (EventSubscription x))) a

18101767 moveOrDelete _ ni parent = Constant $ case getComposeMaybe $ PatchDMapWithMove._nodeInfo_to ni of

18111768 Nothing -> do

18121769 oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ _mergeSubscribedParentWithMove_subscription parent

@@ -1817,47 +1774,46 @@ mergeCheapWithMove nt = mergeGCheap' getInitialSubscribers updateMe destroy

18171774 return Nothing

18181775 toDelete <- fmap catMaybes $ mapM (\(_ :=> v) -> getConstant v) $ DMap.toList $ DMap.intersectionWithKey moveOrDelete (unPatchDMapWithMove p) oldParents

18191776 return (toDelete, applyAlways p' oldParents)

1820− getInitialSubscribers :: MergeInitFunc k v q x (MergeSubscribedParentWithMove x k)

1777+ getInitialSubscribers :: MergeInitFunc k x (MergeSubscribedParentWithMove x k)

18211778 getInitialSubscribers initialParents subscriber = do

18221779 subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do

18231780 keyRef <- liftIO $ newIORef k

18241781 let s = subscriber $ liftIO $ readIORef keyRef

1825− (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead (nt e) s

1782+ (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead e s

18261783 height <- liftIO $ getEventSubscribedHeight parentSubd

1827− return (fmap (k :=>) parentOcc, height, k :=> MergeSubscribedParentWithMove subscription keyRef)

1784+ return (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> MergeSubscribedParentWithMove subscription keyRef)

18281785 return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers

18291786 , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here

18301787 , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers

18311788 )

1832−

18331789 destroy :: MergeDestroyFunc k (MergeSubscribedParentWithMove x k)

18341790 destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParentWithMove sub _) -> unsubscribe sub

18351791

1836−type MergeUpdateFunc k v x p s

1837− = (forall a. EventM x (k a) -> Subscriber x (v a))

1792+type MergeUpdateFunc k x p s

1793+ = (forall a. EventM x (k a) -> Subscriber x a)

18381794 -> IORef HeightBag

18391795 -> DMap k s

18401796 -> p

18411797 -> EventM x ([EventSubscription x], DMap k s)

18421798

1843−type MergeInitFunc k v q x s

1844− = DMap k q

1845− -> (forall a. EventM x (k a) -> Subscriber x (v a))

1846− -> EventM x (DMap k v, [Height], DMap k s)

1799+type MergeInitFunc k x s

1800+ = DMap k (Event x)

1801+ -> (forall a. EventM x (k a) -> Subscriber x a)

1802+ -> EventM x (DMap k Identity, [Height], DMap k s)

18471803

18481804type MergeDestroyFunc k s

18491805 = DMap k s

18501806 -> IO ()

18511807

1852−data Merge x k v s = Merge

1808+data Merge x k s = Merge

18531809 { _merge_parentsRef :: {-# UNPACK #-} !(IORef (DMap k s))

18541810 , _merge_heightBagRef :: {-# UNPACK #-} !(IORef HeightBag)

18551811 , _merge_heightRef :: {-# UNPACK #-} !(IORef Height)

1856− , _merge_sub :: {-# UNPACK #-} !(Subscriber x (DMap k v))

1857− , _merge_accumRef :: {-# UNPACK #-} !(IORef (DMap k v))

1812+ , _merge_sub :: {-# UNPACK #-} !(Subscriber x (DMap k Identity))

1813+ , _merge_accumRef :: {-# UNPACK #-} !(IORef (DMap k Identity))

18581814 }

18591815

1860−invalidateMergeHeight :: Merge x k v s -> IO ()

1816+invalidateMergeHeight :: Merge x k s -> IO ()

18611817invalidateMergeHeight m = invalidateMergeHeight' (_merge_heightRef m) (_merge_sub m)

18621818

18631819invalidateMergeHeight' :: IORef Height -> Subscriber x a -> IO ()

@@ -1867,7 +1823,8 @@ invalidateMergeHeight' heightRef sub = do

18671823 writeIORef heightRef $! invalidHeight

18681824 subscriberInvalidateHeight sub oldHeight

18691825

1870−revalidateMergeHeight :: Merge x k v s -> IO ()

1826+

1827+revalidateMergeHeight :: Merge x k s -> IO ()

18711828revalidateMergeHeight m = do

18721829 currentHeight <- readIORef $ _merge_heightRef m

18731830 when (currentHeight == invalidHeight) $ do -- revalidateMergeHeight may be called multiple times; perhaps the's a way to finesse it to avoid this check

@@ -1883,19 +1840,19 @@ revalidateMergeHeight m = do

18831840 subscriberRecalculateHeight (_merge_sub m) height

18841841 GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show (DMap.size parents) <> ") for Merge"

18851842

1886−scheduleMergeSelf :: HasSpiderTimeline x => Merge x k v s -> Height -> EventM x ()

1843+scheduleMergeSelf :: HasSpiderTimeline x => Merge x k s -> Height -> EventM x ()

18871844scheduleMergeSelf m height = scheduleMerge' height (_merge_heightRef m) $ do

18881845 vals <- liftIO $ readIORef $ _merge_accumRef m

18891846 liftIO $ writeIORef (_merge_accumRef m) $! DMap.empty -- Once we're done with this, we can clear it immediately, because if there's a cacheEvent in front of us, it'll handle subsequent subscribers, and if not, we won't get subsequent subscribers

18901847 --TODO: Assert that m is not empty

18911848 subscriberPropagate (_merge_sub m) vals

18921849

1893−mergeSubscriber :: forall x k v s a. (HasSpiderTimeline x, GCompare k) => Merge x k v s -> EventM x (k a) -> Subscriber x (v a)

1850+mergeSubscriber :: forall x k s a. (HasSpiderTimeline x, GCompare k) => Merge x k s -> EventM x (k a) -> Subscriber x a

18941851mergeSubscriber m getKey = Subscriber

18951852 { subscriberPropagate = \a -> do

18961853 oldM <- liftIO $ readIORef $ _merge_accumRef m

18971854 k <- getKey

1898− let newM = DMap.insertWith (error $ "Same key fired multiple times for Merge") k a oldM

1855+ let newM = DMap.insertWith (error $ "Same key fired multiple times for Merge") k (Identity a) oldM

18991856 tracePropagate (Proxy :: Proxy x) $ " DMap.size oldM = " <> show (DMap.size oldM) <> "; DMap.size newM = " <> show (DMap.size newM)

19001857 liftIO $ writeIORef (_merge_accumRef m) $! newM

19011858 when (DMap.null oldM) $ do -- Only schedule the firing once

@@ -1926,7 +1883,7 @@ mergeSubscriber m getKey = Subscriber

19261883 }

19271884

19281885--TODO: Be able to run as much of this as possible promptly

1929−updateMerge :: (HasSpiderTimeline x, GCompare k) => Merge x k v s -> MergeUpdateFunc k v x p s -> p -> SomeMergeUpdate x

1886+updateMerge :: (HasSpiderTimeline x, GCompare k) => Merge x k s -> MergeUpdateFunc k x p s -> p -> SomeMergeUpdate x

19301887updateMerge m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m) (revalidateMergeHeight m)

19311888 where updateMe = do

19321889 oldParents <- liftIO $ readIORef $ _merge_parentsRef m

@@ -1934,10 +1891,9 @@ updateMerge m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m)

19341891 liftIO $ writeIORef (_merge_parentsRef m) $! newParents

19351892 return subscriptionsToKill

19361893

1937−{-# INLINE mergeGCheap' #-}

1938−mergeGCheap' :: forall k v x p s q. (HasSpiderTimeline x, GCompare k, PatchTarget p ~ DMap k q)

1939− => MergeInitFunc k v q x s -> MergeUpdateFunc k v x p s -> MergeDestroyFunc k s -> DynamicS x p -> Event x (DMap k v)

1940−mergeGCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do

1894+{-# INLINE mergeCheap' #-}

1895+mergeCheap' :: forall k x p s. (HasSpiderTimeline x, GCompare k, PatchTarget p ~ DMap k (Event x)) => MergeInitFunc k x s -> MergeUpdateFunc k x p s -> MergeDestroyFunc k s -> Dynamic x p -> Event x (DMap k Identity)

1896+mergeCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do

19411897 initialParents <- readBehaviorUntracked $ dynamicCurrent d

19421898 accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized"

19431899 heightRef <- liftIO $ newIORef $ error "merge: heightRef not yet initialized"

@@ -1985,11 +1941,11 @@ mergeGCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do

19851941 , occ

19861942 )

19871943

1988−mergeInt :: forall x a. (HasSpiderTimeline x) => DynamicS x (PatchIntMap (Event x a)) -> Event x (IntMap a)

1944+mergeInt :: forall x a. (HasSpiderTimeline x) => Dynamic x (PatchIntMap (Event x a)) -> Event x (IntMap a)

19891945mergeInt = cacheEvent . mergeIntCheap

19901946

19911947{-# INLINABLE mergeIntCheap #-}

1992−mergeIntCheap :: forall x a. (HasSpiderTimeline x) => DynamicS x (PatchIntMap (Event x a)) -> Event x (IntMap a)

1948+mergeIntCheap :: forall x a. (HasSpiderTimeline x) => Dynamic x (PatchIntMap (Event x a)) -> Event x (IntMap a)

19931949mergeIntCheap d = Event $ \sub -> do

19941950 initialParents <- readBehaviorUntracked $ dynamicCurrent d

19951951 accum <- liftIO $ FastMutableIntMap.newEmpty

@@ -2086,16 +2042,14 @@ mergeIntCheap d = Event $ \sub -> do

20862042 )

20872043

20882044newtype EventSelector x k = EventSelector { select :: forall a. k a -> Event x a }

2089−newtype EventSelectorG x k v = EventSelectorG { selectG :: forall a. k a -> Event x (v a) }

20902045

2091−fanG :: (HasSpiderTimeline x, GCompare k) => Event x (DMap k v) -> EventSelectorG x k v

2092−fanG e = unsafePerformIO $ do

2093− ref <- newIORef Nothing

2046+fan :: (HasSpiderTimeline x, GCompare k) => Event x (DMap k Identity) -> EventSelector x k

2047+fan e =

20942048 let f = Fan

20952049 { fanParent = e

2096− , fanSubscribed = ref

2050+ , fanSubscribed = unsafeNewIORef e Nothing

20972051 }

2098− pure $ EventSelectorG $ \k -> eventFan k f

2052+ in EventSelector $ \k -> eventFan k f

20992053

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

21012055runHoldInits holdInitRef dynInitRef mergeInitRef = do

@@ -2149,7 +2103,7 @@ clearEventEnv (EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeI

21492103-- | Run an event action outside of a frame

21502104runFrame :: forall x a. HasSpiderTimeline x => EventM x a -> SpiderHost x a --TODO: This function also needs to hold the mutex

21512105runFrame a = SpiderHost $ do

2152− let env = _spiderTimeline_eventEnv $ unSTE (spiderTimeline :: SpiderTimelineEnv x)

2106+ let env = _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimelineEnv x)

21532107 let go = do

21542108 result <- a

21552109 runHoldInits (eventEnvHoldInits env) (eventEnvDynInits env) (eventEnvMergeInits env) -- This must happen before doing the assignments, in case subscribing a Hold causes existing Holds to be read by the newly-propagated events

@@ -2360,7 +2314,7 @@ instance HasSpiderTimeline x => Monad (Reflex.Class.Dynamic (SpiderTimeline x))

23602314 fail _ = error "Dynamic does not support 'fail'"

23612315

23622316{-# INLINABLE newJoinDyn #-}

2363−newJoinDyn :: HasSpiderTimeline x => DynamicS x (Identity (DynamicS x (Identity a))) -> Reflex.Spider.Internal.Dyn x (Identity a)

2317+newJoinDyn :: HasSpiderTimeline x => Reflex.Spider.Internal.Dynamic x (Identity (Reflex.Spider.Internal.Dynamic x (Identity a))) -> Reflex.Spider.Internal.Dyn x (Identity a)

23642318newJoinDyn d =

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

23662320 eOuter = Reflex.Spider.Internal.push (fmap (Just . Identity) . readBehaviorUntracked . dynamicCurrent . runIdentity) $ dynamicUpdated d

@@ -2510,7 +2464,7 @@ unsafeNewSpiderTimelineEnv = do

25102464#ifdef DEBUG

25112465 depthRef <- newIORef 0

25122466#endif

2513− return $ STE $ SpiderTimelineEnv

2467+ return $ SpiderTimelineEnv

25142468 { _spiderTimeline_lock = lock

25152469 , _spiderTimeline_eventEnv = env

25162470#ifdef DEBUG

@@ -2522,17 +2476,17 @@ unsafeNewSpiderTimelineEnv = do

25222476newSpiderTimeline :: IO (Some SpiderTimelineEnv)

25232477newSpiderTimeline = withSpiderTimeline (pure . Some)

25242478

2525−data LocalSpiderTimeline (x :: Type) s

2479+data LocalSpiderTimeline x s

25262480

25272481instance Reifies s (SpiderTimelineEnv x) =>

25282482 HasSpiderTimeline (LocalSpiderTimeline x s) where

2529− spiderTimeline = localSpiderTimeline Proxy $ reflect (Proxy :: Proxy s)

2483+ spiderTimeline = localSpiderTimeline (Proxy :: Proxy s) $ reflect (Proxy :: Proxy s)

25302484

25312485localSpiderTimeline

2532− :: proxy s

2486+ :: Proxy s

25332487 -> SpiderTimelineEnv x

25342488 -> SpiderTimelineEnv (LocalSpiderTimeline x s)

2535−localSpiderTimeline _ = coerce

2489+localSpiderTimeline _ = unsafeCoerce

25362490

25372491-- | Pass a new timeline to the given function.

25382492withSpiderTimeline :: (forall x. HasSpiderTimeline x => SpiderTimelineEnv x -> IO r) -> IO r

@@ -2540,18 +2494,18 @@ withSpiderTimeline k = do

25402494 env <- unsafeNewSpiderTimelineEnv

25412495 reify env $ \s -> k $ localSpiderTimeline s env

25422496

2543−newtype SpiderPullM (x :: Type) a = SpiderPullM (BehaviorM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)

2497+newtype SpiderPullM x a = SpiderPullM (BehaviorM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)

25442498

25452499type ComputeM = EventM

25462500

2547−newtype SpiderPushM (x :: Type) a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)

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

25482502

25492503instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where

25502504 {-# SPECIALIZE instance R.Reflex (SpiderTimeline Global) #-}

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

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

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

2554− newtype Incremental (SpiderTimeline x) p = SpiderIncremental { unSpiderIncremental :: DynamicS x p }

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

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

25552509 type PullM (SpiderTimeline x) = SpiderPullM x

25562510 type PushM (SpiderTimeline x) = SpiderPushM x

25572511 {-# INLINABLE never #-}

@@ -2564,15 +2518,10 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where

25642518 pushCheap f = SpiderEvent . pushCheap (coerce f) . unSpiderEvent

25652519 {-# INLINABLE pull #-}

25662520 pull = SpiderBehavior . pull . coerce

2567− {-# INLINABLE fanG #-}

2568− fanG e = R.EventSelectorG $ SpiderEvent . selectG (fanG (unSpiderEvent e))

2569− {-# INLINABLE mergeG #-}

2570− mergeG

2571− :: forall (k :: k2 -> *) q (v :: k2 -> *). GCompare k

2572− => (forall a. q a -> R.Event (SpiderTimeline x) (v a))

2573− -> DMap k q

2574− -> R.Event (SpiderTimeline x) (DMap k v)

2575− mergeG nt = SpiderEvent . mergeG (unSpiderEvent #. nt) . dynamicConst

2521+ {-# INLINABLE merge #-}

2522+ merge = SpiderEvent . merge . dynamicConst . (coerce :: DMap k (R.Event (SpiderTimeline x)) -> DMap k (Event x))

2523+ {-# INLINABLE fan #-}

2524+ fan e = R.EventSelector $ SpiderEvent . select (fan (unSpiderEvent e))

25762525 {-# INLINABLE switch #-}

25772526 switch = SpiderEvent . switch . (coerce :: Behavior x (R.Event (SpiderTimeline x) a) -> Behavior x (Event x a)) . unSpiderBehavior

25782527 {-# INLINABLE coincidence #-}

@@ -2580,15 +2529,15 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where

25802529 {-# INLINABLE current #-}

25812530 current = SpiderBehavior . dynamicCurrent . unSpiderDynamic

25822531 {-# INLINABLE updated #-}

2583− updated = SpiderEvent #. dynamicUpdated .# fmap coerce . unSpiderDynamic

2532+ updated = coerce $ SpiderEvent . dynamicUpdated . unSpiderDynamic

25842533 {-# INLINABLE unsafeBuildDynamic #-}

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

25862535 {-# INLINABLE unsafeBuildIncremental #-}

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

2588− {-# INLINABLE mergeIncrementalG #-}

2589− mergeIncrementalG nt = SpiderEvent #. mergeG (coerce #. nt) .# unSpiderIncremental

2590− {-# INLINABLE mergeIncrementalWithMoveG #-}

2591− mergeIncrementalWithMoveG nt = SpiderEvent #. mergeWithMove (coerce #. nt) .# unSpiderIncremental

2537+ {-# INLINABLE mergeIncremental #-}

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

2539+ {-# INLINABLE mergeIncrementalWithMove #-}

2540+ mergeIncrementalWithMove = SpiderEvent . mergeWithMove . (unsafeCoerce :: Dynamic x (PatchDMapWithMove k (R.Event (SpiderTimeline x))) -> Dynamic x (PatchDMapWithMove k (Event x))) . unSpiderIncremental

25922541 {-# INLINABLE currentIncremental #-}

25932542 currentIncremental = SpiderBehavior . dynamicCurrent . unSpiderIncremental

25942543 {-# INLINABLE updatedIncremental #-}

@@ -2599,10 +2548,9 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where

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

26002549 eventCoercion Coercion = Coercion

26012550 behaviorCoercion Coercion = Coercion

2602− dynamicCoercion Coercion = Coercion

2603− incrementalCoercion Coercion Coercion = Coercion

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

26042552 {-# INLINABLE mergeIntIncremental #-}

2605− mergeIntIncremental = SpiderEvent . mergeInt . coerce

2553+ mergeIntIncremental = SpiderEvent . mergeInt . (unsafeCoerce :: Dynamic x (PatchIntMap (R.Event (SpiderTimeline x) a)) -> Dynamic x (PatchIntMap (Event x a))) . unSpiderIncremental

26062554 {-# INLINABLE fanInt #-}

26072555 fanInt e = R.EventSelectorInt $ SpiderEvent . selectInt (fanInt (unSpiderEvent e))

26082556

@@ -2627,7 +2575,7 @@ instance MonadAtomicRef (EventM x) where

26272575 atomicModifyRef r f = liftIO $ atomicModifyRef r f

26282576

26292577-- | The monad for actions that manipulate a Spider timeline identified by @x@

2630−newtype SpiderHost (x :: Type) a = SpiderHost { unSpiderHost :: IO a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)

2578+newtype SpiderHost x a = SpiderHost { unSpiderHost :: IO a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)

26312579

26322580instance Monad (SpiderHost x) where

26332581 {-# INLINABLE (>>=) #-}

@@ -2649,7 +2597,7 @@ runSpiderHost (SpiderHost a) = a

26492597runSpiderHostForTimeline :: SpiderHost x a -> SpiderTimelineEnv x -> IO a

26502598runSpiderHostForTimeline (SpiderHost a) _ = a

26512599

2652−newtype SpiderHostFrame (x :: Type) a = SpiderHostFrame { runSpiderHostFrame :: EventM x a }

2600+newtype SpiderHostFrame x a = SpiderHostFrame { runSpiderHostFrame :: EventM x a }

26532601 deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)

26542602

26552603instance Monad (SpiderHostFrame x) where

test/GC.hs+3−4

@@ -27,7 +27,6 @@ import qualified Reflex.Spider.Internal as S

2727

2828import System.Exit

2929import System.Mem

30−import Data.Coerce

3130

3231main :: IO ()

3332main = do

@@ -47,7 +46,7 @@ hostPerf ref = S.runSpiderHost $ do

4746 eventToPerform <- Host.runHostFrame $ do

4847 (reqMap :: S.Event S.Global (DMap (Const2 Int (DMap Tell (S.SpiderHostFrame S.Global))) Identity))

4948 <- S.SpiderHostFrame

50− $ fmap ( S.mergeG coerce

49+ $ fmap ( S.merge

5150 . S.dynamicHold)

5251 $ S.hold DMap.empty

5352 -- Construct a new heap object for the subscriber, invalidating any weak references to the subscriber if they are not retained

@@ -56,8 +55,8 @@ hostPerf ref = S.runSpiderHost $ do

5655 { S.subscriberPropagate = S.subscriberPropagate sub

5756 }

5857 return (s, o))

59− $ runIdentity . runIdentity <$> S.selectG

60− (S.fanG $ S.pushCheap (return . Just . mapKeyValuePairsMonotonic (\(t :=> e) -> WrapArg t :=> Identity e)) response)

58+ $ runIdentity <$> S.select

59+ (S.fan $ S.pushCheap (return . Just . mapKeyValuePairsMonotonic (\(t :=> e) -> WrapArg t :=> Identity e)) response)

6160 (WrapArg Request)

6261 return $ alignWith (mergeThese (<>))

6362 (flip S.pushCheap eadd $ \_ -> return $ Just $ DMap.singleton Request $ do

test/Reflex/Bench/Focused.hs−12

@@ -130,16 +130,6 @@ mapDynChain = iterM (return . fmap (+1))

130130joinDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)

131131joinDynChain = iterM (\d -> return $ join $ fmap (const d) d)

132132

133−holdDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)

134−holdDynChain = iterM (\d -> sample (current d) >>= flip holdDyn (updated d))

135−

136−buildDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)

137−buildDynChain = iterM (\d -> do

138− let b = fmap (+1) (current d)

139− e = fmap (*2) (updated d)

140− buildDynamic (sample b) e)

141−

142−

143133combineDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)

144134combineDynChain = iterM (\d -> return $ zipDynWith (+) d d)

145135

@@ -318,8 +308,6 @@ dynamics :: Word -> [(String, TestCase)]

318308dynamics n =

319309 [ testE "mapDynChain" $ fmap updated $ mapDynChain n =<< d

320310 , testE "joinDynChain" $ fmap updated $ joinDynChain n =<< d

321− , testE "holdDynChain" $ fmap updated $ holdDynChain n =<< d

322− , testE "buildDynChain" $ fmap updated $ buildDynChain n =<< d

323311 , testE "combineDynChain" $ fmap updated $ combineDynChain n =<< d

324312 , testE "dense mergeTree" $ fmap (updated . mergeTreeDyn 8) dense

325313 , testE "sparse mergeTree" $ fmap (updated . mergeTreeDyn 8) sparse