d349bfa · reflex · git.iko.soy

git.iko.soy/reflex

Replace runWithReplace with mapMWithReplace

commitd349bfa0fa14fa900bf3160ad94e203265feb85a authorRyan Trinkle <ryan.trinkle@gmail.com> dateMon 12 Jun 2017, 11:27 (9 years ago) parentef4da28

9 files changed+84−49

compare with develop

unifiedsplit

src/Reflex/Class.hs+11−3 src/Reflex/DynamicWriter.hs+2−2 src/Reflex/EventWriter.hs+21−13 src/Reflex/PerformEvent/Base.hs+5−5 src/Reflex/PostBuild/Base.hs+5−5 src/Reflex/Query/Base.hs+2−2 src/Reflex/Requester/Base.hs+25−14 src/Reflex/Spider/Internal.hs+11−3 src/Reflex/TriggerEvent/Base.hs+2−2

src/Reflex/Class.hs+11−3

@@ -103,6 +103,7 @@ module Reflex.Class

103103 -- * Miscellaneous convenience functions

104104 , ffor

105105 , MonadAdjust (..)

106+ , runWithReplace

106107 , sequenceDMapWithAdjust

107108 , sequenceDMapWithAdjustWithMove

108109 , mapMapWithAdjustWithMove

@@ -701,6 +702,8 @@ mergeWith = mergeWith' id

701702

702703{-# INLINE mergeWith' #-}

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

705+mergeWith' _ _ [] = never

706+mergeWith' f _ [e] = fmap f e

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

705708 . merge

706709 . DMap.fromDistinctAscList

@@ -1023,6 +1026,9 @@ infixl 4 <@>

10231026(<@) = tag

10241027infixl 4 <@

10251028

1029+runWithReplace :: MonadAdjust t m => m a -> Event t (m b) -> m (a, Event t b)

1030+runWithReplace = mapMWithReplace id id

1031+

10261032-- | A 'Monad' that supports adjustment over time. After an action has been

10271033-- run, if the given events fire, it will adjust itself so that its net effect

10281034-- is as though it had originally been run with the new value. Note that there

@@ -1030,14 +1036,14 @@ infixl 4 <@

10301036-- other side-effects) cannot be undone, so it is up to the instance implementer

10311037-- to determine what the best meaning for this class is in such cases.

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

1033− runWithReplace :: m a -> Event t (m b) -> m (a, Event t b)

1039+ mapMWithReplace :: (a -> m b) -> (a' -> m b') -> a -> Event t a' -> m (b, Event t b')

10341040 traverseDMapWithKeyWithAdjust :: GCompare k => (forall a. k a -> v a -> m (v' a)) -> DMap k v -> Event t (PatchDMap k v) -> m (DMap k v', Event t (PatchDMap k v'))

10351041 traverseDMapWithKeyWithAdjustWithMove :: GCompare k => (forall a. k a -> v a -> m (v' a)) -> DMap k v -> Event t (PatchDMapWithMove k v) -> m (DMap k v', Event t (PatchDMapWithMove k v'))

10361042

10371043instance MonadAdjust t m => MonadAdjust t (ReaderT r m) where

1038− runWithReplace a0 a' = do

1044+ mapMWithReplace f g a0 a' = do

10391045 r <- ask

1040− lift $ runWithReplace (runReaderT a0 r) $ fmap (`runReaderT` r) a'

1046+ lift $ mapMWithReplace ((`runReaderT` r) . f) ((`runReaderT` r) . g) a0 a'

10411047 traverseDMapWithKeyWithAdjust f dm0 dm' = do

10421048 r <- ask

10431049 lift $ traverseDMapWithKeyWithAdjust (\k v -> runReaderT (f k v) r) dm0 dm'

@@ -1094,6 +1100,8 @@ mergeWithCheap' f g = mergeWithFoldCheap' $ foldl1 g . fmap f

10941100

10951101{-# INLINE mergeWithFoldCheap' #-}

10961102mergeWithFoldCheap' :: Reflex t => (NonEmpty a -> b) -> [Event t a] -> Event t b

1103+mergeWithFoldCheap' _ [] = never

1104+mergeWithFoldCheap' f [e] = fmapCheap (f . (:|[])) e

10971105mergeWithFoldCheap' f es =

10981106 fmapCheap (f . (\(h : t) -> h :| t) . map (\(Const2 _ :=> Identity v) -> v) . DMap.toList)

10991107 . merge

src/Reflex/DynamicWriter.hs+2−2

@@ -138,8 +138,8 @@ newtype DynamicWriterTLoweredResult t w v a = DynamicWriterTLoweredResult (v a,

138138-- 'MonadAdjust', the 'Dynamic' output of that action will also be updated to

139139-- match.

140140instance (MonadAdjust t m, MonadFix m, Monoid w, MonadHold t m, Reflex t) => MonadAdjust t (DynamicWriterT t w m) where

141− runWithReplace a0 a' = do

142− (result0, result') <- lift $ runWithReplace (runDynamicWriterT a0) $ runDynamicWriterT <$> a'

141+ mapMWithReplace f g a0 a' = do

142+ (result0, result') <- lift $ mapMWithReplace (runDynamicWriterT . f) (runDynamicWriterT . g) a0 a'

143143 tellDyn . join =<< holdDyn (snd result0) (snd <$> result')

144144 return (fst result0, fst <$> result')

145145 traverseDMapWithKeyWithAdjust = traverseDMapWithKeyWithAdjustImpl traverseDMapWithKeyWithAdjust mapPatchDMap weakenPatchDMapWith mergeDynIncremental

src/Reflex/EventWriter.hs+21−13

@@ -17,7 +17,7 @@ module Reflex.EventWriter

1717 ( EventWriterT (..)

1818 , runEventWriterT

1919 , EventWriter (..)

20− , runWithReplaceEventWriterTWith

20+ , mapMWithReplaceEventWriterTWith

2121 , sequenceDMapWithAdjustEventWriterTWith

2222 ) where

2323

@@ -78,7 +78,7 @@ instance MonadHold t m => MonadHold t (EventWriterT t w m) where

7878 holdIncremental v0 = lift . holdIncremental v0

7979

8080instance (Reflex t, MonadAdjust t m, MonadHold t m, Semigroup w, Semigroup w) => MonadAdjust t (EventWriterT t w m) where

81− runWithReplace = runWithReplaceEventWriterTWith $ \dm0 dm' -> lift $ runWithReplace dm0 dm'

81+ mapMWithReplace = mapMWithReplaceEventWriterTWith $ \f g dm0 dm' -> lift $ mapMWithReplace f g dm0 dm'

8282 traverseDMapWithKeyWithAdjust = sequenceDMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjust f dm0 dm') mapPatchDMap weakenPatchDMapWith patchMapNewElements mergeMapIncremental

8383 traverseDMapWithKeyWithAdjustWithMove = sequenceDMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjustWithMove f dm0 dm') mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElements mergeMapIncrementalWithMove

8484

@@ -88,19 +88,27 @@ instance Requester t m => Requester t (EventWriterT t w m) where

8888 withRequesting f = EventWriterT $ withRequesting $ unEventWriterT . f

8989

9090

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

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

91+-- | Given a function like 'mapMWithReplace' for the underlying monad, implement

92+-- 'mapMWithReplace' for 'EventWriterT'. This is necessary when the underlying

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

9494-- 'MonadAdjust' behavior.

95−runWithReplaceEventWriterTWith :: forall m t w a b. (Reflex t, MonadHold t m, Semigroup w)

96− => (forall a' b'. m a' -> Event t (m b') -> EventWriterT t w m (a', Event t b'))

97− -> EventWriterT t w m a

98− -> Event t (EventWriterT t w m b)

99− -> EventWriterT t w m (a, Event t b)

100−runWithReplaceEventWriterTWith f a0 a' = do

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

102− g (EventWriterT r) = runStateT r mempty

103− (result0, result') <- f (g a0) $ fmap g a'

95+mapMWithReplaceEventWriterTWith :: forall m t w a a' b b'. (Reflex t, MonadHold t m, Semigroup w)

96+ => (forall aa aa' bb bb'.

97+ (aa -> m bb) ->

98+ (aa' -> m bb') ->

99+ aa ->

100+ Event t aa' ->

101+ EventWriterT t w m (bb, Event t bb')

102+ )

103+ -> (a -> EventWriterT t w m b)

104+ -> (a' -> EventWriterT t w m b')

105+ -> a

106+ -> Event t a'

107+ -> EventWriterT t w m (b, Event t b')

108+mapMWithReplaceEventWriterTWith base f g a0 a' = do

109+ let runInternal :: EventWriterT t w m c -> m (c, Seq (Event t w))

110+ runInternal (EventWriterT r) = runStateT r mempty

111+ (result0, result') <- base (runInternal . f) (runInternal . g) a0 a'

104112 request <- holdDyn (fmapCheap sconcat $ mergeList $ toList $ snd result0) $ fmapCheap (fmapCheap sconcat . mergeList . toList . snd) result'

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

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

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

@@ -70,11 +70,11 @@ instance (ReflexHost t, Ref m ~ Ref IO, PrimMonad (HostFrame t)) => PerformEvent

7070 performEvent = PerformEventT . requestingIdentity

7171

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

73− runWithReplace outerA0 outerA' = PerformEventT $ runWithReplaceRequesterTWith f (coerce outerA0) (coerceEvent outerA')

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' <- requestingIdentity a'

73+ mapMWithReplace f g outerA0 outerA' = PerformEventT $ mapMWithReplaceRequesterTWith base (coerce f) (coerce g) outerA0 outerA'

74+ where base :: (a -> HostFrame t b) -> (a' -> HostFrame t b') -> a -> Event t a' -> RequesterT t (HostFrame t) Identity (HostFrame t) (b, Event t b')

75+ base f' g' a0 a' = do

76+ result0 <- lift $ f' a0

77+ result' <- requestingIdentity $ fmapCheap g' a'

7878 return (result0, result')

7979 traverseDMapWithKeyWithAdjust f outerDm0 outerDm' = PerformEventT $ sequenceDMapWithAdjustRequesterTWith (defaultAdjustBase traversePatchDMapWithKey) mapPatchDMap weakenPatchDMapWith patchMapNewElements mergeMapIncremental (\k v -> unPerformEventT $ f k v) (coerce outerDm0) (coerceEvent outerDm')

8080 traverseDMapWithKeyWithAdjustWithMove f outerDm0 outerDm' = PerformEventT $ sequenceDMapWithAdjustRequesterTWith (defaultAdjustBase traversePatchDMapWithMoveWithKey) mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElements mergeMapIncrementalWithMove (\k v -> unPerformEventT $ f k v) (coerce outerDm0) (coerceEvent outerDm')

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

@@ -73,11 +73,11 @@ instance MonadHold t m => MonadHold t (PostBuildT t m) where

7373 holdIncremental v0 = lift . holdIncremental v0

7474

7575instance PerformEvent t m => PerformEvent t (PostBuildT t m) where

76− type Performable (PostBuildT t m) = PostBuildT t (Performable m)

76+ type Performable (PostBuildT t m) = Performable m

7777 {-# INLINABLE performEvent_ #-}

78− performEvent_ e = liftWith $ \run -> performEvent_ $ fmap run e

78+ performEvent_ = lift . performEvent_

7979 {-# INLINABLE performEvent #-}

80− performEvent e = liftWith $ \run -> performEvent $ fmap run e

80+ performEvent = lift . performEvent

8181

8282instance (ReflexHost t, MonadReflexCreateTrigger t m) => MonadReflexCreateTrigger t (PostBuildT t m) where

8383 {-# INLINABLE newEventWithTrigger #-}

@@ -106,10 +106,10 @@ instance MonadAtomicRef m => MonadAtomicRef (PostBuildT t m) where

106106 atomicModifyRef r = lift . atomicModifyRef r

107107

108108instance (Reflex t, MonadHold t m, MonadFix m, MonadAdjust t m, PerformEvent t m) => MonadAdjust t (PostBuildT t m) where

109− runWithReplace a0 a' = do

109+ mapMWithReplace f g a0 a' = do

110110 postBuild <- getPostBuild

111111 lift $ do

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

112+ rec result@(_, result') <- mapMWithReplace ((`runPostBuildT` postBuild) . f) (\v -> runPostBuildT (g v) =<< headE voidResult') a0 a'

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

114114 return result

115115 traverseDMapWithKeyWithAdjust = mapDMapWithAdjustImpl traverseDMapWithKeyWithAdjust mapPatchDMap

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

@@ -71,8 +71,8 @@ let sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q

7171-}

7272

7373instance (Reflex t, MonadFix m, Group q, Additive q, Query q, MonadHold t m, MonadAdjust t m) => MonadAdjust t (QueryT t q m) where

74− runWithReplace (QueryT a0) a' = do

75− ((r0, bs0), r') <- QueryT $ lift $ runWithReplace (runStateT a0 []) $ fmapCheap (flip runStateT [] . unQueryT) a'

74+ mapMWithReplace f g a0 a' = do

75+ ((r0, bs0), r') <- QueryT $ lift $ mapMWithReplace ((`runStateT` []) . unQueryT . f) ((`runStateT` []) . unQueryT . g) a0 a'

7676 let sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q

7777 sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty

7878 bs' = fmapCheap snd $ r'

src/Reflex/Requester/Base.hs+25−14

@@ -17,7 +17,7 @@

1717module Reflex.Requester.Base

1818 ( RequesterT (..)

1919 , runRequesterT

20− , runWithReplaceRequesterTWith

20+ , mapMWithReplaceRequesterTWith

2121 , sequenceDMapWithAdjustRequesterTWith

2222 ) where

2323

@@ -105,23 +105,34 @@ instance MonadReader r m => MonadReader r (RequesterT t request response m) wher

105105 reader = lift . reader

106106

107107instance (Reflex t, MonadAdjust t m, MonadHold t m) => MonadAdjust t (RequesterT t request response m) where

108− runWithReplace (RequesterT a) em = RequesterT $ runWithReplace a (coerceEvent em)

108+ mapMWithReplace f g a0 a' = RequesterT $ mapMWithReplace (coerce f) (coerce g) a0 a'

109109 traverseDMapWithKeyWithAdjust f dm edm = RequesterT $ traverseDMapWithKeyWithAdjust (\k v -> unRequesterT $ f k v) (coerce dm) (coerceEvent edm)

110110 traverseDMapWithKeyWithAdjustWithMove f dm edm = RequesterT $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unRequesterT $ f k v) (coerce dm) (coerceEvent edm)

111111

112−runWithReplaceRequesterTWith :: forall m t request response a b. (Reflex t, MonadHold t m)

113− => (forall a' b'. m a' -> Event t (m b') -> RequesterT t request response m (a', Event t b'))

114− -> RequesterT t request response m a

115− -> Event t (RequesterT t request response m b)

116− -> RequesterT t request response m (a, Event t b)

117−runWithReplaceRequesterTWith f a0 a' =

118− let f' :: forall a' b'. ReaderT (EventSelector t (WrapArg response (Tag (PrimState m)))) m a'

119− -> Event t (ReaderT (EventSelector t (WrapArg response (Tag (PrimState m)))) m b')

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

121− f' x y = do

112+mapMWithReplaceRequesterTWith :: forall m t request response a a' b b'. (Reflex t, MonadHold t m)

113+ => (forall aa aa' bb bb'.

114+ (aa -> m bb) ->

115+ (aa' -> m bb') ->

116+ aa ->

117+ Event t aa' ->

118+ RequesterT t request response m (bb, Event t bb')

119+ )

120+ -> (a -> RequesterT t request response m b)

121+ -> (a' -> RequesterT t request response m b')

122+ -> a

123+ -> Event t a'

124+ -> RequesterT t request response m (b, Event t b')

125+mapMWithReplaceRequesterTWith base f g a0 a' =

126+ let base' :: forall aaa aaa' bbb bbb'.

127+ (aaa -> ReaderT (EventSelector t (WrapArg response (Tag (PrimState m)))) m bbb)

128+ -> (aaa' -> ReaderT (EventSelector t (WrapArg response (Tag (PrimState m)))) m bbb')

129+ -> aaa

130+ -> Event t aaa'

131+ -> EventWriterT t (DMap (Tag (PrimState m)) request) (ReaderT (EventSelector t (WrapArg response (Tag (PrimState m)))) m) (bbb, Event t bbb')

132+ base' f' g' x y = do

122133 r <- EventWriterT $ ask

123− unRequesterT (f (runReaderT x r) (fmapCheap (`runReaderT` r) y))

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

134+ unRequesterT $ base ((`runReaderT` r) . f') ((`runReaderT` r) . g') x y

135+ in RequesterT $ mapMWithReplaceEventWriterTWith base' (coerce f) (coerce g) a0 a'

125136

126137sequenceDMapWithAdjustRequesterTWith :: forall k t request response m v v' p p'.

127138 ( GCompare k

src/Reflex/Spider/Internal.hs+11−3

@@ -1113,16 +1113,24 @@ instance HasSpiderTimeline x => Align (Event x) where

11131113 nil = eventNever

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

11151115

1116+{-# INLINE mapEventCheap #-}

1117+mapEventCheap :: HasSpiderTimeline x => (a -> b) -> Event x a -> Event x b

1118+mapEventCheap f = pushCheap $ return . Just . f

1119+

1120+{-# INLINE alignCheap #-}

1121+alignCheap :: HasSpiderTimeline x => Event x a -> Event x b -> Event x (These a b)

1122+alignCheap ea eb = fmapMaybe dmapToThese $ mergeCheap $ dynamicConst $ DMap.fromList [LeftTag :=> ea, RightTag :=> eb]

1123+

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

11171125

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

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

1127+newMapDyn f d = dynamicDynIdentity $ unsafeBuildDynamic (fmap f $ readBehaviorTracked $ dynamicCurrent d) (mapEventCheap (Identity . f . runIdentity) $ dynamicUpdated d)

11201128

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

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

11231131zipDynWith f da db =

1124− let eab = align (dynamicUpdated da) (dynamicUpdated db)

1125− ec = flip push eab $ \o -> do

1132+ let eab = alignCheap (dynamicUpdated da) (dynamicUpdated db)

1133+ ec = flip pushCheap eab $ \o -> do

11261134 (a, b) <- case o of

11271135 This (Identity a) -> do

11281136 b <- readBehaviorUntracked $ dynamicCurrent db

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

@@ -116,8 +116,8 @@ instance MonadHold t m => MonadHold t (TriggerEventT t m) where

116116 holdIncremental v0 v' = lift $ holdIncremental v0 v'

117117

118118instance MonadAdjust t m => MonadAdjust t (TriggerEventT t m) where

119− {-# INLINABLE runWithReplace #-}

120− runWithReplace (TriggerEventT a0) a' = TriggerEventT $ runWithReplace a0 (coerceEvent a')

119+ {-# INLINABLE mapMWithReplace #-}

120+ mapMWithReplace f g a0 a' = TriggerEventT $ mapMWithReplace (unTriggerEventT . f) (unTriggerEventT . g) a0 a'

121121 {-# INLINABLE traverseDMapWithKeyWithAdjust #-}

122122 traverseDMapWithKeyWithAdjust f dm0 dm' = TriggerEventT $ traverseDMapWithKeyWithAdjust (coerce . f) dm0 dm'

123123 {-# INLINABLE traverseDMapWithKeyWithAdjustWithMove #-}