git.iko.soy/patch
on 18579ea help sign in
patch/src/Reflex/Host/Class.hs
299 lines 13 kB history raw
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE ExistentialQuantification #-}
3{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE FunctionalDependencies #-}
6{-# LANGUAGE GADTs #-}
7{-# LANGUAGE MultiParamTypeClasses #-}
8{-# LANGUAGE RankNTypes #-}
9{-# LANGUAGE RoleAnnotations #-}
10{-# LANGUAGE ScopedTypeVariables #-}
11{-# LANGUAGE TypeFamilies #-}
12{-# LANGUAGE UndecidableInstances #-}
13#ifdef USE_REFLEX_OPTIMIZER
14{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
15#endif
16-- | This module provides the interface for hosting 'Reflex' engines. This
17-- should only be necessary if you're writing a binding or some other library
18-- that provides a core event loop.
19module Reflex.Host.Class
20 ( ReflexHost (..)
21 , MonadSubscribeEvent (..)
22 , MonadReadEvent (..)
23 , MonadReflexCreateTrigger (..)
24 , MonadReflexHost (..)
25 , fireEvents
26 , newEventWithTriggerRef
27 , fireEventRef
28 , fireEventRefAndRead
29 ) where
31import Reflex.Class
33import Control.Applicative
34import Control.Monad
35import Control.Monad.Fix
36import Control.Monad.Identity
37import Control.Monad.Ref
38import Control.Monad.Trans
39import Control.Monad.Trans.Cont (ContT ())
40import Control.Monad.Trans.Except (ExceptT ())
41import Control.Monad.Trans.Reader (ReaderT ())
42import Control.Monad.Trans.RWS (RWST ())
43import Control.Monad.Trans.State (StateT ())
44import qualified Control.Monad.Trans.State.Strict as Strict
45import Control.Monad.Trans.Writer (WriterT ())
46import Data.Dependent.Sum (DSum (..))
47import Data.GADT.Compare
48import Data.Monoid
50#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
51import Control.Monad.Primitive (touch)
52import Data.IORef
53import Reflex.Spider.Internal (EventM (..), HasSpiderTimeline, RootTrigger, SpiderEventHandle (..),
54 SpiderHost (..), SpiderHostFrame (..), Subscriber (..), newEventWithTriggerIO,
55 newFanEventWithTriggerIO, run, runFrame, scheduleClear, subscribe)
56import qualified Reflex.Spider.Internal
57#endif
59-- Note: this import must come last to silence warnings from AMP
60import Prelude hiding (foldl, mapM, mapM_, sequence, sequence_)
62#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
63#include "../Spider/SpiderTimelineHost.include.hs"
64#endif
66-- | Framework implementation support class for the reflex implementation
67-- represented by @t@.
68class ( Reflex t
69 , MonadReflexCreateTrigger t (HostFrame t)
70 , MonadSample t (HostFrame t)
71 , MonadHold t (HostFrame t)
72 , MonadFix (HostFrame t)
73 , MonadSubscribeEvent t (HostFrame t)
74 ) => ReflexHost t where
75 type EventTrigger t :: * -> *
76 type EventHandle t :: * -> *
77 type HostFrame t :: * -> *
79-- | Monad in which Events can be 'subscribed'. This forces all underlying
80-- event sources to be initialized, so that the event will fire whenever it
81-- ought to. Events must be subscribed before they are read using readEvent
82class (Reflex t, Monad m) => MonadSubscribeEvent t m | m -> t where
83 -- | Subscribe to an event and set it up if needed.
84 --
85 -- This function will create a new 'EventHandle' from an 'Event'. This handle
86 -- may then be used via 'readEvent' in the read callback of
87 -- 'fireEventsAndRead'.
88 --
89 -- If the event wasn't subscribed to before (either manually or through a
90 -- dependent event or behavior) then this function will cause the event and
91 -- all dependencies of this event to be set up. For example, if the event was
92 -- created by 'newEventWithTrigger', then it's callback will be executed.
93 --
94 -- It's safe to call this function multiple times.
95 subscribeEvent :: Event t a -> m (EventHandle t a)
97-- | Monad that allows to read events' values.
98class (ReflexHost t, Applicative m, Monad m) => MonadReadEvent t m | m -> t where
99 -- | Read the value of an 'Event' from an 'EventHandle' (created by calling
100 -- 'subscribeEvent').
101 --
102 -- After event propagation is done, all events can be in two states: either
103 -- they are firing with some value or they are not firing. In the former
104 -- case, this function returns @Just act@, where @act@ in an action to read
105 -- the current value of the event. In the latter case, the function returns
106 -- @Nothing@.
107 --
108 -- This function is normally used in the calllback for 'fireEventsAndRead'.
109 readEvent :: EventHandle t a -> m (Maybe (m a))
111-- | A monad where new events feed from external sources can be created.
112class (Applicative m, Monad m) => MonadReflexCreateTrigger t m | m -> t where
113 -- | Creates a root 'Event' (one that is not based on any other event).
114 --
115 -- When a subscriber first subscribes to an event (building another event that
116 -- depends on the subscription) the given callback function is run and passed
117 -- a trigger. The callback function can then set up the event source in IO.
118 -- After this is done, the callback function must return an accompanying
119 -- teardown action.
120 --
121 -- Any time between setup and teardown the trigger can be used to fire the
122 -- event, by passing it to 'fireEventsAndRead'.
123 --
124 -- Note: An event may be set up multiple times. So after the teardown action
125 -- is executed, the event may still be set up again in the future.
126 newEventWithTrigger :: (EventTrigger t a -> IO (IO ())) -> m (Event t a)
127 newFanEventWithTrigger :: GCompare k => (forall a. k a -> EventTrigger t a -> IO (IO ())) -> m (EventSelector t k)
129-- | 'MonadReflexHost' designates monads that can run reflex frames.
130class ( ReflexHost t
131 , MonadReflexCreateTrigger t m
132 , MonadSubscribeEvent t m
133 , MonadReadEvent t (ReadPhase m)
134 , MonadSample t (ReadPhase m)
135 , MonadHold t (ReadPhase m)
136 ) => MonadReflexHost t m | m -> t where
137 type ReadPhase m :: * -> *
138 -- | Propagate some events firings and read the values of events afterwards.
139 --
140 -- This function will create a new frame to fire the given events. It will
141 -- then update all dependent events and behaviors. After that is done, the
142 -- given callback is executed which allows to read the final values of events
143 -- and check whether they have fired in this frame or not.
144 --
145 -- All events that are given are fired at the same time.
146 --
147 -- This function is typically used in the main loop of a reflex framework
148 -- implementation. The main loop waits for external events to happen (such as
149 -- keyboard input or a mouse click) and then fires the corresponding events
150 -- using this function. The read callback can be used to read output events
151 -- and perform a corresponding response action to the external event.
152 fireEventsAndRead :: [DSum (EventTrigger t) Identity] -> ReadPhase m a -> m a
154 -- | Run a frame without any events firing.
155 --
156 -- This function should be used when you want to use 'sample' and 'hold' when
157 -- no events are currently firing. Using this function in that case can
158 -- improve performance, since the implementation can assume that no events are
159 -- firing when 'sample' or 'hold' are called.
160 --
161 -- This function is commonly used to set up the basic event network when the
162 -- application starts up.
163 runHostFrame :: HostFrame t a -> m a
165-- | Like 'fireEventsAndRead', but without reading any events.
166fireEvents :: MonadReflexHost t m => [DSum (EventTrigger t) Identity] -> m ()
167fireEvents dm = fireEventsAndRead dm $ return ()
168{-# INLINE fireEvents #-}
170-- | Create a new event and store its trigger in an 'IORef' while it's active.
171--
172-- An event is only active between the set up (when it's first subscribed to)
173-- and the teardown phases (when noboby is subscribing the event anymore). This
174-- function returns an Event and an 'IORef'. As long as the event is active, the
175-- 'IORef' will contain 'Just' the event trigger to trigger this event. When the
176-- event is not active, the 'IORef' will contain 'Nothing'. This allows event
177-- sources to be more efficient, since they don't need to produce events when
178-- nobody is listening.
179newEventWithTriggerRef :: (MonadReflexCreateTrigger t m, MonadRef m, Ref m ~ Ref IO) => m (Event t a, Ref m (Maybe (EventTrigger t a)))
180newEventWithTriggerRef = do
181 rt <- newRef Nothing
182 e <- newEventWithTrigger $ \t -> do
183 writeRef rt $ Just t
184 return $ writeRef rt Nothing
185 return (e, rt)
186{-# INLINE newEventWithTriggerRef #-}
188-- | Fire the given trigger if it is not 'Nothing'.
189fireEventRef :: (MonadReflexHost t m, MonadRef m, Ref m ~ Ref IO) => Ref m (Maybe (EventTrigger t a)) -> a -> m ()
190fireEventRef mtRef input = do
191 mt <- readRef mtRef
192 case mt of
193 Nothing -> return ()
194 Just trigger -> fireEvents [trigger :=> Identity input]
196-- | Fire the given trigger if it is not 'Nothing', and read from the given
197-- 'EventHandle'.
198fireEventRefAndRead :: (MonadReflexHost t m, MonadRef m, Ref m ~ Ref IO) => Ref m (Maybe (EventTrigger t a)) -> a -> EventHandle t b -> m (Maybe b)
199fireEventRefAndRead mtRef input e = do
200 mt <- readRef mtRef
201 case mt of
202 Nothing -> return Nothing -- Since we aren't firing the input, the output can't fire
203 Just trigger -> fireEventsAndRead [trigger :=> Identity input] $ do
204 mGetValue <- readEvent e
205 case mGetValue of
206 Nothing -> return Nothing
207 Just getValue -> fmap Just getValue
210--------------------------------------------------------------------------------
211-- Instances
212--------------------------------------------------------------------------------
214instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (ReaderT r m) where
215 newEventWithTrigger = lift . newEventWithTrigger
216 newFanEventWithTrigger initializer = lift $ newFanEventWithTrigger initializer
218instance MonadSubscribeEvent t m => MonadSubscribeEvent t (ReaderT r m) where
219 subscribeEvent = lift . subscribeEvent
221instance MonadReflexHost t m => MonadReflexHost t (ReaderT r m) where
222 type ReadPhase (ReaderT r m) = ReadPhase m
223 fireEventsAndRead dm a = lift $ fireEventsAndRead dm a
224 runHostFrame = lift . runHostFrame
226instance (MonadReflexCreateTrigger t m, Monoid w) => MonadReflexCreateTrigger t (WriterT w m) where
227 newEventWithTrigger = lift . newEventWithTrigger
228 newFanEventWithTrigger initializer = lift $ newFanEventWithTrigger initializer
230instance (MonadSubscribeEvent t m, Monoid w) => MonadSubscribeEvent t (WriterT w m) where
231 subscribeEvent = lift . subscribeEvent
233instance (MonadReflexHost t m, Monoid w) => MonadReflexHost t (WriterT w m) where
234 type ReadPhase (WriterT w m) = ReadPhase m
235 fireEventsAndRead dm a = lift $ fireEventsAndRead dm a
236 runHostFrame = lift . runHostFrame
238instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (StateT s m) where
239 newEventWithTrigger = lift . newEventWithTrigger
240 newFanEventWithTrigger initializer = lift $ newFanEventWithTrigger initializer
242instance MonadSubscribeEvent t m => MonadSubscribeEvent t (StateT r m) where
243 subscribeEvent = lift . subscribeEvent
245instance MonadReflexHost t m => MonadReflexHost t (StateT s m) where
246 type ReadPhase (StateT s m) = ReadPhase m
247 fireEventsAndRead dm a = lift $ fireEventsAndRead dm a
248 runHostFrame = lift . runHostFrame
251instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (Strict.StateT s m) where
252 newEventWithTrigger = lift . newEventWithTrigger
253 newFanEventWithTrigger initializer = lift $ newFanEventWithTrigger initializer
255instance MonadSubscribeEvent t m => MonadSubscribeEvent t (Strict.StateT r m) where
256 subscribeEvent = lift . subscribeEvent
258instance MonadReflexHost t m => MonadReflexHost t (Strict.StateT s m) where
259 type ReadPhase (Strict.StateT s m) = ReadPhase m
260 fireEventsAndRead dm a = lift $ fireEventsAndRead dm a
261 runHostFrame = lift . runHostFrame
265instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (ContT r m) where
266 newEventWithTrigger = lift . newEventWithTrigger
267 newFanEventWithTrigger initializer = lift $ newFanEventWithTrigger initializer
269instance MonadSubscribeEvent t m => MonadSubscribeEvent t (ContT r m) where
270 subscribeEvent = lift . subscribeEvent
272instance MonadReflexHost t m => MonadReflexHost t (ContT r m) where
273 type ReadPhase (ContT r m) = ReadPhase m
274 fireEventsAndRead dm a = lift $ fireEventsAndRead dm a
275 runHostFrame = lift . runHostFrame
277instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (ExceptT e m) where
278 newEventWithTrigger = lift . newEventWithTrigger
279 newFanEventWithTrigger initializer = lift $ newFanEventWithTrigger initializer
281instance MonadSubscribeEvent t m => MonadSubscribeEvent t (ExceptT r m) where
282 subscribeEvent = lift . subscribeEvent
284instance MonadReflexHost t m => MonadReflexHost t (ExceptT e m) where
285 type ReadPhase (ExceptT e m) = ReadPhase m
286 fireEventsAndRead dm a = lift $ fireEventsAndRead dm a
287 runHostFrame = lift . runHostFrame
289instance (MonadReflexCreateTrigger t m, Monoid w) => MonadReflexCreateTrigger t (RWST r w s m) where
290 newEventWithTrigger = lift . newEventWithTrigger
291 newFanEventWithTrigger initializer = lift $ newFanEventWithTrigger initializer
293instance (MonadSubscribeEvent t m, Monoid w) => MonadSubscribeEvent t (RWST r w s m) where
294 subscribeEvent = lift . subscribeEvent
296instance (MonadReflexHost t m, Monoid w) => MonadReflexHost t (RWST r w s m) where
297 type ReadPhase (RWST r w s m) = ReadPhase m
298 fireEventsAndRead dm a = lift $ fireEventsAndRead dm a
299 runHostFrame = lift . runHostFrame