1{-# LANGUAGE FlexibleInstances #-}
2{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3{-# LANGUAGE InstanceSigs #-}
4{-# LANGUAGE KindSignatures #-}
5{-# LANGUAGE LambdaCase #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
7{-# LANGUAGE RankNTypes #-}
8{-# LANGUAGE ScopedTypeVariables #-}
9{-# LANGUAGE TypeFamilies #-}
10{-# LANGUAGE UndecidableInstances #-}
11{-# LANGUAGE StandaloneDeriving #-}
13module Reflex.Query.Base
22import Control.Applicative (liftA2)
23import Control.Monad.Exception
24import Control.Monad.Fix
25import Control.Monad.Primitive
26import Control.Monad.Reader
27import Control.Monad.Ref
28import Control.Monad.State.Strict
30import Data.Dependent.Map (DMap, DSum (..))
31import qualified Data.Dependent.Map as DMap
33import Data.Functor.Compose
34import Data.Functor.Misc
35import Data.IntMap (IntMap)
36import qualified Data.IntMap as IntMap
38import qualified Data.Map as Map
39import Data.Monoid ((<>))
40import qualified Data.Semigroup as S
41import Data.Some (Some)
42import qualified Data.Some as Some
46import Reflex.Adjustable.Class
47import Reflex.DynamicWriter.Class
48import Reflex.EventWriter.Base
49import Reflex.EventWriter.Class
50import Reflex.Host.Class
51import qualified Reflex.Patch.MapWithMove as MapWithMove
52import Reflex.PerformEvent.Class
53import Reflex.PostBuild.Class
54import Reflex.Query.Class
55import Reflex.Requester.Class
56import Reflex.TriggerEvent.Class
58newtype QueryT t q m a = QueryT { unQueryT :: StateT [Behavior t q] (EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m)) a }
59 deriving (Functor, Applicative, Monad, MonadException, MonadFix, MonadIO, MonadAtomicRef)
61deriving instance MonadHold t m => MonadHold t (QueryT t q m)
62deriving instance MonadSample t m => MonadSample t (QueryT t q m)
64runQueryT :: (MonadFix m, Additive q, Group q, Reflex t) => QueryT t q m a -> Dynamic t (QueryResult q) -> m (a, Incremental t (AdditivePatch q))
65runQueryT (QueryT a) qr = do
66 ((r, bs), es) <- runReaderT (runEventWriterT (runStateT a mempty)) qr
67 return (r, unsafeBuildIncremental (foldlM (\b c -> (b <>) <$> sample c) mempty bs) (fmapCheap AdditivePatch es))
69newtype QueryTLoweredResult t q v = QueryTLoweredResult (v, [Behavior t q])
71getQueryTLoweredResultValue :: QueryTLoweredResult t q v -> v
72getQueryTLoweredResultValue (QueryTLoweredResult (v, _)) = v
74getQueryTLoweredResultWritten :: QueryTLoweredResult t q v -> [Behavior t q]
75getQueryTLoweredResultWritten (QueryTLoweredResult (_, w)) = w
78let sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q
79 sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty
80 bs' = fmapCheap snd $ r'
81 patches = unsafeBuildIncremental (sampleBs bs0) $
82 flip pushCheap bs' $ \bs -> do
83 p <- (~~) <$> sampleBs bs <*> sample (currentIncremental patches)
84 return (Just (AdditivePatch p))
87instance (Reflex t, MonadFix m, Group q, Additive q, Query q, MonadHold t m, Adjustable t m) => Adjustable t (QueryT t q m) where
88 runWithReplace (QueryT a0) a' = do
89 ((r0, bs0), r') <- QueryT $ lift $ runWithReplace (runStateT a0 []) $ fmapCheap (flip runStateT [] . unQueryT) a'
90 let sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q
91 sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty
92 bs' = fmapCheap snd $ r'
94 let patches = flip pushAlwaysCheap bs' $ \newBs -> do
96 (~~) <$> sampleBs newBs <*> sampleBs oldBs
97 QueryT $ modify $ (:) $ pull $ sampleBs =<< sample bbs
98 QueryT $ lift $ tellEvent patches
99 return (r0, fmapCheap fst r')
101 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'))
102 traverseIntMapWithKeyWithAdjust f im0 im' = do
103 let f' :: IntMap.Key -> v -> EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m) (QueryTLoweredResult t q v')
104 f' k v = fmap QueryTLoweredResult $ flip runStateT [] $ unQueryT $ f k v
105 (result0, result') <- QueryT $ lift $ traverseIntMapWithKeyWithAdjust f' im0 im'
106 let liftedResult0 = IntMap.map getQueryTLoweredResultValue result0
107 liftedResult' = fforCheap result' $ \(PatchIntMap p) -> PatchIntMap $
108 IntMap.map (fmap getQueryTLoweredResultValue) p
109 liftedBs0 :: IntMap [Behavior t q]
110 liftedBs0 = IntMap.map getQueryTLoweredResultWritten result0
111 liftedBs' :: Event t (PatchIntMap [Behavior t q])
112 liftedBs' = fforCheap result' $ \(PatchIntMap p) -> PatchIntMap $
113 IntMap.map (fmap getQueryTLoweredResultWritten) p
114 sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q
115 sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty
116 accumBehaviors :: forall m'. MonadHold t m'
117 => IntMap [Behavior t q]
118 -> PatchIntMap [Behavior t q]
119 -> m' ( Maybe (IntMap [Behavior t q])
120 , Maybe (AdditivePatch q))
121 -- f accumulates the child behavior state we receive from running traverseIntMapWithKeyWithAdjust for the underlying monad.
122 -- When an update occurs, it also computes a patch to communicate to the parent QueryT state.
123 -- bs0 is a Map denoting the behaviors of the current children.
124 -- pbs is a PatchMap denoting an update to the behaviors of the current children
125 accumBehaviors bs0 pbs@(PatchIntMap bs') = do
126 let p k bs = case IntMap.lookup k bs0 of
127 Nothing -> case bs of
128 -- If the update is to delete the state for a child that doesn't exist, the patch is mempty.
129 Nothing -> return mempty
130 -- If the update is to update the state for a child that doesn't exist, the patch is the sample of the new state.
131 Just newBs -> sampleBs newBs
132 Just oldBs -> case bs of
133 -- 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
134 Nothing -> negateG <$> sampleBs oldBs
135 -- 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
136 -- composed with the sampling the child's new state.
137 Just newBs -> (~~) <$> sampleBs newBs <*> sampleBs oldBs
138 -- we compute the patch by iterating over the update PatchMap and proceeding by cases. Then we fold over the
139 -- child patches and wrap them in AdditivePatch.
140 patch <- AdditivePatch . fold <$> IntMap.traverseWithKey p bs'
141 return (apply pbs bs0, Just patch)
142 (qpatch :: Event t (AdditivePatch q)) <- mapAccumMaybeM_ accumBehaviors liftedBs0 liftedBs'
143 tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch
144 return (liftedResult0, liftedResult')
146 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'))
147 traverseDMapWithKeyWithAdjust f dm0 dm' = do
148 let f' :: forall a. k a -> v a -> EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m) (Compose (QueryTLoweredResult t q) v' a)
149 f' k v = fmap (Compose . QueryTLoweredResult) $ flip runStateT [] $ unQueryT $ f k v
150 (result0, result') <- QueryT $ lift $ traverseDMapWithKeyWithAdjust f' dm0 dm'
151 let liftedResult0 = mapKeyValuePairsMonotonic (\(k :=> Compose r) -> k :=> getQueryTLoweredResultValue r) result0
152 liftedResult' = fforCheap result' $ \(PatchDMap p) -> PatchDMap $
153 mapKeyValuePairsMonotonic (\(k :=> ComposeMaybe mr) -> k :=> ComposeMaybe (fmap (getQueryTLoweredResultValue . getCompose) mr)) p
154 liftedBs0 :: Map (Some k) [Behavior t q]
155 liftedBs0 = Map.fromDistinctAscList $ (\(k :=> Compose r) -> (Some.This k, getQueryTLoweredResultWritten r)) <$> DMap.toList result0
156 liftedBs' :: Event t (PatchMap (Some k) [Behavior t q])
157 liftedBs' = fforCheap result' $ \(PatchDMap p) -> PatchMap $
158 Map.fromDistinctAscList $ (\(k :=> ComposeMaybe mr) -> (Some.This k, fmap (getQueryTLoweredResultWritten . getCompose) mr)) <$> DMap.toList p
159 sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q
160 sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty
161 accumBehaviors :: forall m'. MonadHold t m'
162 => Map (Some k) [Behavior t q]
163 -> PatchMap (Some k) [Behavior t q]
164 -> m' ( Maybe (Map (Some k) [Behavior t q])
165 , Maybe (AdditivePatch q))
166 -- f accumulates the child behavior state we receive from running traverseDMapWithKeyWithAdjust for the underlying monad.
167 -- When an update occurs, it also computes a patch to communicate to the parent QueryT state.
168 -- bs0 is a Map denoting the behaviors of the current children.
169 -- pbs is a PatchMap denoting an update to the behaviors of the current children
170 accumBehaviors bs0 pbs@(PatchMap bs') = do
171 let p k bs = case Map.lookup k bs0 of
172 Nothing -> case bs of
173 -- If the update is to delete the state for a child that doesn't exist, the patch is mempty.
174 Nothing -> return mempty
175 -- If the update is to update the state for a child that doesn't exist, the patch is the sample of the new state.
176 Just newBs -> sampleBs newBs
177 Just oldBs -> case bs of
178 -- 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
179 Nothing -> negateG <$> sampleBs oldBs
180 -- 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
181 -- composed with the sampling the child's new state.
182 Just newBs -> (~~) <$> sampleBs newBs <*> sampleBs oldBs
183 -- we compute the patch by iterating over the update PatchMap and proceeding by cases. Then we fold over the
184 -- child patches and wrap them in AdditivePatch.
185 patch <- AdditivePatch . fold <$> Map.traverseWithKey p bs'
186 return (apply pbs bs0, Just patch)
187 (qpatch :: Event t (AdditivePatch q)) <- mapAccumMaybeM_ accumBehaviors liftedBs0 liftedBs'
188 tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch
189 return (liftedResult0, liftedResult')
191 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'))
192 traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = do
193 let f' :: forall a. k a -> v a -> EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m) (Compose (QueryTLoweredResult t q) v' a)
194 f' k v = fmap (Compose . QueryTLoweredResult) $ flip runStateT [] $ unQueryT $ f k v
195 (result0, result') <- QueryT $ lift $ traverseDMapWithKeyWithAdjustWithMove f' dm0 dm'
196 let liftedResult0 = mapKeyValuePairsMonotonic (\(k :=> Compose r) -> k :=> getQueryTLoweredResultValue r) result0
197 liftedResult' = fforCheap result' $ mapPatchDMapWithMove (getQueryTLoweredResultValue . getCompose)
198 liftedBs0 :: Map (Some k) [Behavior t q]
199 liftedBs0 = Map.fromDistinctAscList $ (\(k :=> Compose r) -> (Some.This k, getQueryTLoweredResultWritten r)) <$> DMap.toList result0
200 liftedBs' :: Event t (PatchMapWithMove (Some k) [Behavior t q])
201 liftedBs' = fforCheap result' $ weakenPatchDMapWithMoveWith (getQueryTLoweredResultWritten . getCompose) {- \(PatchDMap p) -> PatchMapWithMove $
202 Map.fromDistinctAscList $ (\(k :=> mr) -> (Some.This k, fmap (fmap (getQueryTLoweredResultWritten . getCompose)) mr)) <$> DMap.toList p -}
203 sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q
204 sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty
205 accumBehaviors' :: forall m'. MonadHold t m'
206 => Map (Some k) [Behavior t q]
207 -> PatchMapWithMove (Some k) [Behavior t q]
208 -> m' ( Maybe (Map (Some k) [Behavior t q])
209 , Maybe (AdditivePatch q))
210 -- f accumulates the child behavior state we receive from running traverseDMapWithKeyWithAdjustWithMove for the underlying monad.
211 -- When an update occurs, it also computes a patch to communicate to the parent QueryT state.
212 -- bs0 is a Map denoting the behaviors of the current children.
213 -- pbs is a PatchMapWithMove denoting an update to the behaviors of the current children
214 accumBehaviors' bs0 pbs = do
215 let bs' = unPatchMapWithMove pbs
216 p k bs = case Map.lookup k bs0 of
217 Nothing -> case MapWithMove._nodeInfo_from bs of
218 -- If the update is to delete the state for a child that doesn't exist, the patch is mempty.
219 MapWithMove.From_Delete -> return mempty
220 -- If the update is to update the state for a child that doesn't exist, the patch is the sample of the new state.
221 MapWithMove.From_Insert newBs -> sampleBs newBs
222 MapWithMove.From_Move k' -> case Map.lookup k' bs0 of
223 Nothing -> return mempty
224 Just newBs -> sampleBs newBs
225 Just oldBs -> case MapWithMove._nodeInfo_from bs of
226 -- 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
227 MapWithMove.From_Delete -> negateG <$> sampleBs oldBs
228 -- 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
229 -- composed with the sampling the child's new state.
230 MapWithMove.From_Insert newBs -> (~~) <$> sampleBs newBs <*> sampleBs oldBs
231 MapWithMove.From_Move k'
232 | k' == k -> return mempty
233 | otherwise -> case Map.lookup k' bs0 of
234 -- If we are moving from a non-existent key, that is a delete
235 Nothing -> negateG <$> sampleBs oldBs
236 Just newBs -> (~~) <$> sampleBs newBs <*> sampleBs oldBs
237 -- we compute the patch by iterating over the update PatchMap and proceeding by cases. Then we fold over the
238 -- child patches and wrap them in AdditivePatch.
239 patch <- AdditivePatch . fold <$> Map.traverseWithKey p bs'
240 return (apply pbs bs0, Just patch)
241 (qpatch :: Event t (AdditivePatch q)) <- mapAccumMaybeM_ accumBehaviors' liftedBs0 liftedBs'
242 tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch
243 return (liftedResult0, liftedResult')
245instance MonadTrans (QueryT t q) where
246 lift = QueryT . lift . lift . lift
248instance PrimMonad m => PrimMonad (QueryT t q m) where
249 type PrimState (QueryT t q m) = PrimState m
250 primitive = lift . primitive
252instance PostBuild t m => PostBuild t (QueryT t q m) where
253 getPostBuild = lift getPostBuild
255instance (MonadAsyncException m) => MonadAsyncException (QueryT t q m) where
256 mask f = QueryT $ mask $ \unMask -> unQueryT $ f $ QueryT . unMask . unQueryT
258instance TriggerEvent t m => TriggerEvent t (QueryT t q m) where
259 newTriggerEvent = lift newTriggerEvent
260 newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
261 newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
263instance PerformEvent t m => PerformEvent t (QueryT t q m) where
264 type Performable (QueryT t q m) = Performable m
265 performEvent_ = lift . performEvent_
266 performEvent = lift . performEvent
268instance MonadRef m => MonadRef (QueryT t q m) where
269 type Ref (QueryT t q m) = Ref m
270 newRef = QueryT . newRef
271 readRef = QueryT . readRef
272 writeRef r = QueryT . writeRef r
274instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (QueryT t q m) where
275 newEventWithTrigger = QueryT . newEventWithTrigger
276 newFanEventWithTrigger a = QueryT . lift $ newFanEventWithTrigger a
278-- TODO: Monoid and Semigroup can likely be derived once StateT has them.
279instance (Monoid a, Monad m) => Monoid (QueryT t q m a) where
283instance (S.Semigroup a, Monad m) => S.Semigroup (QueryT t q m a) where
286-- | withQueryT's QueryMorphism argument needs to be a group homomorphism in order to behave correctly
287withQueryT :: (MonadFix m, PostBuild t m, Group q, Group q', Additive q, Additive q', Query q')
288 => QueryMorphism q q'
293 (result, q) <- lift $ runQueryT a $ mapQueryResult f <$> r'
294 tellQueryIncremental $ unsafeBuildIncremental
295 (fmap (mapQuery f) (sample (currentIncremental q)))
296 (fmapCheap (AdditivePatch . mapQuery f . unAdditivePatch) $ updatedIncremental q)
299-- | dynWithQueryT's (Dynamic t QueryMorphism) argument needs to be a group homomorphism at all times in order to behave correctly
300dynWithQueryT :: (MonadFix m, PostBuild t m, Group q, Additive q, Group q', Additive q', Query q')
301 => Dynamic t (QueryMorphism q q')
304dynWithQueryT f q = do
306 (result, q') <- lift $ runQueryT q $ zipDynWith mapQueryResult f r'
307 tellQueryIncremental $ zipDynIncrementalWith mapQuery f q'
309 where zipDynIncrementalWith g da ib =
310 let eab = align (updated da) (updatedIncremental ib)
311 ec = flip push eab $ \case
313 aOld <- sample $ current da
314 b <- sample $ currentIncremental ib
315 return $ Just $ AdditivePatch (g a b ~~ g aOld b)
316 That (AdditivePatch b) -> do
317 a <- sample $ current da
318 return $ Just $ AdditivePatch $ g a b
319 These a (AdditivePatch b) -> do
320 aOld <- sample $ current da
321 bOld <- sample $ currentIncremental ib
322 return $ Just $ AdditivePatch $ mconcat [ g a bOld, negateG (g aOld bOld), g a b]
323 in unsafeBuildIncremental (g <$> sample (current da) <*> sample (currentIncremental ib)) ec
325instance (Monad m, Group q, Additive q, Query q, Reflex t) => MonadQuery t q (QueryT t q m) where
326 tellQueryIncremental q = do
327 QueryT (modify (currentIncremental q:))
328 QueryT (lift (tellEvent (fmapCheap unAdditivePatch (updatedIncremental q))))
329 askQueryResult = QueryT ask
330 queryIncremental q = do
331 tellQueryIncremental q
332 zipDynWith crop (incrementalToDynamic q) <$> askQueryResult
334instance Requester t m => Requester t (QueryT t q m) where
335 type Request (QueryT t q m) = Request m
336 type Response (QueryT t q m) = Response m
337 requesting = lift . requesting
338 requesting_ = lift . requesting_
340instance EventWriter t w m => EventWriter t w (QueryT t q m) where
341 tellEvent = lift . tellEvent
343instance MonadDynamicWriter t w m => MonadDynamicWriter t w (QueryT t q m) where
344 tellDyn = lift . tellDyn
keysesc to close
- j k
- move down, up
- enter
- open
- esc
- back, or up a level
- 1 2 3 4
- readme, files, commits, refs
- /
- filter
- y
- copy the clone command
- c
- compare the chosen commit with another (or shift-click both)
- ?
- show or hide this list