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