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