@@ -7,7 +7,14 @@
7{-# LANGUAGE ScopedTypeVariables #-}
7{-# LANGUAGE ScopedTypeVariables #-}
8{-# LANGUAGE TypeFamilies #-}
8{-# LANGUAGE TypeFamilies #-}
9{-# LANGUAGE UndecidableInstances #-}
9{-# LANGUAGE UndecidableInstances #-}
10−module Reflex.Query.Base where
10+module Reflex.Query.Base
12import Control.Monad.Exception
19import Control.Monad.Exception
13import Control.Monad.Fix
20import Control.Monad.Fix
@@ -44,16 +51,22 @@ newtype QueryT t q m a = QueryT { unQueryT :: StateT [Behavior t q] (EventWriter
44runQueryT :: (MonadFix m, Additive q, Group q, Reflex t) => QueryT t q m a -> Dynamic t (QueryResult q) -> m (a, Incremental t (AdditivePatch q))
51runQueryT :: (MonadFix m, Additive q, Group q, Reflex t) => QueryT t q m a -> Dynamic t (QueryResult q) -> m (a, Incremental t (AdditivePatch q))
45runQueryT (QueryT a) qr = do
52runQueryT (QueryT a) qr = do
46 ((r, bs), es) <- runReaderT (runEventWriterT (runStateT a mempty)) qr
53 ((r, bs), es) <- runReaderT (runEventWriterT (runStateT a mempty)) qr
47− return (r, unsafeBuildIncremental (foldlM (\b c -> fmap (b <>) $ sample c) mempty bs) (fmapCheap AdditivePatch es))
54+ return (r, unsafeBuildIncremental (foldlM (\b c -> (b <>) <$> sample c) mempty bs) (fmapCheap AdditivePatch es))
49newtype QueryTLoweredResult t q v = QueryTLoweredResult (v, [Behavior t q])
56newtype QueryTLoweredResult t q v = QueryTLoweredResult (v, [Behavior t q])
58+getQueryTLoweredResultValue :: QueryTLoweredResult t q v -> v
59+getQueryTLoweredResultValue (QueryTLoweredResult (v, _)) = v
61+getQueryTLoweredResultWritten :: QueryTLoweredResult t q v -> [Behavior t q]
62+getQueryTLoweredResultWritten (QueryTLoweredResult (_, w)) = w
51instance (Reflex t, MonadFix m, Group q, Additive q, Query q, MonadHold t m, MonadAdjust t m) => MonadAdjust t (QueryT t q m) where
64instance (Reflex t, MonadFix m, Group q, Additive q, Query q, MonadHold t m, MonadAdjust t m) => MonadAdjust t (QueryT t q m) where
52 runWithReplace (QueryT a0) a' = do
65 runWithReplace (QueryT a0) a' = do
53 ((r0, bs0), r') <- QueryT $ lift $ runWithReplace (runStateT a0 []) $ fmapCheap (flip runStateT [] . unQueryT) a'
66 ((r0, bs0), r') <- QueryT $ lift $ runWithReplace (runStateT a0 []) $ fmapCheap (flip runStateT [] . unQueryT) a'
54 tellQueryIncremental $
67 tellQueryIncremental $
55 let sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q
68 let sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q
56− sampleBs = foldlM (\b a -> fmap (b <>) $ sample a) mempty
69+ sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty
57 bs' = fmapCheap snd $ r'
70 bs' = fmapCheap snd $ r'
58 patches = unsafeBuildIncremental (sampleBs bs0) $
71 patches = unsafeBuildIncremental (sampleBs bs0) $
59 flip pushCheap bs' $ \bs -> do
72 flip pushCheap bs' $ \bs -> do
@@ -63,32 +76,30 @@ instance (Reflex t, MonadFix m, Group q, Additive q, Query q, MonadHold t m, Mon
63 return (r0, fmapCheap fst r')
76 return (r0, fmapCheap fst r')
64 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'))
77 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'))
65 traverseDMapWithKeyWithAdjust f dm0 dm' = do
78 traverseDMapWithKeyWithAdjust f dm0 dm' = do
66− let f' :: forall a. k a -> v a -> EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m) (Compose (QueryTLoweredResult t q) v' a)
79+ let f' :: forall a. k a -> v a -> EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m) (Compose (QueryTLoweredResult t q) v' a)
67 f' k v = fmap (Compose . QueryTLoweredResult) $ flip runStateT [] $ unQueryT $ f k v
80 f' k v = fmap (Compose . QueryTLoweredResult) $ flip runStateT [] $ unQueryT $ f k v
68− (result0, result') <- QueryT $ lift $ traverseDMapWithKeyWithAdjust f' dm0 dm'
81+ (result0, result') <- QueryT $ lift $ traverseDMapWithKeyWithAdjust f' dm0 dm'
69− let getValue (QueryTLoweredResult (v, _)) = v
70− getWritten (QueryTLoweredResult (_, w)) = w
71− liftedResult0 = mapKeyValuePairsMonotonic (\(k :=> Compose r) -> k :=> getValue r) result0
82+ let liftedResult0 = mapKeyValuePairsMonotonic (\(k :=> Compose r) -> k :=> getQueryTLoweredResultValue r) result0
72 liftedResult' = fforCheap result' $ \(PatchDMap p) -> PatchDMap $
83 liftedResult' = fforCheap result' $ \(PatchDMap p) -> PatchDMap $
73− mapKeyValuePairsMonotonic (\(k :=> ComposeMaybe mr) -> k :=> ComposeMaybe (fmap (getValue . getCompose) mr)) p
84+ mapKeyValuePairsMonotonic (\(k :=> ComposeMaybe mr) -> k :=> ComposeMaybe (fmap (getQueryTLoweredResultValue . getCompose) mr)) p
74 liftedBs0 :: Map (Some k) [Behavior t q]
85 liftedBs0 :: Map (Some k) [Behavior t q]
75− liftedBs0 = Map.fromDistinctAscList $ (\(k :=> Compose r) -> (Some.This k, getWritten r)) <$> DMap.toList result0
86+ liftedBs0 = Map.fromDistinctAscList $ (\(k :=> Compose r) -> (Some.This k, getQueryTLoweredResultWritten r)) <$> DMap.toList result0
76 liftedBs' :: Event t (PatchMap (Some k) [Behavior t q])
87 liftedBs' :: Event t (PatchMap (Some k) [Behavior t q])
77 liftedBs' = fforCheap result' $ \(PatchDMap p) -> PatchMap $
88 liftedBs' = fforCheap result' $ \(PatchDMap p) -> PatchMap $
78− Map.fromDistinctAscList $ (\(k :=> ComposeMaybe mr) -> (Some.This k, fmap (getWritten . getCompose) mr)) <$> DMap.toList p
89+ Map.fromDistinctAscList $ (\(k :=> ComposeMaybe mr) -> (Some.This k, fmap (getQueryTLoweredResultWritten . getCompose) mr)) <$> DMap.toList p
79 sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q
90 sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q
80− sampleBs = foldlM (\b a -> fmap (b <>) $ sample a) mempty
91+ sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty
81 accumBehaviors :: forall m'. MonadHold t m'
92 accumBehaviors :: forall m'. MonadHold t m'
82 => Map (Some k) [Behavior t q]
93 => Map (Some k) [Behavior t q]
83 -> PatchMap (Some k) [Behavior t q]
94 -> PatchMap (Some k) [Behavior t q]
84 -> m' ( Maybe (Map (Some k) [Behavior t q])
95 -> m' ( Maybe (Map (Some k) [Behavior t q])
85− , Maybe (AdditivePatch q))
96+ , Maybe (AdditivePatch q))
86 -- f accumulates the child behavior state we receive from running traverseDMapWithKeyWithAdjust for the underlying monad.
97 -- f accumulates the child behavior state we receive from running traverseDMapWithKeyWithAdjust for the underlying monad.
87 -- When an update occurs, it also computes a patch to communicate to the parent QueryT state.
98 -- When an update occurs, it also computes a patch to communicate to the parent QueryT state.
88 -- bs0 is a Map denoting the behaviors of the current children.
99 -- bs0 is a Map denoting the behaviors of the current children.
89 -- pbs is a PatchMap denoting an update to the behaviors of the current children
100 -- pbs is a PatchMap denoting an update to the behaviors of the current children
90 accumBehaviors bs0 pbs@(PatchMap bs') = do
101 accumBehaviors bs0 pbs@(PatchMap bs') = do
91− let g k bs = case Map.lookup k bs0 of
102+ let p k bs = case Map.lookup k bs0 of
92 Nothing -> case bs of
103 Nothing -> case bs of
93 -- If the update is to delete the state for a child that doesn't exist, the patch is mempty.
104 -- If the update is to delete the state for a child that doesn't exist, the patch is mempty.
94 Nothing -> return mempty
105 Nothing -> return mempty
@@ -96,45 +107,43 @@ instance (Reflex t, MonadFix m, Group q, Additive q, Query q, MonadHold t m, Mon
96 Just newBs -> sampleBs newBs
107 Just newBs -> sampleBs newBs
97 Just oldBs -> case bs of
108 Just oldBs -> case bs of
98 -- 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
109 -- 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
99− Nothing -> fmap negateG $ sampleBs oldBs
110+ Nothing -> negateG <$> sampleBs oldBs
100 -- 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
111 -- 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
101 -- composed with the sampling the child's new state.
112 -- composed with the sampling the child's new state.
102 Just newBs -> (~~) <$> sampleBs newBs <*> sampleBs oldBs
113 Just newBs -> (~~) <$> sampleBs newBs <*> sampleBs oldBs
103 -- we compute the patch by iterating over the update PatchMap and proceeding by cases. Then we fold over the
114 -- we compute the patch by iterating over the update PatchMap and proceeding by cases. Then we fold over the
104 -- child patches and wrap them in AdditivePatch.
115 -- child patches and wrap them in AdditivePatch.
105− patch <- fmap (AdditivePatch . fold) $ Map.traverseWithKey g bs'
116+ patch <- AdditivePatch . fold <$> Map.traverseWithKey p bs'
106 return (apply pbs bs0, Just patch)
117 return (apply pbs bs0, Just patch)
107 (qpatch :: Event t (AdditivePatch q)) <- mapAccumMaybeM_ accumBehaviors liftedBs0 liftedBs'
118 (qpatch :: Event t (AdditivePatch q)) <- mapAccumMaybeM_ accumBehaviors liftedBs0 liftedBs'
108− tellQueryIncremental $ unsafeBuildIncremental (fmap fold $ mapM sampleBs liftedBs0) qpatch
119+ tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch
109 return (liftedResult0, liftedResult')
120 return (liftedResult0, liftedResult')
110 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'))
121 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'))
111 traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = do
122 traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = do
112− let f' :: forall a. k a -> v a -> EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m) (Compose (QueryTLoweredResult t q) v' a)
123+ let f' :: forall a. k a -> v a -> EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m) (Compose (QueryTLoweredResult t q) v' a)
113 f' k v = fmap (Compose . QueryTLoweredResult) $ flip runStateT [] $ unQueryT $ f k v
124 f' k v = fmap (Compose . QueryTLoweredResult) $ flip runStateT [] $ unQueryT $ f k v
114− (result0, result') <- QueryT $ lift $ traverseDMapWithKeyWithAdjustWithMove f' dm0 dm'
125+ (result0, result') <- QueryT $ lift $ traverseDMapWithKeyWithAdjustWithMove f' dm0 dm'
115− let getValue (QueryTLoweredResult (v, _)) = v
116− getWritten (QueryTLoweredResult (_, w)) = w
117− liftedResult0 = mapKeyValuePairsMonotonic (\(k :=> Compose r) -> k :=> getValue r) result0
126+ let liftedResult0 = mapKeyValuePairsMonotonic (\(k :=> Compose r) -> k :=> getQueryTLoweredResultValue r) result0
118− liftedResult' = fforCheap result' $ mapPatchDMapWithMove (getValue . getCompose)
127+ liftedResult' = fforCheap result' $ mapPatchDMapWithMove (getQueryTLoweredResultValue . getCompose)
119 liftedBs0 :: Map (Some k) [Behavior t q]
128 liftedBs0 :: Map (Some k) [Behavior t q]
120− liftedBs0 = Map.fromDistinctAscList $ (\(k :=> Compose r) -> (Some.This k, getWritten r)) <$> DMap.toList result0
129+ liftedBs0 = Map.fromDistinctAscList $ (\(k :=> Compose r) -> (Some.This k, getQueryTLoweredResultWritten r)) <$> DMap.toList result0
121 liftedBs' :: Event t (PatchMapWithMove (Some k) [Behavior t q])
130 liftedBs' :: Event t (PatchMapWithMove (Some k) [Behavior t q])
122− liftedBs' = fforCheap result' $ weakenPatchDMapWithMoveWith (getWritten . getCompose) {- \(PatchDMap p) -> PatchMapWithMove $
131+ liftedBs' = fforCheap result' $ weakenPatchDMapWithMoveWith (getQueryTLoweredResultWritten . getCompose) {- \(PatchDMap p) -> PatchMapWithMove $
123− Map.fromDistinctAscList $ (\(k :=> mr) -> (Some.This k, fmap (fmap (getWritten . getCompose)) mr)) <$> DMap.toList p -}
132+ Map.fromDistinctAscList $ (\(k :=> mr) -> (Some.This k, fmap (fmap (getQueryTLoweredResultWritten . getCompose)) mr)) <$> DMap.toList p -}
124 sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q
133 sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q
125− sampleBs = foldlM (\b a -> fmap (b <>) $ sample a) mempty
134+ sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty
126− accumBehaviors :: forall m'. MonadHold t m'
135+ accumBehaviors' :: forall m'. MonadHold t m'
127− => Map (Some k) [Behavior t q]
136+ => Map (Some k) [Behavior t q]
128− -> PatchMapWithMove (Some k) [Behavior t q]
137+ -> PatchMapWithMove (Some k) [Behavior t q]
129− -> m' ( Maybe (Map (Some k) [Behavior t q])
138+ -> m' ( Maybe (Map (Some k) [Behavior t q])
130− , Maybe (AdditivePatch q))
139+ , Maybe (AdditivePatch q))
131 -- f accumulates the child behavior state we receive from running traverseDMapWithKeyWithAdjustWithMove for the underlying monad.
140 -- f accumulates the child behavior state we receive from running traverseDMapWithKeyWithAdjustWithMove for the underlying monad.
132 -- When an update occurs, it also computes a patch to communicate to the parent QueryT state.
141 -- When an update occurs, it also computes a patch to communicate to the parent QueryT state.
133 -- bs0 is a Map denoting the behaviors of the current children.
142 -- bs0 is a Map denoting the behaviors of the current children.
134 -- pbs is a PatchMapWithMove denoting an update to the behaviors of the current children
143 -- pbs is a PatchMapWithMove denoting an update to the behaviors of the current children
135− accumBehaviors bs0 pbs = do
144+ accumBehaviors' bs0 pbs = do
136 let bs' = unPatchMapWithMove pbs
145 let bs' = unPatchMapWithMove pbs
137− g k bs = case Map.lookup k bs0 of
146+ p k bs = case Map.lookup k bs0 of
138 Nothing -> case MapWithMove._nodeInfo_from bs of
147 Nothing -> case MapWithMove._nodeInfo_from bs of
139 -- If the update is to delete the state for a child that doesn't exist, the patch is mempty.
148 -- If the update is to delete the state for a child that doesn't exist, the patch is mempty.
140 MapWithMove.From_Delete -> return mempty
149 MapWithMove.From_Delete -> return mempty
@@ -145,7 +154,7 @@ instance (Reflex t, MonadFix m, Group q, Additive q, Query q, MonadHold t m, Mon
145 Just newBs -> sampleBs newBs
154 Just newBs -> sampleBs newBs
146 Just oldBs -> case MapWithMove._nodeInfo_from bs of
155 Just oldBs -> case MapWithMove._nodeInfo_from bs of
147 -- 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
156 -- 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
148− MapWithMove.From_Delete -> fmap negateG $ sampleBs oldBs
157+ MapWithMove.From_Delete -> negateG <$> sampleBs oldBs
149 -- 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
158 -- 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
150 -- composed with the sampling the child's new state.
159 -- composed with the sampling the child's new state.
151 MapWithMove.From_Insert newBs -> (~~) <$> sampleBs newBs <*> sampleBs oldBs
160 MapWithMove.From_Insert newBs -> (~~) <$> sampleBs newBs <*> sampleBs oldBs
@@ -153,14 +162,14 @@ instance (Reflex t, MonadFix m, Group q, Additive q, Query q, MonadHold t m, Mon
153 | k' == k -> return mempty
162 | k' == k -> return mempty
154 | otherwise -> case Map.lookup k' bs0 of
163 | otherwise -> case Map.lookup k' bs0 of
155 -- If we are moving from a non-existent key, that is a delete
164 -- If we are moving from a non-existent key, that is a delete
156− Nothing -> fmap negateG $ sampleBs oldBs
165+ Nothing -> negateG <$> sampleBs oldBs
157 Just newBs -> (~~) <$> sampleBs newBs <*> sampleBs oldBs
166 Just newBs -> (~~) <$> sampleBs newBs <*> sampleBs oldBs
158 -- we compute the patch by iterating over the update PatchMap and proceeding by cases. Then we fold over the
167 -- we compute the patch by iterating over the update PatchMap and proceeding by cases. Then we fold over the
159 -- child patches and wrap them in AdditivePatch.
168 -- child patches and wrap them in AdditivePatch.
160− patch <- fmap (AdditivePatch . fold) $ Map.traverseWithKey g bs'
169+ patch <- AdditivePatch . fold <$> Map.traverseWithKey p bs'
161 return (apply pbs bs0, Just patch)
170 return (apply pbs bs0, Just patch)
162− (qpatch :: Event t (AdditivePatch q)) <- mapAccumMaybeM_ accumBehaviors liftedBs0 liftedBs'
171+ (qpatch :: Event t (AdditivePatch q)) <- mapAccumMaybeM_ accumBehaviors' liftedBs0 liftedBs'
163− tellQueryIncremental $ unsafeBuildIncremental (fmap fold $ mapM sampleBs liftedBs0) qpatch
172+ tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch
164 return (liftedResult0, liftedResult')
173 return (liftedResult0, liftedResult')
166instance MonadTrans (QueryT t q) where
175instance MonadTrans (QueryT t q) where