1{-# LANGUAGE FlexibleInstances #-}
2{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3{-# LANGUAGE InstanceSigs #-}
4{-# LANGUAGE KindSignatures #-}
5{-# LANGUAGE MultiParamTypeClasses #-}
6{-# LANGUAGE RankNTypes #-}
7{-# LANGUAGE ScopedTypeVariables #-}
8{-# LANGUAGE TypeFamilies #-}
9{-# LANGUAGE UndecidableInstances #-}
10module Reflex.Query.Base
19import Control.Monad.Exception
20import Control.Monad.Fix
21import Control.Monad.Reader
22import Control.Monad.Ref
23import Control.Monad.State.Strict
25import Data.Dependent.Map (DMap, DSum (..))
26import qualified Data.Dependent.Map as DMap
28import Data.Functor.Compose
29import Data.Functor.Misc
31import qualified Data.Map as Map
33import Data.Some (Some)
34import qualified Data.Some as Some
38import Reflex.EventWriter
39import Reflex.Host.Class
40import Reflex.PerformEvent.Class
41import Reflex.PostBuild.Class
42import Reflex.Query.Class
43import Reflex.TriggerEvent.Class
44import qualified Reflex.Patch.MapWithMove as MapWithMove
46newtype QueryT t q m a = QueryT { unQueryT :: StateT [Behavior t q] (EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m)) a }
47 deriving (Functor, Applicative, Monad, MonadException, MonadFix, MonadIO, MonadHold t, MonadSample t, MonadAtomicRef)
49runQueryT :: (MonadFix m, Additive q, Group q, Reflex t) => QueryT t q m a -> Dynamic t (QueryResult q) -> m (a, Incremental t (AdditivePatch q))
50runQueryT (QueryT a) qr = do
51 ((r, bs), es) <- runReaderT (runEventWriterT (runStateT a mempty)) qr
52 return (r, unsafeBuildIncremental (foldlM (\b c -> (b <>) <$> sample c) mempty bs) (fmapCheap AdditivePatch es))
54newtype QueryTLoweredResult t q v = QueryTLoweredResult (v, [Behavior t q])
56getQueryTLoweredResultValue :: QueryTLoweredResult t q v -> v
57getQueryTLoweredResultValue (QueryTLoweredResult (v, _)) = v
59getQueryTLoweredResultWritten :: QueryTLoweredResult t q v -> [Behavior t q]
60getQueryTLoweredResultWritten (QueryTLoweredResult (_, w)) = w
62instance (Reflex t, MonadFix m, Group q, Additive q, Query q, MonadHold t m, MonadAdjust t m) => MonadAdjust t (QueryT t q m) where
63 runWithReplace (QueryT a0) a' = do
64 ((r0, bs0), r') <- QueryT $ lift $ runWithReplace (runStateT a0 []) $ fmapCheap (flip runStateT [] . unQueryT) a'
65 tellQueryIncremental $
66 let sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q
67 sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty
68 bs' = fmapCheap snd $ r'
69 patches = unsafeBuildIncremental (sampleBs bs0) $
70 flip pushCheap bs' $ \bs -> do
71 p <- (~~) <$> sampleBs bs <*> sample (currentIncremental patches)
72 return (Just (AdditivePatch p))
74 return (r0, fmapCheap fst r')
75 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'))
76 traverseDMapWithKeyWithAdjust f dm0 dm' = do
77 let f' :: forall a. k a -> v a -> EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m) (Compose (QueryTLoweredResult t q) v' a)
78 f' k v = fmap (Compose . QueryTLoweredResult) $ flip runStateT [] $ unQueryT $ f k v
79 (result0, result') <- QueryT $ lift $ traverseDMapWithKeyWithAdjust f' dm0 dm'
80 let liftedResult0 = mapKeyValuePairsMonotonic (\(k :=> Compose r) -> k :=> getQueryTLoweredResultValue r) result0
81 liftedResult' = fforCheap result' $ \(PatchDMap p) -> PatchDMap $
82 mapKeyValuePairsMonotonic (\(k :=> ComposeMaybe mr) -> k :=> ComposeMaybe (fmap (getQueryTLoweredResultValue . getCompose) mr)) p
83 liftedBs0 :: Map (Some k) [Behavior t q]
84 liftedBs0 = Map.fromDistinctAscList $ (\(k :=> Compose r) -> (Some.This k, getQueryTLoweredResultWritten r)) <$> DMap.toList result0
85 liftedBs' :: Event t (PatchMap (Some k) [Behavior t q])
86 liftedBs' = fforCheap result' $ \(PatchDMap p) -> PatchMap $
87 Map.fromDistinctAscList $ (\(k :=> ComposeMaybe mr) -> (Some.This k, fmap (getQueryTLoweredResultWritten . getCompose) mr)) <$> DMap.toList p
88 sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q
89 sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty
90 accumBehaviors :: forall m'. MonadHold t m'
91 => Map (Some k) [Behavior t q]
92 -> PatchMap (Some k) [Behavior t q]
93 -> m' ( Maybe (Map (Some k) [Behavior t q])
94 , Maybe (AdditivePatch q))
95 -- f accumulates the child behavior state we receive from running traverseDMapWithKeyWithAdjust for the underlying monad.
96 -- When an update occurs, it also computes a patch to communicate to the parent QueryT state.
97 -- bs0 is a Map denoting the behaviors of the current children.
98 -- pbs is a PatchMap denoting an update to the behaviors of the current children
99 accumBehaviors bs0 pbs@(PatchMap bs') = do
100 let p k bs = case Map.lookup k bs0 of
101 Nothing -> case bs of
102 -- If the update is to delete the state for a child that doesn't exist, the patch is mempty.
103 Nothing -> return mempty
104 -- If the update is to update the state for a child that doesn't exist, the patch is the sample of the new state.
105 Just newBs -> sampleBs newBs
106 Just oldBs -> case bs of
107 -- 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
108 Nothing -> negateG <$> sampleBs oldBs
109 -- 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
110 -- composed with the sampling the child's new state.
111 Just newBs -> (~~) <$> sampleBs newBs <*> sampleBs oldBs
112 -- we compute the patch by iterating over the update PatchMap and proceeding by cases. Then we fold over the
113 -- child patches and wrap them in AdditivePatch.
114 patch <- AdditivePatch . fold <$> Map.traverseWithKey p bs'
115 return (apply pbs bs0, Just patch)
116 (qpatch :: Event t (AdditivePatch q)) <- mapAccumMaybeM_ accumBehaviors liftedBs0 liftedBs'
117 tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch
118 return (liftedResult0, liftedResult')
119 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'))
120 traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = do
121 let f' :: forall a. k a -> v a -> EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m) (Compose (QueryTLoweredResult t q) v' a)
122 f' k v = fmap (Compose . QueryTLoweredResult) $ flip runStateT [] $ unQueryT $ f k v
123 (result0, result') <- QueryT $ lift $ traverseDMapWithKeyWithAdjustWithMove f' dm0 dm'
124 let liftedResult0 = mapKeyValuePairsMonotonic (\(k :=> Compose r) -> k :=> getQueryTLoweredResultValue r) result0
125 liftedResult' = fforCheap result' $ mapPatchDMapWithMove (getQueryTLoweredResultValue . getCompose)
126 liftedBs0 :: Map (Some k) [Behavior t q]
127 liftedBs0 = Map.fromDistinctAscList $ (\(k :=> Compose r) -> (Some.This k, getQueryTLoweredResultWritten r)) <$> DMap.toList result0
128 liftedBs' :: Event t (PatchMapWithMove (Some k) [Behavior t q])
129 liftedBs' = fforCheap result' $ weakenPatchDMapWithMoveWith (getQueryTLoweredResultWritten . getCompose) {- \(PatchDMap p) -> PatchMapWithMove $
130 Map.fromDistinctAscList $ (\(k :=> mr) -> (Some.This k, fmap (fmap (getQueryTLoweredResultWritten . getCompose)) mr)) <$> DMap.toList p -}
131 sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q
132 sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty
133 accumBehaviors' :: forall m'. MonadHold t m'
134 => Map (Some k) [Behavior t q]
135 -> PatchMapWithMove (Some k) [Behavior t q]
136 -> m' ( Maybe (Map (Some k) [Behavior t q])
137 , Maybe (AdditivePatch q))
138 -- f accumulates the child behavior state we receive from running traverseDMapWithKeyWithAdjustWithMove for the underlying monad.
139 -- When an update occurs, it also computes a patch to communicate to the parent QueryT state.
140 -- bs0 is a Map denoting the behaviors of the current children.
141 -- pbs is a PatchMapWithMove denoting an update to the behaviors of the current children
142 accumBehaviors' bs0 pbs = do
143 let bs' = unPatchMapWithMove pbs
144 p k bs = case Map.lookup k bs0 of
145 Nothing -> case MapWithMove._nodeInfo_from bs of
146 -- If the update is to delete the state for a child that doesn't exist, the patch is mempty.
147 MapWithMove.From_Delete -> return mempty
148 -- If the update is to update the state for a child that doesn't exist, the patch is the sample of the new state.
149 MapWithMove.From_Insert newBs -> sampleBs newBs
150 MapWithMove.From_Move k' -> case Map.lookup k' bs0 of
151 Nothing -> return mempty
152 Just newBs -> sampleBs newBs
153 Just oldBs -> case MapWithMove._nodeInfo_from bs of
154 -- 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
155 MapWithMove.From_Delete -> negateG <$> sampleBs oldBs
156 -- 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
157 -- composed with the sampling the child's new state.
158 MapWithMove.From_Insert newBs -> (~~) <$> sampleBs newBs <*> sampleBs oldBs
159 MapWithMove.From_Move k'
160 | k' == k -> return mempty
161 | otherwise -> case Map.lookup k' bs0 of
162 -- If we are moving from a non-existent key, that is a delete
163 Nothing -> negateG <$> sampleBs oldBs
164 Just newBs -> (~~) <$> sampleBs newBs <*> sampleBs oldBs
165 -- we compute the patch by iterating over the update PatchMap and proceeding by cases. Then we fold over the
166 -- child patches and wrap them in AdditivePatch.
167 patch <- AdditivePatch . fold <$> Map.traverseWithKey p bs'
168 return (apply pbs bs0, Just patch)
169 (qpatch :: Event t (AdditivePatch q)) <- mapAccumMaybeM_ accumBehaviors' liftedBs0 liftedBs'
170 tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch
171 return (liftedResult0, liftedResult')
173instance MonadTrans (QueryT t q) where
174 lift = QueryT . lift . lift . lift
176instance PostBuild t m => PostBuild t (QueryT t q m) where
177 getPostBuild = lift getPostBuild
179instance (MonadAsyncException m) => MonadAsyncException (QueryT t q m) where
180 mask f = QueryT $ mask $ \unMask -> unQueryT $ f $ QueryT . unMask . unQueryT
182instance TriggerEvent t m => TriggerEvent t (QueryT t q m) where
183 newTriggerEvent = lift newTriggerEvent
184 newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
185 newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
187instance PerformEvent t m => PerformEvent t (QueryT t q m) where
188 type Performable (QueryT t q m) = Performable m
189 performEvent_ = lift . performEvent_
190 performEvent = lift . performEvent
192instance MonadRef m => MonadRef (QueryT t q m) where
193 type Ref (QueryT t q m) = Ref m
194 newRef = QueryT . newRef
195 readRef = QueryT . readRef
196 writeRef r = QueryT . writeRef r
198instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (QueryT t q m) where
199 newEventWithTrigger = QueryT . newEventWithTrigger
200 newFanEventWithTrigger a = QueryT . lift $ newFanEventWithTrigger a
202mapQuery :: QueryMorphism q q' -> q -> q'
203mapQuery = _queryMorphism_mapQuery
205mapQueryResult :: QueryMorphism q q' -> QueryResult q' -> QueryResult q
206mapQueryResult = _queryMorphism_mapQueryResult
208-- | withQueryT's QueryMorphism argument needs to be a group homomorphism in order to behave correctly
209withQueryT :: (MonadFix m, PostBuild t m, Group q, Group q', Additive q, Additive q', Query q')
210 => QueryMorphism q q'
215 (result, q) <- lift $ runQueryT a $ mapQueryResult f <$> r'
216 tellQueryIncremental $ unsafeBuildIncremental
217 (fmap (mapQuery f) (sample (currentIncremental q)))
218 (fmapCheap (AdditivePatch . mapQuery f . unAdditivePatch) $ updatedIncremental q)
221-- | dynWithQueryT's (Dynamic t QueryMorphism) argument needs to be a group homomorphism at all times in order to behave correctly
222dynWithQueryT :: (MonadFix m, PostBuild t m, Group q, Additive q, Group q', Additive q', Query q')
223 => Dynamic t (QueryMorphism q q')
226dynWithQueryT f q = do
228 (result, q') <- lift $ runQueryT q $ zipDynWith mapQueryResult f r'
229 tellQueryIncremental $ zipDynIncrementalWith mapQuery f q'
231 where zipDynIncrementalWith g da ib =
232 let eab = align (updated da) (updatedIncremental ib)
233 ec = flip push eab $ \o -> case o of
235 aOld <- sample $ current da
236 b <- sample $ currentIncremental ib
237 return $ Just $ AdditivePatch (g a b ~~ g aOld b)
238 That (AdditivePatch b) -> do
239 a <- sample $ current da
240 return $ Just $ AdditivePatch $ g a b
241 These a (AdditivePatch b) -> do
242 aOld <- sample $ current da
243 bOld <- sample $ currentIncremental ib
244 return $ Just $ AdditivePatch $ mconcat [ g a bOld, negateG (g aOld bOld), g a b]
245 in unsafeBuildIncremental (g <$> sample (current da) <*> sample (currentIncremental ib)) ec
247instance (Monad m, Group q, Additive q, Query q, Reflex t) => MonadQuery t q (QueryT t q m) where
248 tellQueryIncremental q = do
249 QueryT (modify (currentIncremental q:))
250 QueryT (lift (tellEvent (fmapCheap unAdditivePatch (updatedIncremental q))))
251 askQueryResult = QueryT ask
252 queryIncremental q = do
253 tellQueryIncremental q
255 return $ zipDynWith crop (incrementalToDynamic q) r
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