bd8077e · reflex · git.iko.soy

git.iko.soy/reflex

Add MonadPostpone and PostponeT

commitbd8077e140703c7036cffe192c34d7e156eb9e3f authorRyan Trinkle <ryan.trinkle@gmail.com> dateMon 13 Mar 2017, 17:56 (10 years ago) parentdb1dd70

7 files changed+108−8

compare with develop

unifiedsplit

reflex.cabal+2 src/Reflex.hs+2 src/Reflex/PerformEvent/Base.hs+13−8 src/Reflex/PostBuild/Base.hs+6 src/Reflex/Postpone/Base.hs+71 src/Reflex/Postpone/Class.hs+6 src/Reflex/Requester/Base.hs+8

reflex.cabal+2

@@ -81,6 +81,8 @@ library

8181 Reflex.PerformEvent.Class,

8282 Reflex.PostBuild.Base,

8383 Reflex.PostBuild.Class,

84+ Reflex.Postpone.Base,

85+ Reflex.Postpone.Class,

8486 Reflex.Requester.Base,

8587 Reflex.Requester.Class,

8688 Reflex.Spider,

src/Reflex.hs+2

@@ -17,6 +17,8 @@ import Reflex.PerformEvent.Base as X

1717import Reflex.PerformEvent.Class as X

1818import Reflex.PostBuild.Base as X

1919import Reflex.PostBuild.Class as X

20+import Reflex.Postpone.Base as X

21+import Reflex.Postpone.Class as X

2022import Reflex.Requester.Base as X

2123import Reflex.Requester.Class as X

2224import Reflex.Spider as X

src/Reflex/PerformEvent/Base.hs+13−8

@@ -27,6 +27,8 @@ module Reflex.PerformEvent.Base

2727import Reflex.Class

2828import Reflex.Host.Class

2929import Reflex.PerformEvent.Class

30+import Reflex.Postpone.Base

31+import Reflex.Postpone.Class

3032import Reflex.Requester.Base

3133import Reflex.Requester.Class

3234

@@ -49,7 +51,7 @@ newtype FireCommand t m = FireCommand { runFireCommand :: forall a. [DSum (Event

4951

5052-- | Provides a basic implementation of 'PerformEvent'. Note that, despite the

5153-- name, 'PerformEventT' is not an instance of 'MonadTrans'.

52−newtype PerformEventT t m a = PerformEventT { unPerformEventT :: RequesterT t (HostFrame t) Identity (HostFrame t) a }

54+newtype PerformEventT t m a = PerformEventT { unPerformEventT :: RequesterT t (HostFrame t) Identity (PostponeT (HostFrame t)) a }

5355

5456deriving instance ReflexHost t => Functor (PerformEventT t m)

5557deriving instance ReflexHost t => Applicative (PerformEventT t m)

@@ -71,23 +73,23 @@ instance (ReflexHost t, Ref m ~ Ref IO, PrimMonad (HostFrame t)) => PerformEvent

7173

7274instance (ReflexHost t, PrimMonad (HostFrame t)) => MonadAdjust t (PerformEventT t m) where

7375 runWithReplace outerA0 outerA' = PerformEventT $ runWithReplaceRequesterTWith f (coerce outerA0) (coerceEvent outerA')

74− where f :: HostFrame t a -> Event t (HostFrame t b) -> RequesterT t (HostFrame t) Identity (HostFrame t) (a, Event t b)

76+ where f :: PostponeT (HostFrame t) a -> Event t (PostponeT (HostFrame t) b) -> RequesterT t (HostFrame t) Identity (PostponeT (HostFrame t)) (a, Event t b)

7577 f a0 a' = do

7678 result0 <- lift a0

77− result' <- requestingIdentity a'

79+ result' <- requestingIdentity $ fmapCheap runPostponeT a' --TODO: Avoid this fmap

7880 return (result0, result')

7981 traverseDMapWithKeyWithAdjust f outerDm0 outerDm' = PerformEventT $ sequenceDMapWithAdjustRequesterTWith (defaultAdjustBase traversePatchDMapWithKey) mapPatchDMap weakenPatchDMapWith patchMapNewElements mergeMapIncremental (\k v -> unPerformEventT $ f k v) (coerce outerDm0) (coerceEvent outerDm')

8082 traverseDMapWithKeyWithAdjustWithMove f outerDm0 outerDm' = PerformEventT $ sequenceDMapWithAdjustRequesterTWith (defaultAdjustBase traversePatchDMapWithMoveWithKey) mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElements mergeMapIncrementalWithMove (\k v -> unPerformEventT $ f k v) (coerce outerDm0) (coerceEvent outerDm')

8183

82−defaultAdjustBase :: forall t v v2 k' p. (Monad (HostFrame t), PrimMonad (HostFrame t), Reflex t)

84+defaultAdjustBase :: forall t v v2 k' p. (PrimMonad (HostFrame t), Reflex t)

8385 => ((forall a. k' a -> v a -> HostFrame t (v2 a)) -> p k' v -> HostFrame t (p k' v2))

84− -> (forall a. k' a -> v a -> HostFrame t (v2 a))

86+ -> (forall a. k' a -> v a -> PostponeT (HostFrame t) (v2 a))

8587 -> DMap k' v

8688 -> Event t (p k' v)

87− -> RequesterT t (HostFrame t) Identity (HostFrame t) (DMap k' v2, Event t (p k' v2))

89+ -> RequesterT t (HostFrame t) Identity (PostponeT (HostFrame t)) (DMap k' v2, Event t (p k' v2))

8890defaultAdjustBase traversePatchWithKey f' dm0 dm' = do

8991 result0 <- lift $ DMap.traverseWithKey f' dm0

90− result' <- requestingIdentity $ ffor dm' $ traversePatchWithKey f'

92+ result' <- requestingIdentity $ ffor dm' $ traversePatchWithKey $ \k v -> runPostponeT $ f' k v

9193 return (result0, result')

9294

9395instance ReflexHost t => MonadReflexCreateTrigger t (PerformEventT t m) where

@@ -111,7 +113,7 @@ hostPerformEventT :: forall t m a.

111113 -> m (a, FireCommand t m)

112114hostPerformEventT a = do

113115 (response, responseTrigger) <- newEventWithTriggerRef

114− (result, eventToPerform) <- runHostFrame $ runRequesterT (unPerformEventT a) response

116+ (result, eventToPerform) <- runHostFrame $ runPostponeT $ runRequesterT (unPerformEventT a) response

115117 eventToPerformHandle <- subscribeEvent eventToPerform

116118 return $ (,) result $ FireCommand $ \triggers (readPhase :: ReadPhase m a') -> do

117119 let go :: [DSum (EventTrigger t) Identity] -> m [a']

@@ -155,3 +157,6 @@ instance (MonadRef (HostFrame t), ReflexHost t) => MonadRef (PerformEventT t m)

155157instance (MonadAtomicRef (HostFrame t), ReflexHost t) => MonadAtomicRef (PerformEventT t m) where

156158 {-# INLINABLE atomicModifyRef #-}

157159 atomicModifyRef r = PerformEventT . lift . atomicModifyRef r

160+

161+instance (ReflexHost t, MonadIO (HostFrame t)) => MonadPostpone (PerformEventT t m) where

162+ postpone = PerformEventT . postpone . unPerformEventT

src/Reflex/PostBuild/Base.hs+6

@@ -23,6 +23,7 @@ import Reflex.Class

2323import Reflex.Host.Class

2424import Reflex.PerformEvent.Class

2525import Reflex.PostBuild.Class

26+import Reflex.Postpone.Class

2627import Reflex.TriggerEvent.Class

2728

2829import Control.Monad.Exception

@@ -140,3 +141,8 @@ mapDMapWithAdjustImpl base mapPatch f dm0 dm' = do

140141 let voidResult' = fmapCheap (\_ -> ()) result'

141142 let loweredDm' = ffor dm' $ mapPatch (Compose . (,) (True, voidResult'))

142143 return (result0, result')

144+

145+instance (Reflex t, MonadPostpone m) => MonadPostpone (PostBuildT t m) where

146+ postpone a = do

147+ r <- getPostBuild

148+ lift $ postpone $ runPostBuildT a r

src/Reflex/Postpone/Base.hsnew file+71

@@ -0,0 +1,71 @@

1+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

2+{-# LANGUAGE UndecidableInstances #-}

3+{-# LANGUAGE FlexibleInstances #-}

4+{-# LANGUAGE MultiParamTypeClasses #-}

5+{-# LANGUAGE TypeFamilies #-}

6+module Reflex.Postpone.Base where

8+import Reflex.Class

9+import Reflex.Host.Class

10+import Reflex.Postpone.Class

11+

12+import Control.Concurrent.MVar

13+import Control.Monad.Exception

14+import Control.Monad.Primitive

15+import Control.Monad.Ref

16+import Control.Monad.State.Strict

17+import Data.Sequence as Seq

18+import System.IO.Unsafe

19+

20+newtype PostponeT m a = PostponeT { unPostponeT :: StateT (Seq (PostponeT m ())) m a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException)

21+

22+runPostponeT :: Monad m => PostponeT m a -> m a

23+runPostponeT a = do

24+ (result, postponed) <- runStateT (unPostponeT a) mempty

25+ when (not $ Seq.null postponed) $ do

26+ runPostponeT $ sequence_ postponed

27+ return result

28+

29+instance MonadIO m => MonadPostpone (PostponeT m) where

30+ postpone a = PostponeT $ do

31+ v <- liftIO $ newEmptyMVar

32+ modify (|> (a >>= liftIO . putMVar v))

33+ liftIO $ unsafeInterleaveIO $ takeMVar v

34+

35+instance PrimMonad m => PrimMonad (PostponeT m) where

36+ type PrimState (PostponeT m) = PrimState m

37+ primitive = lift . primitive

38+

39+instance MonadTrans PostponeT where

40+ lift = PostponeT . lift

41+

42+instance MonadSample t m => MonadSample t (PostponeT m) where

43+ {-# INLINABLE sample #-}

44+ sample = lift . sample

45+

46+instance MonadHold t m => MonadHold t (PostponeT m) where

47+ {-# INLINABLE hold #-}

48+ hold v0 v' = lift $ hold v0 v'

49+ {-# INLINABLE holdDyn #-}

50+ holdDyn v0 v' = lift $ holdDyn v0 v'

51+ {-# INLINABLE holdIncremental #-}

52+ holdIncremental v0 v' = lift $ holdIncremental v0 v'

53+

54+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (PostponeT m) where

55+ {-# INLINABLE newEventWithTrigger #-}

56+ newEventWithTrigger = lift . newEventWithTrigger

57+ {-# INLINABLE newFanEventWithTrigger #-}

58+ newFanEventWithTrigger f = lift $ newFanEventWithTrigger f

59+

60+instance MonadRef m => MonadRef (PostponeT m) where

61+ type Ref (PostponeT m) = Ref m

62+ {-# INLINABLE newRef #-}

63+ newRef = lift . newRef

64+ {-# INLINABLE readRef #-}

65+ readRef = lift . readRef

66+ {-# INLINABLE writeRef #-}

67+ writeRef r = lift . writeRef r

68+

69+instance MonadAtomicRef m => MonadAtomicRef (PostponeT m) where

70+ {-# INLINABLE atomicModifyRef #-}

71+ atomicModifyRef r = lift . atomicModifyRef r

src/Reflex/Postpone/Class.hsnew file+6

@@ -0,0 +1,6 @@

1+module Reflex.Postpone.Class where

3+class Monad m => MonadPostpone m where

4+ -- | Postpone an action until all containing 'mfix'es can be expected to have

5+ -- finished executing

6+ postpone :: m a -> m a

src/Reflex/Requester/Base.hs+8

@@ -26,6 +26,7 @@ import Reflex.EventWriter

2626import Reflex.Host.Class

2727import Reflex.PerformEvent.Class

2828import Reflex.PostBuild.Class

29+import Reflex.Postpone.Class

2930import Reflex.Requester.Class

3031import Reflex.TriggerEvent.Class

3132

@@ -149,3 +150,10 @@ sequenceDMapWithAdjustRequesterTWith base mapPatch weakenPatchWith patchNewEleme

149150 r <- EventWriterT ask

150151 unRequesterT $ base (\k v -> runReaderT (f' k v) r) x y

151152 in RequesterT $ sequenceDMapWithAdjustEventWriterTWith base' mapPatch weakenPatchWith patchNewElements mergePatchIncremental (\k v -> unRequesterT $ f k v) (coerce dm0) (coerceEvent dm')

153+

154+instance (MonadPostpone m, Reflex t) => MonadPostpone (RequesterT t request response m) where

155+ postpone a = RequesterT $ do

156+ r <- ask

157+ (result, w) <- lift $ lift $ postpone $ runReaderT (runEventWriterT $ unRequesterT a) r

158+ tellEvent w

159+ return result