e584b4a · patch · git.iko.soy

git.iko.soy/patch

TriggerEventT improvements

commite584b4a6bdc4136c74f255aff13705f2b82d0ac5 authorWill Fancher <elvishjerricco@gmail.com> dateTue 25 Apr 2017, 15:29 (9 years ago) parent39301ec

2 files changed+24−5

compare with develop

unifiedsplit

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

src/Reflex/Class.hs+1−1

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

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

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

929929

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

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

931931 runWithReplace a0 a' = do

932932 r <- ask

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

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

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

55{-# LANGUAGE GeneralizedNewtypeDeriving #-}

66{-# LANGUAGE MultiParamTypeClasses #-}

77{-# LANGUAGE TypeFamilies #-}

89module Reflex.TriggerEvent.Base

910 ( TriggerEventT (..)

1011 , runTriggerEventT

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

1516

1617import Control.Concurrent

1718import Control.Monad.Exception

19+import Control.Monad.Primitive

1820import Control.Monad.Reader

1921import Control.Monad.Ref

22+import Data.Coerce

2023import Data.Dependent.Sum

24+import Data.IORef

2125import Reflex.Class

2226import Reflex.Host.Class

2327import Reflex.PerformEvent.Class

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

2933data TriggerInvocation a = TriggerInvocation a (IO ())

3034

3135-- | 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)) }

3337

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

3641

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

3843-- 'TriggerInvocation's can be passed; it is expected that some other thread

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

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

4247runTriggerEventT = runReaderT . unTriggerEventT

4348

4449instance MonadTrans (TriggerEventT t) where

50+ {-# INLINABLE lift #-}

4551 lift = TriggerEventT . lift

4652

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+

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

4859 type Performable (TriggerEventT t m) = Performable m

4960 {-# INLINABLE performEvent_ #-}

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

105116 {-# INLINABLE holdIncremental #-}

106117 holdIncremental v0 v' = lift $ holdIncremental v0 v'

107118

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+

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

109128-- 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])

111130askEvents = TriggerEventT ask