64626cf · patch · git.iko.soy

git.iko.soy/patch

on develop help sign in

Fix traverse* Adjustable methods in EventWriterT

64626cfKen Micklas8 years ago

src/Reflex/Class.hs+43

compare with develop

unifiedsplit

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

44 -- ** Combining 'Event's

45 , leftmost

46 , mergeMap

47+ , mergeIntMap

47 , mergeMapIncremental

48 , mergeMapIncremental

48 , mergeMapIncrementalWithMove

49 , mergeMapIncrementalWithMove

49 , mergeIntMapIncremental

50 , mergeIntMapIncremental

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

66 , switchHold

67 , switchHold

67 , switchHoldPromptly

68 , switchHoldPromptly

68 , switchHoldPromptOnly

69 , switchHoldPromptOnly

70+ , switchHoldPromptOnlyIncremental

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

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

70 , tag

72 , tag

71 , tagMaybe

73 , tagMaybe

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

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

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

782mergeMap = fmap dmapToMap . merge . mapWithFunctorToDMap

784mergeMap = fmap dmapToMap . merge . mapWithFunctorToDMap

783

785

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+

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

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

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

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

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

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

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

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

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

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

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

861

867

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+

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

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

863 nil = never

906 nil = never

864 align = alignEventWithMaybe Just

907 align = alignEventWithMaybe Just

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

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

4{-# LANGUAGE ExistentialQuantification #-}

5{-# LANGUAGE FlexibleInstances #-}

6{-# LANGUAGE GeneralizedNewtypeDeriving #-}

7+{-# LANGUAGE LambdaCase #-}

7{-# LANGUAGE MultiParamTypeClasses #-}

8{-# LANGUAGE MultiParamTypeClasses #-}

8{-# LANGUAGE Rank2Types #-}

9{-# LANGUAGE Rank2Types #-}

9{-# LANGUAGE ScopedTypeVariables #-}

10{-# LANGUAGE ScopedTypeVariables #-}

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

40import Control.Monad.State.Strict

41import Control.Monad.State.Strict

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

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

42import qualified Data.Dependent.Map as DMap

43import qualified Data.Dependent.Map as DMap

43−import Data.Foldable

44import Data.Functor.Compose

45import Data.Functor.Misc

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

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

48import qualified Data.IntMap.Strict as IntMap

49import Data.List.NonEmpty (NonEmpty (..))

50import Data.Map (Map)

51+import qualified Data.Map as Map

51import Data.Semigroup

52import Data.Semigroup

52import Data.Some (Some)

53import Data.Some (Some)

53import Data.Tuple

54import Data.Tuple

54−import Data.Type.Equality

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

56import Unsafe.Coerce

57import Unsafe.Coerce

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

135

136

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

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

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

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

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

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

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

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

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

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

141

142

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

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

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

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

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

160 return (fst result0, fmapCheap fst result')

161 return (fst result0, fmapCheap fst result')

161

162

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

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

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

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

165 -> IntMap v

166 -> IntMap v

166 -> Event t (p v)

167 -> Event t (p v)

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

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

168 )

169 )

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

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

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

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

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

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

172 -> IntMap v

173 -> IntMap v

173 -> Event t (p v)

174 -> Event t (p v)

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

175 -> 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

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

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

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

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

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

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

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

182 requests0 = fmap fst children0

183 requests0 = fmap fst children0

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

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

184 requests' = fmapCheap (fmap fst) children'

185 requests' = fmapCheap (fmap fst) children'

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

186+ e <- switchHoldPromptOnlyIncremental requests0 requests' mergePatchNewElements mergePatchIncremental

186− tellEventsPromptly requests' patchNewElements $ mergePatchIncremental childRequestMap

187+ tellEvent $ fforMaybeCheap e $ \m ->

188+ case IntMap.elems m of

189+ [] -> Nothing

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

187 return (result0, result')

191 return (result0, result')

188

192

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

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

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

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

192 -> DMap k v

196 -> DMap k v

193 -> Event t (p k v)

197 -> Event t (p k v)

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

195 )

199 )

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

200 -> ((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))

201 -> ((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)))

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

203 -> (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))

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

201 -> DMap k v

205 -> DMap k v

202 -> Event t (p k v)

206 -> Event t (p k v)

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

207 -> 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

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

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

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

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

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

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

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

211 requests0 = weakenDMapWith (fst . getCompose) children0

215 requests0 = weakenDMapWith (fst . getCompose) children0

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

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

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

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

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

218+ e <- switchHoldPromptOnlyIncremental requests0 requests' mergePatchNewElements mergePatchIncremental

215− tellEventsPromptly requests' patchNewElements $ mergePatchIncremental childRequestMap

219+ tellEvent $ fforMaybeCheap e $ \m ->

220+ case Map.elems m of

221+ [] -> Nothing

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

216 return (result0, result')

223 return (result0, result')

217

224

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−

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

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

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

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

236 performEvent_ = lift . performEvent_

227 performEvent_ = lift . performEvent_

src/Reflex/FunctorMaybe.hs+10

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

4 ( FunctorMaybe (..)

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

7import Data.Maybe

11import Data.Maybe

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

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

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

31-- | @fmapMaybe = mapMaybe@

35-- | @fmapMaybe = mapMaybe@

32instance FunctorMaybe [] where

36instance FunctorMaybe [] where

33 fmapMaybe = mapMaybe

37 fmapMaybe = mapMaybe

38+

39+instance FunctorMaybe (Map k) where

40+ fmapMaybe = Map.mapMaybe

41+

42+instance FunctorMaybe IntMap where

43+ fmapMaybe = IntMap.mapMaybe