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