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.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
76let sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q
77 sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty
78 bs' = fmapCheap snd $ r'
79 patches = unsafeBuildIncremental (sampleBs bs0) $
80 flip pushCheap bs' $ \bs -> do
81 p <- (~~) <$> sampleBs bs <*> sample (currentIncremental patches)
82 return (Just (AdditivePatch p))
85instance (Reflex t, MonadFix m, Group q, Additive q, Query q, MonadHold t m, Adjustable t m) => Adjustable t (QueryT t q m) where
86 runWithReplace (QueryT a0) a' = do
87 ((r0, bs0), r') <- QueryT $ lift $ runWithReplace (runStateT a0 []) $ fmapCheap (flip runStateT [] . unQueryT) a'
88 let sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q
89 sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty
90 bs' = fmapCheap snd $ r'
92 let patches = flip pushAlwaysCheap bs' $ \newBs -> do
94 (~~) <$> sampleBs newBs <*> sampleBs oldBs
95 QueryT $ modify $ (:) $ pull $ sampleBs =<< sample bbs
96 QueryT $ lift $ tellEvent patches
97 return (r0, fmapCheap fst r')
99 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'))
100 traverseIntMapWithKeyWithAdjust f im0 im' = do
101 let f' :: IntMap.Key -> v -> EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m) (QueryTLoweredResult t q v')
102 f' k v = fmap QueryTLoweredResult $ flip runStateT [] $ unQueryT $ f k v
103 (result0, result') <- QueryT $ lift $ traverseIntMapWithKeyWithAdjust f' im0 im'
104 let liftedResult0 = IntMap.map (\r -> getQueryTLoweredResultValue r) result0
105 liftedResult' = fforCheap result' $ \(PatchIntMap p) -> PatchIntMap $
106 IntMap.map (\mr -> fmap getQueryTLoweredResultValue mr) p
107 liftedBs0 :: IntMap [Behavior t q]
108 liftedBs0 = IntMap.map (\r -> getQueryTLoweredResultWritten r) result0
109 liftedBs' :: Event t (PatchIntMap [Behavior t q])
110 liftedBs' = fforCheap result' $ \(PatchIntMap p) -> PatchIntMap $
111 IntMap.map (\mr -> fmap getQueryTLoweredResultWritten mr) p
112 sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q
113 sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty
114 accumBehaviors :: forall m'. MonadHold t m'
115 => IntMap [Behavior t q]
116 -> PatchIntMap [Behavior t q]
117 -> m' ( Maybe (IntMap [Behavior t q])
118 , Maybe (AdditivePatch q))
119 -- f accumulates the child behavior state we receive from running traverseIntMapWithKeyWithAdjust for the underlying monad.
120 -- When an update occurs, it also computes a patch to communicate to the parent QueryT state.
121 -- bs0 is a Map denoting the behaviors of the current children.
122 -- pbs is a PatchMap denoting an update to the behaviors of the current children
123 accumBehaviors bs0 pbs@(PatchIntMap bs') = do
124 let p k bs = case IntMap.lookup k bs0 of
125 Nothing -> case bs of
126 -- If the update is to delete the state for a child that doesn't exist, the patch is mempty.
127 Nothing -> return mempty
128 -- If the update is to update the state for a child that doesn't exist, the patch is the sample of the new state.
129 Just newBs -> sampleBs newBs
130 Just oldBs -> case bs of
131 -- 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
132 Nothing -> negateG <$> sampleBs oldBs
133 -- 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
134 -- composed with the sampling the child's new state.
135 Just newBs -> (~~) <$> sampleBs newBs <*> sampleBs oldBs
136 -- we compute the patch by iterating over the update PatchMap and proceeding by cases. Then we fold over the
137 -- child patches and wrap them in AdditivePatch.
138 patch <- AdditivePatch . fold <$> IntMap.traverseWithKey p bs'
139 return (apply pbs bs0, Just patch)
140 (qpatch :: Event t (AdditivePatch q)) <- mapAccumMaybeM_ accumBehaviors liftedBs0 liftedBs'
141 tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch
142 return (liftedResult0, liftedResult')
144 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'))
145 traverseDMapWithKeyWithAdjust f dm0 dm' = do
146 let f' :: forall a. k a -> v a -> EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m) (Compose (QueryTLoweredResult t q) v' a)
147 f' k v = fmap (Compose . QueryTLoweredResult) $ flip runStateT [] $ unQueryT $ f k v
148 (result0, result') <- QueryT $ lift $ traverseDMapWithKeyWithAdjust f' dm0 dm'
149 let liftedResult0 = mapKeyValuePairsMonotonic (\(k :=> Compose r) -> k :=> getQueryTLoweredResultValue r) result0
150 liftedResult' = fforCheap result' $ \(PatchDMap p) -> PatchDMap $
151 mapKeyValuePairsMonotonic (\(k :=> ComposeMaybe mr) -> k :=> ComposeMaybe (fmap (getQueryTLoweredResultValue . getCompose) mr)) p
152 liftedBs0 :: Map (Some k) [Behavior t q]
153 liftedBs0 = Map.fromDistinctAscList $ (\(k :=> Compose r) -> (Some.This k, getQueryTLoweredResultWritten r)) <$> DMap.toList result0
154 liftedBs' :: Event t (PatchMap (Some k) [Behavior t q])
155 liftedBs' = fforCheap result' $ \(PatchDMap p) -> PatchMap $
156 Map.fromDistinctAscList $ (\(k :=> ComposeMaybe mr) -> (Some.This k, fmap (getQueryTLoweredResultWritten . getCompose) mr)) <$> DMap.toList p
157 sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q
158 sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty
159 accumBehaviors :: forall m'. MonadHold t m'
160 => Map (Some k) [Behavior t q]
161 -> PatchMap (Some k) [Behavior t q]
162 -> m' ( Maybe (Map (Some k) [Behavior t q])
163 , Maybe (AdditivePatch q))
164 -- f accumulates the child behavior state we receive from running traverseDMapWithKeyWithAdjust for the underlying monad.
165 -- When an update occurs, it also computes a patch to communicate to the parent QueryT state.
166 -- bs0 is a Map denoting the behaviors of the current children.
167 -- pbs is a PatchMap denoting an update to the behaviors of the current children
168 accumBehaviors bs0 pbs@(PatchMap bs') = do
169 let p k bs = case Map.lookup k bs0 of
170 Nothing -> case bs of
171 -- If the update is to delete the state for a child that doesn't exist, the patch is mempty.
172 Nothing -> return mempty
173 -- If the update is to update the state for a child that doesn't exist, the patch is the sample of the new state.
174 Just newBs -> sampleBs newBs
175 Just oldBs -> case bs of
176 -- 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
177 Nothing -> negateG <$> sampleBs oldBs
178 -- 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
179 -- composed with the sampling the child's new state.
180 Just newBs -> (~~) <$> sampleBs newBs <*> sampleBs oldBs
181 -- we compute the patch by iterating over the update PatchMap and proceeding by cases. Then we fold over the
182 -- child patches and wrap them in AdditivePatch.
183 patch <- AdditivePatch . fold <$> Map.traverseWithKey p bs'
184 return (apply pbs bs0, Just patch)
185 (qpatch :: Event t (AdditivePatch q)) <- mapAccumMaybeM_ accumBehaviors liftedBs0 liftedBs'
186 tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch
187 return (liftedResult0, liftedResult')
189 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'))
190 traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = do
191 let f' :: forall a. k a -> v a -> EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m) (Compose (QueryTLoweredResult t q) v' a)
192 f' k v = fmap (Compose . QueryTLoweredResult) $ flip runStateT [] $ unQueryT $ f k v
193 (result0, result') <- QueryT $ lift $ traverseDMapWithKeyWithAdjustWithMove f' dm0 dm'
194 let liftedResult0 = mapKeyValuePairsMonotonic (\(k :=> Compose r) -> k :=> getQueryTLoweredResultValue r) result0
195 liftedResult' = fforCheap result' $ mapPatchDMapWithMove (getQueryTLoweredResultValue . getCompose)
196 liftedBs0 :: Map (Some k) [Behavior t q]
197 liftedBs0 = Map.fromDistinctAscList $ (\(k :=> Compose r) -> (Some.This k, getQueryTLoweredResultWritten r)) <$> DMap.toList result0
198 liftedBs' :: Event t (PatchMapWithMove (Some k) [Behavior t q])
199 liftedBs' = fforCheap result' $ weakenPatchDMapWithMoveWith (getQueryTLoweredResultWritten . getCompose) {- \(PatchDMap p) -> PatchMapWithMove $
200 Map.fromDistinctAscList $ (\(k :=> mr) -> (Some.This k, fmap (fmap (getQueryTLoweredResultWritten . getCompose)) mr)) <$> DMap.toList p -}
201 sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q
202 sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty
203 accumBehaviors' :: forall m'. MonadHold t m'
204 => Map (Some k) [Behavior t q]
205 -> PatchMapWithMove (Some k) [Behavior t q]
206 -> m' ( Maybe (Map (Some k) [Behavior t q])
207 , Maybe (AdditivePatch q))
208 -- f accumulates the child behavior state we receive from running traverseDMapWithKeyWithAdjustWithMove for the underlying monad.
209 -- When an update occurs, it also computes a patch to communicate to the parent QueryT state.
210 -- bs0 is a Map denoting the behaviors of the current children.
211 -- pbs is a PatchMapWithMove denoting an update to the behaviors of the current children
212 accumBehaviors' bs0 pbs = do
213 let bs' = unPatchMapWithMove pbs
214 p k bs = case Map.lookup k bs0 of
215 Nothing -> case MapWithMove._nodeInfo_from bs of
216 -- If the update is to delete the state for a child that doesn't exist, the patch is mempty.
217 MapWithMove.From_Delete -> return mempty
218 -- If the update is to update the state for a child that doesn't exist, the patch is the sample of the new state.
219 MapWithMove.From_Insert newBs -> sampleBs newBs
220 MapWithMove.From_Move k' -> case Map.lookup k' bs0 of
221 Nothing -> return mempty
222 Just newBs -> sampleBs newBs
223 Just oldBs -> case MapWithMove._nodeInfo_from bs of
224 -- 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
225 MapWithMove.From_Delete -> negateG <$> sampleBs oldBs
226 -- 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
227 -- composed with the sampling the child's new state.
228 MapWithMove.From_Insert newBs -> (~~) <$> sampleBs newBs <*> sampleBs oldBs
229 MapWithMove.From_Move k'
230 | k' == k -> return mempty
231 | otherwise -> case Map.lookup k' bs0 of
232 -- If we are moving from a non-existent key, that is a delete
233 Nothing -> negateG <$> sampleBs oldBs
234 Just newBs -> (~~) <$> sampleBs newBs <*> sampleBs oldBs
235 -- we compute the patch by iterating over the update PatchMap and proceeding by cases. Then we fold over the
236 -- child patches and wrap them in AdditivePatch.
237 patch <- AdditivePatch . fold <$> Map.traverseWithKey p bs'
238 return (apply pbs bs0, Just patch)
239 (qpatch :: Event t (AdditivePatch q)) <- mapAccumMaybeM_ accumBehaviors' liftedBs0 liftedBs'
240 tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch
241 return (liftedResult0, liftedResult')
243instance MonadTrans (QueryT t q) where
244 lift = QueryT . lift . lift . lift
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
281mapQuery :: QueryMorphism q q' -> q -> q'
282mapQuery = _queryMorphism_mapQuery
284mapQueryResult :: QueryMorphism q q' -> QueryResult q' -> QueryResult q
285mapQueryResult = _queryMorphism_mapQueryResult
287-- | withQueryT's QueryMorphism argument needs to be a group homomorphism in order to behave correctly
288withQueryT :: (MonadFix m, PostBuild t m, Group q, Group q', Additive q, Additive q', Query q')
289 => QueryMorphism q q'
294 (result, q) <- lift $ runQueryT a $ mapQueryResult f <$> r'
295 tellQueryIncremental $ unsafeBuildIncremental
296 (fmap (mapQuery f) (sample (currentIncremental q)))
297 (fmapCheap (AdditivePatch . mapQuery f . unAdditivePatch) $ updatedIncremental q)
300-- | dynWithQueryT's (Dynamic t QueryMorphism) argument needs to be a group homomorphism at all times in order to behave correctly
301dynWithQueryT :: (MonadFix m, PostBuild t m, Group q, Additive q, Group q', Additive q', Query q')
302 => Dynamic t (QueryMorphism q q')
305dynWithQueryT f q = do
307 (result, q') <- lift $ runQueryT q $ zipDynWith mapQueryResult f r'
308 tellQueryIncremental $ zipDynIncrementalWith mapQuery f q'
310 where zipDynIncrementalWith g da ib =
311 let eab = align (updated da) (updatedIncremental ib)
312 ec = flip push eab $ \case
314 aOld <- sample $ current da
315 b <- sample $ currentIncremental ib
316 return $ Just $ AdditivePatch (g a b ~~ g aOld b)
317 That (AdditivePatch b) -> do
318 a <- sample $ current da
319 return $ Just $ AdditivePatch $ g a b
320 These a (AdditivePatch b) -> do
321 aOld <- sample $ current da
322 bOld <- sample $ currentIncremental ib
323 return $ Just $ AdditivePatch $ mconcat [ g a bOld, negateG (g aOld bOld), g a b]
324 in unsafeBuildIncremental (g <$> sample (current da) <*> sample (currentIncremental ib)) ec
326instance (Monad m, Group q, Additive q, Query q, Reflex t) => MonadQuery t q (QueryT t q m) where
327 tellQueryIncremental q = do
328 QueryT (modify (currentIncremental q:))
329 QueryT (lift (tellEvent (fmapCheap unAdditivePatch (updatedIncremental q))))
330 askQueryResult = QueryT ask
331 queryIncremental q = do
332 tellQueryIncremental q
333 zipDynWith crop (incrementalToDynamic q) <$> askQueryResult
335instance Requester t m => Requester t (QueryT t q m) where
336 type Request (QueryT t q m) = Request m
337 type Response (QueryT t q m) = Response m
338 requesting = lift . requesting
339 requesting_ = lift . requesting_
341instance EventWriter t w m => EventWriter t w (QueryT t q m) where
342 tellEvent = lift . tellEvent
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