@@ -1,10 +1,17 @@
1+-- | This module defines 'TriggerEventT', the standard implementation of
2+-- 'TriggerEvent'.
13{-# LANGUAGE DeriveFunctor #-}
24{-# LANGUAGE FlexibleInstances #-}
35{-# LANGUAGE GeneralizedNewtypeDeriving #-}
46{-# LANGUAGE MultiParamTypeClasses #-}
57{-# LANGUAGE TypeFamilies #-}
6−
7−module Reflex.TriggerEvent.Base where
8+module Reflex.TriggerEvent.Base
9+ ( TriggerEventT (..)
10+ , runTriggerEventT
11+ , askEvents
12+ , TriggerInvocation (..)
13+ , EventTriggerRef (..)
14+ ) where
815
916import Control.Concurrent
1017import Control.Monad.Exception
@@ -17,97 +24,88 @@ import Reflex.PerformEvent.Class
1724import Reflex.PostBuild.Class
1825import Reflex.TriggerEvent.Class
1926
27+-- | A value with which to fire an 'Event', as well as a callback to invoke
28+-- after its propagation has completed.
2029data TriggerInvocation a = TriggerInvocation a (IO ())
2130
31+-- | A reference to an 'EventTrigger' suitable for firing with 'TriggerEventT'.
2232newtype EventTriggerRef t m a = EventTriggerRef { unEventTriggerRef :: Ref m (Maybe (EventTrigger t a)) }
2333
24−newtype TriggerEventT t m a = TriggerEventT
25− { unTriggerEventT :: ReaderT (Chan [DSum (EventTriggerRef t m) TriggerInvocation]) m a
26− } deriving ( Functor
27− , Applicative
28− , Monad
29− , MonadFix
30− , MonadIO
31− , MonadException
32− , MonadAsyncException
33− )
34+-- | A basic implementation of 'TriggerEvent'.
35+newtype TriggerEventT t m a = TriggerEventT { unTriggerEventT :: ReaderT (Chan [DSum (EventTriggerRef t m) TriggerInvocation]) m a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)
3436
37+-- | Run a 'TriggerEventT' action. The argument should be a 'Chan' into which
38+-- 'TriggerInvocation's can be passed; it is expected that some other thread
39+-- will be responsible for popping values out of the 'Chan' and firing their
40+-- 'EventTrigger's.
3541runTriggerEventT :: TriggerEventT t m a -> Chan [DSum (EventTriggerRef t m) TriggerInvocation] -> m a
3642runTriggerEventT = runReaderT . unTriggerEventT
3743
3844instance MonadTrans (TriggerEventT t) where
3945 lift = TriggerEventT . lift
4046
41−instance PerformEvent t m =>
42− PerformEvent t (TriggerEventT t m) where
47+instance PerformEvent t m => PerformEvent t (TriggerEventT t m) where
4348 type Performable (TriggerEventT t m) = Performable m
44− performEvent_ e = lift $ performEvent_ e
4549 {-# INLINABLE performEvent_ #-}
46− performEvent e = lift $ performEvent e
50+ performEvent_ e = lift $ performEvent_ e
4751 {-# INLINABLE performEvent #-}
52+ performEvent e = lift $ performEvent e
4853
49−instance PostBuild t m =>
50− PostBuild t (TriggerEventT t m) where
51− getPostBuild = lift getPostBuild
54+instance PostBuild t m => PostBuild t (TriggerEventT t m) where
5255 {-# INLINABLE getPostBuild #-}
56+ getPostBuild = lift getPostBuild
5357
54−instance MonadReflexCreateTrigger t m =>
55− MonadReflexCreateTrigger t (TriggerEventT t m) where
56− newEventWithTrigger = lift . newEventWithTrigger
58+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (TriggerEventT t m) where
5759 {-# INLINABLE newEventWithTrigger #-}
58− newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
60+ newEventWithTrigger = lift . newEventWithTrigger
5961 {-# INLINABLE newFanEventWithTrigger #-}
62+ newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
6063
61−instance (Monad m, MonadRef m, Ref m ~ Ref IO, MonadReflexCreateTrigger t m) =>
62− TriggerEvent t (TriggerEventT t m) where
64+instance (Monad m, MonadRef m, Ref m ~ Ref IO, MonadReflexCreateTrigger t m) => TriggerEvent t (TriggerEventT t m) where
65+ {-# INLINABLE newTriggerEvent #-}
6366 newTriggerEvent = do
6467 (e, t) <- newTriggerEventWithOnComplete
6568 return (e, \a -> t a $ return ())
66− {-# INLINABLE newTriggerEvent #-}
69+ {-# INLINABLE newTriggerEventWithOnComplete #-}
6770 newTriggerEventWithOnComplete = do
6871 events <- askEvents
6972 (eResult, reResultTrigger) <- lift newEventWithTriggerRef
7073 return . (,) eResult $ \a cb ->
7174 writeChan events [EventTriggerRef reResultTrigger :=> TriggerInvocation a cb]
72− {-# INLINABLE newTriggerEventWithOnComplete #-}
75+ {-# INLINABLE newEventWithLazyTriggerWithOnComplete #-}
7376 newEventWithLazyTriggerWithOnComplete f = do
7477 events <- askEvents
7578 lift . newEventWithTrigger $ \t ->
7679 f $ \a cb -> do
7780 reResultTrigger <- newRef $ Just t
7881 writeChan events [EventTriggerRef reResultTrigger :=> TriggerInvocation a cb]
79− {-# INLINABLE newEventWithLazyTriggerWithOnComplete #-}
8082
81−instance MonadRef m =>
82− MonadRef (TriggerEventT t m) where
83+instance MonadRef m => MonadRef (TriggerEventT t m) where
8384 type Ref (TriggerEventT t m) = Ref m
84− newRef = lift . newRef
8585 {-# INLINABLE newRef #-}
86− readRef = lift . readRef
86+ newRef = lift . newRef
8787 {-# INLINABLE readRef #-}
88− writeRef r = lift . writeRef r
88+ readRef = lift . readRef
8989 {-# INLINABLE writeRef #-}
90+ writeRef r = lift . writeRef r
9091
91−instance MonadAtomicRef m =>
92− MonadAtomicRef (TriggerEventT t m) where
93− atomicModifyRef r = lift . atomicModifyRef r
92+instance MonadAtomicRef m => MonadAtomicRef (TriggerEventT t m) where
9493 {-# INLINABLE atomicModifyRef #-}
94+ atomicModifyRef r = lift . atomicModifyRef r
9595
96−instance MonadSample t m =>
97− MonadSample t (TriggerEventT t m) where
98− sample = lift . sample
96+instance MonadSample t m => MonadSample t (TriggerEventT t m) where
9997 {-# INLINABLE sample #-}
98+ sample = lift . sample
10099
101−instance MonadHold t m =>
102− MonadHold t (TriggerEventT t m) where
103− hold v0 v' = lift $ hold v0 v'
100+instance MonadHold t m => MonadHold t (TriggerEventT t m) where
104101 {-# INLINABLE hold #-}
105− holdDyn v0 v' = lift $ holdDyn v0 v'
102+ hold v0 v' = lift $ hold v0 v'
106103 {-# INLINABLE holdDyn #-}
107− holdIncremental v0 v' = lift $ holdIncremental v0 v'
104+ holdDyn v0 v' = lift $ holdDyn v0 v'
108105 {-# INLINABLE holdIncremental #-}
106+ holdIncremental v0 v' = lift $ holdIncremental v0 v'
109107
110−askEvents
111− :: Monad m
112− => TriggerEventT t m (Chan [DSum (EventTriggerRef t m) TriggerInvocation])
108+-- | Retrieve the current 'Chan'; event trigger invocations pushed into it will
109+-- be fired.
110+askEvents :: Monad m => TriggerEventT t m (Chan [DSum (EventTriggerRef t m) TriggerInvocation])
113111askEvents = TriggerEventT ask