git.iko.soy/patch
on df8152b help sign in
patch/src/Reflex/Query/Base.hs
287 lines 16 kB history raw
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
11 ( QueryT (..)
12 , runQueryT
13 , mapQuery
14 , mapQueryResult
15 , dynWithQueryT
16 , withQueryT
17 ) where
19import Control.Applicative (liftA2)
20import Control.Monad.Exception
21import Control.Monad.Fix
22import Control.Monad.Reader
23import Control.Monad.Ref
24import Control.Monad.State.Strict
25import Data.Align
26import Data.Dependent.Map (DMap, DSum (..))
27import qualified Data.Dependent.Map as DMap
28import Data.Foldable
29import Data.Functor.Compose
30import Data.Functor.Misc
31import Data.Map (Map)
32import qualified Data.Map as Map
33import Data.Monoid ((<>))
34import qualified Data.Semigroup as S
35import Data.Some (Some)
36import qualified Data.Some as Some
37import Data.These
39import Reflex.Class
40import Reflex.EventWriter.Class
41import Reflex.EventWriter.Base
42import Reflex.Host.Class
43import Reflex.PerformEvent.Class
44import Reflex.PostBuild.Class
45import Reflex.Query.Class
46import Reflex.Requester.Class
47import Reflex.TriggerEvent.Class
48import qualified Reflex.Patch.MapWithMove as MapWithMove
50newtype QueryT t q m a = QueryT { unQueryT :: StateT [Behavior t q] (EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m)) a }
51 deriving (Functor, Applicative, Monad, MonadException, MonadFix, MonadIO, MonadHold t, MonadSample t, MonadAtomicRef)
53runQueryT :: (MonadFix m, Additive q, Group q, Reflex t) => QueryT t q m a -> Dynamic t (QueryResult q) -> m (a, Incremental t (AdditivePatch q))
54runQueryT (QueryT a) qr = do
55 ((r, bs), es) <- runReaderT (runEventWriterT (runStateT a mempty)) qr
56 return (r, unsafeBuildIncremental (foldlM (\b c -> (b <>) <$> sample c) mempty bs) (fmapCheap AdditivePatch es))
58newtype QueryTLoweredResult t q v = QueryTLoweredResult (v, [Behavior t q])
60getQueryTLoweredResultValue :: QueryTLoweredResult t q v -> v
61getQueryTLoweredResultValue (QueryTLoweredResult (v, _)) = v
63getQueryTLoweredResultWritten :: QueryTLoweredResult t q v -> [Behavior t q]
64getQueryTLoweredResultWritten (QueryTLoweredResult (_, w)) = w
66{-
67let sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q
68 sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty
69 bs' = fmapCheap snd $ r'
70 patches = unsafeBuildIncremental (sampleBs bs0) $
71 flip pushCheap bs' $ \bs -> do
72 p <- (~~) <$> sampleBs bs <*> sample (currentIncremental patches)
73 return (Just (AdditivePatch p))
74-}
76instance (Reflex t, MonadFix m, Group q, Additive q, Query q, MonadHold t m, Adjustable t m) => Adjustable t (QueryT t q m) where
77 runWithReplace (QueryT a0) a' = do
78 ((r0, bs0), r') <- QueryT $ lift $ runWithReplace (runStateT a0 []) $ fmapCheap (flip runStateT [] . unQueryT) a'
79 let sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q
80 sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty
81 bs' = fmapCheap snd $ r'
82 bbs <- hold bs0 bs'
83 let patches = flip pushAlwaysCheap bs' $ \newBs -> do
84 oldBs <- sample bbs
85 (~~) <$> sampleBs newBs <*> sampleBs oldBs
86 QueryT $ modify $ (:) $ pull $ sampleBs =<< sample bbs
87 QueryT $ lift $ tellEvent patches
88 return (r0, fmapCheap fst r')
89 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'))
90 traverseDMapWithKeyWithAdjust f dm0 dm' = do
91 let f' :: forall a. k a -> v a -> EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m) (Compose (QueryTLoweredResult t q) v' a)
92 f' k v = fmap (Compose . QueryTLoweredResult) $ flip runStateT [] $ unQueryT $ f k v
93 (result0, result') <- QueryT $ lift $ traverseDMapWithKeyWithAdjust f' dm0 dm'
94 let liftedResult0 = mapKeyValuePairsMonotonic (\(k :=> Compose r) -> k :=> getQueryTLoweredResultValue r) result0
95 liftedResult' = fforCheap result' $ \(PatchDMap p) -> PatchDMap $
96 mapKeyValuePairsMonotonic (\(k :=> ComposeMaybe mr) -> k :=> ComposeMaybe (fmap (getQueryTLoweredResultValue . getCompose) mr)) p
97 liftedBs0 :: Map (Some k) [Behavior t q]
98 liftedBs0 = Map.fromDistinctAscList $ (\(k :=> Compose r) -> (Some.This k, getQueryTLoweredResultWritten r)) <$> DMap.toList result0
99 liftedBs' :: Event t (PatchMap (Some k) [Behavior t q])
100 liftedBs' = fforCheap result' $ \(PatchDMap p) -> PatchMap $
101 Map.fromDistinctAscList $ (\(k :=> ComposeMaybe mr) -> (Some.This k, fmap (getQueryTLoweredResultWritten . getCompose) mr)) <$> DMap.toList p
102 sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q
103 sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty
104 accumBehaviors :: forall m'. MonadHold t m'
105 => Map (Some k) [Behavior t q]
106 -> PatchMap (Some k) [Behavior t q]
107 -> m' ( Maybe (Map (Some k) [Behavior t q])
108 , Maybe (AdditivePatch q))
109 -- f accumulates the child behavior state we receive from running traverseDMapWithKeyWithAdjust for the underlying monad.
110 -- When an update occurs, it also computes a patch to communicate to the parent QueryT state.
111 -- bs0 is a Map denoting the behaviors of the current children.
112 -- pbs is a PatchMap denoting an update to the behaviors of the current children
113 accumBehaviors bs0 pbs@(PatchMap bs') = do
114 let p k bs = case Map.lookup k bs0 of
115 Nothing -> case bs of
116 -- If the update is to delete the state for a child that doesn't exist, the patch is mempty.
117 Nothing -> return mempty
118 -- If the update is to update the state for a child that doesn't exist, the patch is the sample of the new state.
119 Just newBs -> sampleBs newBs
120 Just oldBs -> case bs of
121 -- 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
122 Nothing -> negateG <$> sampleBs oldBs
123 -- 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
124 -- composed with the sampling the child's new state.
125 Just newBs -> (~~) <$> sampleBs newBs <*> sampleBs oldBs
126 -- we compute the patch by iterating over the update PatchMap and proceeding by cases. Then we fold over the
127 -- child patches and wrap them in AdditivePatch.
128 patch <- AdditivePatch . fold <$> Map.traverseWithKey p bs'
129 return (apply pbs bs0, Just patch)
130 (qpatch :: Event t (AdditivePatch q)) <- mapAccumMaybeM_ accumBehaviors liftedBs0 liftedBs'
131 tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch
132 return (liftedResult0, liftedResult')
133 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'))
134 traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = do
135 let f' :: forall a. k a -> v a -> EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m) (Compose (QueryTLoweredResult t q) v' a)
136 f' k v = fmap (Compose . QueryTLoweredResult) $ flip runStateT [] $ unQueryT $ f k v
137 (result0, result') <- QueryT $ lift $ traverseDMapWithKeyWithAdjustWithMove f' dm0 dm'
138 let liftedResult0 = mapKeyValuePairsMonotonic (\(k :=> Compose r) -> k :=> getQueryTLoweredResultValue r) result0
139 liftedResult' = fforCheap result' $ mapPatchDMapWithMove (getQueryTLoweredResultValue . getCompose)
140 liftedBs0 :: Map (Some k) [Behavior t q]
141 liftedBs0 = Map.fromDistinctAscList $ (\(k :=> Compose r) -> (Some.This k, getQueryTLoweredResultWritten r)) <$> DMap.toList result0
142 liftedBs' :: Event t (PatchMapWithMove (Some k) [Behavior t q])
143 liftedBs' = fforCheap result' $ weakenPatchDMapWithMoveWith (getQueryTLoweredResultWritten . getCompose) {- \(PatchDMap p) -> PatchMapWithMove $
144 Map.fromDistinctAscList $ (\(k :=> mr) -> (Some.This k, fmap (fmap (getQueryTLoweredResultWritten . getCompose)) mr)) <$> DMap.toList p -}
145 sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q
146 sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty
147 accumBehaviors' :: forall m'. MonadHold t m'
148 => Map (Some k) [Behavior t q]
149 -> PatchMapWithMove (Some k) [Behavior t q]
150 -> m' ( Maybe (Map (Some k) [Behavior t q])
151 , Maybe (AdditivePatch q))
152 -- f accumulates the child behavior state we receive from running traverseDMapWithKeyWithAdjustWithMove for the underlying monad.
153 -- When an update occurs, it also computes a patch to communicate to the parent QueryT state.
154 -- bs0 is a Map denoting the behaviors of the current children.
155 -- pbs is a PatchMapWithMove denoting an update to the behaviors of the current children
156 accumBehaviors' bs0 pbs = do
157 let bs' = unPatchMapWithMove pbs
158 p k bs = case Map.lookup k bs0 of
159 Nothing -> case MapWithMove._nodeInfo_from bs of
160 -- If the update is to delete the state for a child that doesn't exist, the patch is mempty.
161 MapWithMove.From_Delete -> return mempty
162 -- If the update is to update the state for a child that doesn't exist, the patch is the sample of the new state.
163 MapWithMove.From_Insert newBs -> sampleBs newBs
164 MapWithMove.From_Move k' -> case Map.lookup k' bs0 of
165 Nothing -> return mempty
166 Just newBs -> sampleBs newBs
167 Just oldBs -> case MapWithMove._nodeInfo_from bs of
168 -- 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
169 MapWithMove.From_Delete -> negateG <$> sampleBs oldBs
170 -- 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
171 -- composed with the sampling the child's new state.
172 MapWithMove.From_Insert newBs -> (~~) <$> sampleBs newBs <*> sampleBs oldBs
173 MapWithMove.From_Move k'
174 | k' == k -> return mempty
175 | otherwise -> case Map.lookup k' bs0 of
176 -- If we are moving from a non-existent key, that is a delete
177 Nothing -> negateG <$> sampleBs oldBs
178 Just newBs -> (~~) <$> sampleBs newBs <*> sampleBs oldBs
179 -- we compute the patch by iterating over the update PatchMap and proceeding by cases. Then we fold over the
180 -- child patches and wrap them in AdditivePatch.
181 patch <- AdditivePatch . fold <$> Map.traverseWithKey p bs'
182 return (apply pbs bs0, Just patch)
183 (qpatch :: Event t (AdditivePatch q)) <- mapAccumMaybeM_ accumBehaviors' liftedBs0 liftedBs'
184 tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch
185 return (liftedResult0, liftedResult')
187instance MonadTrans (QueryT t q) where
188 lift = QueryT . lift . lift . lift
190instance PostBuild t m => PostBuild t (QueryT t q m) where
191 getPostBuild = lift getPostBuild
193instance (MonadAsyncException m) => MonadAsyncException (QueryT t q m) where
194 mask f = QueryT $ mask $ \unMask -> unQueryT $ f $ QueryT . unMask . unQueryT
196instance TriggerEvent t m => TriggerEvent t (QueryT t q m) where
197 newTriggerEvent = lift newTriggerEvent
198 newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
199 newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
201instance PerformEvent t m => PerformEvent t (QueryT t q m) where
202 type Performable (QueryT t q m) = Performable m
203 performEvent_ = lift . performEvent_
204 performEvent = lift . performEvent
206instance MonadRef m => MonadRef (QueryT t q m) where
207 type Ref (QueryT t q m) = Ref m
208 newRef = QueryT . newRef
209 readRef = QueryT . readRef
210 writeRef r = QueryT . writeRef r
212instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (QueryT t q m) where
213 newEventWithTrigger = QueryT . newEventWithTrigger
214 newFanEventWithTrigger a = QueryT . lift $ newFanEventWithTrigger a
216-- TODO: Monoid and Semigroup can likely be derived once StateT has them.
217instance (Monoid a, Monad m) => Monoid (QueryT t q m a) where
218 mempty = pure mempty
219 mappend = (<>)
221instance (S.Semigroup a, Monad m) => S.Semigroup (QueryT t q m a) where
222 (<>) = liftA2 (S.<>)
225mapQuery :: QueryMorphism q q' -> q -> q'
226mapQuery = _queryMorphism_mapQuery
228mapQueryResult :: QueryMorphism q q' -> QueryResult q' -> QueryResult q
229mapQueryResult = _queryMorphism_mapQueryResult
231-- | withQueryT's QueryMorphism argument needs to be a group homomorphism in order to behave correctly
232withQueryT :: (MonadFix m, PostBuild t m, Group q, Group q', Additive q, Additive q', Query q')
233 => QueryMorphism q q'
234 -> QueryT t q m a
235 -> QueryT t q' m a
236withQueryT f a = do
237 r' <- askQueryResult
238 (result, q) <- lift $ runQueryT a $ mapQueryResult f <$> r'
239 tellQueryIncremental $ unsafeBuildIncremental
240 (fmap (mapQuery f) (sample (currentIncremental q)))
241 (fmapCheap (AdditivePatch . mapQuery f . unAdditivePatch) $ updatedIncremental q)
242 return result
244-- | dynWithQueryT's (Dynamic t QueryMorphism) argument needs to be a group homomorphism at all times in order to behave correctly
245dynWithQueryT :: (MonadFix m, PostBuild t m, Group q, Additive q, Group q', Additive q', Query q')
246 => Dynamic t (QueryMorphism q q')
247 -> QueryT t q m a
248 -> QueryT t q' m a
249dynWithQueryT f q = do
250 r' <- askQueryResult
251 (result, q') <- lift $ runQueryT q $ zipDynWith mapQueryResult f r'
252 tellQueryIncremental $ zipDynIncrementalWith mapQuery f q'
253 return result
254 where zipDynIncrementalWith g da ib =
255 let eab = align (updated da) (updatedIncremental ib)
256 ec = flip push eab $ \o -> case o of
257 This a -> do
258 aOld <- sample $ current da
259 b <- sample $ currentIncremental ib
260 return $ Just $ AdditivePatch (g a b ~~ g aOld b)
261 That (AdditivePatch b) -> do
262 a <- sample $ current da
263 return $ Just $ AdditivePatch $ g a b
264 These a (AdditivePatch b) -> do
265 aOld <- sample $ current da
266 bOld <- sample $ currentIncremental ib
267 return $ Just $ AdditivePatch $ mconcat [ g a bOld, negateG (g aOld bOld), g a b]
268 in unsafeBuildIncremental (g <$> sample (current da) <*> sample (currentIncremental ib)) ec
270instance (Monad m, Group q, Additive q, Query q, Reflex t) => MonadQuery t q (QueryT t q m) where
271 tellQueryIncremental q = do
272 QueryT (modify (currentIncremental q:))
273 QueryT (lift (tellEvent (fmapCheap unAdditivePatch (updatedIncremental q))))
274 askQueryResult = QueryT ask
275 queryIncremental q = do
276 tellQueryIncremental q
277 r <- askQueryResult
278 return $ zipDynWith crop (incrementalToDynamic q) r
280instance Requester t m => Requester t (QueryT t q m) where
281 type Request (QueryT t q m) = Request m
282 type Response (QueryT t q m) = Response m
283 requesting = lift . requesting
284 requesting_ = lift . requesting_
286instance EventWriter t w m => EventWriter t w (QueryT t q m) where
287 tellEvent = lift . tellEvent