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