@@ -1,177 +0,0 @@
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.Dom.PerformEvent.Base where
13−
14−import Foreign.JavaScript.TH
15−import Reflex
16−import Reflex.Deletable.Class
17−import Reflex.Dom.PerformEvent.Class
18−import Reflex.Host.Class
19−
20−import Control.Lens
21−import Control.Monad.Exception
22−import Control.Monad.Identity
23−import Control.Monad.Ref
24−import Control.Monad.State.Strict
25−import Data.Align
26−import Data.Dependent.Map (DMap)
27−import qualified Data.Dependent.Map as DMap
28−import Data.Dependent.Sum
29−import Data.Functor.Compose
30−import Data.Functor.Misc
31−import Data.Maybe
32−import Data.Semigroup
33−import Data.These
34−import Data.Word
35−
36−newtype EventTriggerRef t m a = EventTriggerRef { unEventTriggerRef :: Ref m (Maybe (EventTrigger t a)) }
37−
38−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?
39−
40−newtype PerformEventT t m a = PerformEventT { unPerformEventT :: StateT [Event t (These (PerformEventT t m [DSum (EventTriggerRef t m) Identity]) ())] (HostFrame t) a }
41−
42−deriving instance ReflexHost t => Functor (PerformEventT t m)
43−deriving instance ReflexHost t => Applicative (PerformEventT t m)
44−deriving instance ReflexHost t => Monad (PerformEventT t m)
45−deriving instance ReflexHost t => MonadFix (PerformEventT t m)
46−deriving instance (ReflexHost t, MonadIO (HostFrame t)) => MonadIO (PerformEventT t m)
47−deriving instance (ReflexHost t, MonadException (HostFrame t)) => MonadException (PerformEventT t m)
48−
49−instance (ReflexHost t, MonadAsyncException (HostFrame t)) => MonadAsyncException (PerformEventT t m) where
50− mask f = PerformEventT $ mask $ \unmask -> unPerformEventT $ f $ PerformEventT . unmask . unPerformEventT
51−
52−instance (ReflexHost t, HasWebView (HostFrame t)) => HasWebView (PerformEventT t m) where
53− type WebViewPhantom (PerformEventT t m) = WebViewPhantom (HostFrame t)
54− askWebView = PerformEventT $ lift askWebView
55−
56−instance (ReflexHost t, Ref m ~ Ref IO, MonadRef (HostFrame t), Ref (HostFrame t) ~ Ref IO) => PerformEvent t (PerformEventT t m) where
57− type Performable (PerformEventT t m) = PerformEventT t m
58− {-# INLINABLE performEvent_ #-}
59− performEvent_ = PerformEventT . modify . (:) . fmap (This . (>> return []))
60− {-# INLINABLE performEvent #-}
61− performEvent e = PerformEventT $ do
62− (eResult, reResultTrigger) <- newEventWithTriggerRef
63− modify $ (:) $ ffor e $ \o -> This $ do
64− result <- o
65− return [EventTriggerRef reResultTrigger :=> Identity result]
66− return eResult
67−
68−instance (ReflexHost t, Monad (HostFrame t), Ref (HostFrame t) ~ Ref IO, Ref m ~ Ref IO) => Deletable t (PerformEventT t m) where
69− {-# INLINABLE deletable #-}
70− deletable d a = PerformEventT $ do
71− (result, reverseEventsToPerform) <- lift $ runStateT (unPerformEventT a) []
72− let (numberedEvents, _) = numberWith (\n e -> Const2 n :=> e) (reverse reverseEventsToPerform) (1 :: Word64)
73− eventToPerform <- lift $ mergePerformEventsAndAdd (DMap.fromList numberedEvents) never
74− modify (align eventToPerform d :)
75− return result
76−
77−instance ReflexHost t => MonadReflexCreateTrigger t (PerformEventT t m) where
78− {-# INLINABLE newEventWithTrigger #-}
79− newEventWithTrigger = PerformEventT . lift . newEventWithTrigger
80− {-# INLINABLE newFanEventWithTrigger #-}
81− newFanEventWithTrigger f = PerformEventT $ lift $ newFanEventWithTrigger f
82−
83−{-# INLINABLE numberWith #-}
84−numberWith :: (Enum n, Traversable t) => (n -> a -> b) -> t a -> n -> (t b, n)
85−numberWith f t n0 = flip runState n0 $ forM t $ \x -> state $ \n -> (f n x, succ n)
86−
87−{-# INLINABLE mergePerformEventsAndAdd #-}
88−mergePerformEventsAndAdd :: forall t m. ReflexHost t
89− => DMap (Const2 Word64 (These (PerformEventT t m [DSum (EventTriggerRef t m) Identity]) ())) (Event t)
90− -> Event t (PatchDMap (DMap (Const2 Word64 (These (PerformEventT t m [DSum (EventTriggerRef t m) Identity]) ())) (Event t)))
91− -> HostFrame t (Event t (PerformEventT t m [DSum (EventTriggerRef t m) Identity]))
92−mergePerformEventsAndAdd initial eAddNew = do
93− rec events :: Incremental t PatchDMap (DMap (Const2 Word64 (These (PerformEventT t m [DSum (EventTriggerRef t m) Identity]) ())) (Event t))
94− <- holdIncremental initial $ eAddNew <> eDelete --TODO: Eliminate empty firings
95− let event = mergeWith DMap.union [mergeIncremental events, coincidence (fmap (\(PatchDMap m) -> merge $ DMap.mapMaybeWithKey (const getCompose) m) eAddNew)]
96− eventToPerform :: Event t (PerformEventT t m [DSum (EventTriggerRef t m) Identity])
97− eventToPerform = ffor event $
98− fmap concat .
99− sequence .
100− fmapMaybe (\(Const2 _ :=> Identity x) -> x ^? here) .
101− DMap.toList
102− eDelete :: Event t (PatchDMap (DMap (Const2 Word64 (These (PerformEventT t m [DSum (EventTriggerRef t m) Identity]) ())) (Event t)))
103− eDelete = fforMaybe event $
104− fmap (PatchDMap . DMap.fromList) .
105− (\l -> if null l then Nothing else Just l) .
106− fmapMaybe (\(Const2 k :=> Identity x) -> (Const2 k :=> Compose Nothing) <$ x ^? there) .
107− DMap.toList
108− return eventToPerform
109−
110−{-# INLINABLE runPerformEventT #-}
111−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]))
112−runPerformEventT (PerformEventT a) = do
113− (result, reverseEventsToPerform) <- runStateT a []
114− (eAddNew, reAddNewTrigger) <- newEventWithTriggerRef
115− let (numberedEvents, nextNumber) = numberWith (\n e -> Const2 n :=> e) (reverse reverseEventsToPerform) (1 :: Word64)
116− nextNumberRef <- newRef nextNumber
117− let runResult :: PerformEventT t m [DSum (EventTriggerRef t m) Identity] -> HostFrame t [DSum (EventTriggerRef t m) Identity]
118− runResult (PerformEventT r) = do
119− (followups, reverseNewEventsToPerform) <- runStateT r []
120− oldN <- readRef nextNumberRef
121− let (numberedNewEvents, newN) = numberWith (\n e -> Const2 n :=> Compose (Just e)) (reverse reverseNewEventsToPerform) oldN
122− if newN == oldN then return followups else do
123− writeRef nextNumberRef newN
124− return $ (EventTriggerRef reAddNewTrigger :=> Identity (PatchDMap (DMap.fromList numberedNewEvents))) : followups
125− eventToPerform <- mergePerformEventsAndAdd (DMap.fromList numberedEvents) eAddNew
126− return (result, runResult <$> eventToPerform)
127−
128−{-# INLINABLE hostPerformEventT #-}
129−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)
130−hostPerformEventT a = do
131− (result, eventToPerform) <- runHostFrame $ runPerformEventT a
132− eventToPerformHandle <- subscribeEvent eventToPerform
133− return $ (,) result $ FireCommand $ \triggers (readPhase :: ReadPhase m a') -> do
134− let go :: [DSum (EventTrigger t) Identity] -> m [a']
135− go ts = do
136− (result', mToPerform) <- fireEventsAndRead ts $ do
137− mToPerform <- sequence =<< readEvent eventToPerformHandle
138− result' <- readPhase
139− return (result', mToPerform)
140− case mToPerform of
141− Nothing -> return [result']
142− Just toPerform -> do
143− followupEventTriggerRefs <- runHostFrame toPerform
144− followupEventTriggers <- forM followupEventTriggerRefs $ \(EventTriggerRef rt :=> x) -> do
145− mt <- readRef rt
146− return $ fmap (:=> x) mt
147− fmap (result':) $ go $ catMaybes followupEventTriggers
148− go triggers
149−
150−instance ReflexHost t => MonadSample t (PerformEventT t m) where
151− {-# INLINABLE sample #-}
152− sample = PerformEventT . lift . sample
153−
154−instance (ReflexHost t, MonadHold t m) => MonadHold t (PerformEventT t m) where
155− {-# INLINABLE hold #-}
156− hold v0 v' = PerformEventT $ lift $ hold v0 v'
157− {-# INLINABLE holdDyn #-}
158− holdDyn v0 v' = PerformEventT $ lift $ holdDyn v0 v'
159− {-# INLINABLE holdIncremental #-}
160− holdIncremental v0 v' = PerformEventT $ lift $ holdIncremental v0 v'
161−
162−instance (MonadRef (HostFrame t), ReflexHost t) => MonadRef (PerformEventT t m) where
163− type Ref (PerformEventT t m) = Ref (HostFrame t)
164− {-# INLINABLE newRef #-}
165− newRef = PerformEventT . lift . newRef
166− {-# INLINABLE readRef #-}
167− readRef = PerformEventT . lift . readRef
168− {-# INLINABLE writeRef #-}
169− writeRef r = PerformEventT . lift . writeRef r
170−
171−instance (MonadAtomicRef (HostFrame t), ReflexHost t) => MonadAtomicRef (PerformEventT t m) where
172− {-# INLINABLE atomicModifyRef #-}
173− atomicModifyRef r = PerformEventT . lift . atomicModifyRef r
174−
175−instance (HasJS x (HostFrame t), ReflexHost t) => HasJS x (PerformEventT t m) where
176− type JSM (PerformEventT t m) = JSM (HostFrame t)
177− liftJS = PerformEventT . lift . liftJS