@@ -7,7 +7,14 @@
77{-# LANGUAGE ScopedTypeVariables #-}
88{-# LANGUAGE TypeFamilies #-}
99{-# LANGUAGE UndecidableInstances #-}
10−module Reflex.Query.Base where
10+module Reflex.Query.Base
11+ ( QueryT (..)
12+ , runQueryT
13+ , mapQuery
14+ , mapQueryResult
15+ , dynWithQueryT
16+ , withQueryT
17+ ) where
1118
1219import Control.Monad.Exception
1320import Control.Monad.Fix
@@ -44,16 +51,22 @@ newtype QueryT t q m a = QueryT { unQueryT :: StateT [Behavior t q] (EventWriter
4451runQueryT :: (MonadFix m, Additive q, Group q, Reflex t) => QueryT t q m a -> Dynamic t (QueryResult q) -> m (a, Incremental t (AdditivePatch q))
4552runQueryT (QueryT a) qr = do
4653 ((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))
4855
4956newtype QueryTLoweredResult t q v = QueryTLoweredResult (v, [Behavior t q])
5057
58+getQueryTLoweredResultValue :: QueryTLoweredResult t q v -> v
59+getQueryTLoweredResultValue (QueryTLoweredResult (v, _)) = v
60+
61+getQueryTLoweredResultWritten :: QueryTLoweredResult t q v -> [Behavior t q]
62+getQueryTLoweredResultWritten (QueryTLoweredResult (_, w)) = w
63+
5164instance (Reflex t, MonadFix m, Group q, Additive q, Query q, MonadHold t m, MonadAdjust t m) => MonadAdjust t (QueryT t q m) where
5265 runWithReplace (QueryT a0) a' = do
5366 ((r0, bs0), r') <- QueryT $ lift $ runWithReplace (runStateT a0 []) $ fmapCheap (flip runStateT [] . unQueryT) a'
5467 tellQueryIncremental $
5568 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
5770 bs' = fmapCheap snd $ r'
5871 patches = unsafeBuildIncremental (sampleBs bs0) $
5972 flip pushCheap bs' $ \bs -> do
@@ -63,32 +76,30 @@ instance (Reflex t, MonadFix m, Group q, Additive q, Query q, MonadHold t m, Mon
6376 return (r0, fmapCheap fst r')
6477 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'))
6578 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)
6780 f' k v = fmap (Compose . QueryTLoweredResult) $ flip runStateT [] $ unQueryT $ f k v
68− (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
81+ (result0, result') <- QueryT $ lift $ traverseDMapWithKeyWithAdjust f' dm0 dm'
82+ let liftedResult0 = mapKeyValuePairsMonotonic (\(k :=> Compose r) -> k :=> getQueryTLoweredResultValue r) result0
7283 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
7485 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
7687 liftedBs' :: Event t (PatchMap (Some k) [Behavior t q])
7788 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
7990 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
8192 accumBehaviors :: forall m'. MonadHold t m'
8293 => Map (Some k) [Behavior t q]
8394 -> PatchMap (Some k) [Behavior t q]
8495 -> m' ( Maybe (Map (Some k) [Behavior t q])
85− , Maybe (AdditivePatch q))
96+ , Maybe (AdditivePatch q))
8697 -- f accumulates the child behavior state we receive from running traverseDMapWithKeyWithAdjust for the underlying monad.
8798 -- When an update occurs, it also computes a patch to communicate to the parent QueryT state.
8899 -- bs0 is a Map denoting the behaviors of the current children.
89100 -- pbs is a PatchMap denoting an update to the behaviors of the current children
90101 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
92103 Nothing -> case bs of
93104 -- If the update is to delete the state for a child that doesn't exist, the patch is mempty.
94105 Nothing -> return mempty
@@ -96,45 +107,43 @@ instance (Reflex t, MonadFix m, Group q, Additive q, Query q, MonadHold t m, Mon
96107 Just newBs -> sampleBs newBs
97108 Just oldBs -> case bs of
98109 -- 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
100111 -- 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
101112 -- composed with the sampling the child's new state.
102113 Just newBs -> (~~) <$> sampleBs newBs <*> sampleBs oldBs
103114 -- we compute the patch by iterating over the update PatchMap and proceeding by cases. Then we fold over the
104115 -- child patches and wrap them in AdditivePatch.
105− patch <- fmap (AdditivePatch . fold) $ Map.traverseWithKey g bs'
116+ patch <- AdditivePatch . fold <$> Map.traverseWithKey p bs'
106117 return (apply pbs bs0, Just patch)
107118 (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
109120 return (liftedResult0, liftedResult')
110121 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'))
111122 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)
113124 f' k v = fmap (Compose . QueryTLoweredResult) $ flip runStateT [] $ unQueryT $ f k v
114− (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
118− liftedResult' = fforCheap result' $ mapPatchDMapWithMove (getValue . getCompose)
125+ (result0, result') <- QueryT $ lift $ traverseDMapWithKeyWithAdjustWithMove f' dm0 dm'
126+ let liftedResult0 = mapKeyValuePairsMonotonic (\(k :=> Compose r) -> k :=> getQueryTLoweredResultValue r) result0
127+ liftedResult' = fforCheap result' $ mapPatchDMapWithMove (getQueryTLoweredResultValue . getCompose)
119128 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
121130 liftedBs' :: Event t (PatchMapWithMove (Some k) [Behavior t q])
122− liftedBs' = fforCheap result' $ weakenPatchDMapWithMoveWith (getWritten . getCompose) {- \(PatchDMap p) -> PatchMapWithMove $
123− Map.fromDistinctAscList $ (\(k :=> mr) -> (Some.This k, fmap (fmap (getWritten . getCompose)) mr)) <$> DMap.toList p -}
131+ liftedBs' = fforCheap result' $ weakenPatchDMapWithMoveWith (getQueryTLoweredResultWritten . getCompose) {- \(PatchDMap p) -> PatchMapWithMove $
132+ Map.fromDistinctAscList $ (\(k :=> mr) -> (Some.This k, fmap (fmap (getQueryTLoweredResultWritten . getCompose)) mr)) <$> DMap.toList p -}
124133 sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q
125− sampleBs = foldlM (\b a -> fmap (b <>) $ sample a) mempty
126− accumBehaviors :: forall m'. MonadHold t m'
127− => Map (Some k) [Behavior t q]
128− -> PatchMapWithMove (Some k) [Behavior t q]
129− -> m' ( Maybe (Map (Some k) [Behavior t q])
130− , Maybe (AdditivePatch q))
134+ sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty
135+ accumBehaviors' :: forall m'. MonadHold t m'
136+ => Map (Some k) [Behavior t q]
137+ -> PatchMapWithMove (Some k) [Behavior t q]
138+ -> m' ( Maybe (Map (Some k) [Behavior t q])
139+ , Maybe (AdditivePatch q))
131140 -- f accumulates the child behavior state we receive from running traverseDMapWithKeyWithAdjustWithMove for the underlying monad.
132141 -- When an update occurs, it also computes a patch to communicate to the parent QueryT state.
133142 -- bs0 is a Map denoting the behaviors of the current children.
134143 -- pbs is a PatchMapWithMove denoting an update to the behaviors of the current children
135− accumBehaviors bs0 pbs = do
144+ accumBehaviors' bs0 pbs = do
136145 let bs' = unPatchMapWithMove pbs
137− g k bs = case Map.lookup k bs0 of
146+ p k bs = case Map.lookup k bs0 of
138147 Nothing -> case MapWithMove._nodeInfo_from bs of
139148 -- If the update is to delete the state for a child that doesn't exist, the patch is mempty.
140149 MapWithMove.From_Delete -> return mempty
@@ -145,7 +154,7 @@ instance (Reflex t, MonadFix m, Group q, Additive q, Query q, MonadHold t m, Mon
145154 Just newBs -> sampleBs newBs
146155 Just oldBs -> case MapWithMove._nodeInfo_from bs of
147156 -- 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
149158 -- 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
150159 -- composed with the sampling the child's new state.
151160 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
153162 | k' == k -> return mempty
154163 | otherwise -> case Map.lookup k' bs0 of
155164 -- If we are moving from a non-existent key, that is a delete
156− Nothing -> fmap negateG $ sampleBs oldBs
165+ Nothing -> negateG <$> sampleBs oldBs
157166 Just newBs -> (~~) <$> sampleBs newBs <*> sampleBs oldBs
158167 -- we compute the patch by iterating over the update PatchMap and proceeding by cases. Then we fold over the
159168 -- child patches and wrap them in AdditivePatch.
160− patch <- fmap (AdditivePatch . fold) $ Map.traverseWithKey g bs'
169+ patch <- AdditivePatch . fold <$> Map.traverseWithKey p bs'
161170 return (apply pbs bs0, Just patch)
162− (qpatch :: Event t (AdditivePatch q)) <- mapAccumMaybeM_ accumBehaviors liftedBs0 liftedBs'
163− tellQueryIncremental $ unsafeBuildIncremental (fmap fold $ mapM sampleBs liftedBs0) qpatch
171+ (qpatch :: Event t (AdditivePatch q)) <- mapAccumMaybeM_ accumBehaviors' liftedBs0 liftedBs'
172+ tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch
164173 return (liftedResult0, liftedResult')
165174
166175instance MonadTrans (QueryT t q) where