1ff7dbf · patch · git.iko.soy

git.iko.soy/patch

Add runWithReplace to provide widgetHoldInternal behavior

commit1ff7dbf10944ce300911269bb4cdd1052248bc3c authorRyan Trinkle <ryan.trinkle@gmail.com> dateSat 5 Nov 2016, 17:39 (10 years ago) parent02007dd

4 files changed+51−6

compare with develop

unifiedsplit

src/Reflex/Class.hs+4 src/Reflex/DynamicWriter.hs+4 src/Reflex/PerformEvent/Base.hs+31−2 src/Reflex/PostBuild/Class.hs+12−4

src/Reflex/Class.hs+4

@@ -840,9 +840,13 @@ zipListWithEvent f l e = do

840840 mapAccumMaybe_ f' l e

841841

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

843+ runWithReplace :: m a -> Event t (m b) -> m (a, Event t b)

843844 sequenceDMapWithAdjust :: GCompare k => DMap k m -> Event t (PatchDMap k m) -> m (DMap k Identity, Event t (PatchDMap k Identity))

844845

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

847+ runWithReplace a0 a' = do

848+ r <- ask

849+ lift $ runWithReplace (runReaderT a0 r) $ fmap (`runReaderT` r) a'

846850 sequenceDMapWithAdjust dm0 dm' = do

847851 r <- ask

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

src/Reflex/DynamicWriter.hs+4

@@ -157,6 +157,10 @@ instance MonadState s m => MonadState s (DynamicWriterT t w m) where

157157newtype DynamicWriterTLoweredResult t w v = DynamicWriterTLoweredResult { unDynamicWriterTLoweredResult :: (v, Dynamic t w) }

158158

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

160+ runWithReplace a0 a' = do

161+ (result0, result') <- lift $ runWithReplace (runDynamicWriterT a0) $ runDynamicWriterT <$> a'

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

163+ return (fst result0, fst <$> result')

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

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

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

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

@@ -32,6 +32,7 @@ import Data.Dependent.Map (DMap, GCompare (..), Some)

3232import qualified Data.Dependent.Map as DMap

3333import Data.Dependent.Sum

3434import Data.Functor.Misc

35+import qualified Data.List.NonEmpty as NonEmpty

3536import Data.Maybe

3637import Data.Semigroup

3738import qualified Data.Some as Some

@@ -64,6 +65,12 @@ instance (ReflexHost t, Ref m ~ Ref IO, PrimMonad (HostFrame t)) => PerformEvent

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

6566

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

68+ runWithReplace outerA0 outerA' = PerformEventT $ runWithReplaceRequestTWith f (coerce outerA0) (coerceEvent outerA')

69+ where f :: HostFrame t a -> Event t (HostFrame t b) -> RequestT t (HostFrame t) Identity (HostFrame t) (a, Event t b)

70+ f a0 a' = do

71+ result0 <- lift a0

72+ result' <- requesting a'

73+ return (result0, fmap runIdentity result')

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

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

6976 f dm0 dm' = do

@@ -185,9 +192,30 @@ instance MonadHold t m => MonadHold t (RequestT t request response m) where

185192 holdIncremental v0 = lift . holdIncremental v0

186193

187194instance (Reflex t, MonadAdjust t m, MonadHold t m) => MonadAdjust t (RequestT t request response m) where

195+ runWithReplace = runWithReplaceRequestTWith $ \dm0 dm' -> lift $ runWithReplace dm0 dm'

188196 sequenceDMapWithAdjust = sequenceDMapWithAdjustRequestTWith $ \dm0 dm' -> lift $ sequenceDMapWithAdjust dm0 dm'

189197

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

198+runWithReplaceRequestTWith :: forall m t request response a b. (Reflex t, MonadHold t m)

199+ => (forall a' b'.

200+ m a'

201+ -> Event t (m b')

202+ -> RequestT t request response m (a', Event t b')

203+ )

204+ -> RequestT t request response m a

205+ -> Event t (RequestT t request response m b)

206+ -> RequestT t request response m (a, Event t b)

207+runWithReplaceRequestTWith f a0 a' = do

208+ response <- RequestT ask

209+ let g :: RequestT t request response m c -> m (c, [Event t (DMap (Tag (PrimState m)) request)])

210+ g (RequestT r) = runReaderT (runStateT r mempty) response

211+ (result0, result') <- f (g a0) $ g <$> a'

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

213+ -- 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.)

214+ RequestT $ modify $ (:) $ coincidence $ updated request

215+ RequestT $ modify $ (:) $ switch $ current request

216+ return (fst result0, fst <$> result')

217+

218+sequenceDMapWithAdjustRequestTWith :: (GCompare k, Reflex t, MonadHold t m)

191219 => (forall k'. GCompare k'

192220 => DMap k' m

193221 -> Event t (PatchDMap k' m)

@@ -210,9 +238,10 @@ sequenceDMapWithAdjustRequestTWith f (dm0 :: DMap k (RequestT t request response

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

211239 mapKeyValuePairsMonotonic (\(WrapArg k :=> ComposeMaybe mv) -> Const2 (Some.This k) :=> ComposeMaybe (fmap (mergeWith DMap.union . fst . runIdentity) mv)) p

212240 childRequestMap <- holdIncremental requests0 requests'

241+ -- 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.)

242+ RequestT $ modify $ (:) $ coincidence $ ffor requests' $ \(PatchDMap p) -> mergeWith DMap.union $ catMaybes $ ffor (DMap.toList p) $ \(Const2 _ :=> ComposeMaybe me) -> me

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

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

215− RequestT $ modify $ (:) $ coincidence $ ffor requests' $ \(PatchDMap p) -> mergeWith DMap.union $ catMaybes $ ffor (DMap.toList p) $ \(Const2 _ :=> ComposeMaybe me) -> me

216245 return (result0, result')

217246

218247instance PerformEvent t m => PerformEvent t (RequestT t request response m) where

src/Reflex/PostBuild/Class.hs+12−4

@@ -94,10 +94,18 @@ instance PostBuild t m => PostBuild t (ReaderT r m) where

9494 getPostBuild = lift getPostBuild

9595

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

97+ runWithReplace a0 a' = do

98+ postBuild <- getPostBuild

99+ lift $ do

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

101+ let voidResult' = void result'

102+ return result

97103 sequenceDMapWithAdjust dm0 dm' = do

98104 postBuild <- getPostBuild

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

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

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

102− DMap.map (ComposeMaybe . fmap (\v -> runPostBuildT v =<< headE (void result')) . 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

103− return (result0, result')

106+ lift $ do

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

108+ let voidResult' = void result'

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

110+ 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

111+ return (result0, result')