develop...d7e1f98 · reflex

git.iko.soy/reflex

on d7e1f98 help sign in

reflex.cabal+2

since splitsnapshots

unifiedsplit

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

81 Reflex.PerformEvent.Class,

82 Reflex.PostBuild.Base,

83 Reflex.PostBuild.Class,

84+ Reflex.Postpone.Base,

85+ Reflex.Postpone.Class,

84 Reflex.Requester.Base,

86 Reflex.Requester.Base,

85 Reflex.Requester.Class,

87 Reflex.Requester.Class,

86 Reflex.Spider,

88 Reflex.Spider,

src/Reflex.hs+2

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

17import Reflex.PerformEvent.Class as X

18import Reflex.PostBuild.Base as X

19import Reflex.PostBuild.Class as X

20+import Reflex.Postpone.Base as X

21+import Reflex.Postpone.Class as X

20import Reflex.Requester.Base as X

22import Reflex.Requester.Base as X

21import Reflex.Requester.Class as X

23import Reflex.Requester.Class as X

22import Reflex.Spider as X

24import Reflex.Spider as X

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

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

27import Reflex.Class

28import Reflex.Host.Class

29import Reflex.PerformEvent.Class

30+import Reflex.Postpone.Base

31+import Reflex.Postpone.Class

30import Reflex.Requester.Base

32import Reflex.Requester.Base

31import Reflex.Requester.Class

33import Reflex.Requester.Class

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

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

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

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

53-- 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 }

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

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

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

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

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

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

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

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

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

75 f a0 a' = do

77 f a0 a' = do

76 result0 <- lift a0

78 result0 <- lift a0

77− result' <- requestingIdentity a'

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

78 return (result0, result')

80 return (result0, result')

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

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

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

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

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)

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

85 => ((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))

85 -> DMap k' v

87 -> DMap k' v

86 -> Event t (p k' v)

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

88defaultAdjustBase traversePatchWithKey f' dm0 dm' = do

90defaultAdjustBase traversePatchWithKey f' dm0 dm' = do

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

91 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

91 return (result0, result')

93 return (result0, result')

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

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

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

111 -> m (a, FireCommand t m)

113 -> m (a, FireCommand t m)

112hostPerformEventT a = do

114hostPerformEventT a = do

113 (response, responseTrigger) <- newEventWithTriggerRef

115 (response, responseTrigger) <- newEventWithTriggerRef

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

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

115 eventToPerformHandle <- subscribeEvent eventToPerform

117 eventToPerformHandle <- subscribeEvent eventToPerform

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

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

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

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

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

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

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

156 {-# INLINABLE atomicModifyRef #-}

158 {-# INLINABLE atomicModifyRef #-}

157 atomicModifyRef r = PerformEventT . lift . atomicModifyRef r

159 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

23import Reflex.Host.Class

24import Reflex.PerformEvent.Class

25import Reflex.PostBuild.Class

26+import Reflex.Postpone.Class

26import Reflex.TriggerEvent.Class

27import Reflex.TriggerEvent.Class

28import Control.Monad.Exception

29import Control.Monad.Exception

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

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

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

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

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

142 return (result0, result')

143 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+17

@@ -0,0 +1,17 @@

1+module Reflex.Postpone.Class where

3+import Control.Monad.Trans.Control

4+import Control.Monad.Trans.Reader

5+import Control.Monad.Trans.Writer

7+class Monad m => MonadPostpone m where

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

9+ -- finished executing

10+ postpone :: m a -> m a

11+

12+instance MonadPostpone m => MonadPostpone (ReaderT r m) where

13+ postpone = liftThrough postpone

14+

15+instance (MonadPostpone m, Monoid w) => MonadPostpone (WriterT w m) where

16+ postpone = liftThrough postpone

17+

src/Reflex/Requester/Base.hs+8

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

26import Reflex.Host.Class

27import Reflex.PerformEvent.Class

28import Reflex.PostBuild.Class

29+import Reflex.Postpone.Class

29import Reflex.Requester.Class

30import Reflex.Requester.Class

30import Reflex.TriggerEvent.Class

31import Reflex.TriggerEvent.Class

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

149 r <- EventWriterT ask

150 r <- EventWriterT ask

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

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

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

152 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