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