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