64626cf · reflex · git.iko.soy

git.iko.soy/reflex

Fix traverse* Adjustable methods in EventWriterT

commit64626cf46f4121142cec220a1a7d5b7329886cf6 authorKen Micklas <ken.micklas@obsidian.systems> dateThu 25 Oct 2018, 17:07 (8 years ago) parent6ddfb78

3 files changed+75−31

compare with develop

unifiedsplit

src/Reflex/Class.hs+43 src/Reflex/EventWriter/Base.hs+22−31 src/Reflex/FunctorMaybe.hs+10

src/Reflex/Class.hs+43

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

4444 -- ** Combining 'Event's

4545 , leftmost

4646 , mergeMap

47+ , mergeIntMap

4748 , mergeMapIncremental

4849 , mergeMapIncrementalWithMove

4950 , mergeIntMapIncremental

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

6667 , switchHold

6768 , switchHoldPromptly

6869 , switchHoldPromptOnly

70+ , switchHoldPromptOnlyIncremental

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

7072 , tag

7173 , tagMaybe

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

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

782784mergeMap = fmap dmapToMap . merge . mapWithFunctorToDMap

783785

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

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

788+mergeIntMap = fmap dmapToIntMap . merge . intMapWithFunctorToDMap

789+

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

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

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

@@ -859,6 +865,43 @@ switchHoldPromptOnly e0 e' = do

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

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

861867

868+data ApplyElement p

869+ = Append (PatchTarget p)

870+ | Apply p

871+

872+-- | Like 'switchHoldPromptOnly' but for a patchable data structure of events.

873+switchHoldPromptOnlyIncremental

874+ :: forall t m p pt w

875+ . ( Reflex t

876+ , MonadHold t m

877+ , Functor p

878+ , Functor pt

879+ , FunctorMaybe pt

880+ , Monoid (pt (Maybe w))

881+ , Patch (p (Maybe w))

882+ , PatchTarget (p (Maybe w)) ~ pt (Maybe w)

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

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

885+ )

886+ => pt (Event t w)

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

888+ -> (p (Event t w) -> Event t (pt w))

889+ -> (Incremental t (p (Event t w)) -> Event t (pt w))

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

891+switchHoldPromptOnlyIncremental e0 ee mergePatchNewElements mergePatchIncremental = do

892+ let replaced :: Event t (p (Maybe w))

893+ replaced = fmap (const Nothing) <$> ee

894+ new :: Event t (pt (Maybe w))

895+ new = fmap (fmap Just) $ coincidence $ fmapCheap mergePatchNewElements ee

896+ held <- fmap (fmap Just) . mergePatchIncremental <$> holdIncremental e0 ee

897+ let e = mergeList [fmapCheap Append held, fmapCheap Apply replaced, fmapCheap Append new]

898+ return $ fmap (fmapMaybe id) $ ffor e $ \chain -> foldl applyElement mempty chain

899+ where

900+ applyElement :: pt (Maybe w) -> ApplyElement (p (Maybe w)) -> pt (Maybe w)

901+ applyElement pt = \case

902+ Append new -> new <> pt

903+ Apply p -> applyAlways p pt

904+

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

863906 nil = never

864907 align = alignEventWithMaybe Just

src/Reflex/EventWriter/Base.hs+22−31

@@ -4,6 +4,7 @@

44{-# LANGUAGE ExistentialQuantification #-}

55{-# LANGUAGE FlexibleInstances #-}

66{-# LANGUAGE GeneralizedNewtypeDeriving #-}

7+{-# LANGUAGE LambdaCase #-}

78{-# LANGUAGE MultiParamTypeClasses #-}

89{-# LANGUAGE Rank2Types #-}

910{-# LANGUAGE ScopedTypeVariables #-}

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

4041import Control.Monad.State.Strict

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

4243import qualified Data.Dependent.Map as DMap

43−import Data.Foldable

4444import Data.Functor.Compose

4545import Data.Functor.Misc

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

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

4848import qualified Data.IntMap.Strict as IntMap

4949import Data.List.NonEmpty (NonEmpty (..))

5050import Data.Map (Map)

51+import qualified Data.Map as Map

5152import Data.Semigroup

5253import Data.Some (Some)

5354import Data.Tuple

54−import Data.Type.Equality

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

5556

5657import Unsafe.Coerce

5758

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

135136

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

137138 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

139+ traverseIntMapWithKeyWithAdjust = sequenceIntMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseIntMapWithKeyWithAdjust f dm0 dm') (mergeIntMap . patchIntMapNewElementsMap) mergeIntIncremental

140+ traverseDMapWithKeyWithAdjust = sequenceDMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjust f dm0 dm') mapPatchDMap weakenPatchDMapWith (mergeMap . patchMapNewElementsMap) mergeMapIncremental

141+ traverseDMapWithKeyWithAdjustWithMove = sequenceDMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjustWithMove f dm0 dm') mapPatchDMapWithMove weakenPatchDMapWithMoveWith (mergeMap . patchMapWithMoveNewElementsMap) mergeMapIncrementalWithMove

141142

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

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

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

160161 return (fst result0, fmapCheap fst result')

161162

162163-- | 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+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), Patch (p (Maybe w)), PatchTarget (p (Maybe w)) ~ IntMap (Maybe w))

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

165166 -> IntMap v

166167 -> Event t (p v)

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

168169 )

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

170+ -> (p (Event t w) -> Event t (IntMap w))

170171 -> (Incremental t (p (Event t w)) -> Event t (IntMap w))

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

172173 -> IntMap v

173174 -> Event t (p v)

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

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

176+sequenceIntMapWithAdjustEventWriterTWith base mergePatchNewElements mergePatchIncremental f dm0 dm' = do

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

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

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

@@ -182,12 +183,15 @@ sequenceIntMapWithAdjustEventWriterTWith base patchNewElements mergePatchIncreme

182183 requests0 = fmap fst children0

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

184185 requests' = fmapCheap (fmap fst) children'

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

186− tellEventsPromptly requests' patchNewElements $ mergePatchIncremental childRequestMap

186+ e <- switchHoldPromptOnlyIncremental requests0 requests' mergePatchNewElements mergePatchIncremental

187+ tellEvent $ fforMaybeCheap e $ \m ->

188+ case IntMap.elems m of

189+ [] -> Nothing

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

187191 return (result0, result')

188192

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

194+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), GCompare k, PatchTarget (p' (Some k) w) ~ Map (Some k) w, Patch (p' (Some k) (Maybe w)), PatchTarget (p' (Some k) (Maybe w)) ~ Map (Some k) (Maybe w), Functor (p' (Some k)))

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

192196 -> DMap k v

193197 -> Event t (p k v)

@@ -195,13 +199,13 @@ sequenceDMapWithAdjustEventWriterTWith :: forall t m p p' w k v v'. (Reflex t, M

195199 )

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

197201 -> ((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])

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

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

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

201205 -> DMap k v

202206 -> Event t (p k v)

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

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

208+sequenceDMapWithAdjustEventWriterTWith base mapPatch weakenPatchWith mergePatchNewElements mergePatchIncremental f dm0 dm' = do

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

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

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

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

211215 requests0 = weakenDMapWith (fst . getCompose) children0

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

213217 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

218+ e <- switchHoldPromptOnlyIncremental requests0 requests' mergePatchNewElements mergePatchIncremental

219+ tellEvent $ fforMaybeCheap e $ \m ->

220+ case Map.elems m of

221+ [] -> Nothing

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

216223 return (result0, result')

217224

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−

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

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

236227 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