86b821a · patch · git.iko.soy

git.iko.soy/patch

Merge pull request #203 from reflex-frp/queryt-optimization

86b821aAli Abrar8 years ago

ChangeLog.md+5−4

@@ -4,7 +4,8 @@

5* Deprecate FunctorMaybe in favor of Data.Witherable.Filterable. We still export fmapMaybe, ffilter, etc., but they all rely on Filterable now.

6* Rename MonadDynamicWriter to DynamicWriter and add a deprecation for the old name.

7−* Remove many deprecated functions

7+* Remove many deprecated functions.

8−* Add a Num instance for Dynamic

8+* Add a Num instance for Dynamic.

9−* Add matchRequestsWithResponses to make it easier to use Requester with protocols that don't do this matching for you

9+* Add matchRequestsWithResponses to make it easier to use Requester with protocols that don't do this matching for you.

10−* Add withRequesterT to map functions over the request and response of a RequesterT

10+* Add withRequesterT to map functions over the request and response of a RequesterT.

11+* Suppress nil patches in QueryT as an optimization. The Query type must now have an Eq instance.

src/Reflex/Query/Base.hs+22−29

@@ -74,26 +74,19 @@ getQueryTLoweredResultValue (QueryTLoweredResult (v, _)) = v

74getQueryTLoweredResultWritten :: QueryTLoweredResult t q v -> [Behavior t q]

75getQueryTLoweredResultWritten (QueryTLoweredResult (_, w)) = w

77−{-

77+maskMempty :: (Eq a, Monoid a) => a -> Maybe a

78−let sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q

78+maskMempty x = if x == mempty then Nothing else Just x

79− sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty

80− bs' = fmapCheap snd $ r'

81− patches = unsafeBuildIncremental (sampleBs bs0) $

82− flip pushCheap bs' $ \bs -> do

83− p <- (~~) <$> sampleBs bs <*> sample (currentIncremental patches)

84− return (Just (AdditivePatch p))

85−-}

87−instance (Reflex t, MonadFix m, Group q, Additive q, Query q, MonadHold t m, Adjustable t m) => Adjustable t (QueryT t q m) where

80+instance (Reflex t, MonadFix m, Group q, Additive q, Query q, Eq q, MonadHold t m, Adjustable t m) => Adjustable t (QueryT t q m) where

88 runWithReplace (QueryT a0) a' = do

81 runWithReplace (QueryT a0) a' = do

89 ((r0, bs0), r') <- QueryT $ lift $ runWithReplace (runStateT a0 []) $ fmapCheap (flip runStateT [] . unQueryT) a'

82 ((r0, bs0), r') <- QueryT $ lift $ runWithReplace (runStateT a0 []) $ fmapCheap (flip runStateT [] . unQueryT) a'

90 let sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q

83 let sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q

91 sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty

84 sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty

92 bs' = fmapCheap snd $ r'

85 bs' = fmapCheap snd $ r'

93 bbs <- hold bs0 bs'

86 bbs <- hold bs0 bs'

94− let patches = flip pushAlwaysCheap bs' $ \newBs -> do

87+ let patches = flip pushCheap bs' $ \newBs -> do

95 oldBs <- sample bbs

88 oldBs <- sample bbs

96− (~~) <$> sampleBs newBs <*> sampleBs oldBs

89+ maskMempty <$> ((~~) <$> sampleBs newBs <*> sampleBs oldBs)

97 QueryT $ modify $ (:) $ pull $ sampleBs =<< sample bbs

90 QueryT $ modify $ (:) $ pull $ sampleBs =<< sample bbs

98 QueryT $ lift $ tellEvent patches

91 QueryT $ lift $ tellEvent patches

99 return (r0, fmapCheap fst r')

92 return (r0, fmapCheap fst r')

@@ -171,19 +164,19 @@ instance (Reflex t, MonadFix m, Group q, Additive q, Query q, MonadHold t m, Adj

171 let p k bs = case Map.lookup k bs0 of

164 let p k bs = case Map.lookup k bs0 of

172 Nothing -> case bs of

165 Nothing -> case bs of

173 -- If the update is to delete the state for a child that doesn't exist, the patch is mempty.

166 -- If the update is to delete the state for a child that doesn't exist, the patch is mempty.

174− Nothing -> return mempty

167+ Nothing -> return Nothing

175 -- If the update is to update the state for a child that doesn't exist, the patch is the sample of the new state.

168 -- If the update is to update the state for a child that doesn't exist, the patch is the sample of the new state.

176− Just newBs -> sampleBs newBs

169+ Just newBs -> maskMempty <$> sampleBs newBs

177 Just oldBs -> case bs of

170 Just oldBs -> case bs of

178 -- If the update is to delete the state for a child that already exists, the patch is the negation of the child's current state

171 -- If the update is to delete the state for a child that already exists, the patch is the negation of the child's current state

179− Nothing -> negateG <$> sampleBs oldBs

172+ Nothing -> maskMempty . negateG <$> sampleBs oldBs

180 -- If the update is to update the state for a child that already exists, the patch is the negation of sampling the child's current state

173 -- If the update is to update the state for a child that already exists, the patch is the negation of sampling the child's current state

181 -- composed with the sampling the child's new state.

174 -- composed with the sampling the child's new state.

182− Just newBs -> (~~) <$> sampleBs newBs <*> sampleBs oldBs

175+ Just newBs -> maskMempty <$> ((~~) <$> sampleBs newBs <*> sampleBs oldBs)

183 -- we compute the patch by iterating over the update PatchMap and proceeding by cases. Then we fold over the

176 -- we compute the patch by iterating over the update PatchMap and proceeding by cases. Then we fold over the

184 -- child patches and wrap them in AdditivePatch.

177 -- child patches and wrap them in AdditivePatch.

185− patch <- AdditivePatch . fold <$> Map.traverseWithKey p bs'

178+ patch <- fold <$> Map.traverseWithKey p bs'

186− return (apply pbs bs0, Just patch)

179+ return (apply pbs bs0, AdditivePatch <$> patch)

187 (qpatch :: Event t (AdditivePatch q)) <- mapAccumMaybeM_ accumBehaviors liftedBs0 liftedBs'

180 (qpatch :: Event t (AdditivePatch q)) <- mapAccumMaybeM_ accumBehaviors liftedBs0 liftedBs'

188 tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch

181 tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch

189 return (liftedResult0, liftedResult')

182 return (liftedResult0, liftedResult')

@@ -216,28 +209,28 @@ instance (Reflex t, MonadFix m, Group q, Additive q, Query q, MonadHold t m, Adj

216 p k bs = case Map.lookup k bs0 of

209 p k bs = case Map.lookup k bs0 of

217 Nothing -> case MapWithMove._nodeInfo_from bs of

210 Nothing -> case MapWithMove._nodeInfo_from bs of

218 -- If the update is to delete the state for a child that doesn't exist, the patch is mempty.

211 -- If the update is to delete the state for a child that doesn't exist, the patch is mempty.

219− MapWithMove.From_Delete -> return mempty

212+ MapWithMove.From_Delete -> return Nothing

220 -- If the update is to update the state for a child that doesn't exist, the patch is the sample of the new state.

213 -- If the update is to update the state for a child that doesn't exist, the patch is the sample of the new state.

221− MapWithMove.From_Insert newBs -> sampleBs newBs

214+ MapWithMove.From_Insert newBs -> maskMempty <$> sampleBs newBs

222 MapWithMove.From_Move k' -> case Map.lookup k' bs0 of

215 MapWithMove.From_Move k' -> case Map.lookup k' bs0 of

223− Nothing -> return mempty

216+ Nothing -> return Nothing

224− Just newBs -> sampleBs newBs

217+ Just newBs -> maskMempty <$> sampleBs newBs

225 Just oldBs -> case MapWithMove._nodeInfo_from bs of

218 Just oldBs -> case MapWithMove._nodeInfo_from bs of

226 -- If the update is to delete the state for a child that already exists, the patch is the negation of the child's current state

219 -- If the update is to delete the state for a child that already exists, the patch is the negation of the child's current state

227− MapWithMove.From_Delete -> negateG <$> sampleBs oldBs

220+ MapWithMove.From_Delete -> maskMempty . negateG <$> sampleBs oldBs

228 -- If the update is to update the state for a child that already exists, the patch is the negation of sampling the child's current state

221 -- If the update is to update the state for a child that already exists, the patch is the negation of sampling the child's current state

229 -- composed with the sampling the child's new state.

222 -- composed with the sampling the child's new state.

230− MapWithMove.From_Insert newBs -> (~~) <$> sampleBs newBs <*> sampleBs oldBs

223+ MapWithMove.From_Insert newBs -> maskMempty <$> ((~~) <$> sampleBs newBs <*> sampleBs oldBs)

231 MapWithMove.From_Move k'

224 MapWithMove.From_Move k'

232− | k' == k -> return mempty

225+ | k' == k -> return Nothing

233 | otherwise -> case Map.lookup k' bs0 of

226 | otherwise -> case Map.lookup k' bs0 of

234 -- If we are moving from a non-existent key, that is a delete

227 -- If we are moving from a non-existent key, that is a delete

235− Nothing -> negateG <$> sampleBs oldBs

228+ Nothing -> maskMempty . negateG <$> sampleBs oldBs

236− Just newBs -> (~~) <$> sampleBs newBs <*> sampleBs oldBs

229+ Just newBs -> maskMempty <$> ((~~) <$> sampleBs newBs <*> sampleBs oldBs)

237 -- we compute the patch by iterating over the update PatchMap and proceeding by cases. Then we fold over the

230 -- we compute the patch by iterating over the update PatchMap and proceeding by cases. Then we fold over the

238 -- child patches and wrap them in AdditivePatch.

231 -- child patches and wrap them in AdditivePatch.

239− patch <- AdditivePatch . fold <$> Map.traverseWithKey p bs'

232+ patch <- fold <$> Map.traverseWithKey p bs'

240− return (apply pbs bs0, Just patch)

233+ return (apply pbs bs0, AdditivePatch <$> patch)

241 (qpatch :: Event t (AdditivePatch q)) <- mapAccumMaybeM_ accumBehaviors' liftedBs0 liftedBs'

234 (qpatch :: Event t (AdditivePatch q)) <- mapAccumMaybeM_ accumBehaviors' liftedBs0 liftedBs'

242 tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch

235 tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch

243 return (liftedResult0, liftedResult')

236 return (liftedResult0, liftedResult')