daec2bb · reflex · git.iko.soy

git.iko.soy/reflex

on develop help sign in

Merge pull request #85 from reflex-frp/dan-perf

daec2bbRyan Trinkle10 years ago

reflex.cabal+31

compare with develop

unifiedsplit

@@ -28,6 +28,16 @@ flag use-template-haskell

28 default: True

29 manual: True

31+flag expose-all-unfoldings

32+ description: Build the library with -fexpose-all-unfoldings which can help client code specialize better

33+ default: False

34+ manual: True

35+

36+flag debug-trace-events

37+ description: add instrumentation that outputs the stack trace of the definition of an event whenever it is subscribed to. Warning: It is very slow!

38+ default: False

39+ manual: True

40+

31library

41library

32 hs-source-dirs: src

42 hs-source-dirs: src

33 build-depends:

43 build-depends:

@@ -84,6 +94,10 @@ library

84 else

94 else

85 exposed-modules: Reflex.Pure

95 exposed-modules: Reflex.Pure

97+ if flag(debug-trace-events)

98+ cpp-options: -DDEBUG_TRACE_EVENTS

99+ build-depends: bytestring

100+

87 if flag(use-reflex-optimizer)

101 if flag(use-reflex-optimizer)

88 cpp-options: -DUSE_REFLEX_OPTIMIZER

102 cpp-options: -DUSE_REFLEX_OPTIMIZER

89 build-depends: ghc

103 build-depends: ghc

@@ -103,6 +117,9 @@ library

103 build-depends:

117 build-depends:

104 dependent-sum == 0.4.*

118 dependent-sum == 0.4.*

105

119

120+ if flag(expose-all-unfoldings)

121+ ghc-options: -fexpose-all-unfoldings

122+

106test-suite semantics

123test-suite semantics

107 type: exitcode-stdio-1.0

124 type: exitcode-stdio-1.0

108 main-is: semantics.hs

125 main-is: semantics.hs

@@ -152,6 +169,20 @@ test-suite RequesterT

152 , reflex

169 , reflex

153 , ref-tf

170 , ref-tf

154

171

172+test-suite GC-Semantics

173+ type: exitcode-stdio-1.0

174+ main-is: GC.hs

175+ hs-source-dirs: test

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

177+ buildable: False

178+ build-depends: base

179+ , dependent-sum

180+ , dependent-map

181+ , these

182+ , transformers

183+ , reflex

184+ , ref-tf

185+

155benchmark spider-bench

186benchmark spider-bench

156 type: exitcode-stdio-1.0

187 type: exitcode-stdio-1.0

157 hs-source-dirs: bench

188 hs-source-dirs: bench

src/Reflex/Class.hs+67−9

@@ -97,6 +97,14 @@ module Reflex.Class

97 , appendEvents

98 , onceE

99 , sequenceThese

100+ , fmapMaybeCheap

101+ , fmapCheap

102+ , fforCheap

103+ , fforMaybeCheap

104+ , pushAlwaysCheap

105+ , tagCheap

106+ , mergeWithCheap

107+ , mergeWithCheap'

100#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

108#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

101 , Spider

109 , Spider

102 , SpiderEnv

110 , SpiderEnv

@@ -109,6 +117,7 @@ module Reflex.Class

109 , never

117 , never

110 , constant

118 , constant

111 , push

119 , push

120+ , pushCheap

112 , pull

121 , pull

113 , merge

122 , merge

114 , fan

123 , fan

@@ -225,6 +234,8 @@ class ( MonadHold t (PushM t)

225 -- 'Behavior's and hold 'Event's, and use the results to produce a occurring

234 -- 'Behavior's and hold 'Event's, and use the results to produce a occurring

226 -- (Just) or non-occurring (Nothing) result

235 -- (Just) or non-occurring (Nothing) result

227 push :: (a -> PushM t (Maybe b)) -> Event t a -> Event t b

236 push :: (a -> PushM t (Maybe b)) -> Event t a -> Event t b

237+ -- | Like 'push' but intended for functions that the implementation can consider cheap to compute for performance considerations. WARNING: The function passed to 'pushCheap' may be run multiple times without any caching.

238+ pushCheap :: (a -> PushM t (Maybe b)) -> Event t a -> Event t b

228 -- | Create a 'Behavior' by reading from other 'Behavior's; the result will be

239 -- | Create a 'Behavior' by reading from other 'Behavior's; the result will be

229 -- recomputed whenever any of the read 'Behavior's changes

240 -- recomputed whenever any of the read 'Behavior's changes

230 pull :: PullM t a -> Behavior t a

241 pull :: PullM t a -> Behavior t a

@@ -283,6 +294,7 @@ instance t ~ SpiderTimeline Global => Reflex t where

283never :: Reflex t => Event t a

294never :: Reflex t => Event t a

284constant :: Reflex t => a -> Behavior t a

295constant :: Reflex t => a -> Behavior t a

285push :: Reflex t => (a -> PushM t (Maybe b)) -> Event t a -> Event t b

296push :: Reflex t => (a -> PushM t (Maybe b)) -> Event t a -> Event t b

297+pushCheap :: Reflex t => (a -> PushM t (Maybe b)) -> Event t a -> Event t b

286pull :: Reflex t => PullM t a -> Behavior t a

298pull :: Reflex t => PullM t a -> Behavior t a

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

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

288fan :: (Reflex t, GCompare k) => Event t (DMap k Identity) -> EventSelector t k

300fan :: (Reflex t, GCompare k) => Event t (DMap k Identity) -> EventSelector t k

@@ -305,6 +317,8 @@ never = SpiderEvent S.eventNever

305constant = SpiderBehavior . S.behaviorConst

317constant = SpiderBehavior . S.behaviorConst

306{-# INLINE push #-}

318{-# INLINE push #-}

307push f = SpiderEvent . S.push (coerce f) . unSpiderEvent

319push f = SpiderEvent . S.push (coerce f) . unSpiderEvent

320+{-# INLINE pushCheap #-}

321+pushCheap f = SpiderEvent . S.pushCheap (coerce f) . unSpiderEvent

308{-# INLINE pull #-}

322{-# INLINE pull #-}

309pull = SpiderBehavior . S.pull . coerce

323pull = SpiderBehavior . S.pull . coerce

310{-# INLINE merge #-}

324{-# INLINE merge #-}

@@ -318,7 +332,7 @@ coincidence = SpiderEvent . S.coincidence . (coerce :: S.Event x (Event (SpiderT

318{-# INLINE current #-}

332{-# INLINE current #-}

319current = SpiderBehavior . S.dynamicCurrent . unSpiderDynamic

333current = SpiderBehavior . S.dynamicCurrent . unSpiderDynamic

320{-# INLINE updated #-}

334{-# INLINE updated #-}

321−updated = SpiderEvent . fmap runIdentity . dynamicUpdated . unSpiderDynamic

335+updated = coerceEvent . SpiderEvent . dynamicUpdated . unSpiderDynamic

322{-# INLINE unsafeBuildDynamic #-}

336{-# INLINE unsafeBuildDynamic #-}

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

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

324{-# INLINE unsafeBuildIncremental #-}

338{-# INLINE unsafeBuildIncremental #-}

@@ -638,11 +652,15 @@ instance (Semigroup a, Reflex t) => Monoid (Event t a) where

638-- with the given function.

652-- with the given function.

639{-# INLINE mergeWith #-}

653{-# INLINE mergeWith #-}

640mergeWith :: Reflex t => (a -> a -> a) -> [Event t a] -> Event t a

654mergeWith :: Reflex t => (a -> a -> a) -> [Event t a] -> Event t a

655+mergeWith = mergeWith' id

656+

657+{-# INLINE mergeWith' #-}

658+mergeWith' :: Reflex t => (a -> b) -> (b -> b -> b) -> [Event t a] -> Event t b

641−mergeWith f es = fmap (Prelude.foldl1 f . map (\(Const2 _ :=> Identity v) -> v) . DMap.toList)

659+mergeWith' f g es = fmap (Prelude.foldl1 g . map (\(Const2 _ :=> Identity v) -> f v) . DMap.toList)

642− . merge

660+ . merge

643− . DMap.fromDistinctAscList

661+ . DMap.fromDistinctAscList

644− . map (\(k, v) -> Const2 k :=> v)

662+ . map (\(k, v) -> Const2 k :=> v)

645− $ zip [0 :: Int ..] es

663+ $ zip [0 :: Int ..] es

646

664

647-- | Create a new 'Event' that occurs if at least one of the 'Event's in the

665-- | Create a new 'Event' that occurs if at least one of the 'Event's in the

648-- list occurs. If multiple occur at the same time the value is the value of the

666-- list occurs. If multiple occur at the same time the value is the value of the

@@ -656,7 +674,7 @@ leftmost = mergeWith const

656-- time.

674-- time.

657mergeList :: Reflex t => [Event t a] -> Event t (NonEmpty a)

675mergeList :: Reflex t => [Event t a] -> Event t (NonEmpty a)

658mergeList [] = never

676mergeList [] = never

659−mergeList es = mergeWith (<>) $ map (fmap (:|[])) es

677+mergeList es = mergeWithCheap' (:|[]) (<>) es

660

678

661-- | Create a new 'Event' combining the map of 'Event's into an 'Event' that

679-- | Create a new 'Event' combining the map of 'Event's into an 'Event' that

662-- occurs if at least one of them occurs and has a map of values of all 'Event's

680-- occurs if at least one of them occurs and has a map of values of all 'Event's

@@ -896,6 +914,46 @@ instance (Reflex t, MonadAdjust t m) => MonadAdjust t (ReaderT r m) where

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

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

897 lift $ sequenceDMapWithAdjust loweredDm0 loweredDm'

915 lift $ sequenceDMapWithAdjust loweredDm0 loweredDm'

898

916

917+------------------

918+-- Cheap Functions

919+------------------

920+

921+{-# INLINE pushAlwaysCheap #-}

922+pushAlwaysCheap :: Reflex t => (a -> PushM t b) -> Event t a -> Event t b

923+pushAlwaysCheap f = pushCheap (fmap Just . f)

924+

925+{-# INLINE fmapMaybeCheap #-}

926+fmapMaybeCheap :: Reflex t => (a -> Maybe b) -> Event t a -> Event t b

927+fmapMaybeCheap f = pushCheap $ return . f

928+

929+{-# INLINE fforMaybeCheap #-}

930+fforMaybeCheap :: Reflex t => Event t a -> (a -> Maybe b) -> Event t b

931+fforMaybeCheap = flip fmapMaybeCheap

932+

933+{-# INLINE fforCheap #-}

934+fforCheap :: Reflex t => Event t a -> (a -> b) -> Event t b

935+fforCheap = flip fmapCheap

936+

937+{-# INLINE fmapCheap #-}

938+fmapCheap :: Reflex t => (a -> b) -> Event t a -> Event t b

939+fmapCheap f = pushCheap $ return . Just . f

940+

941+{-# INLINE tagCheap #-}

942+tagCheap :: Reflex t => Behavior t b -> Event t a -> Event t b

943+tagCheap b = pushAlwaysCheap $ \_ -> sample b

944+

945+{-# INLINE mergeWithCheap #-}

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

947+mergeWithCheap = mergeWithCheap' id

948+

949+{-# INLINE mergeWithCheap' #-}

950+mergeWithCheap' :: Reflex t => (a -> b) -> (b -> b -> b) -> [Event t a] -> Event t b

951+mergeWithCheap' f g es = fmapCheap (Prelude.foldl1 g . map (\(Const2 _ :=> Identity v) -> f v) . DMap.toList)

952+ . merge

953+ . DMap.fromDistinctAscList

954+ . map (\(k, v) -> Const2 k :=> v)

955+ $ zip [0 :: Int ..] es

956+

899--------------------------------------------------------------------------------

957--------------------------------------------------------------------------------

900-- Deprecated functions

958-- Deprecated functions

901--------------------------------------------------------------------------------

959--------------------------------------------------------------------------------

@@ -918,6 +976,6 @@ onceE = headE

918#endif

976#endif

919sequenceThese :: Monad m => These (m a) (m b) -> m (These a b)

977sequenceThese :: Monad m => These (m a) (m b) -> m (These a b)

920sequenceThese t = case t of

978sequenceThese t = case t of

921− This ma -> liftM This ma

979+ This ma -> fmap This ma

922 These ma mb -> liftM2 These ma mb

980 These ma mb -> liftM2 These ma mb

923− That mb -> liftM That mb

981+ That mb -> fmap That mb

src/Reflex/Dynamic.hs+1−1

@@ -522,7 +522,7 @@ apDyn :: forall t m a b. (Reflex t, Monad m)

522 => m (Dynamic t (a -> b))

523 -> Dynamic t a

524 -> m (Dynamic t b)

525−apDyn m a = liftM (<*> a) m

525+apDyn m a = fmap (<*> a) m

526

527--TODO: The pattern of using hold (sample b0) can be reused in various places as a safe way of building certain kinds of Dynamics; see if we can factor this out

528-- | This function no longer needs to be monadic, so it has been replaced by

src/Reflex/EventWriter.hs+17−7

@@ -26,6 +26,7 @@ import Reflex.Class

26import Reflex.Host.Class

27import Reflex.PerformEvent.Class

28import Reflex.PostBuild.Class

29+import Reflex.Requester.Class

29import Reflex.TriggerEvent.Class

30import Reflex.TriggerEvent.Class

31import Control.Monad.Exception

32import Control.Monad.Exception

@@ -53,7 +54,7 @@ class (Monad m, Monoid w) => EventWriter t w m | m -> t w where

54-- | A basic implementation of 'EventWriter'.

55-- | A basic implementation of 'EventWriter'.

55newtype EventWriterT t w m a = EventWriterT { unEventWriterT :: StateT (Seq (Event t w)) m a }

56newtype EventWriterT t w m a = EventWriterT { unEventWriterT :: StateT (Seq (Event t w)) m a }

56− deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException)

57+ deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)

58-- | Run a 'EventWriterT' action.

59-- | Run a 'EventWriterT' action.

59runEventWriterT :: (Reflex t, Monad m, Semigroup w) => EventWriterT t w m a -> m (a, Event t w)

60runEventWriterT :: (Reflex t, Monad m, Semigroup w) => EventWriterT t w m a -> m (a, Event t w)

@@ -79,6 +80,12 @@ instance (Reflex t, MonadAdjust t m, MonadHold t m, Monoid w, Semigroup w) => Mo

79 runWithReplace = runWithReplaceEventWriterTWith $ \dm0 dm' -> lift $ runWithReplace dm0 dm'

80 runWithReplace = runWithReplaceEventWriterTWith $ \dm0 dm' -> lift $ runWithReplace dm0 dm'

80 sequenceDMapWithAdjust = sequenceDMapWithAdjustEventWriterTWith $ \dm0 dm' -> lift $ sequenceDMapWithAdjust dm0 dm'

81 sequenceDMapWithAdjust = sequenceDMapWithAdjustEventWriterTWith $ \dm0 dm' -> lift $ sequenceDMapWithAdjust dm0 dm'

83+instance Requester t m => Requester t (EventWriterT t w m) where

84+ type Request (EventWriterT t w m) = Request m

85+ type Response (EventWriterT t w m) = Response m

86+ withRequesting f = EventWriterT $ withRequesting $ unEventWriterT . f

87+

88+

82-- | Given a function like 'runWithReplace' for the underlying monad, implement

89-- | Given a function like 'runWithReplace' for the underlying monad, implement

83-- 'runWithReplace' for 'EventWriterT'. This is necessary when the underlying

90-- 'runWithReplace' for 'EventWriterT'. This is necessary when the underlying

84-- monad doesn't have a 'MonadAdjust' instance or to override the default

91-- monad doesn't have a 'MonadAdjust' instance or to override the default

@@ -91,12 +98,12 @@ runWithReplaceEventWriterTWith :: forall m t w a b. (Reflex t, MonadHold t m, Mo

91runWithReplaceEventWriterTWith f a0 a' = do

98runWithReplaceEventWriterTWith f a0 a' = do

92 let g :: EventWriterT t w m c -> m (c, Seq (Event t w))

99 let g :: EventWriterT t w m c -> m (c, Seq (Event t w))

93 g (EventWriterT r) = runStateT r mempty

100 g (EventWriterT r) = runStateT r mempty

94− (result0, result') <- f (g a0) $ g <$> a'

101+ (result0, result') <- f (g a0) $ fmap g a'

95− request <- holdDyn (fmap (mconcat . NonEmpty.toList) $ mergeList $ toList $ snd result0) $ fmap (mconcat . NonEmpty.toList) . mergeList . toList . snd <$> result'

102+ request <- holdDyn (fmapCheap (mconcat . NonEmpty.toList) $ mergeList $ toList $ snd result0) $ fmapCheap (fmapCheap (mconcat . NonEmpty.toList) . mergeList . toList . snd) result'

96 -- We add these two separately to take advantage of the free merge being done later. The coincidence case must come first so that it has precedence if both fire simultaneously. (Really, we should probably block the 'switch' whenever 'updated' fires, but switchPromptlyDyn has the same issue.)

103 -- We add these two separately to take advantage of the free merge being done later. The coincidence case must come first so that it has precedence if both fire simultaneously. (Really, we should probably block the 'switch' whenever 'updated' fires, but switchPromptlyDyn has the same issue.)

97 EventWriterT $ modify $ flip (|>) $ coincidence $ updated request

104 EventWriterT $ modify $ flip (|>) $ coincidence $ updated request

98 EventWriterT $ modify $ flip (|>) $ switch $ current request

105 EventWriterT $ modify $ flip (|>) $ switch $ current request

99− return (fst result0, fst <$> result')

106+ return (fst result0, fmapCheap fst result')

100

107

101-- | Like 'runWithReplaceEventWriterTWith', but for 'sequenceDMapWithAdjust'.

108-- | Like 'runWithReplaceEventWriterTWith', but for 'sequenceDMapWithAdjust'.

102sequenceDMapWithAdjustEventWriterTWith :: (GCompare k, Reflex t, MonadHold t m, Monoid w, Semigroup w)

109sequenceDMapWithAdjustEventWriterTWith :: (GCompare k, Reflex t, MonadHold t m, Monoid w, Semigroup w)

@@ -113,16 +120,16 @@ sequenceDMapWithAdjustEventWriterTWith f (dm0 :: DMap k (EventWriterT t w m)) dm

113 inputTransform = DMapTransform WrapArg (\(EventWriterT v) -> swap <$> runStateT v mempty)

120 inputTransform = DMapTransform WrapArg (\(EventWriterT v) -> swap <$> runStateT v mempty)

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

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

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

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

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

123+ result' = fforCheap children' $ \(PatchDMap p) -> PatchDMap $

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

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

118 requests0 :: DMap (Const2 (Some k) w) (Event t)

125 requests0 :: DMap (Const2 (Some k) w) (Event t)

119 requests0 = mapKeyValuePairsMonotonic (\(WrapArg k :=> Identity (r, _)) -> Const2 (Some.This k) :=> mconcat (toList r)) children0

126 requests0 = mapKeyValuePairsMonotonic (\(WrapArg k :=> Identity (r, _)) -> Const2 (Some.This k) :=> mconcat (toList r)) children0

120 requests' :: Event t (PatchDMap (Const2 (Some k) w) (Event t))

127 requests' :: Event t (PatchDMap (Const2 (Some k) w) (Event t))

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

128+ requests' = fforCheap children' $ \(PatchDMap p) -> PatchDMap $

122 mapKeyValuePairsMonotonic (\(WrapArg k :=> ComposeMaybe mv) -> Const2 (Some.This k) :=> ComposeMaybe (fmap (mconcat . toList . fst . runIdentity) mv)) p

129 mapKeyValuePairsMonotonic (\(WrapArg k :=> ComposeMaybe mv) -> Const2 (Some.This k) :=> ComposeMaybe (fmap (mconcat . toList . fst . runIdentity) mv)) p

123 childRequestMap <- holdIncremental requests0 requests'

130 childRequestMap <- holdIncremental requests0 requests'

124 -- We add these two separately to take advantage of the free merge being done later. The coincidence case must come first so that it has precedence if both fire simultaneously. (Really, we should probably block the 'switch' whenever 'updated' fires, but switchPromptlyDyn has the same issue.)

131 -- We add these two separately to take advantage of the free merge being done later. The coincidence case must come first so that it has precedence if both fire simultaneously. (Really, we should probably block the 'switch' whenever 'updated' fires, but switchPromptlyDyn has the same issue.)

125− EventWriterT $ modify $ flip (|>) $ coincidence $ ffor requests' $ \(PatchDMap p) -> mconcat $ toList $ catMaybes $ ffor (DMap.toList p) $ \(Const2 _ :=> ComposeMaybe me) -> me

132+ EventWriterT $ modify $ flip (|>) $ coincidence $ fforCheap requests' $ \(PatchDMap p) -> mconcat $ toList $ catMaybes $ ffor (DMap.toList p) $ \(Const2 _ :=> ComposeMaybe me) -> me

126 EventWriterT $ modify $ flip (|>) $ ffor (mergeIncremental childRequestMap) $ \m ->

133 EventWriterT $ modify $ flip (|>) $ ffor (mergeIncremental childRequestMap) $ \m ->

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

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

128 return (result0, result')

135 return (result0, result')

@@ -151,6 +158,9 @@ instance MonadRef m => MonadRef (EventWriterT t w m) where

151 readRef = lift . readRef

158 readRef = lift . readRef

152 writeRef r = lift . writeRef r

159 writeRef r = lift . writeRef r

153

160

161+instance MonadAtomicRef m => MonadAtomicRef (EventWriterT t w m) where

162+ atomicModifyRef r = lift . atomicModifyRef r

163+

154instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (EventWriterT t w m) where

164instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (EventWriterT t w m) where

155 newEventWithTrigger = lift . newEventWithTrigger

165 newEventWithTrigger = lift . newEventWithTrigger

156 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f

166 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f

src/Reflex/Patch.hs+24−14

@@ -5,11 +5,15 @@

5{-# LANGUAGE LambdaCase #-}

6{-# LANGUAGE StandaloneDeriving #-}

7{-# LANGUAGE TypeFamilies #-}

8+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

8module Reflex.Patch

9module Reflex.Patch

9 ( Patch (..)

10 ( Patch (..)

10 , PatchDMap (..)

11 , PatchDMap (..)

11 , ComposeMaybe (..)

12 , ComposeMaybe (..)

12 , PatchMap (..)

13 , PatchMap (..)

14+ , Group (..)

15+ , Additive

16+ , AdditivePatch (..)

13 ) where

17 ) where

15import Control.Monad.Identity

19import Control.Monad.Identity

@@ -42,21 +46,9 @@ instance Patch (Identity a) where

42-- deleted.

46-- deleted.

43newtype PatchDMap k v = PatchDMap (DMap k (ComposeMaybe v))

47newtype PatchDMap k v = PatchDMap (DMap k (ComposeMaybe v))

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

49+deriving instance GCompare k => Semigroup (PatchDMap k v)

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

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

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

49− stimes = stimesIdempotentMonoid

50−#else

51− times1p n x = case compare n 0 of

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

53− EQ -> mempty

54− GT -> x

55−#endif

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

51+deriving instance GCompare k => Monoid (PatchDMap k v)

58− mempty = PatchDMap mempty

59− mappend = (<>)

61instance GCompare k => Patch (PatchDMap k v) where

53instance GCompare k => Patch (PatchDMap k v) where

62 type PatchTarget (PatchDMap k v) = DMap k v

54 type PatchTarget (PatchDMap k v) = DMap k v

@@ -95,3 +87,21 @@ instance Ord k => Semigroup (PatchMap k v) where

95instance Ord k => Monoid (PatchMap k v) where

87instance Ord k => Monoid (PatchMap k v) where

96 mempty = PatchMap mempty

88 mempty = PatchMap mempty

97 mappend = (<>)

89 mappend = (<>)

90+

91+---- Patches based on commutative groups

92+

93+-- | A 'Group' is a 'Monoid' where every element has an inverse.

94+class (Semigroup q, Monoid q) => Group q where

95+ negateG :: q -> q

96+ (~~) :: q -> q -> q

97+ r ~~ s = r <> negateG s

98+

99+-- | An 'Additive' 'Semigroup' is one where the multiplication is commutative

100+class Semigroup q => Additive q where

101+

102+-- | The elements of an 'Additive' 'Semigroup' can be considered as patches of their own type.

103+newtype AdditivePatch p = AdditivePatch { unAdditivePatch :: p }

104+

105+instance Additive p => Patch (AdditivePatch p) where

106+ type PatchTarget (AdditivePatch p) = p

107+ apply (AdditivePatch p) q = Just $ p <> q

src/Reflex/PerformEvent/Base.hs+4−4

@@ -74,15 +74,15 @@ instance (ReflexHost t, PrimMonad (HostFrame t)) => MonadAdjust t (PerformEventT

74 where f :: HostFrame t a -> Event t (HostFrame t b) -> RequesterT t (HostFrame t) Identity (HostFrame t) (a, Event t b)

75 f a0 a' = do

76 result0 <- lift a0

77− result' <- requesting a'

77+ result' <- requestingIdentity a'

78− return (result0, fmap runIdentity result')

78+ return (result0, result')

79 sequenceDMapWithAdjust (outerDm0 :: DMap k (PerformEventT t m)) outerDm' = PerformEventT $ sequenceDMapWithAdjustRequesterTWith f (coerce outerDm0) (coerceEvent outerDm')

80 where f :: DMap k' (HostFrame t) -> Event t (PatchDMap k' (HostFrame t)) -> RequesterT t (HostFrame t) Identity (HostFrame t) (DMap k' Identity, Event t (PatchDMap k' Identity))

81 f dm0 dm' = do

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

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

83+ result' <- requestingIdentity $ ffor dm' $ \(PatchDMap p) -> do

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

85− return (result0, fmap runIdentity result')

85+ return (result0, result')

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

88 {-# INLINABLE newEventWithTrigger #-}

src/Reflex/PostBuild/Base.hs+2−2

@@ -106,14 +106,14 @@ instance (Reflex t, MonadHold t m, MonadFix m, MonadAdjust t m, PerformEvent t m

106 postBuild <- getPostBuild

107 lift $ do

108 rec result@(_, result') <- runWithReplace (runPostBuildT a0 postBuild) $ fmap (\v -> runPostBuildT v =<< headE voidResult') a'

109− let voidResult' = void result'

109+ let voidResult' = fmapCheap (\_ -> ()) result'

110 return result

111 sequenceDMapWithAdjust dm0 dm' = do

112 postBuild <- getPostBuild

113 let loweredDm0 = DMap.map (`runPostBuildT` postBuild) dm0

114 lift $ do

115 rec (result0, result') <- sequenceDMapWithAdjust loweredDm0 loweredDm'

116− let voidResult' = void result'

116+ let voidResult' = fmapCheap (\_ -> ()) result'

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

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

119 return (result0, result')

src/Reflex/Pure.hs+3

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

66 push :: (a -> PushM (Pure t) (Maybe b)) -> Event (Pure t) a -> Event (Pure t) b

67 push f e = Event $ memo $ \t -> unEvent e t >>= \o -> f o t

69+ pushCheap :: (a -> PushM (Pure t) (Maybe b)) -> Event (Pure t) a -> Event (Pure t) b

70+ pushCheap = push

71+

69 pull :: PullM (Pure t) a -> Behavior (Pure t) a

72 pull :: PullM (Pure t) a -> Behavior (Pure t) a

70 pull = Behavior . memo

73 pull = Behavior . memo

src/Reflex/Requester/Base.hs+2−2

@@ -70,7 +70,7 @@ instance (Reflex t, PrimMonad m) => Requester t (RequesterT t request response m

70 t <- lift newTag

71 s <- RequesterT ask

72 (req, result) <- a $ select s $ WrapArg t

73− RequesterT $ tellEvent $ DMap.singleton t <$> req

73+ RequesterT $ tellEvent $ fmapCheap (DMap.singleton t) req

74 return result

76instance MonadTrans (RequesterT t request response) where

@@ -111,7 +111,7 @@ runWithReplaceRequesterTWith f a0 a' =

111 -> EventWriterT t (DMap (Tag (PrimState m)) request) (ReaderT (EventSelector t (WrapArg response (Tag (PrimState m)))) m) (a', Event t b')

112 f' x y = do

113 r <- EventWriterT $ ask

114− unRequesterT (f (runReaderT x r) (fmap (`runReaderT` r) y))

114+ unRequesterT (f (runReaderT x r) (fmapCheap (`runReaderT` r) y))

115 in RequesterT $ runWithReplaceEventWriterTWith f' (coerce a0) (coerceEvent a')

116

117sequenceDMapWithAdjustRequesterTWith :: (GCompare k, Reflex t, MonadHold t m)

src/Reflex/Requester/Class.hs+1−1

@@ -84,4 +84,4 @@ requesting_ req = withRequesting $ \_ -> return (req, ())

84-- | Emit a request whenever the given 'Event' fires, and unwrap the responses

85-- before returning them. @Response m@ must be 'Identity'.

86requestingIdentity :: (Requester t m, Response m ~ Identity) => Event t (Request m a) -> m (Event t a)

87−requestingIdentity = fmap (fmap runIdentity) . requesting

87+requestingIdentity = fmap coerceEvent . requesting

src/Reflex/Spider/Internal.hs+85−55

@@ -26,7 +26,7 @@

26#endif

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

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

29−module Reflex.Spider.Internal where

29+module Reflex.Spider.Internal (module Reflex.Spider.Internal) where

31import Control.Applicative

32import Control.Concurrent

@@ -89,6 +89,20 @@ import Reflex.Patch

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

90import Prelude hiding (any, concat, mapM, mapM_, sequence)

92+#ifdef DEBUG_TRACE_EVENTS

93+import System.IO (stderr)

94+import qualified Data.ByteString.Char8 as BS8

95+#endif

96+

97+#ifdef DEBUG_TRACE_EVENTS

98+

99+withStackOneLine :: (BS8.ByteString -> a) -> a

100+withStackOneLine expr = unsafePerformIO $ do

101+ stack <- currentCallStack

102+ return (expr (BS8.pack (unwords (reverse stack))))

103+

104+#endif

105+

92debugPropagate :: Bool

106debugPropagate :: Bool

107

94debugInvalidateHeight :: Bool

108debugInvalidateHeight :: Bool

@@ -190,6 +204,20 @@ unsafeNodeId a = unsafePerformIO $ do

190 newNodeId

204 newNodeId

191#endif

205#endif

192

206

207+--------------------------------------------------------------------------------

208+-- EventSubscription

209+--------------------------------------------------------------------------------

210+

211+--NB: Once you subscribe to an Event, you must always hold on the the WHOLE EventSubscription you get back

212+-- If you do not retain the subscription, you may be prematurely unsubscribed from the parent event.

213+data EventSubscription x = EventSubscription

214+ { _eventSubscription_unsubscribe :: !(IO ())

215+ , _eventSubscription_subscribed :: {-# UNPACK #-} !(EventSubscribed x)

216+ }

217+

218+unsubscribe :: EventSubscription x -> IO ()

219+unsubscribe (EventSubscription u _) = u

220+

193--------------------------------------------------------------------------------

221--------------------------------------------------------------------------------

194-- Event

222-- Event

195--------------------------------------------------------------------------------

223--------------------------------------------------------------------------------

@@ -236,44 +264,53 @@ data CacheSubscribed x a

236--subscriber joins

264--subscriber joins

237{-# NOINLINE cacheEvent #-}

265{-# NOINLINE cacheEvent #-}

238cacheEvent :: HasSpiderTimeline x => Event x a -> Event x a

266cacheEvent :: HasSpiderTimeline x => Event x a -> Event x a

267+cacheEvent e =

268+#ifdef DEBUG_TRACE_EVENTS

269+ withStackOneLine $ \callSite -> Event $

270+#else

271+ Event $

272+#endif

273+ let !mSubscribedRef = unsafeNewIORef e Nothing

239−cacheEvent e = Event $ \sub -> {-# SCC "cacheEvent" #-} do

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

240− let !mSubscribedRef = unsafeNewIORef e Nothing

275+#ifdef DEBUG_TRACE_EVENTS

276+ unless (BS8.null callSite) $ liftIO $ BS8.hPutStrLn stderr callSite

277+#endif

241− mSubscribed <- liftIO $ readIORef mSubscribedRef

278+ mSubscribed <- liftIO $ readIORef mSubscribedRef

242− case mSubscribed of

279+ case mSubscribed of

243− Just subscribed -> liftIO $ do

280+ Just subscribed -> liftIO $ do

244− ticket <- WeakBag.insert sub (_cacheSubscribed_subscribers subscribed) (_cacheSubscribed_weakSelf subscribed) cleanupCacheSubscribed

281+ ticket <- WeakBag.insert sub (_cacheSubscribed_subscribers subscribed) (_cacheSubscribed_weakSelf subscribed) cleanupCacheSubscribed

245− occ <- readIORef $ _cacheSubscribed_occurrence subscribed

282+ occ <- readIORef $ _cacheSubscribed_occurrence subscribed

246− let es = EventSubscribed

283+ let es = EventSubscribed

247− { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ _cacheSubscribed_parent subscribed

284+ { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ _cacheSubscribed_parent subscribed

248− , eventSubscribedRetained = toAny subscribed

285+ , eventSubscribedRetained = toAny subscribed

249− }

286+ }

250− return (EventSubscription (WeakBag.remove ticket >> touch ticket) es, occ)

287+ return (EventSubscription (WeakBag.remove ticket >> touch ticket) es, occ)

251− Nothing -> do

288+ Nothing -> do

252− weakSelf <- liftIO $ newIORef $ error "cacheEvent: weakSelf not yet intialized"

289+ weakSelf <- liftIO $ newIORef $ error "cacheEvent: weakSelf not yet intialized"

253− (subscribers, ticket) <- liftIO $ WeakBag.singleton sub weakSelf cleanupCacheSubscribed

290+ (subscribers, ticket) <- liftIO $ WeakBag.singleton sub weakSelf cleanupCacheSubscribed

254− occRef <- liftIO $ newIORef undefined

291+ occRef <- liftIO $ newIORef undefined

255− (parentSub, occ) <- subscribeAndRead e $ Subscriber

292+ (parentSub, occ) <- subscribeAndRead e $ Subscriber

256− { subscriberPropagate = \a -> do

293+ { subscriberPropagate = \a -> do

257− liftIO $ writeIORef occRef $ Just a

294+ liftIO $ writeIORef occRef $ Just a

258− scheduleClear occRef

295+ scheduleClear occRef

259− propagate a subscribers

296+ propagate a subscribers

260− , subscriberInvalidateHeight = \old -> do

297+ , subscriberInvalidateHeight = \old -> do

261− WeakBag.traverse subscribers $ invalidateSubscriberHeight old

298+ WeakBag.traverse subscribers $ invalidateSubscriberHeight old

262− , subscriberRecalculateHeight = \new -> do

299+ , subscriberRecalculateHeight = \new -> do

263− WeakBag.traverse subscribers $ recalculateSubscriberHeight new

300+ WeakBag.traverse subscribers $ recalculateSubscriberHeight new

264− }

301+ }

265− liftIO $ writeIORef occRef occ

302+ liftIO $ writeIORef occRef occ

266− when (isJust occ) $ scheduleClear occRef

303+ when (isJust occ) $ scheduleClear occRef

267− let !subscribed = CacheSubscribed

304+ let !subscribed = CacheSubscribed

268− { _cacheSubscribed_subscribers = subscribers

305+ { _cacheSubscribed_subscribers = subscribers

269− , _cacheSubscribed_weakSelf = weakSelf

306+ , _cacheSubscribed_weakSelf = weakSelf

270− , _cacheSubscribed_parent = parentSub

307+ , _cacheSubscribed_parent = parentSub

271− , _cacheSubscribed_cached = mSubscribedRef

308+ , _cacheSubscribed_cached = mSubscribedRef

272− , _cacheSubscribed_occurrence = occRef

309+ , _cacheSubscribed_occurrence = occRef

273− }

310+ }

274− liftIO $ writeIORef mSubscribedRef $ Just subscribed

311+ liftIO $ writeIORef mSubscribedRef $ Just subscribed

275− liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "PushSubscribed"

312+ liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "PushSubscribed"

276− return (EventSubscription (WeakBag.remove ticket >> touch ticket) (EventSubscribed (eventSubscribedHeightRef $ _eventSubscription_subscribed parentSub) (toAny subscribed)), occ)

313+ return (EventSubscription (WeakBag.remove ticket >> touch ticket) (EventSubscribed (eventSubscribedHeightRef $ _eventSubscription_subscribed parentSub) (toAny subscribed)), occ)

277

314

278cleanupCacheSubscribed :: CacheSubscribed x a -> IO ()

315cleanupCacheSubscribed :: CacheSubscribed x a -> IO ()

279cleanupCacheSubscribed self = do

316cleanupCacheSubscribed self = do

@@ -558,18 +595,6 @@ walkInvalidHeightParents s0 = do

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

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

559subscribeHoldEvent = subscribeAndRead . holdEvent

596subscribeHoldEvent = subscribeAndRead . holdEvent

560

597

561−--------------------------------------------------------------------------------

562−-- EventSubscription

563−--------------------------------------------------------------------------------

564−

565−data EventSubscription x = EventSubscription

566− { _eventSubscription_unsubscribe :: !(IO ())

567− , _eventSubscription_subscribed :: {-# UNPACK #-} !(EventSubscribed x)

568− }

569−

570−unsubscribe :: EventSubscription x -> IO ()

571−unsubscribe (EventSubscription u _) = u

572−

573--------------------------------------------------------------------------------

598--------------------------------------------------------------------------------

574-- Behavior

599-- Behavior

575--------------------------------------------------------------------------------

600--------------------------------------------------------------------------------

@@ -1344,7 +1369,7 @@ getRootSubscribed k r sub = do

1344{-# ANN cleanupRootSubscribed "HLint: ignore Redundant bracket" #-}

1369{-# ANN cleanupRootSubscribed "HLint: ignore Redundant bracket" #-}

1345#endif

1370#endif

1346cleanupRootSubscribed :: RootSubscribed x a -> IO ()

1371cleanupRootSubscribed :: RootSubscribed x a -> IO ()

1347−cleanupRootSubscribed self@(RootSubscribed { rootSubscribedKey = k, rootSubscribedCachedSubscribed = cached }) = do

1372+cleanupRootSubscribed self@RootSubscribed { rootSubscribedKey = k, rootSubscribedCachedSubscribed = cached } = do

1348 rootSubscribedUninit self

1373 rootSubscribedUninit self

1349 modifyIORef' cached $ DMap.delete k

1374 modifyIORef' cached $ DMap.delete k

1350

1375

@@ -1641,9 +1666,12 @@ mergeCheap d = Event $ \sub -> do

1641 , subscriberInvalidateHeight = \_ -> return ()

1666 , subscriberInvalidateHeight = \_ -> return ()

1642 , subscriberRecalculateHeight = \_ -> return ()

1667 , subscriberRecalculateHeight = \_ -> return ()

1643 }

1668 }

1644− (EventSubscription _ changeSubd, change) <- subscribeAndRead (dynamicUpdated d) s

1669+ (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) s

1645 forM_ change $ \c -> defer $ SomeMergeUpdate (updateMe c) invalidateMyHeight revalidateMyHeight

1670 forM_ change $ \c -> defer $ SomeMergeUpdate (updateMe c) invalidateMyHeight revalidateMyHeight

1671+ -- We explicitly hold on to the unsubscribe function from subscribing to the update event.

1672+ -- If we don't do this, there are certain cases where mergeCheap will fail to properly retain

1673+ -- its subscription.

1646− liftIO $ writeIORef changeSubdRef (s, changeSubd)

1674+ liftIO $ writeIORef changeSubdRef (s, changeSubscription)

1647 let unsubscribeAll = do

1675 let unsubscribeAll = do

1648 parents <- readIORef parentsRef

1676 parents <- readIORef parentsRef

1649 forM_ (DMap.toList parents) $ \(_ :=> MergeSubscribedParent s) -> unsubscribe s

1677 forM_ (DMap.toList parents) $ \(_ :=> MergeSubscribedParent s) -> unsubscribe s

@@ -1922,6 +1950,8 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where

1922 constant = SpiderBehavior . behaviorConst

1950 constant = SpiderBehavior . behaviorConst

1923 {-# INLINE push #-}

1951 {-# INLINE push #-}

1924 push f = SpiderEvent . push (coerce f) . unSpiderEvent

1952 push f = SpiderEvent . push (coerce f) . unSpiderEvent

1953+ {-# INLINE pushCheap #-}

1954+ pushCheap f = SpiderEvent . pushCheap (coerce f) . unSpiderEvent

1925 {-# INLINABLE pull #-}

1955 {-# INLINABLE pull #-}

1926 pull = SpiderBehavior . pull . coerce

1956 pull = SpiderBehavior . pull . coerce

1927 {-# INLINABLE merge #-}

1957 {-# INLINABLE merge #-}

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

1935 {-# INLINABLE current #-}

1965 {-# INLINABLE current #-}

1936 current = SpiderBehavior . dynamicCurrent . unSpiderDynamic

1966 current = SpiderBehavior . dynamicCurrent . unSpiderDynamic

1937 {-# INLINABLE updated #-}

1967 {-# INLINABLE updated #-}

1938− updated = SpiderEvent . fmap runIdentity . dynamicUpdated . unSpiderDynamic

1968+ updated = coerce $ SpiderEvent . dynamicUpdated . unSpiderDynamic

1939 {-# INLINABLE unsafeBuildDynamic #-}

1969 {-# INLINABLE unsafeBuildDynamic #-}

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

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

1941 {-# INLINABLE unsafeBuildIncremental #-}

1971 {-# INLINABLE unsafeBuildIncremental #-}

test/EventWriterT.hs+1−1

@@ -14,7 +14,7 @@ import Reflex.EventWriter

14import Reflex.Host.Class

15import Reflex.PerformEvent.Base

17−import System.Exit (exitFailure, exitSuccess)

17+import System.Exit (exitFailure)

19main :: IO ()

20main = do

test/GC.hsnew file+95

@@ -0,0 +1,95 @@

1+{-# LANGUAGE OverloadedStrings, FlexibleContexts, GADTs, TypeFamilies, RankNTypes, ScopedTypeVariables, LambdaCase #-}

2+module Main where

4+import Control.Monad

5+import Control.Monad.IO.Class

6+import Control.Monad.Ref

7+import Data.Align

8+import Data.Dependent.Map (DMap)

9+import qualified Data.Dependent.Map as DMap

10+import Data.Dependent.Sum

11+import Data.Functor.Identity

12+import Data.GADT.Compare

13+import Data.IORef

14+import Data.Semigroup

15+import Data.These

16+

17+import Data.Functor.Misc

18+import Reflex.Patch

19+

20+import qualified Reflex.Spider.Internal as S

21+import qualified Reflex.Host.Class as Host

22+

23+import System.Mem

24+import System.Exit

25+

26+main :: IO ()

27+main = do

28+ ref <- newIORef Nothing

29+ hostPerf ref

30+ readIORef ref >>= maybe exitFailure (putStrLn . ("Result " <>) . show)

31+

32+hostPerf :: IORef (Maybe Int) -> IO ()

33+hostPerf ref = S.runSpiderHost $ do

34+ ---- body

35+ liftIO $ putStrLn "#creating triggers"

36+ (response', responseTrigger) <- Host.newEventWithTriggerRef

37+ (eadd', addTriggerRef) <- Host.newEventWithTriggerRef

38+ let response = S.unSpiderEvent response'

39+ eadd = S.unSpiderEvent eadd'

40+ liftIO $ putStrLn "#creating event graph"

41+ eventToPerform <- Host.runHostFrame $ do

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

43+ <- S.SpiderHostFrame

44+ $ fmap ( S.merge

45+ . S.dynamicHold)

46+ $ S.hold DMap.empty

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

48+ $ (\e -> S.Event $ \sub -> do

49+ (s, o) <- S.subscribeAndRead e $ sub

50+ { S.subscriberPropagate = S.subscriberPropagate sub

51+ }

52+ return (s, o))

53+ $ runIdentity <$> S.select

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

55+ (WrapArg Request)

56+ return $ alignWith (mergeThese (<>))

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

58+ liftIO $ putStrLn "#eadd fired"

59+ return $ PatchDMap $ DMap.singleton (Const2 (1 :: Int)) $ ComposeMaybe $ Just

60+ $ S.pushCheap (return . Just . DMap.singleton Action . (\_ -> liftIO (writeIORef ref (Just 1)))) $ eadd)

61+ (flip S.pushCheap reqMap $ \m -> return $ Just $ mconcat $ (\(Const2 _ :=> Identity reqs) -> reqs) <$> DMap.toList m)

62+ ---- epilogue

63+ eventToPerformHandle <- Host.subscribeEvent (S.SpiderEvent eventToPerform)

64+ liftIO $ putStrLn "#performing GC" >> performMajorGC

65+ liftIO $ putStrLn "#attempting to fire eadd"

66+ mAddTrigger <- readRef addTriggerRef

67+ forM_ mAddTrigger $ \t -> replicateM_ 2 $ do

68+ liftIO $ putStrLn "#firing eadd"

69+ mToPerform <- Host.fireEventsAndRead [t :=> Identity ()] $ sequence =<< Host.readEvent eventToPerformHandle

70+ case mToPerform of

71+ Nothing -> return ()

72+ Just toPerform -> do

73+ responses <- Host.runHostFrame $ DMap.traverseWithKey (\_ v -> Identity <$> v) toPerform

74+ mrt <- readRef responseTrigger

75+ let followupEventTriggers = case mrt of

76+ Just rt -> [rt :=> Identity responses]

77+ Nothing -> []

78+ Host.fireEventsAndRead followupEventTriggers $ return ()

79+ return ()

80+ return ()

81+

82+data Tell a where

83+ Action :: Tell ()

84+ Request :: Tell (PatchDMap (Const2 Int (DMap Tell (S.SpiderHostFrame S.Global))) (S.Event S.Global))

85+

86+instance GEq Tell where

87+ geq Action Action = Just Refl

88+ geq Request Request = Just Refl

89+ geq _ _ = Nothing

90+

91+instance GCompare Tell where

92+ gcompare Action Action = GEQ

93+ gcompare Request Request = GEQ

94+ gcompare Action Request = GLT

95+ gcompare Request Action = GGT

test/hlint.hs+1

@@ -12,5 +12,6 @@ main = do

12 , "--ignore=Use const"

13 , "--ignore=Use >=>"

14 , "--ignore=Use ."

15+ , "--cpp-define=USE_TEMPLATE_HASKELL"

15 ]

16 ]

16 if null ideas then exitSuccess else exitFailure

17 if null ideas then exitSuccess else exitFailure