git.iko.soy/reflex
on mapm-with-replace help sign in
reflex/src/Reflex/TriggerEvent/Base.hs
129 lines 5.3 kB history raw
1-- | This module defines 'TriggerEventT', the standard implementation of
2-- 'TriggerEvent'.
3{-# LANGUAGE DeriveFunctor #-}
4{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
7{-# LANGUAGE TypeFamilies #-}
8module Reflex.TriggerEvent.Base
9 ( TriggerEventT (..)
10 , runTriggerEventT
11 , askEvents
12 , TriggerInvocation (..)
13 , EventTriggerRef (..)
14 ) where
16import Control.Concurrent
17import Control.Monad.Exception
18import Control.Monad.Primitive
19import Control.Monad.Reader
20import Control.Monad.Ref
21import Data.Coerce
22import Data.Dependent.Sum
23import Data.IORef
24import Reflex.Class
25import Reflex.Host.Class
26import Reflex.PerformEvent.Class
27import Reflex.PostBuild.Class
28import Reflex.TriggerEvent.Class
30-- | A value with which to fire an 'Event', as well as a callback to invoke
31-- after its propagation has completed.
32data TriggerInvocation a = TriggerInvocation a (IO ())
34-- | A reference to an 'EventTrigger' suitable for firing with 'TriggerEventT'.
35newtype EventTriggerRef t a = EventTriggerRef { unEventTriggerRef :: IORef (Maybe (EventTrigger t a)) }
37-- | A basic implementation of 'TriggerEvent'.
38newtype TriggerEventT t m a = TriggerEventT { unTriggerEventT :: ReaderT (Chan [DSum (EventTriggerRef t) TriggerInvocation]) m a }
39 deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)
41-- | Run a 'TriggerEventT' action. The argument should be a 'Chan' into which
42-- 'TriggerInvocation's can be passed; it is expected that some other thread
43-- will be responsible for popping values out of the 'Chan' and firing their
44-- 'EventTrigger's.
45runTriggerEventT :: TriggerEventT t m a -> Chan [DSum (EventTriggerRef t) TriggerInvocation] -> m a
46runTriggerEventT = runReaderT . unTriggerEventT
48instance MonadTrans (TriggerEventT t) where
49 {-# INLINABLE lift #-}
50 lift = TriggerEventT . lift
52instance PrimMonad m => PrimMonad (TriggerEventT t m) where
53 type PrimState (TriggerEventT t m) = PrimState m
54 {-# INLINABLE primitive #-}
55 primitive = lift . primitive
57instance PerformEvent t m => PerformEvent t (TriggerEventT t m) where
58 type Performable (TriggerEventT t m) = Performable m
59 {-# INLINABLE performEvent_ #-}
60 performEvent_ e = lift $ performEvent_ e
61 {-# INLINABLE performEvent #-}
62 performEvent e = lift $ performEvent e
64instance PostBuild t m => PostBuild t (TriggerEventT t m) where
65 {-# INLINABLE getPostBuild #-}
66 getPostBuild = lift getPostBuild
68instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (TriggerEventT t m) where
69 {-# INLINABLE newEventWithTrigger #-}
70 newEventWithTrigger = lift . newEventWithTrigger
71 {-# INLINABLE newFanEventWithTrigger #-}
72 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
74instance (Monad m, MonadRef m, Ref m ~ Ref IO, MonadReflexCreateTrigger t m) => TriggerEvent t (TriggerEventT t m) where
75 {-# INLINABLE newTriggerEvent #-}
76 newTriggerEvent = do
77 (e, t) <- newTriggerEventWithOnComplete
78 return (e, \a -> t a $ return ())
79 {-# INLINABLE newTriggerEventWithOnComplete #-}
80 newTriggerEventWithOnComplete = do
81 events <- askEvents
82 (eResult, reResultTrigger) <- lift newEventWithTriggerRef
83 return . (,) eResult $ \a cb ->
84 writeChan events [EventTriggerRef reResultTrigger :=> TriggerInvocation a cb]
85 {-# INLINABLE newEventWithLazyTriggerWithOnComplete #-}
86 newEventWithLazyTriggerWithOnComplete f = do
87 events <- askEvents
88 lift . newEventWithTrigger $ \t ->
89 f $ \a cb -> do
90 reResultTrigger <- newRef $ Just t
91 writeChan events [EventTriggerRef reResultTrigger :=> TriggerInvocation a cb]
93instance MonadRef m => MonadRef (TriggerEventT t m) where
94 type Ref (TriggerEventT t m) = Ref m
95 {-# INLINABLE newRef #-}
96 newRef = lift . newRef
97 {-# INLINABLE readRef #-}
98 readRef = lift . readRef
99 {-# INLINABLE writeRef #-}
100 writeRef r = lift . writeRef r
102instance MonadAtomicRef m => MonadAtomicRef (TriggerEventT t m) where
103 {-# INLINABLE atomicModifyRef #-}
104 atomicModifyRef r = lift . atomicModifyRef r
106instance MonadSample t m => MonadSample t (TriggerEventT t m) where
107 {-# INLINABLE sample #-}
108 sample = lift . sample
110instance MonadHold t m => MonadHold t (TriggerEventT t m) where
111 {-# INLINABLE hold #-}
112 hold v0 v' = lift $ hold v0 v'
113 {-# INLINABLE holdDyn #-}
114 holdDyn v0 v' = lift $ holdDyn v0 v'
115 {-# INLINABLE holdIncremental #-}
116 holdIncremental v0 v' = lift $ holdIncremental v0 v'
118instance MonadAdjust t m => MonadAdjust t (TriggerEventT t m) where
119 {-# INLINABLE mapMWithReplace #-}
120 mapMWithReplace f g a0 a' = TriggerEventT $ mapMWithReplace (unTriggerEventT . f) (unTriggerEventT . g) a0 a'
121 {-# INLINABLE traverseDMapWithKeyWithAdjust #-}
122 traverseDMapWithKeyWithAdjust f dm0 dm' = TriggerEventT $ traverseDMapWithKeyWithAdjust (coerce . f) dm0 dm'
123 {-# INLINABLE traverseDMapWithKeyWithAdjustWithMove #-}
124 traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = TriggerEventT $ traverseDMapWithKeyWithAdjustWithMove (coerce . f) dm0 dm'
126-- | Retrieve the current 'Chan'; event trigger invocations pushed into it will
127-- be fired.
128askEvents :: Monad m => TriggerEventT t m (Chan [DSum (EventTriggerRef t) TriggerInvocation])
129askEvents = TriggerEventT ask