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.Reader
26import Control.Monad.Ref
27import Control.Monad.State.Strict
29import Data.Dependent.Map (DMap, DSum (..))
30import qualified Data.Dependent.Map as DMap
32import Data.Functor.Compose
33import Data.Functor.Misc
34import Data.IntMap (IntMap)
35import qualified Data.IntMap as IntMap
37import qualified Data.Map as Map
38import Data.Monoid ((<>))
39import qualified Data.Semigroup as S
40import Data.Some (Some)
41import qualified Data.Some as Some
45import Reflex.Adjustable.Class
46import Reflex.DynamicWriter.Class
47import Reflex.EventWriter.Base
48import Reflex.EventWriter.Class
49import Reflex.Host.Class
50import qualified Reflex.Patch.MapWithMove as MapWithMove
51import Reflex.PerformEvent.Class
52import Reflex.PostBuild.Class
53import Reflex.Query.Class
54import Reflex.Requester.Class
55import Reflex.TriggerEvent.Class
57newtype QueryT t q m a = QueryT { unQueryT :: StateT [Behavior t q] (EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m)) a }
58 deriving (Functor, Applicative, Monad, MonadException, MonadFix, MonadIO, MonadAtomicRef)
60deriving instance MonadHold t m => MonadHold t (QueryT t q m)
61deriving instance MonadSample t m => MonadSample t (QueryT t q m)
63runQueryT :: (MonadFix m, Additive q, Group q, Reflex t) => QueryT t q m a -> Dynamic t (QueryResult q) -> m (a, Incremental t (AdditivePatch q))
64runQueryT (QueryT a) qr = do
65 ((r, bs), es) <- runReaderT (runEventWriterT (runStateT a mempty)) qr
66 return (r, unsafeBuildIncremental (foldlM (\b c -> (b <>) <$> sample c) mempty bs) (fmapCheap AdditivePatch es))
68newtype QueryTLoweredResult t q v = QueryTLoweredResult (v, [Behavior t q])
70getQueryTLoweredResultValue :: QueryTLoweredResult t q v -> v
71getQueryTLoweredResultValue (QueryTLoweredResult (v, _)) = v
73getQueryTLoweredResultWritten :: QueryTLoweredResult t q v -> [Behavior t q]
74getQueryTLoweredResultWritten (QueryTLoweredResult (_, w)) = w
77let sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q
78 sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty
79 bs' = fmapCheap snd $ r'
80 patches = unsafeBuildIncremental (sampleBs bs0) $
81 flip pushCheap bs' $ \bs -> do
82 p <- (~~) <$> sampleBs bs <*> sample (currentIncremental patches)
83 return (Just (AdditivePatch p))
86instance (Reflex t, MonadFix m, Group q, Additive q, Query q, MonadHold t m, Adjustable t m) => Adjustable t (QueryT t q m) where
87 runWithReplace (QueryT a0) a' = do
88 ((r0, bs0), r') <- QueryT $ lift $ runWithReplace (runStateT a0 []) $ fmapCheap (flip runStateT [] . unQueryT) a'
89 let sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q
90 sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty
91 bs' = fmapCheap snd $ r'
93 let patches = flip pushAlwaysCheap bs' $ \newBs -> do
95 (~~) <$> sampleBs newBs <*> sampleBs oldBs
96 QueryT $ modify $ (:) $ pull $ sampleBs =<< sample bbs
97 QueryT $ lift $ tellEvent patches
98 return (r0, fmapCheap fst r')
100 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'))
101 traverseIntMapWithKeyWithAdjust f im0 im' = do
102 let f' :: IntMap.Key -> v -> EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m) (QueryTLoweredResult t q v')
103 f' k v = fmap QueryTLoweredResult $ flip runStateT [] $ unQueryT $ f k v
104 (result0, result') <- QueryT $ lift $ traverseIntMapWithKeyWithAdjust f' im0 im'
105 let liftedResult0 = IntMap.map getQueryTLoweredResultValue result0
106 liftedResult' = fforCheap result' $ \(PatchIntMap p) -> PatchIntMap $
107 IntMap.map (fmap getQueryTLoweredResultValue) p
108 liftedBs0 :: IntMap [Behavior t q]
109 liftedBs0 = IntMap.map getQueryTLoweredResultWritten result0
110 liftedBs' :: Event t (PatchIntMap [Behavior t q])
111 liftedBs' = fforCheap result' $ \(PatchIntMap p) -> PatchIntMap $
112 IntMap.map (fmap getQueryTLoweredResultWritten) p
113 sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q
114 sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty
115 accumBehaviors :: forall m'. MonadHold t m'
116 => IntMap [Behavior t q]
117 -> PatchIntMap [Behavior t q]
118 -> m' ( Maybe (IntMap [Behavior t q])
119 , Maybe (AdditivePatch q))
120 -- f accumulates the child behavior state we receive from running traverseIntMapWithKeyWithAdjust for the underlying monad.
121 -- When an update occurs, it also computes a patch to communicate to the parent QueryT state.
122 -- bs0 is a Map denoting the behaviors of the current children.
123 -- pbs is a PatchMap denoting an update to the behaviors of the current children
124 accumBehaviors bs0 pbs@(PatchIntMap bs') = do
125 let p k bs = case IntMap.lookup k bs0 of
126 Nothing -> case bs of
127 -- If the update is to delete the state for a child that doesn't exist, the patch is mempty.
128 Nothing -> return mempty
129 -- If the update is to update the state for a child that doesn't exist, the patch is the sample of the new state.
130 Just newBs -> sampleBs newBs
131 Just oldBs -> case bs of
132 -- 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
133 Nothing -> negateG <$> sampleBs oldBs
134 -- 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
135 -- composed with the sampling the child's new state.
136 Just newBs -> (~~) <$> sampleBs newBs <*> sampleBs oldBs
137 -- we compute the patch by iterating over the update PatchMap and proceeding by cases. Then we fold over the
138 -- child patches and wrap them in AdditivePatch.
139 patch <- AdditivePatch . fold <$> IntMap.traverseWithKey p bs'
140 return (apply pbs bs0, Just patch)
141 (qpatch :: Event t (AdditivePatch q)) <- mapAccumMaybeM_ accumBehaviors liftedBs0 liftedBs'
142 tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch
143 return (liftedResult0, liftedResult')
145 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'))
146 traverseDMapWithKeyWithAdjust f dm0 dm' = do
147 let f' :: forall a. k a -> v a -> EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m) (Compose (QueryTLoweredResult t q) v' a)
148 f' k v = fmap (Compose . QueryTLoweredResult) $ flip runStateT [] $ unQueryT $ f k v
149 (result0, result') <- QueryT $ lift $ traverseDMapWithKeyWithAdjust f' dm0 dm'
150 let liftedResult0 = mapKeyValuePairsMonotonic (\(k :=> Compose r) -> k :=> getQueryTLoweredResultValue r) result0
151 liftedResult' = fforCheap result' $ \(PatchDMap p) -> PatchDMap $
152 mapKeyValuePairsMonotonic (\(k :=> ComposeMaybe mr) -> k :=> ComposeMaybe (fmap (getQueryTLoweredResultValue . getCompose) mr)) p
153 liftedBs0 :: Map (Some k) [Behavior t q]
154 liftedBs0 = Map.fromDistinctAscList $ (\(k :=> Compose r) -> (Some.This k, getQueryTLoweredResultWritten r)) <$> DMap.toList result0
155 liftedBs' :: Event t (PatchMap (Some k) [Behavior t q])
156 liftedBs' = fforCheap result' $ \(PatchDMap p) -> PatchMap $
157 Map.fromDistinctAscList $ (\(k :=> ComposeMaybe mr) -> (Some.This k, fmap (getQueryTLoweredResultWritten . getCompose) mr)) <$> DMap.toList p
158 sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q
159 sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty
160 accumBehaviors :: forall m'. MonadHold t m'
161 => Map (Some k) [Behavior t q]
162 -> PatchMap (Some k) [Behavior t q]
163 -> m' ( Maybe (Map (Some k) [Behavior t q])
164 , Maybe (AdditivePatch q))
165 -- f accumulates the child behavior state we receive from running traverseDMapWithKeyWithAdjust for the underlying monad.
166 -- When an update occurs, it also computes a patch to communicate to the parent QueryT state.
167 -- bs0 is a Map denoting the behaviors of the current children.
168 -- pbs is a PatchMap denoting an update to the behaviors of the current children
169 accumBehaviors bs0 pbs@(PatchMap bs') = do
170 let p k bs = case Map.lookup k bs0 of
171 Nothing -> case bs of
172 -- If the update is to delete the state for a child that doesn't exist, the patch is mempty.
173 Nothing -> return mempty
174 -- If the update is to update the state for a child that doesn't exist, the patch is the sample of the new state.
175 Just newBs -> sampleBs newBs
176 Just oldBs -> case bs of
177 -- 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
178 Nothing -> negateG <$> sampleBs oldBs
179 -- 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
180 -- composed with the sampling the child's new state.
181 Just newBs -> (~~) <$> sampleBs newBs <*> sampleBs oldBs
182 -- we compute the patch by iterating over the update PatchMap and proceeding by cases. Then we fold over the
183 -- child patches and wrap them in AdditivePatch.
184 patch <- AdditivePatch . fold <$> Map.traverseWithKey p bs'
185 return (apply pbs bs0, Just patch)
186 (qpatch :: Event t (AdditivePatch q)) <- mapAccumMaybeM_ accumBehaviors liftedBs0 liftedBs'
187 tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch
188 return (liftedResult0, liftedResult')
190 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'))
191 traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = do
192 let f' :: forall a. k a -> v a -> EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m) (Compose (QueryTLoweredResult t q) v' a)
193 f' k v = fmap (Compose . QueryTLoweredResult) $ flip runStateT [] $ unQueryT $ f k v
194 (result0, result') <- QueryT $ lift $ traverseDMapWithKeyWithAdjustWithMove f' dm0 dm'
195 let liftedResult0 = mapKeyValuePairsMonotonic (\(k :=> Compose r) -> k :=> getQueryTLoweredResultValue r) result0
196 liftedResult' = fforCheap result' $ mapPatchDMapWithMove (getQueryTLoweredResultValue . getCompose)
197 liftedBs0 :: Map (Some k) [Behavior t q]
198 liftedBs0 = Map.fromDistinctAscList $ (\(k :=> Compose r) -> (Some.This k, getQueryTLoweredResultWritten r)) <$> DMap.toList result0
199 liftedBs' :: Event t (PatchMapWithMove (Some k) [Behavior t q])
200 liftedBs' = fforCheap result' $ weakenPatchDMapWithMoveWith (getQueryTLoweredResultWritten . getCompose) {- \(PatchDMap p) -> PatchMapWithMove $
201 Map.fromDistinctAscList $ (\(k :=> mr) -> (Some.This k, fmap (fmap (getQueryTLoweredResultWritten . getCompose)) mr)) <$> DMap.toList p -}
202 sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q
203 sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty
204 accumBehaviors' :: forall m'. MonadHold t m'
205 => Map (Some k) [Behavior t q]
206 -> PatchMapWithMove (Some k) [Behavior t q]
207 -> m' ( Maybe (Map (Some k) [Behavior t q])
208 , Maybe (AdditivePatch q))
209 -- f accumulates the child behavior state we receive from running traverseDMapWithKeyWithAdjustWithMove for the underlying monad.
210 -- When an update occurs, it also computes a patch to communicate to the parent QueryT state.
211 -- bs0 is a Map denoting the behaviors of the current children.
212 -- pbs is a PatchMapWithMove denoting an update to the behaviors of the current children
213 accumBehaviors' bs0 pbs = do
214 let bs' = unPatchMapWithMove pbs
215 p k bs = case Map.lookup k bs0 of
216 Nothing -> case MapWithMove._nodeInfo_from bs of
217 -- If the update is to delete the state for a child that doesn't exist, the patch is mempty.
218 MapWithMove.From_Delete -> return mempty
219 -- If the update is to update the state for a child that doesn't exist, the patch is the sample of the new state.
220 MapWithMove.From_Insert newBs -> sampleBs newBs
221 MapWithMove.From_Move k' -> case Map.lookup k' bs0 of
222 Nothing -> return mempty
223 Just newBs -> sampleBs newBs
224 Just oldBs -> case MapWithMove._nodeInfo_from bs of
225 -- 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
226 MapWithMove.From_Delete -> negateG <$> sampleBs oldBs
227 -- 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
228 -- composed with the sampling the child's new state.
229 MapWithMove.From_Insert newBs -> (~~) <$> sampleBs newBs <*> sampleBs oldBs
230 MapWithMove.From_Move k'
231 | k' == k -> return mempty
232 | otherwise -> case Map.lookup k' bs0 of
233 -- If we are moving from a non-existent key, that is a delete
234 Nothing -> negateG <$> sampleBs oldBs
235 Just newBs -> (~~) <$> sampleBs newBs <*> sampleBs oldBs
236 -- we compute the patch by iterating over the update PatchMap and proceeding by cases. Then we fold over the
237 -- child patches and wrap them in AdditivePatch.
238 patch <- AdditivePatch . fold <$> Map.traverseWithKey p bs'
239 return (apply pbs bs0, Just patch)
240 (qpatch :: Event t (AdditivePatch q)) <- mapAccumMaybeM_ accumBehaviors' liftedBs0 liftedBs'
241 tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch
242 return (liftedResult0, liftedResult')
244instance MonadTrans (QueryT t q) where
245 lift = QueryT . lift . lift . lift
247instance PostBuild t m => PostBuild t (QueryT t q m) where
248 getPostBuild = lift getPostBuild
250instance (MonadAsyncException m) => MonadAsyncException (QueryT t q m) where
251 mask f = QueryT $ mask $ \unMask -> unQueryT $ f $ QueryT . unMask . unQueryT
253instance TriggerEvent t m => TriggerEvent t (QueryT t q m) where
254 newTriggerEvent = lift newTriggerEvent
255 newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
256 newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
258instance PerformEvent t m => PerformEvent t (QueryT t q m) where
259 type Performable (QueryT t q m) = Performable m
260 performEvent_ = lift . performEvent_
261 performEvent = lift . performEvent
263instance MonadRef m => MonadRef (QueryT t q m) where
264 type Ref (QueryT t q m) = Ref m
265 newRef = QueryT . newRef
266 readRef = QueryT . readRef
267 writeRef r = QueryT . writeRef r
269instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (QueryT t q m) where
270 newEventWithTrigger = QueryT . newEventWithTrigger
271 newFanEventWithTrigger a = QueryT . lift $ newFanEventWithTrigger a
273-- TODO: Monoid and Semigroup can likely be derived once StateT has them.
274instance (Monoid a, Monad m) => Monoid (QueryT t q m a) where
278instance (S.Semigroup a, Monad m) => S.Semigroup (QueryT t q m a) where
281-- | withQueryT's QueryMorphism argument needs to be a group homomorphism in order to behave correctly
282withQueryT :: (MonadFix m, PostBuild t m, Group q, Group q', Additive q, Additive q', Query q')
283 => QueryMorphism q q'
288 (result, q) <- lift $ runQueryT a $ mapQueryResult f <$> r'
289 tellQueryIncremental $ unsafeBuildIncremental
290 (fmap (mapQuery f) (sample (currentIncremental q)))
291 (fmapCheap (AdditivePatch . mapQuery f . unAdditivePatch) $ updatedIncremental q)
294-- | dynWithQueryT's (Dynamic t QueryMorphism) argument needs to be a group homomorphism at all times in order to behave correctly
295dynWithQueryT :: (MonadFix m, PostBuild t m, Group q, Additive q, Group q', Additive q', Query q')
296 => Dynamic t (QueryMorphism q q')
299dynWithQueryT f q = do
301 (result, q') <- lift $ runQueryT q $ zipDynWith mapQueryResult f r'
302 tellQueryIncremental $ zipDynIncrementalWith mapQuery f q'
304 where zipDynIncrementalWith g da ib =
305 let eab = align (updated da) (updatedIncremental ib)
306 ec = flip push eab $ \case
308 aOld <- sample $ current da
309 b <- sample $ currentIncremental ib
310 return $ Just $ AdditivePatch (g a b ~~ g aOld b)
311 That (AdditivePatch b) -> do
312 a <- sample $ current da
313 return $ Just $ AdditivePatch $ g a b
314 These a (AdditivePatch b) -> do
315 aOld <- sample $ current da
316 bOld <- sample $ currentIncremental ib
317 return $ Just $ AdditivePatch $ mconcat [ g a bOld, negateG (g aOld bOld), g a b]
318 in unsafeBuildIncremental (g <$> sample (current da) <*> sample (currentIncremental ib)) ec
320instance (Monad m, Group q, Additive q, Query q, Reflex t) => MonadQuery t q (QueryT t q m) where
321 tellQueryIncremental q = do
322 QueryT (modify (currentIncremental q:))
323 QueryT (lift (tellEvent (fmapCheap unAdditivePatch (updatedIncremental q))))
324 askQueryResult = QueryT ask
325 queryIncremental q = do
326 tellQueryIncremental q
327 zipDynWith crop (incrementalToDynamic q) <$> askQueryResult
329instance Requester t m => Requester t (QueryT t q m) where
330 type Request (QueryT t q m) = Request m
331 type Response (QueryT t q m) = Response m
332 requesting = lift . requesting
333 requesting_ = lift . requesting_
335instance EventWriter t w m => EventWriter t w (QueryT t q m) where
336 tellEvent = lift . tellEvent
338instance MonadDynamicWriter t w m => MonadDynamicWriter t w (QueryT t q m) where
339 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