538e879 · patch · git.iko.soy

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

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

66

67−{-

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

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

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

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−-}

76

69

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

78 runWithReplace (QueryT a0) a' = do

71 runWithReplace (QueryT a0) a' = do

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

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

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

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

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

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

82 bs' = fmapCheap snd $ r'

75 bs' = fmapCheap snd $ r'

83 bbs <- hold bs0 bs'

76 bbs <- hold bs0 bs'

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

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

85 oldBs <- sample bbs

78 oldBs <- sample bbs

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

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

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

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

88 QueryT $ lift $ tellEvent patches

81 QueryT $ lift $ tellEvent patches

89 return (r0, fmapCheap fst r')

82 return (r0, fmapCheap fst r')

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

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

116 Nothing -> case bs of

109 Nothing -> case bs of

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

110 -- 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

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

112 -- 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

121 Just oldBs -> case bs of

114 Just oldBs -> case bs of

122 -- 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

115 -- 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

124 -- 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

117 -- 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

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

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

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

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

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

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

128 -- child patches and wrap them in AdditivePatch.

121 -- child patches and wrap them in AdditivePatch.

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

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

130− return (apply pbs bs0, Just patch)

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

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

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

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

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

133 return (liftedResult0, liftedResult')

126 return (liftedResult0, liftedResult')

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

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

160 Nothing -> case MapWithMove._nodeInfo_from bs of

153 Nothing -> case MapWithMove._nodeInfo_from bs of

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

154 -- 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

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

156 -- 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

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

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

166− Nothing -> return mempty

159+ Nothing -> return Nothing

167− Just newBs -> sampleBs newBs

160+ Just newBs -> Just <$> sampleBs newBs

168 Just oldBs -> case MapWithMove._nodeInfo_from bs of

161 Just oldBs -> case MapWithMove._nodeInfo_from bs of

169 -- 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

162 -- 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

171 -- 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

164 -- 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

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

165 -- 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)

174 MapWithMove.From_Move k'

167 MapWithMove.From_Move k'

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

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

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

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

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

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

178− Nothing -> negateG <$> sampleBs oldBs

171+ Nothing -> Just . negateG <$> sampleBs oldBs

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

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

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

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

181 -- child patches and wrap them in AdditivePatch.

174 -- child patches and wrap them in AdditivePatch.

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

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

183− return (apply pbs bs0, Just patch)

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

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

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

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

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

186 return (liftedResult0, liftedResult')

179 return (liftedResult0, liftedResult')