@@ -64,26 +64,19 @@ getQueryTLoweredResultValue (QueryTLoweredResult (v, _)) = v
6464getQueryTLoweredResultWritten :: QueryTLoweredResult t q v -> [Behavior t q]
6565getQueryTLoweredResultWritten (QueryTLoweredResult (_, w)) = w
6666
67−{-
68−let sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q
69− sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty
70− bs' = fmapCheap snd $ r'
71− patches = unsafeBuildIncremental (sampleBs bs0) $
72− flip pushCheap bs' $ \bs -> do
73− p <- (~~) <$> sampleBs bs <*> sample (currentIncremental patches)
74− return (Just (AdditivePatch p))
75−-}
67+maskMempty :: (Eq a, Monoid a) => a -> Maybe a
68+maskMempty x = if x == mempty then Nothing else Just x
7669
77−instance (Reflex t, MonadFix m, Group q, Additive q, Query q, MonadHold t m, Adjustable t m) => Adjustable t (QueryT t q m) where
70+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
7871 runWithReplace (QueryT a0) a' = do
7972 ((r0, bs0), r') <- QueryT $ lift $ runWithReplace (runStateT a0 []) $ fmapCheap (flip runStateT [] . unQueryT) a'
8073 let sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q
8174 sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty
8275 bs' = fmapCheap snd $ r'
8376 bbs <- hold bs0 bs'
84− let patches = flip pushAlwaysCheap bs' $ \newBs -> do
77+ let patches = flip pushCheap bs' $ \newBs -> do
8578 oldBs <- sample bbs
86− (~~) <$> sampleBs newBs <*> sampleBs oldBs
79+ maskMempty <$> ((~~) <$> sampleBs newBs <*> sampleBs oldBs)
8780 QueryT $ modify $ (:) $ pull $ sampleBs =<< sample bbs
8881 QueryT $ lift $ tellEvent patches
8982 return (r0, fmapCheap fst r')
@@ -115,19 +108,19 @@ instance (Reflex t, MonadFix m, Group q, Additive q, Query q, MonadHold t m, Adj
115108 let p k bs = case Map.lookup k bs0 of
116109 Nothing -> case bs of
117110 -- If the update is to delete the state for a child that doesn't exist, the patch is mempty.
118− Nothing -> return mempty
111+ Nothing -> return Nothing
119112 -- If the update is to update the state for a child that doesn't exist, the patch is the sample of the new state.
120− Just newBs -> sampleBs newBs
113+ Just newBs -> Just <$> sampleBs newBs
121114 Just oldBs -> case bs of
122115 -- 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
123− Nothing -> negateG <$> sampleBs oldBs
116+ Nothing -> Just . negateG <$> sampleBs oldBs
124117 -- 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
125118 -- composed with the sampling the child's new state.
126− Just newBs -> (~~) <$> sampleBs newBs <*> sampleBs oldBs
119+ Just newBs -> maskMempty <$> ((~~) <$> sampleBs newBs <*> sampleBs oldBs)
127120 -- we compute the patch by iterating over the update PatchMap and proceeding by cases. Then we fold over the
128121 -- child patches and wrap them in AdditivePatch.
129− patch <- AdditivePatch . fold <$> Map.traverseWithKey p bs'
130− return (apply pbs bs0, Just patch)
122+ patch <- fold <$> Map.traverseWithKey p bs'
123+ return (apply pbs bs0, AdditivePatch <$> patch)
131124 (qpatch :: Event t (AdditivePatch q)) <- mapAccumMaybeM_ accumBehaviors liftedBs0 liftedBs'
132125 tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch
133126 return (liftedResult0, liftedResult')
@@ -159,28 +152,28 @@ instance (Reflex t, MonadFix m, Group q, Additive q, Query q, MonadHold t m, Adj
159152 p k bs = case Map.lookup k bs0 of
160153 Nothing -> case MapWithMove._nodeInfo_from bs of
161154 -- If the update is to delete the state for a child that doesn't exist, the patch is mempty.
162− MapWithMove.From_Delete -> return mempty
155+ MapWithMove.From_Delete -> return Nothing
163156 -- If the update is to update the state for a child that doesn't exist, the patch is the sample of the new state.
164− MapWithMove.From_Insert newBs -> sampleBs newBs
157+ MapWithMove.From_Insert newBs -> Just <$> sampleBs newBs
165158 MapWithMove.From_Move k' -> case Map.lookup k' bs0 of
166− Nothing -> return mempty
167− Just newBs -> sampleBs newBs
159+ Nothing -> return Nothing
160+ Just newBs -> Just <$> sampleBs newBs
168161 Just oldBs -> case MapWithMove._nodeInfo_from bs of
169162 -- 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
170− MapWithMove.From_Delete -> negateG <$> sampleBs oldBs
163+ MapWithMove.From_Delete -> Just . negateG <$> sampleBs oldBs
171164 -- 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
172165 -- composed with the sampling the child's new state.
173− MapWithMove.From_Insert newBs -> (~~) <$> sampleBs newBs <*> sampleBs oldBs
166+ MapWithMove.From_Insert newBs -> maskMempty <$> ((~~) <$> sampleBs newBs <*> sampleBs oldBs)
174167 MapWithMove.From_Move k'
175− | k' == k -> return mempty
168+ | k' == k -> return Nothing
176169 | otherwise -> case Map.lookup k' bs0 of
177170 -- If we are moving from a non-existent key, that is a delete
178− Nothing -> negateG <$> sampleBs oldBs
179− Just newBs -> (~~) <$> sampleBs newBs <*> sampleBs oldBs
171+ Nothing -> Just . negateG <$> sampleBs oldBs
172+ Just newBs -> maskMempty <$> ((~~) <$> sampleBs newBs <*> sampleBs oldBs)
180173 -- we compute the patch by iterating over the update PatchMap and proceeding by cases. Then we fold over the
181174 -- child patches and wrap them in AdditivePatch.
182− patch <- AdditivePatch . fold <$> Map.traverseWithKey p bs'
183− return (apply pbs bs0, Just patch)
175+ patch <- fold <$> Map.traverseWithKey p bs'
176+ return (apply pbs bs0, AdditivePatch <$> patch)
184177 (qpatch :: Event t (AdditivePatch q)) <- mapAccumMaybeM_ accumBehaviors' liftedBs0 liftedBs'
185178 tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch
186179 return (liftedResult0, liftedResult')