@@ -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,35 @@
1215module Reflex.PerformEvent.Base where
1316
1417import Reflex.Class
15−import Reflex.Deletable.Class
1618import Reflex.Host.Class
1719import Reflex.PerformEvent.Class
1820
1921import Control.Lens
2022import Control.Monad.Exception
2123import Control.Monad.Identity
24+import Control.Monad.Primitive
2225import Control.Monad.Ref
2326import Control.Monad.State.Strict
24−import Data.Align
25−import Data.Dependent.Map (DMap)
27+import Control.Monad.Reader
28+import Data.Coerce
29+import Data.Dependent.Map (DMap, GCompare (..), Some)
2630import qualified Data.Dependent.Map as DMap
2731import Data.Dependent.Sum
2832import Data.Functor.Compose
2933import Data.Functor.Misc
30−import Data.Maybe
3134import Data.Semigroup
35+import qualified Data.Some as Some
3236import Data.These
33−import Data.Word
37+import Data.Tuple
38+import Data.Unique.Tag
39+
40+import Unsafe.Coerce
3441
3542newtype EventTriggerRef t m a = EventTriggerRef { unEventTriggerRef :: Ref m (Maybe (EventTrigger t a)) }
3643
3744newtype 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?
3845
39−newtype PerformEventT t m a = PerformEventT { unPerformEventT :: StateT [Event t (These (PerformEventT t m [DSum (EventTriggerRef t m) Identity]) ())] (HostFrame t) a }
46+newtype PerformEventT t m a = PerformEventT { unPerformEventT :: RequestT t (HostFrame t) Identity (HostFrame t) a }
4047
4148deriving instance ReflexHost t => Functor (PerformEventT t m)
4249deriving instance ReflexHost t => Applicative (PerformEventT t m)
@@ -45,29 +52,21 @@ deriving instance ReflexHost t => MonadFix (PerformEventT t m)
4552deriving instance (ReflexHost t, MonadIO (HostFrame t)) => MonadIO (PerformEventT t m)
4653deriving instance (ReflexHost t, MonadException (HostFrame t)) => MonadException (PerformEventT t m)
4754
48−instance (ReflexHost t, MonadAsyncException (HostFrame t)) => MonadAsyncException (PerformEventT t m) where
49− mask f = PerformEventT $ mask $ \unmask -> unPerformEventT $ f $ PerformEventT . unmask . unPerformEventT
50−
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
55+instance (ReflexHost t, Ref m ~ Ref IO, PrimMonad (HostFrame t)) => PerformEvent t (PerformEventT t m) where
56+ type Performable (PerformEventT t m) = HostFrame t
5357 {-# INLINABLE performEvent_ #-}
54− performEvent_ = PerformEventT . modify . (:) . fmap (This . (>> return []))
58+ performEvent_ = PerformEventT . requesting_
5559 {-# 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
60+ performEvent = PerformEventT . fmap (fmap runIdentity) . requesting
61+
62+instance (ReflexHost t, PrimMonad (HostFrame t)) => MonadAdjust t (PerformEventT t m) where
63+ 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?)
64+ 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)))
65+ f dm0 dm' = do
66+ result0 <- lift $ DMap.traverseWithKey (\_ v -> Identity <$> v) dm0
67+ result' <- requesting $ ffor dm' $ \(PatchDMap p) -> do
68+ PatchDMap <$> DMap.traverseWithKey (\_ (Compose mv) -> Compose <$> mapM (fmap Identity) mv) p
69+ return (result0, fmap runIdentity result')
7170
7271instance ReflexHost t => MonadReflexCreateTrigger t (PerformEventT t m) where
7372 {-# INLINABLE newEventWithTrigger #-}
@@ -75,55 +74,19 @@ instance ReflexHost t => MonadReflexCreateTrigger t (PerformEventT t m) where
7574 {-# INLINABLE newFanEventWithTrigger #-}
7675 newFanEventWithTrigger f = PerformEventT $ lift $ newFanEventWithTrigger f
7776
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−
12377{-# 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)
78+hostPerformEventT :: forall t m a.
79+ ( Monad m
80+ , MonadSubscribeEvent t m
81+ , MonadReflexHost t m
82+ , MonadRef m
83+ , Ref m ~ Ref IO
84+ )
85+ => PerformEventT t m a
86+ -> m (a, FireCommand t m)
12587hostPerformEventT a = do
126− (result, eventToPerform) <- runHostFrame $ runPerformEventT a
88+ (response, responseTrigger) <- newEventWithTriggerRef
89+ (result, eventToPerform) <- runHostFrame $ runRequestT (unPerformEventT a) response
12790 eventToPerformHandle <- subscribeEvent eventToPerform
12891 return $ (,) result $ FireCommand $ \triggers (readPhase :: ReadPhase m a') -> do
12992 let go :: [DSum (EventTrigger t) Identity] -> m [a']
@@ -135,11 +98,12 @@ hostPerformEventT a = do
13598 case mToPerform of
13699 Nothing -> return [result']
137100 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
101+ responses <- runHostFrame $ DMap.traverseWithKey (\_ v -> Identity <$> v) toPerform
102+ mrt <- readRef responseTrigger
103+ let followupEventTriggers = case mrt of
104+ Just rt -> [rt :=> Identity responses]
105+ Nothing -> []
106+ (result':) <$> go followupEventTriggers
143107 go triggers
144108
145109instance ReflexHost t => MonadSample t (PerformEventT t m) where
@@ -166,3 +130,119 @@ instance (MonadRef (HostFrame t), ReflexHost t) => MonadRef (PerformEventT t m)
166130instance (MonadAtomicRef (HostFrame t), ReflexHost t) => MonadAtomicRef (PerformEventT t m) where
167131 {-# INLINABLE atomicModifyRef #-}
168132 atomicModifyRef r = PerformEventT . lift . atomicModifyRef r
133+
134+--------------------------------------------------------------------------------
135+-- RequestT
136+--------------------------------------------------------------------------------
137+
138+newtype RequestT t request response m a
139+ = RequestT { unRequestT :: StateT [Event t (DMap (Tag (PrimState m)) request)] (ReaderT (EventSelector t (WrapArg response (Tag (PrimState m)))) m) a }
140+ deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException)
141+
142+instance MonadTrans (RequestT t request response) where
143+ lift = RequestT . lift . lift
144+
145+runRequestT :: forall t m a request response.
146+ ( Reflex t
147+ , Monad m
148+ )
149+ => RequestT t request response m a
150+ -> Event t (DMap (Tag (PrimState m)) response)
151+ -> m (a, Event t (DMap (Tag (PrimState m)) request))
152+runRequestT (RequestT a) responses = do
153+ (result, requests) <- runReaderT (runStateT a mempty) $ fan $ mapKeyValuePairsMonotonic (\(t :=> e) -> WrapArg t :=> Identity e) <$> responses
154+ return (result, mergeWith DMap.union requests)
155+
156+requesting_ :: (Reflex t, PrimMonad m) => Event t (request a) -> RequestT t request response m ()
157+requesting_ req = do
158+ t <- lift newTag
159+ RequestT $ modify $ (:) $ DMap.singleton t <$> req
160+
161+withRequesting :: (Reflex t, PrimMonad m) => (Event t (response a) -> RequestT t request response m (Event t (request a), r)) -> RequestT t request response m r
162+withRequesting a = do
163+ t <- lift newTag
164+ s <- RequestT ask
165+ (req, result) <- a $ select s $ WrapArg t
166+ RequestT $ modify $ (:) $ DMap.singleton t <$> req
167+ return result
168+
169+requesting :: (Reflex t, PrimMonad m) => Event t (request a) -> RequestT t request response m (Event t (response a))
170+requesting req = withRequesting $ return . (,) req
171+
172+data DMapTransform (a :: *) k k' v v' = forall (b :: *). DMapTransform !(k a -> k' b) !(v a -> v' b)
173+
174+mapPatchKeysAndValuesMonotonic :: GCompare k' => (forall a. DMapTransform a k k' v v') -> PatchDMap (DMap k v) -> PatchDMap (DMap k' v')
175+mapPatchKeysAndValuesMonotonic x (PatchDMap p) = PatchDMap $ mapKeyValuePairsMonotonic (\(k :=> Compose mv) -> case x of DMapTransform f g -> f k :=> Compose (fmap g mv)) p
176+
177+mapKeysAndValuesMonotonic :: (forall a. DMapTransform a k k' v v') -> DMap k v -> DMap k' v'
178+mapKeysAndValuesMonotonic x = mapKeyValuePairsMonotonic $ \(k :=> v) -> case x of
179+ DMapTransform f g -> f k :=> g v
180+
181+instance MonadSample t m => MonadSample t (RequestT t request response m) where
182+ sample = lift . sample
183+
184+instance MonadHold t m => MonadHold t (RequestT t request response m) where
185+ hold v0 = lift . hold v0
186+ holdDyn v0 = lift . holdDyn v0
187+ holdIncremental v0 = lift . holdIncremental v0
188+
189+instance (Reflex t, MonadAdjust t m, MonadHold t m) => MonadAdjust t (RequestT t request response m) where
190+ sequenceDMapWithAdjust = sequenceDMapWithAdjustRequestTWith $ \dm0 dm' -> lift $ sequenceDMapWithAdjust dm0 dm'
191+
192+sequenceDMapWithAdjustRequestTWith :: (GCompare k, Monad m, Reflex t, MonadHold t m)
193+ => (forall k'. GCompare k'
194+ => DMap k' m
195+ -> Event t (PatchDMap (DMap k' m))
196+ -> RequestT t request response m (DMap k' Identity, Event t (PatchDMap (DMap k' Identity)))
197+ )
198+ -> DMap k (RequestT t request response m)
199+ -> Event t (PatchDMap (DMap k (RequestT t request response m)))
200+ -> RequestT t request response m (DMap k Identity, Event t (PatchDMap (DMap k Identity)))
201+sequenceDMapWithAdjustRequestTWith f (dm0 :: DMap k (RequestT t request response m)) dm' = do
202+ response <- RequestT ask
203+ let inputTransform :: forall a. DMapTransform a k (WrapArg ((,) [Event t (DMap (Tag (PrimState m)) request)]) k) (RequestT t request response m) m
204+ inputTransform = DMapTransform WrapArg (\(RequestT v) -> swap <$> runReaderT (runStateT v mempty) response)
205+ (children0, children') <- f (mapKeysAndValuesMonotonic inputTransform dm0) $ mapPatchKeysAndValuesMonotonic inputTransform <$> dm'
206+ let result0 = mapKeyValuePairsMonotonic (\(WrapArg k :=> Identity (_, v)) -> k :=> Identity v) children0
207+ result' = ffor children' $ \(PatchDMap p) -> PatchDMap $
208+ mapKeyValuePairsMonotonic (\(WrapArg k :=> Compose mv) -> k :=> Compose (fmap (Identity . snd . runIdentity) mv)) p
209+ requests0 :: DMap (Const2 (Some k) (DMap (Tag (PrimState m)) request)) (Event t)
210+ requests0 = mapKeyValuePairsMonotonic (\(WrapArg k :=> Identity (r, _)) -> Const2 (Some.This k) :=> mergeWith DMap.union r) children0
211+ requests' :: Event t (PatchDMap (DMap (Const2 (Some k) (DMap (Tag (PrimState m)) request)) (Event t)))
212+ requests' = ffor children' $ \(PatchDMap p) -> PatchDMap $
213+ mapKeyValuePairsMonotonic (\(WrapArg k :=> Compose mv) -> Const2 (Some.This k) :=> Compose (fmap (mergeWith DMap.union . fst . runIdentity) mv)) p
214+ childRequestMap <- holdIncremental requests0 requests'
215+ RequestT $ modify $ (:) $ ffor (mergeIncremental childRequestMap) $ \m ->
216+ mconcat $ (\(Const2 _ :=> Identity reqs) -> reqs) <$> DMap.toList m
217+-- 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)
218+ return (result0, result')
219+
220+--------------------------------------------------------------------------------
221+-- Helpers
222+--------------------------------------------------------------------------------
223+
224+{-# INLINABLE numberWith #-}
225+numberWith :: (Enum n, Traversable t) => (n -> a -> b) -> t a -> n -> (t b, n)
226+numberWith f t n0 = flip runState n0 $ forM t $ \x -> state $ \n -> (f n x, succ n)
227+
228+{-# INLINABLE mergeSelfDeletingEvents #-}
229+mergeSelfDeletingEvents :: forall t m k v. (Ord k, Reflex t, MonadFix m, MonadHold t m)
230+ => DMap (Const2 k (These v ())) (Event t)
231+ -> Event t (PatchDMap (DMap (Const2 k (These v ())) (Event t)))
232+ -> m (Event t [v])
233+mergeSelfDeletingEvents initial eAddNew = do
234+ rec events :: Incremental t PatchDMap (DMap (Const2 k (These v ())) (Event t))
235+ <- holdIncremental initial $ eAddNew <> eDelete --TODO: Eliminate empty firings
236+ let event = mergeWith DMap.union
237+ [ mergeIncremental events
238+ , coincidence $ ffor eAddNew $ \(PatchDMap m) -> merge $ DMap.mapMaybeWithKey (const getCompose) m
239+ ]
240+ eDelete :: Event t (PatchDMap (DMap (Const2 k (These v ())) (Event t)))
241+ eDelete = fforMaybe event $
242+ fmap (PatchDMap . DMap.fromDistinctAscList) .
243+ (\l -> if null l then Nothing else Just l) .
244+ fmapMaybe (\(Const2 k :=> Identity x) -> (Const2 k :=> Compose Nothing) <$ x ^? there) .
245+ DMap.toList
246+ return $ ffor event $
247+ fmapMaybe (\(Const2 _ :=> Identity x) -> x ^? here) .
248+ DMap.toList