git.iko.soy/patch
on eefb776 help sign in
patch/src/Reflex/TriggerEvent/Base.hs
148 lines 6.0 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.Applicative (liftA2)
17import Control.Concurrent
18import Control.Monad.Exception
19import Control.Monad.Primitive
20import Control.Monad.Reader
21import Control.Monad.Ref
22import Data.Coerce
23import Data.Dependent.Sum
24import Data.IORef
25import Data.Monoid ((<>))
26import qualified Data.Semigroup as S
27import Reflex.Class
28import Reflex.Adjustable.Class
29import Reflex.Host.Class
30import Reflex.PerformEvent.Class
31import Reflex.PostBuild.Class
32import Reflex.TriggerEvent.Class
34-- | A value with which to fire an 'Event', as well as a callback to invoke
35-- after its propagation has completed.
36data TriggerInvocation a = TriggerInvocation a (IO ())
38-- | A reference to an 'EventTrigger' suitable for firing with 'TriggerEventT'.
39newtype EventTriggerRef t a = EventTriggerRef { unEventTriggerRef :: IORef (Maybe (EventTrigger t a)) }
41-- | A basic implementation of 'TriggerEvent'.
42newtype TriggerEventT t m a = TriggerEventT { unTriggerEventT :: ReaderT (Chan [DSum (EventTriggerRef t) TriggerInvocation]) m a }
43 deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)
45-- | Run a 'TriggerEventT' action. The argument should be a 'Chan' into which
46-- 'TriggerInvocation's can be passed; it is expected that some other thread
47-- will be responsible for popping values out of the 'Chan' and firing their
48-- 'EventTrigger's.
49runTriggerEventT :: TriggerEventT t m a -> Chan [DSum (EventTriggerRef t) TriggerInvocation] -> m a
50runTriggerEventT = runReaderT . unTriggerEventT
52instance MonadTrans (TriggerEventT t) where
53 {-# INLINABLE lift #-}
54 lift = TriggerEventT . lift
56instance PrimMonad m => PrimMonad (TriggerEventT t m) where
57 type PrimState (TriggerEventT t m) = PrimState m
58 {-# INLINABLE primitive #-}
59 primitive = lift . primitive
61instance PerformEvent t m => PerformEvent t (TriggerEventT t m) where
62 type Performable (TriggerEventT t m) = Performable m
63 {-# INLINABLE performEvent_ #-}
64 performEvent_ e = lift $ performEvent_ e
65 {-# INLINABLE performEvent #-}
66 performEvent e = lift $ performEvent e
68instance PostBuild t m => PostBuild t (TriggerEventT t m) where
69 {-# INLINABLE getPostBuild #-}
70 getPostBuild = lift getPostBuild
72instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (TriggerEventT t m) where
73 {-# INLINABLE newEventWithTrigger #-}
74 newEventWithTrigger = lift . newEventWithTrigger
75 {-# INLINABLE newFanEventWithTrigger #-}
76 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
78instance (Monad m, MonadRef m, Ref m ~ Ref IO, MonadReflexCreateTrigger t m) => TriggerEvent t (TriggerEventT t m) where
79 {-# INLINABLE newTriggerEvent #-}
80 newTriggerEvent = do
81 (e, t) <- newTriggerEventWithOnComplete
82 return (e, \a -> t a $ return ())
83 {-# INLINABLE newTriggerEventWithOnComplete #-}
84 newTriggerEventWithOnComplete = do
85 events <- askEvents
86 (eResult, reResultTrigger) <- lift newEventWithTriggerRef
87 return . (,) eResult $ \a cb ->
88 writeChan events [EventTriggerRef reResultTrigger :=> TriggerInvocation a cb]
89 {-# INLINABLE newEventWithLazyTriggerWithOnComplete #-}
90 newEventWithLazyTriggerWithOnComplete f = do
91 events <- askEvents
92 lift . newEventWithTrigger $ \t ->
93 f $ \a cb -> do
94 reResultTrigger <- newRef $ Just t
95 writeChan events [EventTriggerRef reResultTrigger :=> TriggerInvocation a cb]
97instance MonadRef m => MonadRef (TriggerEventT t m) where
98 type Ref (TriggerEventT t m) = Ref m
99 {-# INLINABLE newRef #-}
100 newRef = lift . newRef
101 {-# INLINABLE readRef #-}
102 readRef = lift . readRef
103 {-# INLINABLE writeRef #-}
104 writeRef r = lift . writeRef r
106instance MonadAtomicRef m => MonadAtomicRef (TriggerEventT t m) where
107 {-# INLINABLE atomicModifyRef #-}
108 atomicModifyRef r = lift . atomicModifyRef r
110instance MonadSample t m => MonadSample t (TriggerEventT t m) where
111 {-# INLINABLE sample #-}
112 sample = lift . sample
114instance MonadHold t m => MonadHold t (TriggerEventT t m) where
115 {-# INLINABLE hold #-}
116 hold v0 v' = lift $ hold v0 v'
117 {-# INLINABLE holdDyn #-}
118 holdDyn v0 v' = lift $ holdDyn v0 v'
119 {-# INLINABLE holdIncremental #-}
120 holdIncremental v0 v' = lift $ holdIncremental v0 v'
121 {-# INLINABLE buildDynamic #-}
122 buildDynamic a0 = lift . buildDynamic a0
123 {-# INLINABLE headE #-}
124 headE = lift . headE
126instance Adjustable t m => Adjustable t (TriggerEventT t m) where
127 {-# INLINABLE runWithReplace #-}
128 runWithReplace (TriggerEventT a0) a' = TriggerEventT $ runWithReplace a0 (coerceEvent a')
129 {-# INLINABLE traverseIntMapWithKeyWithAdjust #-}
130 traverseIntMapWithKeyWithAdjust f dm0 dm' = TriggerEventT $ traverseIntMapWithKeyWithAdjust (coerce . f) dm0 dm'
131 {-# INLINABLE traverseDMapWithKeyWithAdjust #-}
132 traverseDMapWithKeyWithAdjust f dm0 dm' = TriggerEventT $ traverseDMapWithKeyWithAdjust (coerce . f) dm0 dm'
133 {-# INLINABLE traverseDMapWithKeyWithAdjustWithMove #-}
134 traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = TriggerEventT $ traverseDMapWithKeyWithAdjustWithMove (coerce . f) dm0 dm'
136-- TODO: Monoid and Semigroup can likely be derived once ReaderT has them.
137instance (Monoid a, Applicative m) => Monoid (TriggerEventT t m a) where
138 mempty = pure mempty
139 mappend = (<>)
141instance (S.Semigroup a, Applicative m) => S.Semigroup (TriggerEventT t m a) where
142 (<>) = liftA2 (S.<>)
145-- | Retrieve the current 'Chan'; event trigger invocations pushed into it will
146-- be fired.
147askEvents :: Monad m => TriggerEventT t m (Chan [DSum (EventTriggerRef t) TriggerInvocation])
148askEvents = TriggerEventT ask