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