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