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