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