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