e584b4a · patch · git.iko.soy

git.iko.soy/patch

TriggerEventT improvements

e584b4aWill Fancher9 years ago

src/Reflex/Class.hs+1−1

@@ -927,7 +927,7 @@ class (Reflex t, Monad m) => MonadAdjust t m | m -> t where

927 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'))

928 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'))

929

930−instance (Reflex t, MonadAdjust t m) => MonadAdjust t (ReaderT r m) where

930+instance MonadAdjust t m => MonadAdjust t (ReaderT r m) where

931 runWithReplace a0 a' = do

932 r <- ask

933 lift $ runWithReplace (runReaderT a0 r) $ fmap (`runReaderT` r) a'

src/Reflex/TriggerEvent/Base.hs+23−4

@@ -5,6 +5,7 @@

5{-# LANGUAGE GeneralizedNewtypeDeriving #-}

6{-# LANGUAGE MultiParamTypeClasses #-}

7{-# LANGUAGE TypeFamilies #-}

8module Reflex.TriggerEvent.Base

9module Reflex.TriggerEvent.Base

9 ( TriggerEventT (..)

10 ( TriggerEventT (..)

10 , runTriggerEventT

11 , runTriggerEventT

@@ -15,9 +16,12 @@ module Reflex.TriggerEvent.Base

16import Control.Concurrent

17import Control.Concurrent

17import Control.Monad.Exception

18import Control.Monad.Exception

19+import Control.Monad.Primitive

18import Control.Monad.Reader

20import Control.Monad.Reader

19import Control.Monad.Ref

21import Control.Monad.Ref

22+import Data.Coerce

20import Data.Dependent.Sum

23import Data.Dependent.Sum

24+import Data.IORef

21import Reflex.Class

25import Reflex.Class

22import Reflex.Host.Class

26import Reflex.Host.Class

23import Reflex.PerformEvent.Class

27import Reflex.PerformEvent.Class

@@ -29,21 +33,28 @@ import Reflex.TriggerEvent.Class

29data TriggerInvocation a = TriggerInvocation a (IO ())

33data TriggerInvocation a = TriggerInvocation a (IO ())

31-- | A reference to an 'EventTrigger' suitable for firing with 'TriggerEventT'.

35-- | A reference to an 'EventTrigger' suitable for firing with 'TriggerEventT'.

32−newtype EventTriggerRef t m a = EventTriggerRef { unEventTriggerRef :: Ref m (Maybe (EventTrigger t a)) }

36+newtype EventTriggerRef t a = EventTriggerRef { unEventTriggerRef :: IORef (Maybe (EventTrigger t a)) }

34-- | A basic implementation of 'TriggerEvent'.

38-- | 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)

39+newtype TriggerEventT t m a = TriggerEventT { unTriggerEventT :: ReaderT (Chan [DSum (EventTriggerRef t) TriggerInvocation]) m a }

40+ deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)

37-- | Run a 'TriggerEventT' action. The argument should be a 'Chan' into which

42-- | 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

43-- '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

44-- will be responsible for popping values out of the 'Chan' and firing their

40-- 'EventTrigger's.

45-- 'EventTrigger's.

41−runTriggerEventT :: TriggerEventT t m a -> Chan [DSum (EventTriggerRef t m) TriggerInvocation] -> m a

46+runTriggerEventT :: TriggerEventT t m a -> Chan [DSum (EventTriggerRef t) TriggerInvocation] -> m a

42runTriggerEventT = runReaderT . unTriggerEventT

47runTriggerEventT = runReaderT . unTriggerEventT

44instance MonadTrans (TriggerEventT t) where

49instance MonadTrans (TriggerEventT t) where

50+ {-# INLINABLE lift #-}

45 lift = TriggerEventT . lift

51 lift = TriggerEventT . lift

53+instance PrimMonad m => PrimMonad (TriggerEventT t m) where

54+ type PrimState (TriggerEventT t m) = PrimState m

55+ {-# INLINABLE primitive #-}

56+ primitive = lift . primitive

57+

47instance PerformEvent t m => PerformEvent t (TriggerEventT t m) where

58instance PerformEvent t m => PerformEvent t (TriggerEventT t m) where

48 type Performable (TriggerEventT t m) = Performable m

59 type Performable (TriggerEventT t m) = Performable m

49 {-# INLINABLE performEvent_ #-}

60 {-# INLINABLE performEvent_ #-}

@@ -105,7 +116,15 @@ instance MonadHold t m => MonadHold t (TriggerEventT t m) where

105 {-# INLINABLE holdIncremental #-}

116 {-# INLINABLE holdIncremental #-}

106 holdIncremental v0 v' = lift $ holdIncremental v0 v'

117 holdIncremental v0 v' = lift $ holdIncremental v0 v'

107

118

119+instance MonadAdjust t m => MonadAdjust t (TriggerEventT t m) where

120+ {-# INLINABLE runWithReplace #-}

121+ runWithReplace (TriggerEventT a0) a' = TriggerEventT $ runWithReplace a0 (coerceEvent a')

122+ {-# INLINABLE traverseDMapWithKeyWithAdjust #-}

123+ traverseDMapWithKeyWithAdjust f dm0 dm' = TriggerEventT $ traverseDMapWithKeyWithAdjust (coerce . f) dm0 dm'

124+ {-# INLINABLE traverseDMapWithKeyWithAdjustWithMove #-}

125+ traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = TriggerEventT $ traverseDMapWithKeyWithAdjustWithMove (coerce . f) dm0 dm'

126+

108-- | Retrieve the current 'Chan'; event trigger invocations pushed into it will

127-- | Retrieve the current 'Chan'; event trigger invocations pushed into it will

109-- be fired.

128-- be fired.

110−askEvents :: Monad m => TriggerEventT t m (Chan [DSum (EventTriggerRef t m) TriggerInvocation])

129+askEvents :: Monad m => TriggerEventT t m (Chan [DSum (EventTriggerRef t) TriggerInvocation])

111askEvents = TriggerEventT ask

130askEvents = TriggerEventT ask