e54b4a1 · patch · git.iko.soy

git.iko.soy/patch

on develop help sign in

Factor out Reflex.Patch

e54b4a1Ryan Trinkle10 years ago

src/Reflex.hs+1

compare with develop

unifiedsplit

@@ -7,6 +7,7 @@ import Reflex.Dynamic as X

7import Reflex.Dynamic.TH as X

8import Reflex.Dynamic.Uniq as X

9import Reflex.DynamicWriter as X

10+import Reflex.Patch as X

10import Reflex.PerformEvent.Class as X

11import Reflex.PerformEvent.Class as X

11import Reflex.PostBuild.Class as X

12import Reflex.PostBuild.Class as X

12import Reflex.Spider as X

13import Reflex.Spider as X

src/Reflex/Class.hs+2−80

@@ -30,10 +30,6 @@ module Reflex.Class

30 -- ** 'fan'-related types

31 , EventSelector (..)

32 -- ** 'Incremental'-related types

33− , Patch (..)

34− , PatchDMap (..)

35− , ComposeMaybe (..)

36− , PatchMap (..)

37 -- * Convenience functions

33 -- * Convenience functions

38 , constDyn

34 , constDyn

39 , pushAlways

35 , pushAlways

@@ -113,21 +109,20 @@ import Data.Either

113import Data.Foldable

109import Data.Foldable

114import Data.Functor.Bind hiding (join)

110import Data.Functor.Bind hiding (join)

115import qualified Data.Functor.Bind as Bind

111import qualified Data.Functor.Bind as Bind

116−import Data.Functor.Constant

117import Data.Functor.Misc

112import Data.Functor.Misc

118import Data.Functor.Plus

113import Data.Functor.Plus

119import Data.GADT.Compare ((:~:) (..), GEq (..))

114import Data.GADT.Compare ((:~:) (..), GEq (..))

120import Data.GADT.Show (GShow (..))

115import Data.GADT.Show (GShow (..))

121import Data.List.NonEmpty (NonEmpty (..))

116import Data.List.NonEmpty (NonEmpty (..))

122import Data.Map (Map)

117import Data.Map (Map)

123−import qualified Data.Map as Map

124import Data.Maybe

118import Data.Maybe

125import Data.Monoid hiding (Alt, (<>))

119import Data.Monoid hiding (Alt, (<>))

126−import Data.Semigroup (Semigroup, sconcat, stimes, stimesIdempotentMonoid, (<>))

120+import Data.Semigroup (Semigroup, sconcat, stimes, (<>))

127import Data.String

121import Data.String

128import Data.These

122import Data.These

129import Data.Traversable

123import Data.Traversable

130import Data.Type.Coercion

124import Data.Type.Coercion

125+import Reflex.Patch

131

126

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

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

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

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

@@ -233,79 +228,6 @@ coerceEvent = coerceWith $ eventCoercion Coercion

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

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

234coerceDynamic = coerceWith $ dynamicCoercion Coercion

229coerceDynamic = coerceWith $ dynamicCoercion Coercion

235

230

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

237−class Patch p where

238− type PatchTarget p :: *

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

240− -- 'Nothing'.

241− apply :: p -> PatchTarget p -> Maybe (PatchTarget p)

242−

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

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

245−-- representational so that we can use safe 'coerce'.

246−newtype ComposeMaybe f a = ComposeMaybe { getComposeMaybe :: Maybe (f a) }

247−

248−deriving instance Functor f => Functor (ComposeMaybe f)

249−

250−instance Patch (Identity a) where

251− type PatchTarget (Identity a) = a

252− apply (Identity a) _ = Just a

253−

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

255−newtype PatchDMap k v = PatchDMap (DMap k (ComposeMaybe v))

256−

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

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

259− -- PatchDMap is idempotent, so stimes n is id for every n

260−#if MIN_VERSION_semigroups(0,17,0)

261− stimes = stimesIdempotentMonoid

262−#else

263− times1p n x = case compare n 0 of

264− LT -> error "stimesIdempotentMonoid: negative multiplier"

265− EQ -> mempty

266− GT -> x

267−#endif

268−

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

270− mempty = PatchDMap mempty

271− mappend = (<>)

272−

273−instance GCompare k => Patch (PatchDMap k v) where

274− type PatchTarget (PatchDMap k v) = DMap k v

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

276− where insertions = DMap.mapMaybeWithKey (const $ getComposeMaybe) diff

277− deletions = DMap.mapMaybeWithKey (const $ nothingToJust . getComposeMaybe) diff

278− nothingToJust = \case

279− Nothing -> Just $ Constant ()

280− Just _ -> Nothing

281−

282−newtype PatchMap k v = PatchMap (Map k (Maybe v))

283−

284−instance Ord k => Patch (PatchMap k v) where

285− type PatchTarget (PatchMap k v) = Map k v

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

287− where insertions = Map.mapMaybeWithKey (const id) p

288− deletions = Map.mapMaybeWithKey (const nothingToJust) p

289− nothingToJust = \case

290− Nothing -> Just ()

291− Just _ -> Nothing

292−

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

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

295− -- PatchMap is idempotent, so stimes n is id for every n

296−#if MIN_VERSION_semigroups(0,17,0)

297− stimes = stimesIdempotentMonoid

298−#else

299− times1p n x = case compare n 0 of

300− LT -> error "stimesIdempotentMonoid: negative multiplier"

301− EQ -> mempty

302− GT -> x

303−#endif

304−

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

306− mempty = PatchMap mempty

307− mappend = (<>)

308−

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

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

310-- _must_ change when and only when the 'Event' fires, such that the

232-- _must_ change when and only when the 'Event' fires, such that the

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

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

src/Reflex/DynamicWriter.hs+2−1

@@ -28,9 +28,10 @@ import Data.Some (Some)

28import qualified Data.Some as Some

29import Reflex.Class

30import Reflex.Dynamic

31+import Reflex.Host.Class

32+import Reflex.Patch

31import Reflex.PerformEvent.Class

33import Reflex.PerformEvent.Class

32import Reflex.PostBuild.Class

34import Reflex.PostBuild.Class

33−import Reflex.Host.Class

35instance MonadTrans (DynamicWriterT t w) where

36instance MonadTrans (DynamicWriterT t w) where

36 lift = DynamicWriterT . lift

37 lift = DynamicWriterT . lift

src/Reflex/Patch.hsnew file+92

@@ -0,0 +1,92 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE LambdaCase #-}

3+{-# LANGUAGE StandaloneDeriving #-}

4+{-# LANGUAGE TypeFamilies #-}

5+{-# LANGUAGE DeriveFunctor #-}

6+module Reflex.Patch

7+ ( Patch (..)

8+ , PatchDMap (..)

9+ , ComposeMaybe (..)

10+ , PatchMap (..)

11+ ) where

12+

13+import Control.Monad.Identity

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

15+import qualified Data.Dependent.Map as DMap

16+import Data.Functor.Constant

17+import Data.Map (Map)

18+import qualified Data.Map as Map

19+import Data.Semigroup (Semigroup (..), stimesIdempotentMonoid, (<>))

20+

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

22+class Patch p where

23+ type PatchTarget p :: *

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

25+ -- 'Nothing'.

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

27+

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

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

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

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

32+

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

34+

35+instance Patch (Identity a) where

36+ type PatchTarget (Identity a) = a

37+ apply (Identity a) _ = Just a

38+

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

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

41+

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

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

44+ -- PatchDMap is idempotent, so stimes n is id for every n

45+#if MIN_VERSION_semigroups(0,17,0)

46+ stimes = stimesIdempotentMonoid

47+#else

48+ times1p n x = case compare n 0 of

49+ LT -> error "stimesIdempotentMonoid: negative multiplier"

50+ EQ -> mempty

51+ GT -> x

52+#endif

53+

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

55+ mempty = PatchDMap mempty

56+ mappend = (<>)

57+

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

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

60+ 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?

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

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

63+ nothingToJust = \case

64+ Nothing -> Just $ Constant ()

65+ Just _ -> Nothing

66+

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

68+

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

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

71+ 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?

72+ where insertions = Map.mapMaybeWithKey (const id) p

73+ deletions = Map.mapMaybeWithKey (const nothingToJust) p

74+ nothingToJust = \case

75+ Nothing -> Just ()

76+ Just _ -> Nothing

77+

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

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

80+ -- PatchMap is idempotent, so stimes n is id for every n

81+#if MIN_VERSION_semigroups(0,17,0)

82+ stimes = stimesIdempotentMonoid

83+#else

84+ times1p n x = case compare n 0 of

85+ LT -> error "stimesIdempotentMonoid: negative multiplier"

86+ EQ -> mempty

87+ GT -> x

88+#endif

89+

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

91+ mempty = PatchMap mempty

92+ mappend = (<>)

src/Reflex/PerformEvent/Base.hs+2−1

@@ -17,8 +17,9 @@ module Reflex.PerformEvent.Base where

18import Reflex.Class

19import Reflex.Host.Class

20−import Reflex.PostBuild.Class

20+import Reflex.Patch

21import Reflex.PerformEvent.Class

22+import Reflex.PostBuild.Class

23import Control.Lens

24import Control.Lens

24import Control.Monad.Exception

25import Control.Monad.Exception

src/Reflex/PostBuild/Class.hs+1

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

19import qualified Data.Dependent.Map as DMap

20import Reflex.Class

21import Reflex.Host.Class

22+import Reflex.Patch

22import Reflex.PerformEvent.Class

23import Reflex.PerformEvent.Class

24class (Reflex t, Monad m) => PostBuild t m | m -> t where

25class (Reflex t, Monad m) => PostBuild t m | m -> t where

src/Reflex/Pure.hs+1

@@ -31,6 +31,7 @@ import Data.MemoTrie

31import Data.Monoid

32import Data.Type.Coercion

33import Reflex.Class

34+import Reflex.Patch

35data Pure t

36data Pure t

src/Reflex/Spider/Internal.hs+27−26

@@ -71,6 +71,7 @@ import Data.Tree (Forest, Tree (..), drawForest)

71import Data.WeakBag (WeakBag, WeakBagTicket)

72import qualified Data.WeakBag as WeakBag

73import qualified Reflex.Class as R

74+import Reflex.Patch

74import qualified Reflex.Host.Class as R

75import qualified Reflex.Host.Class as R

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

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

@@ -296,7 +297,7 @@ eventCoincidence !c = Event $ wrap eventSubscribedCoincidence $ getCoincidenceSu

296eventHold :: HasSpiderTimeline x => Hold x p -> Event x p

297eventHold :: HasSpiderTimeline x => Hold x p -> Event x p

297eventHold !h = Event $ subscribeHoldEvent h

298eventHold !h = Event $ subscribeHoldEvent h

298

299

299−eventDyn :: (HasSpiderTimeline x, R.Patch p) => Dyn x p -> Event x p

300+eventDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> Event x p

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

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

301

302

302{-# INLINE subscribeCoincidenceInner #-}

303{-# INLINE subscribeCoincidenceInner #-}

@@ -329,7 +330,7 @@ data Subscriber x a = Subscriber

329-- The result is also evaluated to WHNF, since forcing a thunk invalidates

330-- The result is also evaluated to WHNF, since forcing a thunk invalidates

330-- the weak pointer to it in some cases.

331-- the weak pointer to it in some cases.

331

332

332−newSubscriberHold :: (HasSpiderTimeline x, R.Patch p) => Hold x p -> IO (Subscriber x p)

333+newSubscriberHold :: (HasSpiderTimeline x, Patch p) => Hold x p -> IO (Subscriber x p)

333newSubscriberHold h = return $ Subscriber

334newSubscriberHold h = return $ Subscriber

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

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

335 , subscriberInvalidateHeight = \_ -> return ()

336 , subscriberInvalidateHeight = \_ -> return ()

@@ -564,7 +565,7 @@ unsubscribe (EventSubscription u _) = u

564

565

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

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

566

567

567−behaviorHold :: Hold x p -> Behavior x (R.PatchTarget p)

568+behaviorHold :: Hold x p -> Behavior x (PatchTarget p)

568behaviorHold !h = Behavior $ readHoldTracked h

569behaviorHold !h = Behavior $ readHoldTracked h

569

570

570behaviorHoldIdentity :: Hold x (Identity a) -> Behavior x a

571behaviorHoldIdentity :: Hold x (Identity a) -> Behavior x a

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

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

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

601 return a

602 return a

602

603

603−behaviorDyn :: R.Patch p => Dyn x p -> Behavior x (R.PatchTarget p)

604+behaviorDyn :: Patch p => Dyn x p -> Behavior x (PatchTarget p)

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

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

605

606

606{-# INLINE readHoldTracked #-}

607{-# INLINE readHoldTracked #-}

607−readHoldTracked :: Hold x p -> BehaviorM x (R.PatchTarget p)

608+readHoldTracked :: Hold x p -> BehaviorM x (PatchTarget p)

608readHoldTracked h = do

609readHoldTracked h = do

609 result <- liftIO $ readIORef $ holdValue h

610 result <- liftIO $ readIORef $ holdValue h

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

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

@@ -623,7 +624,7 @@ readBehaviorUntracked b = do

623--------------------------------------------------------------------------------

624--------------------------------------------------------------------------------

624

625

625data Dynamic x p = Dynamic

626data Dynamic x p = Dynamic

626− { dynamicCurrent :: !(Behavior x (R.PatchTarget p))

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

627 , dynamicUpdated :: !(Event x p)

628 , dynamicUpdated :: !(Event x p)

628 }

629 }

629

630

@@ -636,13 +637,13 @@ dynamicHold !h = Dynamic

636dynamicHoldIdentity :: HasSpiderTimeline x => Hold x (Identity a) -> Dynamic x (Identity a)

637dynamicHoldIdentity :: HasSpiderTimeline x => Hold x (Identity a) -> Dynamic x (Identity a)

637dynamicHoldIdentity = dynamicHold

638dynamicHoldIdentity = dynamicHold

638

639

639−dynamicConst :: R.PatchTarget p -> Dynamic x p

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

640dynamicConst !a = Dynamic

641dynamicConst !a = Dynamic

641 { dynamicCurrent = behaviorConst a

642 { dynamicCurrent = behaviorConst a

642 , dynamicUpdated = eventNever

643 , dynamicUpdated = eventNever

643 }

644 }

644

645

645−dynamicDyn :: (HasSpiderTimeline x, R.Patch p) => Dyn x p -> Dynamic x p

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

646dynamicDyn !d = Dynamic

647dynamicDyn !d = Dynamic

647 { dynamicCurrent = behaviorDyn d

648 { dynamicCurrent = behaviorDyn d

648 , dynamicUpdated = eventDyn d

649 , dynamicUpdated = eventDyn d

@@ -660,7 +661,7 @@ dynamicDynIdentity = dynamicDyn

660

661

661--type role Hold representational

662--type role Hold representational

662data Hold x p

663data Hold x p

663− = Hold { holdValue :: !(IORef (R.PatchTarget p))

664+ = Hold { holdValue :: !(IORef (PatchTarget p))

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

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

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

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

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

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

@@ -764,9 +765,9 @@ instance HasSpiderTimeline x => Defer (SomeResetCoincidence x) (EventM x) where

764 getDeferralQueue = asksEventEnv eventEnvResetCoincidences

765 getDeferralQueue = asksEventEnv eventEnvResetCoincidences

765

766

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

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

767−{- SPECIALIZE hold :: (HasSpiderTimeline x, R.Patch p) => R.PatchTarget p -> Event x p -> EventM x (Hold x p) #-}

768+{- SPECIALIZE hold :: (HasSpiderTimeline x, Patch p) => PatchTarget p -> Event x p -> EventM x (Hold x p) #-}

768{-# INLINE [1] hold #-}

769{-# INLINE [1] hold #-}

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

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

770hold v0 e = do

771hold v0 e = do

771 valRef <- liftIO $ newIORef v0

772 valRef <- liftIO $ newIORef v0

772 invsRef <- liftIO $ newIORef []

773 invsRef <- liftIO $ newIORef []

@@ -787,7 +788,7 @@ hold v0 e = do

787 return h

788 return h

788

789

789{-# INLINE getHoldEventSubscription #-}

790{-# INLINE getHoldEventSubscription #-}

790−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 ~ EventM x) => Hold x p -> m (EventSubscription x)

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

791getHoldEventSubscription h = do

792getHoldEventSubscription h = do

792 ep <- liftIO $ readIORef $ holdParent h

793 ep <- liftIO $ readIORef $ holdParent h

793 case ep of

794 case ep of

@@ -801,7 +802,7 @@ getHoldEventSubscription h = do

801 Nothing -> return ()

802 Nothing -> return ()

802 Just o -> do

803 Just o -> do

803 old <- liftIO $ readIORef $ holdValue h

804 old <- liftIO $ readIORef $ holdValue h

804− case R.apply o old of

805+ case apply o old of

805 Nothing -> return ()

806 Nothing -> return ()

806 Just new -> do

807 Just new -> do

807 -- Need to evaluate these so that we don't retain the Hold itself

808 -- Need to evaluate these so that we don't retain the Hold itself

@@ -872,7 +873,7 @@ data Root x (k :: * -> *)

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

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

873 }

874 }

874

875

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

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

876

877

877data SomeMergeUpdate x = SomeMergeUpdate

878data SomeMergeUpdate x = SomeMergeUpdate

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

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

@@ -1015,7 +1016,7 @@ instance HasSpiderTimeline x => Align (Event x) where

1015 nil = eventNever

1016 nil = eventNever

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

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

1017

1018

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

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

1019

1020

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

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

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

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

@@ -1036,7 +1037,7 @@ zipDynWith f da db =

1036 return $ Just $ Identity $ f a b

1037 return $ Just $ Identity $ f a b

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

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

1038

1039

1039−unsafeDyn :: BehaviorM x (R.PatchTarget p) -> Event x p -> Dyn x p

1040+unsafeDyn :: BehaviorM x (PatchTarget p) -> Event x p -> Dyn x p

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

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

1041 where x = (readV0, v')

1042 where x = (readV0, v')

1042

1043

@@ -1209,13 +1210,13 @@ listsToForest l = fmap (\(a, l') -> Node a $ listsToForest $ toList l') $ groupB

1209#endif

1210#endif

1210

1211

1211{-# INLINE propagateSubscriberHold #-}

1212{-# INLINE propagateSubscriberHold #-}

1212−propagateSubscriberHold :: forall x p. (HasSpiderTimeline x, R.Patch p) => Hold x p -> p -> EventM x ()

1213+propagateSubscriberHold :: forall x p. (HasSpiderTimeline x, Patch p) => Hold x p -> p -> EventM x ()

1213propagateSubscriberHold h a = do

1214propagateSubscriberHold h a = do

1214 {-# SCC "trace" #-} traceMWhen (Proxy :: Proxy x) debugPropagate $ liftIO $ do

1215 {-# SCC "trace" #-} traceMWhen (Proxy :: Proxy x) debugPropagate $ liftIO $ do

1215 invalidators <- liftIO $ readIORef $ holdInvalidators h

1216 invalidators <- liftIO $ readIORef $ holdInvalidators h

1216 return $ "SubscriberHold" <> showNodeId h <> ": " ++ show (length invalidators)

1217 return $ "SubscriberHold" <> showNodeId h <> ": " ++ show (length invalidators)

1217 v <- {-# SCC "read" #-} liftIO $ readIORef $ holdValue h

1218 v <- {-# SCC "read" #-} liftIO $ readIORef $ holdValue h

1218− case {-# SCC "apply" #-} R.apply a v of

1219+ case {-# SCC "apply" #-} apply a v of

1219 Nothing -> return ()

1220 Nothing -> return ()

1220 Just v' -> do

1221 Just v' -> do

1221 {-# SCC "trace2" #-} withIncreasedDepth $ tracePropagate (Proxy :: Proxy x) $ "propagateSubscriberHold: assigning Hold" <> showNodeId h

1222 {-# SCC "trace2" #-} withIncreasedDepth $ tracePropagate (Proxy :: Proxy x) $ "propagateSubscriberHold: assigning Hold" <> showNodeId h

@@ -1248,7 +1249,7 @@ askBehaviorHoldInits = do

1248 return his

1249 return his

1249

1250

1250{-# INLINE getDynHold #-}

1251{-# INLINE getDynHold #-}

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

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

1252getDynHold d = do

1253getDynHold d = do

1253 mh <- liftIO $ readIORef $ unDyn d

1254 mh <- liftIO $ readIORef $ unDyn d

1254 case mh of

1255 case mh of

@@ -1488,11 +1489,11 @@ subscribeCoincidenceSubscribed :: CoincidenceSubscribed x a -> Subscriber x a ->

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

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

1489

1490

1490{-# INLINE merge #-}

1491{-# INLINE merge #-}

1491−merge :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (R.PatchDMap k (Event x)) -> Event x (DMap k Identity)

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

1492merge d = cacheEvent (mergeCheap d)

1493merge d = cacheEvent (mergeCheap d)

1493

1494

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

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

1495−mergeCheap :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (R.PatchDMap k (Event x)) -> Event x (DMap k Identity)

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

1496mergeCheap d = Event $ \sub -> do

1497mergeCheap d = Event $ \sub -> do

1497 initialParents <- readBehaviorUntracked $ dynamicCurrent d

1498 initialParents <- readBehaviorUntracked $ dynamicCurrent d

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

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

@@ -1580,9 +1581,9 @@ mergeCheap d = Event $ \sub -> do

1580 liftIO $ writeIORef heightBagRef $! myHeightBag

1581 liftIO $ writeIORef heightBagRef $! myHeightBag

1581 changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"

1582 changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"

1582 liftIO $ writeIORef parentsRef $! DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers

1583 liftIO $ writeIORef parentsRef $! DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers

1583− let updateMe (R.PatchDMap p) = do

1584+ let updateMe (PatchDMap p) = do

1584 oldParents <- liftIO $ readIORef parentsRef

1585 oldParents <- liftIO $ readIORef parentsRef

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

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

1586 (mOldSubd, newPs) <- case me of

1587 (mOldSubd, newPs) <- case me of

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

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

1588 Just e -> do

1589 Just e -> do

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

1927 {-# INLINABLE unsafeBuildIncremental #-}

1928 {-# INLINABLE unsafeBuildIncremental #-}

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

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

1929 {-# INLINABLE mergeIncremental #-}

1930 {-# INLINABLE mergeIncremental #-}

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

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

1931 {-# INLINABLE currentIncremental #-}

1932 {-# INLINABLE currentIncremental #-}

1932 currentIncremental = SpiderBehavior . dynamicCurrent . unSpiderIncremental

1933 currentIncremental = SpiderBehavior . dynamicCurrent . unSpiderIncremental

1933 {-# INLINABLE updatedIncremental #-}

1934 {-# INLINABLE updatedIncremental #-}

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

1935 {-# INLINABLE incrementalToDynamic #-}

1936 {-# INLINABLE incrementalToDynamic #-}

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

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

1937 c <- readBehaviorUntracked $ dynamicCurrent i

1938 c <- readBehaviorUntracked $ dynamicCurrent i

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

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

1939 eventCoercion Coercion = Coercion

1940 eventCoercion Coercion = Coercion

1940 behaviorCoercion Coercion = Coercion

1941 behaviorCoercion Coercion = Coercion

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

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

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

1958holdDynSpiderEventM :: HasSpiderTimeline x => a -> R.Event (SpiderTimeline x) a -> EventM x (R.Dynamic (SpiderTimeline x) a)

1959holdDynSpiderEventM :: HasSpiderTimeline x => a -> R.Event (SpiderTimeline x) a -> EventM x (R.Dynamic (SpiderTimeline x) a)

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

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

1960

1961

1961−holdIncrementalSpiderEventM :: (HasSpiderTimeline x, R.Patch p) => R.PatchTarget p -> R.Event (SpiderTimeline x) p -> EventM x (R.Incremental (SpiderTimeline x) p)

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

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

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

1963

1964

1964instance HasSpiderTimeline x => R.MonadHold (SpiderTimeline x) (SpiderHost x) where

1965instance HasSpiderTimeline x => R.MonadHold (SpiderTimeline x) (SpiderHost x) where