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