git.iko.soy/reflex
on develop help sign in
Merge pull request #105 from reflex-frp/triggereventt-improvements
de4861cRyan Trinkle
src/Reflex/Class.hs+1−1
compare with develop
unifiedsplit
@@ -1007,7 +1007,7 @@ class (Reflex t, Monad m) => MonadAdjust t m | m -> t where
1007 traverseDMapWithKeyWithAdjust :: GCompare k => (forall a. k a -> v a -> m (v' a)) -> DMap k v -> Event t (PatchDMap k v) -> m (DMap k v', Event t (PatchDMap k v'))
1007 traverseDMapWithKeyWithAdjust :: GCompare k => (forall a. k a -> v a -> m (v' a)) -> DMap k v -> Event t (PatchDMap k v) -> m (DMap k v', Event t (PatchDMap k v'))
1008 traverseDMapWithKeyWithAdjustWithMove :: GCompare k => (forall a. k a -> v a -> m (v' a)) -> DMap k v -> Event t (PatchDMapWithMove k v) -> m (DMap k v', Event t (PatchDMapWithMove k v'))
1008 traverseDMapWithKeyWithAdjustWithMove :: GCompare k => (forall a. k a -> v a -> m (v' a)) -> DMap k v -> Event t (PatchDMapWithMove k v) -> m (DMap k v', Event t (PatchDMapWithMove k v'))
1009
1009
1010−instance (Reflex t, MonadAdjust t m) => MonadAdjust t (ReaderT r m) where
1010+instance MonadAdjust t m => MonadAdjust t (ReaderT r m) where
1011 runWithReplace a0 a' = do
1011 runWithReplace a0 a' = do
1012 r <- ask
1012 r <- ask
1013 lift $ runWithReplace (runReaderT a0 r) $ fmap (`runReaderT` r) a'
1013 lift $ runWithReplace (runReaderT a0 r) $ fmap (`runReaderT` r) a'
src/Reflex/TriggerEvent/Base.hs+22−4
@@ -15,9 +15,12 @@ module Reflex.TriggerEvent.Base
15
15
16import Control.Concurrent
16import Control.Concurrent
17import Control.Monad.Exception
17import Control.Monad.Exception
18+import Control.Monad.Primitive
18import Control.Monad.Reader
19import Control.Monad.Reader
19import Control.Monad.Ref
20import Control.Monad.Ref
21+import Data.Coerce
20import Data.Dependent.Sum
22import Data.Dependent.Sum
23+import Data.IORef
21import Reflex.Class
24import Reflex.Class
22import Reflex.Host.Class
25import Reflex.Host.Class
23import Reflex.PerformEvent.Class
26import Reflex.PerformEvent.Class
@@ -29,21 +32,28 @@ import Reflex.TriggerEvent.Class
29data TriggerInvocation a = TriggerInvocation a (IO ())
32data TriggerInvocation a = TriggerInvocation a (IO ())
30
33
31-- | A reference to an 'EventTrigger' suitable for firing with 'TriggerEventT'.
34-- | A reference to an 'EventTrigger' suitable for firing with 'TriggerEventT'.
32−newtype EventTriggerRef t m a = EventTriggerRef { unEventTriggerRef :: Ref m (Maybe (EventTrigger t a)) }
35+newtype EventTriggerRef t a = EventTriggerRef { unEventTriggerRef :: IORef (Maybe (EventTrigger t a)) }
33
36
34-- | A basic implementation of 'TriggerEvent'.
37-- | 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)
38+newtype TriggerEventT t m a = TriggerEventT { unTriggerEventT :: ReaderT (Chan [DSum (EventTriggerRef t) TriggerInvocation]) m a }
39+ deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)
36
40
37-- | Run a 'TriggerEventT' action. The argument should be a 'Chan' into which
41-- | 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
42-- '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
43-- will be responsible for popping values out of the 'Chan' and firing their
40-- 'EventTrigger's.
44-- 'EventTrigger's.
41−runTriggerEventT :: TriggerEventT t m a -> Chan [DSum (EventTriggerRef t m) TriggerInvocation] -> m a
45+runTriggerEventT :: TriggerEventT t m a -> Chan [DSum (EventTriggerRef t) TriggerInvocation] -> m a
42runTriggerEventT = runReaderT . unTriggerEventT
46runTriggerEventT = runReaderT . unTriggerEventT
43
47
44instance MonadTrans (TriggerEventT t) where
48instance MonadTrans (TriggerEventT t) where
49+ {-# INLINABLE lift #-}
45 lift = TriggerEventT . lift
50 lift = TriggerEventT . lift
46
51
52+instance PrimMonad m => PrimMonad (TriggerEventT t m) where
53+ type PrimState (TriggerEventT t m) = PrimState m
54+ {-# INLINABLE primitive #-}
55+ primitive = lift . primitive
56+
47instance PerformEvent t m => PerformEvent t (TriggerEventT t m) where
57instance PerformEvent t m => PerformEvent t (TriggerEventT t m) where
48 type Performable (TriggerEventT t m) = Performable m
58 type Performable (TriggerEventT t m) = Performable m
49 {-# INLINABLE performEvent_ #-}
59 {-# INLINABLE performEvent_ #-}
@@ -105,7 +115,15 @@ instance MonadHold t m => MonadHold t (TriggerEventT t m) where
105 {-# INLINABLE holdIncremental #-}
115 {-# INLINABLE holdIncremental #-}
106 holdIncremental v0 v' = lift $ holdIncremental v0 v'
116 holdIncremental v0 v' = lift $ holdIncremental v0 v'
107
117
118+instance MonadAdjust t m => MonadAdjust t (TriggerEventT t m) where
119+ {-# INLINABLE runWithReplace #-}
120+ runWithReplace (TriggerEventT a0) a' = TriggerEventT $ runWithReplace a0 (coerceEvent 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'
125+
108-- | Retrieve the current 'Chan'; event trigger invocations pushed into it will
126-- | Retrieve the current 'Chan'; event trigger invocations pushed into it will
109-- be fired.
127-- be fired.
110−askEvents :: Monad m => TriggerEventT t m (Chan [DSum (EventTriggerRef t m) TriggerInvocation])
128+askEvents :: Monad m => TriggerEventT t m (Chan [DSum (EventTriggerRef t) TriggerInvocation])
111askEvents = TriggerEventT ask
129askEvents = TriggerEventT ask