baac813 · patch · git.iko.soy

git.iko.soy/patch

Merge pull request #239 from reflex-frp/eventwritert-adjustable-fix

Fix traverse* Adjustable methods in EventWriterT

commitbaac813dd52473125b86c67085f48ce347d2836d authorRyan Trinkle <ryan.trinkle@gmail.com> dateFri 9 Nov 2018, 12:10 (8 years ago) parent59ef31e 56fcac1

5 files changed+184−56

compare with develop

unifiedsplit

reflex.cabal+1 src/Reflex/Class.hs+58 src/Reflex/EventWriter/Base.hs+63−53 src/Reflex/FunctorMaybe.hs+10 test/EventWriterT.hs+52−3

reflex.cabal+1

@@ -208,6 +208,7 @@ test-suite EventWriterT

208208 build-depends: base

209209 , containers

210210 , deepseq >= 1.3 && < 1.5

211+ , dependent-map

211212 , dependent-sum

212213 , lens

213214 , mtl

src/Reflex/Class.hs+58

@@ -44,9 +44,13 @@ module Reflex.Class

4444 -- ** Combining 'Event's

4545 , leftmost

4646 , mergeMap

47+ , mergeIntMap

4748 , mergeMapIncremental

4849 , mergeMapIncrementalWithMove

4950 , mergeIntMapIncremental

51+ , coincidencePatchMap

52+ , coincidencePatchMapWithMove

53+ , coincidencePatchIntMap

5054 , mergeList

5155 , mergeWith

5256 , difference

@@ -66,6 +70,7 @@ module Reflex.Class

6670 , switchHold

6771 , switchHoldPromptly

6872 , switchHoldPromptOnly

73+ , switchHoldPromptOnlyIncremental

6974 -- ** Using 'Event's to sample 'Behavior's

7075 , tag

7176 , tagMaybe

@@ -191,6 +196,7 @@ import Data.These

191196import Data.Type.Coercion

192197import Reflex.FunctorMaybe

193198import Reflex.Patch

199+import qualified Reflex.Patch.MapWithMove as PatchMapWithMove

194200

195201import Debug.Trace (trace)

196202

@@ -781,6 +787,10 @@ unsafeMapIncremental f g a = unsafeBuildIncremental (fmap f $ sample $ currentIn

781787mergeMap :: (Reflex t, Ord k) => Map k (Event t a) -> Event t (Map k a)

782788mergeMap = fmap dmapToMap . merge . mapWithFunctorToDMap

783789

790+-- | Like 'mergeMap' but for 'IntMap'.

791+mergeIntMap :: Reflex t => IntMap (Event t a) -> Event t (IntMap a)

792+mergeIntMap = fmap dmapToIntMap . merge . intMapWithFunctorToDMap

793+

784794-- | Create a merge whose parents can change over time

785795mergeMapIncremental :: (Reflex t, Ord k) => Incremental t (PatchMap k (Event t a)) -> Event t (Map k a)

786796mergeMapIncremental = fmap dmapToMap . mergeIncremental . unsafeMapIncremental mapWithFunctorToDMap (const2PatchDMapWith id)

@@ -859,6 +869,54 @@ switchHoldPromptOnly e0 e' = do

859869 eLag <- switch <$> hold e0 e'

860870 return $ coincidence $ leftmost [e', eLag <$ eLag]

861871

872+-- | When the given outer event fires, condense the inner events into the contained patch. Non-firing inner events will be replaced with deletions.

873+coincidencePatchMap :: (Reflex t, Ord k) => Event t (PatchMap k (Event t v)) -> Event t (PatchMap k v)

874+coincidencePatchMap e = fmapCheap PatchMap $ coincidence $ ffor e $ \(PatchMap m) -> mergeMap $ ffor m $ \case

875+ Nothing -> fmapCheap (const Nothing) e

876+ Just ev -> leftmost [fmapCheap Just ev, fmapCheap (const Nothing) e]

877+

878+-- | See 'coincicencePatchMap'

879+coincidencePatchIntMap :: Reflex t => Event t (PatchIntMap (Event t v)) -> Event t (PatchIntMap v)

880+coincidencePatchIntMap e = fmapCheap PatchIntMap $ coincidence $ ffor e $ \(PatchIntMap m) -> mergeIntMap $ ffor m $ \case

881+ Nothing -> fmapCheap (const Nothing) e

882+ Just ev -> leftmost [fmapCheap Just ev, fmapCheap (const Nothing) e]

883+

884+-- | See 'coincicencePatchMap'

885+coincidencePatchMapWithMove :: (Reflex t, Ord k) => Event t (PatchMapWithMove k (Event t v)) -> Event t (PatchMapWithMove k v)

886+coincidencePatchMapWithMove e = fmapCheap unsafePatchMapWithMove $ coincidence $ ffor e $ \p -> mergeMap $ ffor (unPatchMapWithMove p) $ \ni -> case PatchMapWithMove._nodeInfo_from ni of

887+ PatchMapWithMove.From_Delete -> fforCheap e $ \_ ->

888+ ni { PatchMapWithMove._nodeInfo_from = PatchMapWithMove.From_Delete }

889+ PatchMapWithMove.From_Move k -> fforCheap e $ \_ ->

890+ ni { PatchMapWithMove._nodeInfo_from = PatchMapWithMove.From_Move k }

891+ PatchMapWithMove.From_Insert ev -> leftmost

892+ [ fforCheap ev $ \v ->

893+ ni { PatchMapWithMove._nodeInfo_from = PatchMapWithMove.From_Insert v }

894+ , fforCheap e $ \_ ->

895+ ni { PatchMapWithMove._nodeInfo_from = PatchMapWithMove.From_Delete }

896+ ]

897+

898+switchHoldPromptOnlyIncremental

899+ :: forall t m p pt w

900+ . ( Reflex t

901+ , MonadHold t m

902+ , Patch (p (Event t w))

903+ , PatchTarget (p (Event t w)) ~ pt (Event t w)

904+ , Patch (p w)

905+ , PatchTarget (p w) ~ pt w

906+ , Monoid (pt w)

907+ )

908+ => (Incremental t (p (Event t w)) -> Event t (pt w))

909+ -> (Event t (p (Event t w)) -> Event t (p w))

910+ -> pt (Event t w)

911+ -> Event t (p (Event t w))

912+ -> m (Event t (pt w))

913+switchHoldPromptOnlyIncremental mergePatchIncremental coincidencePatch e0 e' = do

914+ lag <- mergePatchIncremental <$> holdIncremental e0 e'

915+ pure $ ffor (align lag (coincidencePatch e')) $ \case

916+ This old -> old

917+ That new -> new `applyAlways` mempty

918+ These old new -> new `applyAlways` old

919+

862920instance Reflex t => Align (Event t) where

863921 nil = never

864922 align = alignEventWithMaybe Just

src/Reflex/EventWriter/Base.hs+63−53

@@ -40,7 +40,6 @@ import Control.Monad.Ref

4040import Control.Monad.State.Strict

4141import Data.Dependent.Map (DMap, DSum (..))

4242import qualified Data.Dependent.Map as DMap

43−import Data.Foldable

4443import Data.Functor.Compose

4544import Data.Functor.Misc

4645import Data.GADT.Compare (GCompare (..), GEq (..), GOrdering (..))

@@ -48,10 +47,11 @@ import Data.IntMap.Strict (IntMap)

4847import qualified Data.IntMap.Strict as IntMap

4948import Data.List.NonEmpty (NonEmpty (..))

5049import Data.Map (Map)

50+import qualified Data.Map as Map

5151import Data.Semigroup

5252import Data.Some (Some)

5353import Data.Tuple

54−import Data.Type.Equality

54+import Data.Type.Equality hiding (apply)

5555

5656import Unsafe.Coerce

5757

@@ -135,9 +135,9 @@ instance MonadHold t m => MonadHold t (EventWriterT t w m) where

135135

136136instance (Reflex t, Adjustable t m, MonadHold t m, Semigroup w) => Adjustable t (EventWriterT t w m) where

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

138− traverseIntMapWithKeyWithAdjust = sequenceIntMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseIntMapWithKeyWithAdjust f dm0 dm') patchIntMapNewElements mergeIntIncremental

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

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

138+ traverseIntMapWithKeyWithAdjust = sequenceIntMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseIntMapWithKeyWithAdjust f dm0 dm') mergeIntIncremental coincidencePatchIntMap

139+ traverseDMapWithKeyWithAdjust = sequenceDMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjust f dm0 dm') mapPatchDMap weakenPatchDMapWith mergeMapIncremental coincidencePatchMap

140+ traverseDMapWithKeyWithAdjustWithMove = sequenceDMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjustWithMove f dm0 dm') mapPatchDMapWithMove weakenPatchDMapWithMoveWith mergeMapIncrementalWithMove coincidencePatchMapWithMove

141141

142142instance Requester t m => Requester t (EventWriterT t w m) where

143143 type Request (EventWriterT t w m) = Request m

@@ -160,19 +160,29 @@ runWithReplaceEventWriterTWith f a0 a' = do

160160 return (fst result0, fmapCheap fst result')

161161

162162-- | Like 'runWithReplaceEventWriterTWith', but for 'sequenceIntMapWithAdjust'.

163−sequenceIntMapWithAdjustEventWriterTWith :: forall t m p w v v'. (Reflex t, MonadHold t m, Semigroup w, Functor p, Patch (p (Event t w)), PatchTarget (p (Event t w)) ~ IntMap (Event t w))

164− => ( (IntMap.Key -> v -> m (Event t w, v'))

165− -> IntMap v

166− -> Event t (p v)

167− -> EventWriterT t w m (IntMap (Event t w, v'), Event t (p (Event t w, v')))

168− )

169− -> (p (Event t w) -> [Event t w])

170− -> (Incremental t (p (Event t w)) -> Event t (IntMap w))

171− -> (IntMap.Key -> v -> EventWriterT t w m v')

172− -> IntMap v

173− -> Event t (p v)

174− -> EventWriterT t w m (IntMap v', Event t (p v'))

175−sequenceIntMapWithAdjustEventWriterTWith base patchNewElements mergePatchIncremental f dm0 dm' = do

163+sequenceIntMapWithAdjustEventWriterTWith

164+ :: forall t m p w v v'

165+ . ( Reflex t

166+ , MonadHold t m

167+ , Semigroup w

168+ , Functor p

169+ , Patch (p (Event t w))

170+ , PatchTarget (p (Event t w)) ~ IntMap (Event t w)

171+ , Patch (p w)

172+ , PatchTarget (p w) ~ IntMap w

173+ )

174+ => ( (IntMap.Key -> v -> m (Event t w, v'))

175+ -> IntMap v

176+ -> Event t (p v)

177+ -> EventWriterT t w m (IntMap (Event t w, v'), Event t (p (Event t w, v')))

178+ )

179+ -> (Incremental t (p (Event t w)) -> Event t (PatchTarget (p w)))

180+ -> (Event t (p (Event t w)) -> Event t (p w))

181+ -> (IntMap.Key -> v -> EventWriterT t w m v')

182+ -> IntMap v

183+ -> Event t (p v)

184+ -> EventWriterT t w m (IntMap v', Event t (p v'))

185+sequenceIntMapWithAdjustEventWriterTWith base mergePatchIncremental coincidencePatch f dm0 dm' = do

176186 let f' :: IntMap.Key -> v -> m (Event t w, v')

177187 f' k v = swap <$> runEventWriterT (f k v)

178188 (children0, children') <- base f' dm0 dm'

@@ -182,26 +192,39 @@ sequenceIntMapWithAdjustEventWriterTWith base patchNewElements mergePatchIncreme

182192 requests0 = fmap fst children0

183193 requests' :: Event t (p (Event t w))

184194 requests' = fmapCheap (fmap fst) children'

185− childRequestMap :: Incremental t (p (Event t w)) <- holdIncremental requests0 requests'

186− tellEventsPromptly requests' patchNewElements $ mergePatchIncremental childRequestMap

195+ e <- switchHoldPromptOnlyIncremental mergePatchIncremental coincidencePatch requests0 requests'

196+ tellEvent $ fforMaybeCheap e $ \m ->

197+ case IntMap.elems m of

198+ [] -> Nothing

199+ h : t -> Just $ sconcat $ h :| t

187200 return (result0, result')

188201

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

190−sequenceDMapWithAdjustEventWriterTWith :: forall t m p p' w k v v'. (Reflex t, MonadHold t m, Semigroup w, Patch (p' (Some k) (Event t w)), PatchTarget (p' (Some k) (Event t w)) ~ Map (Some k) (Event t w))

191− => ( (forall a. k a -> v a -> m (Compose ((,) (Event t w)) v' a))

192− -> DMap k v

193− -> Event t (p k v)

194− -> EventWriterT t w m (DMap k (Compose ((,) (Event t w)) v'), Event t (p k (Compose ((,) (Event t w)) v')))

195− )

196− -> ((forall a. Compose ((,) (Event t w)) v' a -> v' a) -> p k (Compose ((,) (Event t w)) v') -> p k v')

197− -> ((forall a. Compose ((,) (Event t w)) v' a -> Event t w) -> p k (Compose ((,) (Event t w)) v') -> p' (Some k) (Event t w))

198− -> (p' (Some k) (Event t w) -> [Event t w])

199− -> (Incremental t (p' (Some k) (Event t w)) -> Event t (Map (Some k) w))

200− -> (forall a. k a -> v a -> EventWriterT t w m (v' a))

201− -> DMap k v

202− -> Event t (p k v)

203− -> EventWriterT t w m (DMap k v', Event t (p k v'))

204−sequenceDMapWithAdjustEventWriterTWith base mapPatch weakenPatchWith patchNewElements mergePatchIncremental f dm0 dm' = do

203+sequenceDMapWithAdjustEventWriterTWith

204+ :: forall t m p p' w k v v'

205+ . ( Reflex t

206+ , MonadHold t m

207+ , Semigroup w

208+ , Patch (p' (Some k) (Event t w))

209+ , PatchTarget (p' (Some k) (Event t w)) ~ Map (Some k) (Event t w)

210+ , GCompare k

211+ , Patch (p' (Some k) w)

212+ , PatchTarget (p' (Some k) w) ~ Map (Some k) w

213+ )

214+ => ( (forall a. k a -> v a -> m (Compose ((,) (Event t w)) v' a))

215+ -> DMap k v

216+ -> Event t (p k v)

217+ -> EventWriterT t w m (DMap k (Compose ((,) (Event t w)) v'), Event t (p k (Compose ((,) (Event t w)) v')))

218+ )

219+ -> ((forall a. Compose ((,) (Event t w)) v' a -> v' a) -> p k (Compose ((,) (Event t w)) v') -> p k v')

220+ -> ((forall a. Compose ((,) (Event t w)) v' a -> Event t w) -> p k (Compose ((,) (Event t w)) v') -> p' (Some k) (Event t w))

221+ -> (Incremental t (p' (Some k) (Event t w)) -> Event t (PatchTarget (p' (Some k) w)))

222+ -> (Event t (p' (Some k) (Event t w)) -> Event t (p' (Some k) w))

223+ -> (forall a. k a -> v a -> EventWriterT t w m (v' a))

224+ -> DMap k v

225+ -> Event t (p k v)

226+ -> EventWriterT t w m (DMap k v', Event t (p k v'))

227+sequenceDMapWithAdjustEventWriterTWith base mapPatch weakenPatchWith mergePatchIncremental coincidencePatch f dm0 dm' = do

205228 let f' :: forall a. k a -> v a -> m (Compose ((,) (Event t w)) v' a)

206229 f' k v = Compose . swap <$> runEventWriterT (f k v)

207230 (children0, children') <- base f' dm0 dm'

@@ -211,26 +234,13 @@ sequenceDMapWithAdjustEventWriterTWith base mapPatch weakenPatchWith patchNewEle

211234 requests0 = weakenDMapWith (fst . getCompose) children0

212235 requests' :: Event t (p' (Some k) (Event t w))

213236 requests' = fforCheap children' $ weakenPatchWith $ fst . getCompose

214− childRequestMap :: Incremental t (p' (Some k) (Event t w)) <- holdIncremental requests0 requests'

215− tellEventsPromptly requests' patchNewElements $ mergePatchIncremental childRequestMap

237+ e <- switchHoldPromptOnlyIncremental mergePatchIncremental coincidencePatch requests0 requests'

238+ tellEvent $ fforMaybeCheap e $ \m ->

239+ case Map.elems m of

240+ [] -> Nothing

241+ h : t -> Just $ sconcat $ h :| t

216242 return (result0, result')

217243

218−tellEventsPromptly

219− :: ( Foldable f

220− , Reflex t

221− , MonadHold t m

222− , EventWriter t w m

223− )

224− => Event t a

225− -> (a -> [Event t w])

226− -> Event t (f w)

227− -> m ()

228−tellEventsPromptly requests' patchNewElements mergedChildRequestMap = do

229− let patch0 = fforMaybeCheap mergedChildRequestMap $ \m -> case toList m of

230− [] -> Nothing

231− h : t -> Just $ sconcat $ h :| t

232− tellEvent =<< switchHoldPromptOnly patch0 (fmapCheap (mconcat . patchNewElements) requests')

233−

234244instance PerformEvent t m => PerformEvent t (EventWriterT t w m) where

235245 type Performable (EventWriterT t w m) = Performable m

236246 performEvent_ = lift . performEvent_

src/Reflex/FunctorMaybe.hs+10

@@ -4,6 +4,10 @@ module Reflex.FunctorMaybe

44 ( FunctorMaybe (..)

55 ) where

7+import Data.IntMap (IntMap)

8+import qualified Data.IntMap as IntMap

9+import Data.Map (Map)

10+import qualified Data.Map as Map

711import Data.Maybe

812

913--TODO: See if there's a better class in the standard libraries already

@@ -31,3 +35,9 @@ instance FunctorMaybe Maybe where

3135-- | @fmapMaybe = mapMaybe@

3236instance FunctorMaybe [] where

3337 fmapMaybe = mapMaybe

38+

39+instance FunctorMaybe (Map k) where

40+ fmapMaybe = Map.mapMaybe

41+

42+instance FunctorMaybe IntMap where

43+ fmapMaybe = IntMap.mapMaybe

test/EventWriterT.hs+52−3

@@ -1,4 +1,5 @@

11{-# LANGUAGE FlexibleContexts #-}

2+{-# LANGUAGE GADTs #-}

23{-# LANGUAGE RecursiveDo #-}

34{-# LANGUAGE ScopedTypeVariables #-}

45module Main where

@@ -6,6 +7,9 @@ module Main where

67import Control.Lens

78import Control.Monad

89import Control.Monad.Fix

10+import qualified Data.Dependent.Map as DMap

11+import Data.Functor.Misc

12+import qualified Data.Map as M

913import Data.These

1014

1115import Reflex

@@ -28,6 +32,10 @@ main = do

2832 print os2

2933 os3@[[Nothing, Just [2]]] <- runApp' (unwrapApp testMoribundTellEvent) [Just ()]

3034 print os3

35+ os4@[[Nothing, Just [2]]] <- runApp' (unwrapApp testMoribundTellEventDMap) [Just ()]

36+ print os4

37+ os5@[[Nothing, Just [1, 2]]] <- runApp' (unwrapApp testLiveTellEventDMap) [Just ()]

38+ print os5

3139 return ()

3240

3341unwrapApp :: (Reflex t, Monad m) => (a -> EventWriterT t [Int] m ()) -> a -> m (Event t [Int])

@@ -59,7 +67,48 @@ testMoribundTellEvent

5967 => Event t ()

6068 -> EventWriterT t [Int] m ()

6169testMoribundTellEvent pulse = do

62− rec let tellIntOnReplce :: Int -> EventWriterT t [Int] m ()

63− tellIntOnReplce x = tellEvent $ [x] <$ rwrFinished

64− (_, rwrFinished) <- runWithReplace (tellIntOnReplce 1) $ tellIntOnReplce 2 <$ pulse

70+ rec let tellIntOnReplace :: Int -> EventWriterT t [Int] m ()

71+ tellIntOnReplace x = tellEvent $ [x] <$ rwrFinished

72+ (_, rwrFinished) <- runWithReplace (tellIntOnReplace 1) $ tellIntOnReplace 2 <$ pulse

73+ return ()

74+

75+-- | The equivalent of 'testMoribundTellEvent' for 'traverseDMapWithKeyWithAdjust'.

76+testMoribundTellEventDMap

77+ :: forall t m

78+ . ( Reflex t

79+ , Adjustable t m

80+ , MonadHold t m

81+ , MonadFix m

82+ )

83+ => Event t ()

84+ -> EventWriterT t [Int] m ()

85+testMoribundTellEventDMap pulse = do

86+ rec let tellIntOnReplace :: Int -> EventWriterT t [Int] m ()

87+ tellIntOnReplace x = tellEvent $ [x] <$ rwrFinished

88+ (_, rwrFinished :: Event t (PatchDMap (Const2 () Int) Identity)) <-

89+ traverseDMapWithKeyWithAdjust

90+ (\(Const2 ()) (Identity v) -> Identity . const v <$> tellIntOnReplace v)

91+ (mapToDMap $ M.singleton () 1)

92+ ((PatchDMap $ DMap.map (ComposeMaybe . Just) $ mapToDMap $ M.singleton () 2) <$ pulse)

93+ return ()

94+

95+-- | Ensures that elements which are _not_ removed can still fire 'tellEvent's

96+-- during the same frame as other elements are updated.

97+testLiveTellEventDMap

98+ :: forall t m

99+ . ( Reflex t

100+ , Adjustable t m

101+ , MonadHold t m

102+ , MonadFix m

103+ )

104+ => Event t ()

105+ -> EventWriterT t [Int] m ()

106+testLiveTellEventDMap pulse = do

107+ rec let tellIntOnReplace :: Int -> EventWriterT t [Int] m ()

108+ tellIntOnReplace x = tellEvent $ [x] <$ rwrFinished

109+ (_, rwrFinished :: Event t (PatchDMap (Const2 Int ()) Identity)) <-

110+ traverseDMapWithKeyWithAdjust

111+ (\(Const2 k) (Identity ()) -> Identity <$> tellIntOnReplace k)

112+ (mapToDMap $ M.singleton 1 ())

113+ ((PatchDMap $ DMap.map (ComposeMaybe . Just) $ mapToDMap $ M.singleton 2 ()) <$ pulse)

65114 return ()