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.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(Some))
45import Reflex.Adjustable.Class
46import Reflex.DynamicWriter.Class
47import Reflex.EventWriter.Base
48import Reflex.EventWriter.Class
49import Reflex.Host.Class
50import qualified Data.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
76maskMempty :: (Eq a, Monoid a) => a -> Maybe a
77maskMempty x = if x == mempty then Nothing else Just x
79instance (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
80 runWithReplace (QueryT a0) a' = do
81 ((r0, bs0), r') <- QueryT $ lift $ runWithReplace (runStateT a0 []) $ fmapCheap (flip runStateT [] . unQueryT) a'
82 let sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q
83 sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty
84 bs' = fmapCheap snd $ r'
86 let patches = flip pushCheap bs' $ \newBs -> do
88 maskMempty <$> ((~~) <$> sampleBs newBs <*> sampleBs oldBs)
89 QueryT $ modify $ (:) $ pull $ sampleBs =<< sample bbs
90 QueryT $ lift $ tellEvent patches
91 return (r0, fmapCheap fst r')
93 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'))
94 traverseIntMapWithKeyWithAdjust f im0 im' = do
95 let f' :: IntMap.Key -> v -> EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m) (QueryTLoweredResult t q v')
96 f' k v = fmap QueryTLoweredResult $ flip runStateT [] $ unQueryT $ f k v
97 (result0, result') <- QueryT $ lift $ traverseIntMapWithKeyWithAdjust f' im0 im'
98 let liftedResult0 = IntMap.map getQueryTLoweredResultValue result0
99 liftedResult' = fforCheap result' $ \(PatchIntMap p) -> PatchIntMap $
100 IntMap.map (fmap getQueryTLoweredResultValue) p
101 liftedBs0 :: IntMap [Behavior t q]
102 liftedBs0 = IntMap.map getQueryTLoweredResultWritten result0
103 liftedBs' :: Event t (PatchIntMap [Behavior t q])
104 liftedBs' = fforCheap result' $ \(PatchIntMap p) -> PatchIntMap $
105 IntMap.map (fmap getQueryTLoweredResultWritten) p
106 sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q
107 sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty
108 accumBehaviors :: forall m'. MonadHold t m'
109 => IntMap [Behavior t q]
110 -> PatchIntMap [Behavior t q]
111 -> m' ( Maybe (IntMap [Behavior t q])
112 , Maybe (AdditivePatch q))
113 -- f accumulates the child behavior state we receive from running traverseIntMapWithKeyWithAdjust for the underlying monad.
114 -- When an update occurs, it also computes a patch to communicate to the parent QueryT state.
115 -- bs0 is a Map denoting the behaviors of the current children.
116 -- pbs is a PatchMap denoting an update to the behaviors of the current children
117 accumBehaviors bs0 pbs@(PatchIntMap bs') = do
118 let p k bs = case IntMap.lookup k bs0 of
119 Nothing -> case bs of
120 -- If the update is to delete the state for a child that doesn't exist, the patch is mempty.
121 Nothing -> return mempty
122 -- If the update is to update the state for a child that doesn't exist, the patch is the sample of the new state.
123 Just newBs -> sampleBs newBs
124 Just oldBs -> case bs of
125 -- 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
126 Nothing -> negateG <$> sampleBs oldBs
127 -- 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
128 -- composed with the sampling the child's new state.
129 Just newBs -> (~~) <$> sampleBs newBs <*> sampleBs oldBs
130 -- we compute the patch by iterating over the update PatchMap and proceeding by cases. Then we fold over the
131 -- child patches and wrap them in AdditivePatch.
132 patch <- AdditivePatch . fold <$> IntMap.traverseWithKey p bs'
133 return (apply pbs bs0, Just patch)
134 (qpatch :: Event t (AdditivePatch q)) <- mapAccumMaybeM_ accumBehaviors liftedBs0 liftedBs'
135 tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch
136 return (liftedResult0, liftedResult')
138 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'))
139 traverseDMapWithKeyWithAdjust f dm0 dm' = do
140 let f' :: forall a. k a -> v a -> EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m) (Compose (QueryTLoweredResult t q) v' a)
141 f' k v = fmap (Compose . QueryTLoweredResult) $ flip runStateT [] $ unQueryT $ f k v
142 (result0, result') <- QueryT $ lift $ traverseDMapWithKeyWithAdjust f' dm0 dm'
143 let liftedResult0 = mapKeyValuePairsMonotonic (\(k :=> Compose r) -> k :=> getQueryTLoweredResultValue r) result0
144 liftedResult' = fforCheap result' $ \(PatchDMap p) -> PatchDMap $
145 mapKeyValuePairsMonotonic (\(k :=> ComposeMaybe mr) -> k :=> ComposeMaybe (fmap (getQueryTLoweredResultValue . getCompose) mr)) p
146 liftedBs0 :: Map (Some k) [Behavior t q]
147 liftedBs0 = Map.fromDistinctAscList $ (\(k :=> Compose r) -> (Some k, getQueryTLoweredResultWritten r)) <$> DMap.toList result0
148 liftedBs' :: Event t (PatchMap (Some k) [Behavior t q])
149 liftedBs' = fforCheap result' $ \(PatchDMap p) -> PatchMap $
150 Map.fromDistinctAscList $ (\(k :=> ComposeMaybe mr) -> (Some k, fmap (getQueryTLoweredResultWritten . getCompose) mr)) <$> DMap.toList p
151 sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q
152 sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty
153 accumBehaviors :: forall m'. MonadHold t m'
154 => Map (Some k) [Behavior t q]
155 -> PatchMap (Some k) [Behavior t q]
156 -> m' ( Maybe (Map (Some k) [Behavior t q])
157 , Maybe (AdditivePatch q))
158 -- f accumulates the child behavior state we receive from running traverseDMapWithKeyWithAdjust for the underlying monad.
159 -- When an update occurs, it also computes a patch to communicate to the parent QueryT state.
160 -- bs0 is a Map denoting the behaviors of the current children.
161 -- pbs is a PatchMap denoting an update to the behaviors of the current children
162 accumBehaviors bs0 pbs@(PatchMap bs') = do
163 let p k bs = case Map.lookup k bs0 of
164 Nothing -> case bs of
165 -- If the update is to delete the state for a child that doesn't exist, the patch is mempty.
166 Nothing -> return Nothing
167 -- If the update is to update the state for a child that doesn't exist, the patch is the sample of the new state.
168 Just newBs -> maskMempty <$> sampleBs newBs
169 Just oldBs -> case bs of
170 -- 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
171 Nothing -> maskMempty . negateG <$> sampleBs oldBs
172 -- 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
173 -- composed with the sampling the child's new state.
174 Just newBs -> maskMempty <$> ((~~) <$> sampleBs newBs <*> sampleBs oldBs)
175 -- we compute the patch by iterating over the update PatchMap and proceeding by cases. Then we fold over the
176 -- child patches and wrap them in AdditivePatch.
177 patch <- fold <$> Map.traverseWithKey p bs'
178 return (apply pbs bs0, AdditivePatch <$> patch)
179 (qpatch :: Event t (AdditivePatch q)) <- mapAccumMaybeM_ accumBehaviors liftedBs0 liftedBs'
180 tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch
181 return (liftedResult0, liftedResult')
183 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'))
184 traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = do
185 let f' :: forall a. k a -> v a -> EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m) (Compose (QueryTLoweredResult t q) v' a)
186 f' k v = fmap (Compose . QueryTLoweredResult) $ flip runStateT [] $ unQueryT $ f k v
187 (result0, result') <- QueryT $ lift $ traverseDMapWithKeyWithAdjustWithMove f' dm0 dm'
188 let liftedResult0 = mapKeyValuePairsMonotonic (\(k :=> Compose r) -> k :=> getQueryTLoweredResultValue r) result0
189 liftedResult' = fforCheap result' $ mapPatchDMapWithMove (getQueryTLoweredResultValue . getCompose)
190 liftedBs0 :: Map (Some k) [Behavior t q]
191 liftedBs0 = Map.fromDistinctAscList $ (\(k :=> Compose r) -> (Some k, getQueryTLoweredResultWritten r)) <$> DMap.toList result0
192 liftedBs' :: Event t (PatchMapWithMove (Some k) [Behavior t q])
193 liftedBs' = fforCheap result' $ weakenPatchDMapWithMoveWith (getQueryTLoweredResultWritten . getCompose) {- \(PatchDMap p) -> PatchMapWithMove $
194 Map.fromDistinctAscList $ (\(k :=> mr) -> (Some k, fmap (fmap (getQueryTLoweredResultWritten . getCompose)) mr)) <$> DMap.toList p -}
195 sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q
196 sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty
197 accumBehaviors' :: forall m'. MonadHold t m'
198 => Map (Some k) [Behavior t q]
199 -> PatchMapWithMove (Some k) [Behavior t q]
200 -> m' ( Maybe (Map (Some k) [Behavior t q])
201 , Maybe (AdditivePatch q))
202 -- f accumulates the child behavior state we receive from running traverseDMapWithKeyWithAdjustWithMove for the underlying monad.
203 -- When an update occurs, it also computes a patch to communicate to the parent QueryT state.
204 -- bs0 is a Map denoting the behaviors of the current children.
205 -- pbs is a PatchMapWithMove denoting an update to the behaviors of the current children
206 accumBehaviors' bs0 pbs = do
207 let bs' = unPatchMapWithMove pbs
208 p k bs = case Map.lookup k bs0 of
209 Nothing -> case MapWithMove._nodeInfo_from bs of
210 -- If the update is to delete the state for a child that doesn't exist, the patch is mempty.
211 MapWithMove.From_Delete -> return Nothing
212 -- If the update is to update the state for a child that doesn't exist, the patch is the sample of the new state.
213 MapWithMove.From_Insert newBs -> maskMempty <$> sampleBs newBs
214 MapWithMove.From_Move k' -> case Map.lookup k' bs0 of
215 Nothing -> return Nothing
216 Just newBs -> maskMempty <$> sampleBs newBs
217 Just oldBs -> case MapWithMove._nodeInfo_from bs of
218 -- 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
219 MapWithMove.From_Delete -> maskMempty . negateG <$> sampleBs oldBs
220 -- 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
221 -- composed with the sampling the child's new state.
222 MapWithMove.From_Insert newBs -> maskMempty <$> ((~~) <$> sampleBs newBs <*> sampleBs oldBs)
223 MapWithMove.From_Move k'
224 | k' == k -> return Nothing
225 | otherwise -> case Map.lookup k' bs0 of
226 -- If we are moving from a non-existent key, that is a delete
227 Nothing -> maskMempty . negateG <$> sampleBs oldBs
228 Just newBs -> maskMempty <$> ((~~) <$> sampleBs newBs <*> sampleBs oldBs)
229 -- we compute the patch by iterating over the update PatchMap and proceeding by cases. Then we fold over the
230 -- child patches and wrap them in AdditivePatch.
231 patch <- fold <$> Map.traverseWithKey p bs'
232 return (apply pbs bs0, AdditivePatch <$> patch)
233 (qpatch :: Event t (AdditivePatch q)) <- mapAccumMaybeM_ accumBehaviors' liftedBs0 liftedBs'
234 tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch
235 return (liftedResult0, liftedResult')
237instance MonadTrans (QueryT t q) where
238 lift = QueryT . lift . lift . lift
240instance PrimMonad m => PrimMonad (QueryT t q m) where
241 type PrimState (QueryT t q m) = PrimState m
242 primitive = lift . primitive
244instance PostBuild t m => PostBuild t (QueryT t q m) where
245 getPostBuild = lift getPostBuild
247instance (MonadAsyncException m) => MonadAsyncException (QueryT t q m) where
248 mask f = QueryT $ mask $ \unMask -> unQueryT $ f $ QueryT . unMask . unQueryT
250instance TriggerEvent t m => TriggerEvent t (QueryT t q m) where
251 newTriggerEvent = lift newTriggerEvent
252 newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
253 newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
255instance PerformEvent t m => PerformEvent t (QueryT t q m) where
256 type Performable (QueryT t q m) = Performable m
257 performEvent_ = lift . performEvent_
258 performEvent = lift . performEvent
260instance MonadRef m => MonadRef (QueryT t q m) where
261 type Ref (QueryT t q m) = Ref m
262 newRef = QueryT . newRef
263 readRef = QueryT . readRef
264 writeRef r = QueryT . writeRef r
266instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (QueryT t q m) where
267 newEventWithTrigger = QueryT . newEventWithTrigger
268 newFanEventWithTrigger a = QueryT . lift $ newFanEventWithTrigger a
270-- TODO: Monoid and Semigroup can likely be derived once StateT has them.
271instance (Monoid a, Monad m) => Monoid (QueryT t q m a) where
275instance (S.Semigroup a, Monad m) => S.Semigroup (QueryT t q m a) where
278-- | withQueryT's QueryMorphism argument needs to be a group homomorphism in order to behave correctly
279withQueryT :: (MonadFix m, PostBuild t m, Group q, Group q', Additive q, Additive q', Query q')
280 => QueryMorphism q q'
285 (result, q) <- lift $ runQueryT a $ mapQueryResult f <$> r'
286 tellQueryIncremental $ unsafeBuildIncremental
287 (fmap (mapQuery f) (sample (currentIncremental q)))
288 (fmapCheap (AdditivePatch . mapQuery f . unAdditivePatch) $ updatedIncremental q)
291-- | Maps a function over a 'QueryT' that can change the underlying monad
292mapQueryT :: (forall b. m b -> n b) -> QueryT t q m a -> QueryT t q n a
293mapQueryT f (QueryT a) = QueryT $ mapStateT (mapEventWriterT (mapReaderT f)) a
295-- | dynWithQueryT's (Dynamic t QueryMorphism) argument needs to be a group homomorphism at all times in order to behave correctly
296dynWithQueryT :: (MonadFix m, PostBuild t m, Group q, Additive q, Group q', Additive q', Query q')
297 => Dynamic t (QueryMorphism q q')
300dynWithQueryT f q = do
302 (result, q') <- lift $ runQueryT q $ zipDynWith mapQueryResult f r'
303 tellQueryIncremental $ zipDynIncrementalWith mapQuery f q'
305 where zipDynIncrementalWith g da ib =
306 let eab = align (updated da) (updatedIncremental ib)
307 ec = flip push eab $ \case
309 aOld <- sample $ current da
310 b <- sample $ currentIncremental ib
311 return $ Just $ AdditivePatch (g a b ~~ g aOld b)
312 That (AdditivePatch b) -> do
313 a <- sample $ current da
314 return $ Just $ AdditivePatch $ g a b
315 These a (AdditivePatch b) -> do
316 aOld <- sample $ current da
317 bOld <- sample $ currentIncremental ib
318 return $ Just $ AdditivePatch $ mconcat [ g a bOld, negateG (g aOld bOld), g a b]
319 in unsafeBuildIncremental (g <$> sample (current da) <*> sample (currentIncremental ib)) ec
321instance (Monad m, Group q, Additive q, Query q, Reflex t) => MonadQuery t q (QueryT t q m) where
322 tellQueryIncremental q = do
323 QueryT (modify (currentIncremental q:))
324 QueryT (lift (tellEvent (fmapCheap unAdditivePatch (updatedIncremental q))))
325 askQueryResult = QueryT ask
326 queryIncremental q = do
327 tellQueryIncremental q
328 zipDynWith crop (incrementalToDynamic q) <$> askQueryResult
330instance Requester t m => Requester t (QueryT t q m) where
331 type Request (QueryT t q m) = Request m
332 type Response (QueryT t q m) = Response m
333 requesting = lift . requesting
334 requesting_ = lift . requesting_
336instance EventWriter t w m => EventWriter t w (QueryT t q m) where
337 tellEvent = lift . tellEvent
339instance DynamicWriter t w m => DynamicWriter t w (QueryT t q m) where
340 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