1ff7dbf · patch · git.iko.soy

git.iko.soy/patch

on develop help sign in

Add runWithReplace to provide widgetHoldInternal behavior

1ff7dbfRyan Trinkle10 years ago

src/Reflex/Class.hs+4

compare with develop

unifiedsplit

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

840 mapAccumMaybe_ f' l e

841

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

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

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

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

844

845

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

846instance (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'

846 sequenceDMapWithAdjust dm0 dm' = do

850 sequenceDMapWithAdjust dm0 dm' = do

847 r <- ask

851 r <- ask

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

852 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

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

158

159instance (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')

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

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

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

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

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

166 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)

32import qualified Data.Dependent.Map as DMap

33import Data.Dependent.Sum

34import Data.Functor.Misc

35+import qualified Data.List.NonEmpty as NonEmpty

35import Data.Maybe

36import Data.Maybe

36import Data.Semigroup

37import Data.Semigroup

37import qualified Data.Some as Some

38import qualified Data.Some as Some

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

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

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

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

67instance (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')

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

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

68 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))

75 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))

69 f dm0 dm' = do

76 f dm0 dm' = do

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

185 holdIncremental v0 = lift . holdIncremental v0

192 holdIncremental v0 = lift . holdIncremental v0

186

193

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

194instance (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'

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

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

189

197

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+

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

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

191 => (forall k'. GCompare k'

219 => (forall k'. GCompare k'

192 => DMap k' m

220 => DMap k' m

193 -> Event t (PatchDMap k' m)

221 -> Event t (PatchDMap k' m)

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

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

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

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

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

212 childRequestMap <- holdIncremental requests0 requests'

240 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

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

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

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

244 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

216 return (result0, result')

245 return (result0, result')

217

246

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

247instance 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

94 getPostBuild = lift getPostBuild

96instance (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

97 sequenceDMapWithAdjust dm0 dm' = do

103 sequenceDMapWithAdjust dm0 dm' = do

98 postBuild <- getPostBuild

104 postBuild <- getPostBuild

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

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

106+ lift $ do

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

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

108+ let voidResult' = void result'

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

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

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

103− return (result0, result')

111+ return (result0, result')