de4861c · patch · git.iko.soy

git.iko.soy/patch

Merge pull request #105 from reflex-frp/triggereventt-improvements

TriggerEventT improvements

commitde4861c9e3307ca3fcfadf3f576e4896e9f1ad16 authorRyan Trinkle <ryan.trinkle@gmail.com> dateWed 26 Apr 2017, 12:39 (9 years ago) parenta15ae38 70f445a

2 files changed+23−5

compare with develop

unifiedsplit

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

src/Reflex/Class.hs+1−1

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

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

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

10091009

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

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

10111011 runWithReplace a0 a' = do

10121012 r <- ask

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

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

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

1515

1616import Control.Concurrent

1717import Control.Monad.Exception

18+import Control.Monad.Primitive

1819import Control.Monad.Reader

1920import Control.Monad.Ref

21+import Data.Coerce

2022import Data.Dependent.Sum

23+import Data.IORef

2124import Reflex.Class

2225import Reflex.Host.Class

2326import Reflex.PerformEvent.Class

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

2932data TriggerInvocation a = TriggerInvocation a (IO ())

3033

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

3336

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

3640

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

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

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

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

4246runTriggerEventT = runReaderT . unTriggerEventT

4347

4448instance MonadTrans (TriggerEventT t) where

49+ {-# INLINABLE lift #-}

4550 lift = TriggerEventT . lift

4651

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+

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

4858 type Performable (TriggerEventT t m) = Performable m

4959 {-# INLINABLE performEvent_ #-}

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

105115 {-# INLINABLE holdIncremental #-}

106116 holdIncremental v0 v' = lift $ holdIncremental v0 v'

107117

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+

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

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

111129askEvents = TriggerEventT ask