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