@@ -1,7 +1,10 @@
11{-# LANGUAGE FlexibleContexts #-}
22{-# LANGUAGE FlexibleInstances #-}
3+{-# LANGUAGE GADTs #-}
34{-# LANGUAGE GeneralizedNewtypeDeriving #-}
45{-# LANGUAGE MultiParamTypeClasses #-}
6+{-# LANGUAGE PartialTypeSignatures #-}
7+{-# LANGUAGE PolyKinds #-}
58{-# LANGUAGE RankNTypes #-}
69{-# LANGUAGE RecursiveDo #-}
710{-# LANGUAGE ScopedTypeVariables #-}
@@ -12,31 +15,36 @@
1215module Reflex.PerformEvent.Base where
1316
1417import Reflex.Class
15−import Reflex.Deletable.Class
1618import Reflex.Host.Class
19+import Reflex.PostBuild.Class
1720import Reflex.PerformEvent.Class
1821
1922import Control.Lens
2023import Control.Monad.Exception
2124import Control.Monad.Identity
25+import Control.Monad.Primitive
2226import Control.Monad.Ref
2327import Control.Monad.State.Strict
24−import Data.Align
25−import Data.Dependent.Map (DMap)
28+import Control.Monad.Reader
29+import Data.Coerce
30+import Data.Dependent.Map (DMap, GCompare (..), Some)
2631import qualified Data.Dependent.Map as DMap
2732import Data.Dependent.Sum
2833import Data.Functor.Compose
2934import Data.Functor.Misc
30−import Data.Maybe
3135import Data.Semigroup
36+import qualified Data.Some as Some
3237import Data.These
33−import Data.Word
38+import Data.Tuple
39+import Data.Unique.Tag
40+
41+import Unsafe.Coerce
3442
3543newtype EventTriggerRef t m a = EventTriggerRef { unEventTriggerRef :: Ref m (Maybe (EventTrigger t a)) }
3644
3745newtype FireCommand t m = FireCommand { runFireCommand :: forall a. [DSum (EventTrigger t) Identity] -> ReadPhase m a -> m [a] } --TODO: The handling of this ReadPhase seems wrong, or at least inelegant; how do we actually make the decision about what order frames run in?
3846
39−newtype PerformEventT t m a = PerformEventT { unPerformEventT :: StateT [Event t (These (PerformEventT t m [DSum (EventTriggerRef t m) Identity]) ())] (HostFrame t) a }
47+newtype PerformEventT t m a = PerformEventT { unPerformEventT :: RequestT t (HostFrame t) Identity (HostFrame t) a }
4048
4149deriving instance ReflexHost t => Functor (PerformEventT t m)
4250deriving instance ReflexHost t => Applicative (PerformEventT t m)
@@ -45,29 +53,25 @@ deriving instance ReflexHost t => MonadFix (PerformEventT t m)
4553deriving instance (ReflexHost t, MonadIO (HostFrame t)) => MonadIO (PerformEventT t m)
4654deriving instance (ReflexHost t, MonadException (HostFrame t)) => MonadException (PerformEventT t m)
4755
48−instance (ReflexHost t, MonadAsyncException (HostFrame t)) => MonadAsyncException (PerformEventT t m) where
49− mask f = PerformEventT $ mask $ \unmask -> unPerformEventT $ f $ PerformEventT . unmask . unPerformEventT
56+instance (PrimMonad (HostFrame t), ReflexHost t) => PrimMonad (PerformEventT t m) where
57+ type PrimState (PerformEventT t m) = PrimState (HostFrame t)
58+ primitive = PerformEventT . lift . primitive
5059
51−instance (ReflexHost t, Ref m ~ Ref IO, MonadRef (HostFrame t), Ref (HostFrame t) ~ Ref IO) => PerformEvent t (PerformEventT t m) where
52− type Performable (PerformEventT t m) = PerformEventT t m
60+instance (ReflexHost t, Ref m ~ Ref IO, PrimMonad (HostFrame t)) => PerformEvent t (PerformEventT t m) where
61+ type Performable (PerformEventT t m) = HostFrame t
5362 {-# INLINABLE performEvent_ #-}
54− performEvent_ = PerformEventT . modify . (:) . fmap (This . (>> return []))
63+ performEvent_ = PerformEventT . requesting_
5564 {-# INLINABLE performEvent #-}
56− performEvent e = PerformEventT $ do
57− (eResult, reResultTrigger) <- newEventWithTriggerRef
58− modify $ (:) $ ffor e $ \o -> This $ do
59− result <- o
60− return [EventTriggerRef reResultTrigger :=> Identity result]
61− return eResult
62−
63−instance (ReflexHost t, Monad (HostFrame t), Ref (HostFrame t) ~ Ref IO, Ref m ~ Ref IO) => Deletable t (PerformEventT t m) where
64− {-# INLINABLE deletable #-}
65− deletable d a = PerformEventT $ do
66− (result, reverseEventsToPerform) <- lift $ runStateT (unPerformEventT a) []
67− let (numberedEvents, _) = numberWith (\n e -> Const2 n :=> e) (reverse reverseEventsToPerform) (1 :: Word64)
68− eventToPerform <- lift $ mergePerformEventsAndAdd (DMap.fromList numberedEvents) never
69− modify (align eventToPerform d :)
70− return result
65+ performEvent = PerformEventT . fmap (fmap runIdentity) . requesting
66+
67+instance (ReflexHost t, PrimMonad (HostFrame t)) => MonadAdjust t (PerformEventT t m) where
68+ sequenceDMapWithAdjust outerDm0 outerDm' = PerformEventT $ sequenceDMapWithAdjustRequestTWith f (coerce outerDm0) (unsafeCoerce outerDm') --TODO: Eliminate unsafeCoerce (why doesn't coerce work here, even inside the Event and PatchDMap?)
69+ where f :: DMap k (HostFrame t) -> Event t (PatchDMap (DMap k (HostFrame t))) -> RequestT t (HostFrame t) Identity (HostFrame t) (DMap k Identity, Event t (PatchDMap (DMap k Identity)))
70+ f dm0 dm' = do
71+ result0 <- lift $ DMap.traverseWithKey (\_ v -> Identity <$> v) dm0
72+ result' <- requesting $ ffor dm' $ \(PatchDMap p) -> do
73+ PatchDMap <$> DMap.traverseWithKey (\_ (Compose mv) -> Compose <$> mapM (fmap Identity) mv) p
74+ return (result0, fmap runIdentity result')
7175
7276instance ReflexHost t => MonadReflexCreateTrigger t (PerformEventT t m) where
7377 {-# INLINABLE newEventWithTrigger #-}
@@ -75,55 +79,19 @@ instance ReflexHost t => MonadReflexCreateTrigger t (PerformEventT t m) where
7579 {-# INLINABLE newFanEventWithTrigger #-}
7680 newFanEventWithTrigger f = PerformEventT $ lift $ newFanEventWithTrigger f
7781
78−{-# INLINABLE numberWith #-}
79−numberWith :: (Enum n, Traversable t) => (n -> a -> b) -> t a -> n -> (t b, n)
80−numberWith f t n0 = flip runState n0 $ forM t $ \x -> state $ \n -> (f n x, succ n)
81−
82−{-# INLINABLE mergePerformEventsAndAdd #-}
83−mergePerformEventsAndAdd :: forall t m. ReflexHost t
84− => DMap (Const2 Word64 (These (PerformEventT t m [DSum (EventTriggerRef t m) Identity]) ())) (Event t)
85− -> Event t (PatchDMap (DMap (Const2 Word64 (These (PerformEventT t m [DSum (EventTriggerRef t m) Identity]) ())) (Event t)))
86− -> HostFrame t (Event t (PerformEventT t m [DSum (EventTriggerRef t m) Identity]))
87−mergePerformEventsAndAdd initial eAddNew = do
88− rec events :: Incremental t PatchDMap (DMap (Const2 Word64 (These (PerformEventT t m [DSum (EventTriggerRef t m) Identity]) ())) (Event t))
89− <- holdIncremental initial $ eAddNew <> eDelete --TODO: Eliminate empty firings
90− let event = mergeWith DMap.union [mergeIncremental events, coincidence (fmap (\(PatchDMap m) -> merge $ DMap.mapMaybeWithKey (const getCompose) m) eAddNew)]
91− eventToPerform :: Event t (PerformEventT t m [DSum (EventTriggerRef t m) Identity])
92− eventToPerform = ffor event $
93− fmap concat .
94− sequence .
95− fmapMaybe (\(Const2 _ :=> Identity x) -> x ^? here) .
96− DMap.toList
97− eDelete :: Event t (PatchDMap (DMap (Const2 Word64 (These (PerformEventT t m [DSum (EventTriggerRef t m) Identity]) ())) (Event t)))
98− eDelete = fforMaybe event $
99− fmap (PatchDMap . DMap.fromList) .
100− (\l -> if null l then Nothing else Just l) .
101− fmapMaybe (\(Const2 k :=> Identity x) -> (Const2 k :=> Compose Nothing) <$ x ^? there) .
102− DMap.toList
103− return eventToPerform
104−
105−{-# INLINABLE runPerformEventT #-}
106−runPerformEventT :: forall t m a. (ReflexHost t, MonadRef (HostFrame t), Ref (HostFrame t) ~ Ref IO, Ref m ~ Ref IO) => PerformEventT t m a -> HostFrame t (a, Event t (HostFrame t [DSum (EventTriggerRef t m) Identity]))
107−runPerformEventT (PerformEventT a) = do
108− (result, reverseEventsToPerform) <- runStateT a []
109− (eAddNew, reAddNewTrigger) <- newEventWithTriggerRef
110− let (numberedEvents, nextNumber) = numberWith (\n e -> Const2 n :=> e) (reverse reverseEventsToPerform) (1 :: Word64)
111− nextNumberRef <- newRef nextNumber
112− let runResult :: PerformEventT t m [DSum (EventTriggerRef t m) Identity] -> HostFrame t [DSum (EventTriggerRef t m) Identity]
113− runResult (PerformEventT r) = do
114− (followups, reverseNewEventsToPerform) <- runStateT r []
115− oldN <- readRef nextNumberRef
116− let (numberedNewEvents, newN) = numberWith (\n e -> Const2 n :=> Compose (Just e)) (reverse reverseNewEventsToPerform) oldN
117− if newN == oldN then return followups else do
118− writeRef nextNumberRef newN
119− return $ (EventTriggerRef reAddNewTrigger :=> Identity (PatchDMap (DMap.fromList numberedNewEvents))) : followups
120− eventToPerform <- mergePerformEventsAndAdd (DMap.fromList numberedEvents) eAddNew
121− return (result, runResult <$> eventToPerform)
122−
12382{-# INLINABLE hostPerformEventT #-}
124−hostPerformEventT :: forall t m a. (Monad m, MonadSubscribeEvent t m, MonadReflexHost t m, MonadRef m, Ref m ~ Ref IO, MonadRef (HostFrame t), Ref (HostFrame t) ~ Ref IO) => PerformEventT t m a -> m (a, FireCommand t m)
83+hostPerformEventT :: forall t m a.
84+ ( Monad m
85+ , MonadSubscribeEvent t m
86+ , MonadReflexHost t m
87+ , MonadRef m
88+ , Ref m ~ Ref IO
89+ )
90+ => PerformEventT t m a
91+ -> m (a, FireCommand t m)
12592hostPerformEventT a = do
126− (result, eventToPerform) <- runHostFrame $ runPerformEventT a
93+ (response, responseTrigger) <- newEventWithTriggerRef
94+ (result, eventToPerform) <- runHostFrame $ runRequestT (unPerformEventT a) response
12795 eventToPerformHandle <- subscribeEvent eventToPerform
12896 return $ (,) result $ FireCommand $ \triggers (readPhase :: ReadPhase m a') -> do
12997 let go :: [DSum (EventTrigger t) Identity] -> m [a']
@@ -135,11 +103,12 @@ hostPerformEventT a = do
135103 case mToPerform of
136104 Nothing -> return [result']
137105 Just toPerform -> do
138− followupEventTriggerRefs <- runHostFrame toPerform
139− followupEventTriggers <- forM followupEventTriggerRefs $ \(EventTriggerRef rt :=> x) -> do
140− mt <- readRef rt
141− return $ fmap (:=> x) mt
142− fmap (result':) $ go $ catMaybes followupEventTriggers
106+ responses <- runHostFrame $ DMap.traverseWithKey (\_ v -> Identity <$> v) toPerform
107+ mrt <- readRef responseTrigger
108+ let followupEventTriggers = case mrt of
109+ Just rt -> [rt :=> Identity responses]
110+ Nothing -> []
111+ (result':) <$> go followupEventTriggers
143112 go triggers
144113
145114instance ReflexHost t => MonadSample t (PerformEventT t m) where
@@ -166,3 +135,155 @@ instance (MonadRef (HostFrame t), ReflexHost t) => MonadRef (PerformEventT t m)
166135instance (MonadAtomicRef (HostFrame t), ReflexHost t) => MonadAtomicRef (PerformEventT t m) where
167136 {-# INLINABLE atomicModifyRef #-}
168137 atomicModifyRef r = PerformEventT . lift . atomicModifyRef r
138+
139+--------------------------------------------------------------------------------
140+-- RequestT
141+--------------------------------------------------------------------------------
142+
143+newtype RequestT t request response m a
144+ = RequestT { unRequestT :: StateT [Event t (DMap (Tag (PrimState m)) request)] (ReaderT (EventSelector t (WrapArg response (Tag (PrimState m)))) m) a }
145+ deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException)
146+
147+instance MonadTrans (RequestT t request response) where
148+ lift = RequestT . lift . lift
149+
150+runRequestT :: forall t m a request response.
151+ ( Reflex t
152+ , Monad m
153+ )
154+ => RequestT t request response m a
155+ -> Event t (DMap (Tag (PrimState m)) response)
156+ -> m (a, Event t (DMap (Tag (PrimState m)) request))
157+runRequestT (RequestT a) responses = do
158+ (result, requests) <- runReaderT (runStateT a mempty) $ fan $ mapKeyValuePairsMonotonic (\(t :=> e) -> WrapArg t :=> Identity e) <$> responses
159+ return (result, mergeWith DMap.union requests)
160+
161+instance (Reflex t, PrimMonad m) => MonadRequest t (RequestT t request response m) where
162+ type Request (RequestT t request response m) = request
163+ type Response (RequestT t request response m) = response
164+ withRequesting a = do
165+ t <- lift newTag
166+ s <- RequestT ask
167+ (req, result) <- a $ select s $ WrapArg t
168+ RequestT $ modify $ (:) $ DMap.singleton t <$> req
169+ return result
170+
171+data DMapTransform (a :: *) k k' v v' = forall (b :: *). DMapTransform !(k a -> k' b) !(v a -> v' b)
172+
173+mapPatchKeysAndValuesMonotonic :: GCompare k' => (forall a. DMapTransform a k k' v v') -> PatchDMap (DMap k v) -> PatchDMap (DMap k' v')
174+mapPatchKeysAndValuesMonotonic x (PatchDMap p) = PatchDMap $ mapKeyValuePairsMonotonic (\(k :=> Compose mv) -> case x of DMapTransform f g -> f k :=> Compose (fmap g mv)) p
175+
176+mapKeysAndValuesMonotonic :: (forall a. DMapTransform a k k' v v') -> DMap k v -> DMap k' v'
177+mapKeysAndValuesMonotonic x = mapKeyValuePairsMonotonic $ \(k :=> v) -> case x of
178+ DMapTransform f g -> f k :=> g v
179+
180+instance MonadSample t m => MonadSample t (RequestT t request response m) where
181+ sample = lift . sample
182+
183+instance MonadHold t m => MonadHold t (RequestT t request response m) where
184+ hold v0 = lift . hold v0
185+ holdDyn v0 = lift . holdDyn v0
186+ holdIncremental v0 = lift . holdIncremental v0
187+
188+instance (Reflex t, MonadAdjust t m, MonadHold t m) => MonadAdjust t (RequestT t request response m) where
189+ sequenceDMapWithAdjust = sequenceDMapWithAdjustRequestTWith $ \dm0 dm' -> lift $ sequenceDMapWithAdjust dm0 dm'
190+
191+sequenceDMapWithAdjustRequestTWith :: (GCompare k, Monad m, Reflex t, MonadHold t m)
192+ => (forall k'. GCompare k'
193+ => DMap k' m
194+ -> Event t (PatchDMap (DMap k' m))
195+ -> RequestT t request response m (DMap k' Identity, Event t (PatchDMap (DMap k' Identity)))
196+ )
197+ -> DMap k (RequestT t request response m)
198+ -> Event t (PatchDMap (DMap k (RequestT t request response m)))
199+ -> RequestT t request response m (DMap k Identity, Event t (PatchDMap (DMap k Identity)))
200+sequenceDMapWithAdjustRequestTWith f (dm0 :: DMap k (RequestT t request response m)) dm' = do
201+ response <- RequestT ask
202+ let inputTransform :: forall a. DMapTransform a k (WrapArg ((,) [Event t (DMap (Tag (PrimState m)) request)]) k) (RequestT t request response m) m
203+ inputTransform = DMapTransform WrapArg (\(RequestT v) -> swap <$> runReaderT (runStateT v mempty) response)
204+ (children0, children') <- f (mapKeysAndValuesMonotonic inputTransform dm0) $ mapPatchKeysAndValuesMonotonic inputTransform <$> dm'
205+ let result0 = mapKeyValuePairsMonotonic (\(WrapArg k :=> Identity (_, v)) -> k :=> Identity v) children0
206+ result' = ffor children' $ \(PatchDMap p) -> PatchDMap $
207+ mapKeyValuePairsMonotonic (\(WrapArg k :=> Compose mv) -> k :=> Compose (fmap (Identity . snd . runIdentity) mv)) p
208+ requests0 :: DMap (Const2 (Some k) (DMap (Tag (PrimState m)) request)) (Event t)
209+ requests0 = mapKeyValuePairsMonotonic (\(WrapArg k :=> Identity (r, _)) -> Const2 (Some.This k) :=> mergeWith DMap.union r) children0
210+ requests' :: Event t (PatchDMap (DMap (Const2 (Some k) (DMap (Tag (PrimState m)) request)) (Event t)))
211+ requests' = ffor children' $ \(PatchDMap p) -> PatchDMap $
212+ mapKeyValuePairsMonotonic (\(WrapArg k :=> Compose mv) -> Const2 (Some.This k) :=> Compose (fmap (mergeWith DMap.union . fst . runIdentity) mv)) p
213+ childRequestMap <- holdIncremental requests0 requests'
214+ RequestT $ modify $ (:) $ ffor (mergeIncremental childRequestMap) $ \m ->
215+ mconcat $ (\(Const2 _ :=> Identity reqs) -> reqs) <$> DMap.toList m
216+-- RequestT $ modify $ (:) $ coincidence $ ffor requests' $ \(PatchDMap p) -> mergeWith DMap.union $ catMaybes $ ffor (DMap.toList p) $ \(Const2 _ :=> Compose me) -> me -- We could make it prompt like this, but this seems to be slower than just delaying the PostBuild event to allow this stuff to settle (which is more similar to the previous behavior anyway)
217+ return (result0, result')
218+
219+instance PerformEvent t m => PerformEvent t (RequestT t request response m) where
220+ type Performable (RequestT t request response m) = Performable m
221+ performEvent_ = lift . performEvent_
222+ performEvent = lift . performEvent
223+
224+instance PostBuild t m => PostBuild t (RequestT t request response m) where
225+ getPostBuild = lift getPostBuild
226+
227+instance TriggerEvent t m => TriggerEvent t (RequestT t request response m) where
228+ newTriggerEvent = lift newTriggerEvent
229+ newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
230+ newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
231+
232+instance MonadReader r m => MonadReader r (RequestT t request response m) where
233+ ask = lift ask
234+ local f (RequestT a) = RequestT $ mapStateT (mapReaderT $ local f) a
235+ reader = lift . reader
236+
237+{-
238+withRequestT :: forall t m a (req :: * -> *) (req' :: * -> *).
239+ (Reflex t, MonadHold t m, MonadFix m)
240+ => (forall x. request x -> request' x)
241+ -> (forall x. response' x -> response x)
242+ -> RequestT t request response m a
243+ -> RequestT t request' response m a
244+withRequestT f g m = RequestT $ hoist (hoist (withDynamicWriterT f')) (unRequestT m)
245+ where
246+ f' :: Event t [(y, Some request)] -> Event t [(y, Some request')]
247+ f' = fmap . fmap . fmap $ \(SomeRequest req) -> SomeRequest $ f req
248+-}
249+
250+instance MonadRef m => MonadRef (RequestT t request response m) where
251+ type Ref (RequestT t request response m) = Ref m
252+ newRef = lift . newRef
253+ readRef = lift . readRef
254+ writeRef r = lift . writeRef r
255+
256+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (RequestT t request response m) where
257+ newEventWithTrigger = lift . newEventWithTrigger
258+ newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
259+
260+
261+--------------------------------------------------------------------------------
262+-- Helpers
263+--------------------------------------------------------------------------------
264+
265+{-# INLINABLE numberWith #-}
266+numberWith :: (Enum n, Traversable t) => (n -> a -> b) -> t a -> n -> (t b, n)
267+numberWith f t n0 = flip runState n0 $ forM t $ \x -> state $ \n -> (f n x, succ n)
268+
269+{-# INLINABLE mergeSelfDeletingEvents #-}
270+mergeSelfDeletingEvents :: forall t m k v. (Ord k, Reflex t, MonadFix m, MonadHold t m)
271+ => DMap (Const2 k (These v ())) (Event t)
272+ -> Event t (PatchDMap (DMap (Const2 k (These v ())) (Event t)))
273+ -> m (Event t [v])
274+mergeSelfDeletingEvents initial eAddNew = do
275+ rec events :: Incremental t PatchDMap (DMap (Const2 k (These v ())) (Event t))
276+ <- holdIncremental initial $ eAddNew <> eDelete --TODO: Eliminate empty firings
277+ let event = mergeWith DMap.union
278+ [ mergeIncremental events
279+ , coincidence $ ffor eAddNew $ \(PatchDMap m) -> merge $ DMap.mapMaybeWithKey (const getCompose) m
280+ ]
281+ eDelete :: Event t (PatchDMap (DMap (Const2 k (These v ())) (Event t)))
282+ eDelete = fforMaybe event $
283+ fmap (PatchDMap . DMap.fromDistinctAscList) .
284+ (\l -> if null l then Nothing else Just l) .
285+ fmapMaybe (\(Const2 k :=> Identity x) -> (Const2 k :=> Compose Nothing) <$ x ^? there) .
286+ DMap.toList
287+ return $ ffor event $
288+ fmapMaybe (\(Const2 _ :=> Identity x) -> x ^? here) .
289+ DMap.toList