git.iko.soy/patch
on daa1571 help sign in
patch/src/Reflex/TriggerEvent/Base.hs
111 lines 4.4 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.Reader
19import Control.Monad.Ref
20import Data.Dependent.Sum
21import Reflex.Class
22import Reflex.Host.Class
23import Reflex.PerformEvent.Class
24import Reflex.PostBuild.Class
25import Reflex.TriggerEvent.Class
27-- | A value with which to fire an 'Event', as well as a callback to invoke
28-- after its propagation has completed.
29data TriggerInvocation a = TriggerInvocation a (IO ())
31-- | A reference to an 'EventTrigger' suitable for firing with 'TriggerEventT'.
32newtype EventTriggerRef t m a = EventTriggerRef { unEventTriggerRef :: Ref m (Maybe (EventTrigger t a)) }
34-- | A basic implementation of 'TriggerEvent'.
35newtype TriggerEventT t m a = TriggerEventT { unTriggerEventT :: ReaderT (Chan [DSum (EventTriggerRef t m) TriggerInvocation]) m a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)
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.
41runTriggerEventT :: TriggerEventT t m a -> Chan [DSum (EventTriggerRef t m) TriggerInvocation] -> m a
42runTriggerEventT = runReaderT . unTriggerEventT
44instance MonadTrans (TriggerEventT t) where
45 lift = TriggerEventT . lift
47instance PerformEvent t m => PerformEvent t (TriggerEventT t m) where
48 type Performable (TriggerEventT t m) = Performable m
49 {-# INLINABLE performEvent_ #-}
50 performEvent_ e = lift $ performEvent_ e
51 {-# INLINABLE performEvent #-}
52 performEvent e = lift $ performEvent e
54instance PostBuild t m => PostBuild t (TriggerEventT t m) where
55 {-# INLINABLE getPostBuild #-}
56 getPostBuild = lift getPostBuild
58instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (TriggerEventT t m) where
59 {-# INLINABLE newEventWithTrigger #-}
60 newEventWithTrigger = lift . newEventWithTrigger
61 {-# INLINABLE newFanEventWithTrigger #-}
62 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
64instance (Monad m, MonadRef m, Ref m ~ Ref IO, MonadReflexCreateTrigger t m) => TriggerEvent t (TriggerEventT t m) where
65 {-# INLINABLE newTriggerEvent #-}
66 newTriggerEvent = do
67 (e, t) <- newTriggerEventWithOnComplete
68 return (e, \a -> t a $ return ())
69 {-# INLINABLE newTriggerEventWithOnComplete #-}
70 newTriggerEventWithOnComplete = do
71 events <- askEvents
72 (eResult, reResultTrigger) <- lift newEventWithTriggerRef
73 return . (,) eResult $ \a cb ->
74 writeChan events [EventTriggerRef reResultTrigger :=> TriggerInvocation a cb]
75 {-# INLINABLE newEventWithLazyTriggerWithOnComplete #-}
76 newEventWithLazyTriggerWithOnComplete f = do
77 events <- askEvents
78 lift . newEventWithTrigger $ \t ->
79 f $ \a cb -> do
80 reResultTrigger <- newRef $ Just t
81 writeChan events [EventTriggerRef reResultTrigger :=> TriggerInvocation a cb]
83instance MonadRef m => MonadRef (TriggerEventT t m) where
84 type Ref (TriggerEventT t m) = Ref m
85 {-# INLINABLE newRef #-}
86 newRef = lift . newRef
87 {-# INLINABLE readRef #-}
88 readRef = lift . readRef
89 {-# INLINABLE writeRef #-}
90 writeRef r = lift . writeRef r
92instance MonadAtomicRef m => MonadAtomicRef (TriggerEventT t m) where
93 {-# INLINABLE atomicModifyRef #-}
94 atomicModifyRef r = lift . atomicModifyRef r
96instance MonadSample t m => MonadSample t (TriggerEventT t m) where
97 {-# INLINABLE sample #-}
98 sample = lift . sample
100instance MonadHold t m => MonadHold t (TriggerEventT t m) where
101 {-# INLINABLE hold #-}
102 hold v0 v' = lift $ hold v0 v'
103 {-# INLINABLE holdDyn #-}
104 holdDyn v0 v' = lift $ holdDyn v0 v'
105 {-# INLINABLE holdIncremental #-}
106 holdIncremental v0 v' = lift $ holdIncremental v0 v'
108-- | Retrieve the current 'Chan'; event trigger invocations pushed into it will
109-- be fired.
110askEvents :: Monad m => TriggerEventT t m (Chan [DSum (EventTriggerRef t m) TriggerInvocation])
111askEvents = TriggerEventT ask