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