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