@@ -74,26 +74,19 @@ getQueryTLoweredResultValue (QueryTLoweredResult (v, _)) = v
7474getQueryTLoweredResultWritten :: QueryTLoweredResult t q v -> [Behavior t q]
7575getQueryTLoweredResultWritten (QueryTLoweredResult (_, w)) = w
7676
77−{-
78−let sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q
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−-}
77+maskMempty :: (Eq a, Monoid a) => a -> Maybe a
78+maskMempty x = if x == mempty then Nothing else Just x
8679
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
8881 runWithReplace (QueryT a0) a' = do
8982 ((r0, bs0), r') <- QueryT $ lift $ runWithReplace (runStateT a0 []) $ fmapCheap (flip runStateT [] . unQueryT) a'
9083 let sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q
9184 sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty
9285 bs' = fmapCheap snd $ r'
9386 bbs <- hold bs0 bs'
94− let patches = flip pushAlwaysCheap bs' $ \newBs -> do
87+ let patches = flip pushCheap bs' $ \newBs -> do
9588 oldBs <- sample bbs
96− (~~) <$> sampleBs newBs <*> sampleBs oldBs
89+ maskMempty <$> ((~~) <$> sampleBs newBs <*> sampleBs oldBs)
9790 QueryT $ modify $ (:) $ pull $ sampleBs =<< sample bbs
9891 QueryT $ lift $ tellEvent patches
9992 return (r0, fmapCheap fst r')
@@ -171,19 +164,19 @@ instance (Reflex t, MonadFix m, Group q, Additive q, Query q, MonadHold t m, Adj
171164 let p k bs = case Map.lookup k bs0 of
172165 Nothing -> case bs of
173166 -- 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
175168 -- 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
177170 Just oldBs -> case bs of
178171 -- 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
180173 -- 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
181174 -- composed with the sampling the child's new state.
182− Just newBs -> (~~) <$> sampleBs newBs <*> sampleBs oldBs
175+ Just newBs -> maskMempty <$> ((~~) <$> sampleBs newBs <*> sampleBs oldBs)
183176 -- we compute the patch by iterating over the update PatchMap and proceeding by cases. Then we fold over the
184177 -- child patches and wrap them in AdditivePatch.
185− patch <- AdditivePatch . fold <$> Map.traverseWithKey p bs'
186− return (apply pbs bs0, Just patch)
178+ patch <- fold <$> Map.traverseWithKey p bs'
179+ return (apply pbs bs0, AdditivePatch <$> patch)
187180 (qpatch :: Event t (AdditivePatch q)) <- mapAccumMaybeM_ accumBehaviors liftedBs0 liftedBs'
188181 tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch
189182 return (liftedResult0, liftedResult')
@@ -216,28 +209,28 @@ instance (Reflex t, MonadFix m, Group q, Additive q, Query q, MonadHold t m, Adj
216209 p k bs = case Map.lookup k bs0 of
217210 Nothing -> case MapWithMove._nodeInfo_from bs of
218211 -- 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
220213 -- 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
222215 MapWithMove.From_Move k' -> case Map.lookup k' bs0 of
223− Nothing -> return mempty
224− Just newBs -> sampleBs newBs
216+ Nothing -> return Nothing
217+ Just newBs -> maskMempty <$> sampleBs newBs
225218 Just oldBs -> case MapWithMove._nodeInfo_from bs of
226219 -- 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
228221 -- 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
229222 -- 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)
231224 MapWithMove.From_Move k'
232− | k' == k -> return mempty
225+ | k' == k -> return Nothing
233226 | otherwise -> case Map.lookup k' bs0 of
234227 -- If we are moving from a non-existent key, that is a delete
235− Nothing -> negateG <$> sampleBs oldBs
236− Just newBs -> (~~) <$> sampleBs newBs <*> sampleBs oldBs
228+ Nothing -> maskMempty . negateG <$> sampleBs oldBs
229+ Just newBs -> maskMempty <$> ((~~) <$> sampleBs newBs <*> sampleBs oldBs)
237230 -- we compute the patch by iterating over the update PatchMap and proceeding by cases. Then we fold over the
238231 -- child patches and wrap them in AdditivePatch.
239− patch <- AdditivePatch . fold <$> Map.traverseWithKey p bs'
240− return (apply pbs bs0, Just patch)
232+ patch <- fold <$> Map.traverseWithKey p bs'
233+ return (apply pbs bs0, AdditivePatch <$> patch)
241234 (qpatch :: Event t (AdditivePatch q)) <- mapAccumMaybeM_ accumBehaviors' liftedBs0 liftedBs'
242235 tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch
243236 return (liftedResult0, liftedResult')