@@ -29,6 +29,8 @@ import qualified Data.Dependent.Map as DMap
2929import Data.Foldable
3030import Data.Functor.Compose
3131import Data.Functor.Misc
32+import Data.IntMap (IntMap)
33+import qualified Data.IntMap as IntMap
3234import Data.Map (Map)
3335import qualified Data.Map as Map
3436import Data.Monoid ((<>))
@@ -88,6 +90,52 @@ instance (Reflex t, MonadFix m, Group q, Additive q, Query q, MonadHold t m, Adj
8890 QueryT $ modify $ (:) $ pull $ sampleBs =<< sample bbs
8991 QueryT $ lift $ tellEvent patches
9092 return (r0, fmapCheap fst r')
93+
94+ traverseIntMapWithKeyWithAdjust :: forall v v'. (IntMap.Key -> v -> QueryT t q m v') -> IntMap v -> Event t (PatchIntMap v) -> QueryT t q m (IntMap v', Event t (PatchIntMap v'))
95+ traverseIntMapWithKeyWithAdjust f im0 im' = do
96+ let f' :: IntMap.Key -> v -> EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m) (QueryTLoweredResult t q v')
97+ f' k v = fmap QueryTLoweredResult $ flip runStateT [] $ unQueryT $ f k v
98+ (result0, result') <- QueryT $ lift $ traverseIntMapWithKeyWithAdjust f' im0 im'
99+ let liftedResult0 = IntMap.map (\r -> getQueryTLoweredResultValue r) result0
100+ liftedResult' = fforCheap result' $ \(PatchIntMap p) -> PatchIntMap $
101+ IntMap.map (\mr -> fmap getQueryTLoweredResultValue mr) p
102+ liftedBs0 :: IntMap [Behavior t q]
103+ liftedBs0 = IntMap.map (\r -> getQueryTLoweredResultWritten r) result0
104+ liftedBs' :: Event t (PatchIntMap [Behavior t q])
105+ liftedBs' = fforCheap result' $ \(PatchIntMap p) -> PatchIntMap $
106+ IntMap.map (\mr -> fmap getQueryTLoweredResultWritten mr) p
107+ sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q
108+ sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty
109+ accumBehaviors :: forall m'. MonadHold t m'
110+ => IntMap [Behavior t q]
111+ -> PatchIntMap [Behavior t q]
112+ -> m' ( Maybe (IntMap [Behavior t q])
113+ , Maybe (AdditivePatch q))
114+ -- f accumulates the child behavior state we receive from running traverseIntMapWithKeyWithAdjust for the underlying monad.
115+ -- When an update occurs, it also computes a patch to communicate to the parent QueryT state.
116+ -- bs0 is a Map denoting the behaviors of the current children.
117+ -- pbs is a PatchMap denoting an update to the behaviors of the current children
118+ accumBehaviors bs0 pbs@(PatchIntMap bs') = do
119+ let p k bs = case IntMap.lookup k bs0 of
120+ Nothing -> case bs of
121+ -- If the update is to delete the state for a child that doesn't exist, the patch is mempty.
122+ Nothing -> return mempty
123+ -- If the update is to update the state for a child that doesn't exist, the patch is the sample of the new state.
124+ Just newBs -> sampleBs newBs
125+ Just oldBs -> case bs of
126+ -- 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
127+ Nothing -> negateG <$> sampleBs oldBs
128+ -- 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
129+ -- composed with the sampling the child's new state.
130+ Just newBs -> (~~) <$> sampleBs newBs <*> sampleBs oldBs
131+ -- we compute the patch by iterating over the update PatchMap and proceeding by cases. Then we fold over the
132+ -- child patches and wrap them in AdditivePatch.
133+ patch <- AdditivePatch . fold <$> IntMap.traverseWithKey p bs'
134+ return (apply pbs bs0, Just patch)
135+ (qpatch :: Event t (AdditivePatch q)) <- mapAccumMaybeM_ accumBehaviors liftedBs0 liftedBs'
136+ tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch
137+ return (liftedResult0, liftedResult')
138+
91139 traverseDMapWithKeyWithAdjust :: forall (k :: * -> *) v v'. (DMap.GCompare k) => (forall a. k a -> v a -> QueryT t q m (v' a)) -> DMap k v -> Event t (PatchDMap k v) -> QueryT t q m (DMap k v', Event t (PatchDMap k v'))
92140 traverseDMapWithKeyWithAdjust f dm0 dm' = do
93141 let f' :: forall a. k a -> v a -> EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m) (Compose (QueryTLoweredResult t q) v' a)
@@ -132,6 +180,7 @@ instance (Reflex t, MonadFix m, Group q, Additive q, Query q, MonadHold t m, Adj
132180 (qpatch :: Event t (AdditivePatch q)) <- mapAccumMaybeM_ accumBehaviors liftedBs0 liftedBs'
133181 tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch
134182 return (liftedResult0, liftedResult')
183+
135184 traverseDMapWithKeyWithAdjustWithMove :: forall (k :: * -> *) v v'. (DMap.GCompare k) => (forall a. k a -> v a -> QueryT t q m (v' a)) -> DMap k v -> Event t (PatchDMapWithMove k v) -> QueryT t q m (DMap k v', Event t (PatchDMapWithMove k v'))
136185 traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = do
137186 let f' :: forall a. k a -> v a -> EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m) (Compose (QueryTLoweredResult t q) v' a)