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