@@ -0,0 +1,168 @@
1+{-# LANGUAGE FlexibleContexts #-}
2+{-# LANGUAGE FlexibleInstances #-}
3+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4+{-# LANGUAGE MultiParamTypeClasses #-}
5+{-# LANGUAGE RankNTypes #-}
6+{-# LANGUAGE RecursiveDo #-}
7+{-# LANGUAGE ScopedTypeVariables #-}
8+{-# LANGUAGE StandaloneDeriving #-}
9+{-# LANGUAGE TypeFamilies #-}
10+{-# LANGUAGE TypeOperators #-}
11+{-# LANGUAGE UndecidableInstances #-}
12+module Reflex.PerformEvent.Base where
13+
14+import Reflex
15+import Reflex.Deletable.Class
16+import Reflex.PerformEvent.Class
17+import Reflex.Host.Class
18+
19+import Control.Lens
20+import Control.Monad.Exception
21+import Control.Monad.Identity
22+import Control.Monad.Ref
23+import Control.Monad.State.Strict
24+import Data.Align
25+import Data.Dependent.Map (DMap)
26+import qualified Data.Dependent.Map as DMap
27+import Data.Dependent.Sum
28+import Data.Functor.Compose
29+import Data.Functor.Misc
30+import Data.Maybe
31+import Data.Semigroup
32+import Data.These
33+import Data.Word
34+
35+newtype EventTriggerRef t m a = EventTriggerRef { unEventTriggerRef :: Ref m (Maybe (EventTrigger t a)) }
36+
37+newtype 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?
38+
39+newtype PerformEventT t m a = PerformEventT { unPerformEventT :: StateT [Event t (These (PerformEventT t m [DSum (EventTriggerRef t m) Identity]) ())] (HostFrame t) a }
40+
41+deriving instance ReflexHost t => Functor (PerformEventT t m)
42+deriving instance ReflexHost t => Applicative (PerformEventT t m)
43+deriving instance ReflexHost t => Monad (PerformEventT t m)
44+deriving instance ReflexHost t => MonadFix (PerformEventT t m)
45+deriving instance (ReflexHost t, MonadIO (HostFrame t)) => MonadIO (PerformEventT t m)
46+deriving instance (ReflexHost t, MonadException (HostFrame t)) => MonadException (PerformEventT t m)
47+
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
53+ {-# INLINABLE performEvent_ #-}
54+ performEvent_ = PerformEventT . modify . (:) . fmap (This . (>> return []))
55+ {-# 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
71+
72+instance ReflexHost t => MonadReflexCreateTrigger t (PerformEventT t m) where
73+ {-# INLINABLE newEventWithTrigger #-}
74+ newEventWithTrigger = PerformEventT . lift . newEventWithTrigger
75+ {-# INLINABLE newFanEventWithTrigger #-}
76+ newFanEventWithTrigger f = PerformEventT $ lift $ newFanEventWithTrigger f
77+
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+
123+{-# 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)
125+hostPerformEventT a = do
126+ (result, eventToPerform) <- runHostFrame $ runPerformEventT a
127+ eventToPerformHandle <- subscribeEvent eventToPerform
128+ return $ (,) result $ FireCommand $ \triggers (readPhase :: ReadPhase m a') -> do
129+ let go :: [DSum (EventTrigger t) Identity] -> m [a']
130+ go ts = do
131+ (result', mToPerform) <- fireEventsAndRead ts $ do
132+ mToPerform <- sequence =<< readEvent eventToPerformHandle
133+ result' <- readPhase
134+ return (result', mToPerform)
135+ case mToPerform of
136+ Nothing -> return [result']
137+ 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
143+ go triggers
144+
145+instance ReflexHost t => MonadSample t (PerformEventT t m) where
146+ {-# INLINABLE sample #-}
147+ sample = PerformEventT . lift . sample
148+
149+instance (ReflexHost t, MonadHold t m) => MonadHold t (PerformEventT t m) where
150+ {-# INLINABLE hold #-}
151+ hold v0 v' = PerformEventT $ lift $ hold v0 v'
152+ {-# INLINABLE holdDyn #-}
153+ holdDyn v0 v' = PerformEventT $ lift $ holdDyn v0 v'
154+ {-# INLINABLE holdIncremental #-}
155+ holdIncremental v0 v' = PerformEventT $ lift $ holdIncremental v0 v'
156+
157+instance (MonadRef (HostFrame t), ReflexHost t) => MonadRef (PerformEventT t m) where
158+ type Ref (PerformEventT t m) = Ref (HostFrame t)
159+ {-# INLINABLE newRef #-}
160+ newRef = PerformEventT . lift . newRef
161+ {-# INLINABLE readRef #-}
162+ readRef = PerformEventT . lift . readRef
163+ {-# INLINABLE writeRef #-}
164+ writeRef r = PerformEventT . lift . writeRef r
165+
166+instance (MonadAtomicRef (HostFrame t), ReflexHost t) => MonadAtomicRef (PerformEventT t m) where
167+ {-# INLINABLE atomicModifyRef #-}
168+ atomicModifyRef r = PerformEventT . lift . atomicModifyRef r