a224e72 · reflex · git.iko.soy

git.iko.soy/reflex

Add tests, switch to Seq, minor formatting changes, reimplement RequesterT in terms of EventWriterT

commita224e72c84037586f9e7c0f841ec955a4f51098d authorDaniel Haraj <dan@obsidian.systems> dateTue 20 Dec 2016, 18:38 (10 years ago) parent0356ce5

5 files changed+232−130

compare with develop

unifiedsplit

reflex.cabal+21 src/Reflex/EventWriter.hs+29−32 src/Reflex/Requester/Base.hs+51−98 test/EventWriterT.hs+61 test/RequesterT.hs+70

reflex.cabal+21

@@ -118,6 +118,27 @@ test-suite hlint

118118 if impl(ghcjs)

119119 buildable: False

120120

121+test-suite EventWriterT

122+ type: exitcode-stdio-1.0

123+ main-is: EventWriterT.hs

124+ hs-source-dirs: test

125+ build-depends: base

126+ , dependent-sum

127+ , transformers

128+ , reflex

129+ , ref-tf

130+

131+test-suite RequesterT

132+ type: exitcode-stdio-1.0

133+ main-is: RequesterT.hs

134+ hs-source-dirs: test

135+ build-depends: base

136+ , dependent-sum

137+ , dependent-map

138+ , transformers

139+ , reflex

140+ , ref-tf

141+

121142benchmark spider-bench

122143 type: exitcode-stdio-1.0

123144 hs-source-dirs: bench

src/Reflex/EventWriter.hs+29−32

@@ -18,6 +18,8 @@ module Reflex.EventWriter

1818 ( EventWriterT (..)

1919 , runEventWriterT

2020 , EventWriter(..)

21+ , runWithReplaceEventWriterTWith

22+ , sequenceDMapWithAdjustEventWriterTWith

2123 ) where

2224

2325import Reflex.Class

@@ -33,10 +35,12 @@ import Control.Monad.Ref

3335import Control.Monad.State.Strict

3436import Data.Dependent.Map (DMap, DSum (..))

3537import qualified Data.Dependent.Map as DMap

38+import Data.Foldable

3639import Data.Functor.Misc

3740import qualified Data.List.NonEmpty as NonEmpty

3841import Data.Maybe

3942import Data.Semigroup

43+import Data.Sequence

4044import Data.Some (Some)

4145import qualified Data.Some as Some

4246import Data.Tuple

@@ -48,20 +52,17 @@ class (Monad m, Monoid w) => EventWriter t w m | m -> t w where

4852 tellEvent :: Event t w -> m ()

4953

5054-- | A basic implementation of 'EventWriter'.

51−newtype EventWriterT t w m a = EventWriterT { unEventWriterT :: StateT [Event t w] m a }

55+newtype EventWriterT t w m a = EventWriterT { unEventWriterT :: StateT (Seq (Event t w)) m a }

5256 deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException)

5357

5458-- | Run a 'EventWriterT' action.

55−runEventWriterT

56− :: (Reflex t, Monad m, Semigroup w)

57− => EventWriterT t w m a

58− -> m (a, Event t w)

59+runEventWriterT :: (Reflex t, Monad m, Semigroup w) => EventWriterT t w m a -> m (a, Event t w)

5960runEventWriterT (EventWriterT a) = do

6061 (result, requests) <- runStateT a mempty

61− return (result, mconcat $ reverse requests)

62+ return (result, mconcat $ toList requests)

6263

6364instance (Reflex t, Monad m, Monoid w) => EventWriter t w (EventWriterT t w m) where

64− tellEvent w = EventWriterT $ modify (w:)

65+ tellEvent w = EventWriterT $ modify (|> w)

6566

6667instance MonadTrans (EventWriterT t w) where

6768 lift = EventWriterT . lift

@@ -83,50 +84,46 @@ instance (Reflex t, MonadAdjust t m, MonadHold t m, Monoid w, Semigroup w) => Mo

8384-- monad doesn't have a 'MonadAdjust' instance or to override the default

8485-- 'MonadAdjust' behavior.

8586runWithReplaceEventWriterTWith :: forall m t w a b. (Reflex t, MonadHold t m, Monoid w)

86− => (forall a' b'.

87− m a'

88− -> Event t (m b')

89− -> EventWriterT t w m (a', Event t b')

90− )

91− -> EventWriterT t w m a

92− -> Event t (EventWriterT t w m b)

93− -> EventWriterT t w m (a, Event t b)

87+ => (forall a' b'. m a' -> Event t (m b') -> EventWriterT t w m (a', Event t b'))

88+ -> EventWriterT t w m a

89+ -> Event t (EventWriterT t w m b)

90+ -> EventWriterT t w m (a, Event t b)

9491runWithReplaceEventWriterTWith f a0 a' = do

95− let g :: EventWriterT t w m c -> m (c, [Event t w])

92+ let g :: EventWriterT t w m c -> m (c, Seq (Event t w))

9693 g (EventWriterT r) = runStateT r mempty

9794 (result0, result') <- f (g a0) $ g <$> a'

98− request <- holdDyn (fmap (mconcat . NonEmpty.toList) $ mergeList $ snd result0) $ fmap (mconcat . NonEmpty.toList) . mergeList . snd <$> result'

95+ request <- holdDyn (fmap (mconcat . NonEmpty.toList) $ mergeList $ toList $ snd result0) $ fmap (mconcat . NonEmpty.toList) . mergeList . toList . snd <$> result'

9996 -- We add these two separately to take advantage of the free merge being done later. The coincidence case must come first so that it has precedence if both fire simultaneously. (Really, we should probably block the 'switch' whenever 'updated' fires, but switchPromptlyDyn has the same issue.)

100− EventWriterT $ modify $ (:) $ coincidence $ updated request

101− EventWriterT $ modify $ (:) $ switch $ current request

97+ EventWriterT $ modify $ flip (|>) $ coincidence $ updated request

98+ EventWriterT $ modify $ flip (|>) $ switch $ current request

10299 return (fst result0, fst <$> result')

103100

104101-- | Like 'runWithReplaceEventWriterTWith', but for 'sequenceDMapWithAdjust'.

105102sequenceDMapWithAdjustEventWriterTWith :: (GCompare k, Reflex t, MonadHold t m, Monoid w, Semigroup w)

106− => (forall k'. GCompare k'

107− => DMap k' m

108− -> Event t (PatchDMap k' m)

109− -> EventWriterT t w m (DMap k' Identity, Event t (PatchDMap k' Identity))

110− )

111− -> DMap k (EventWriterT t w m)

112− -> Event t (PatchDMap k (EventWriterT t w m))

113− -> EventWriterT t w m (DMap k Identity, Event t (PatchDMap k Identity))

103+ => (forall k'. GCompare k'

104+ => DMap k' m

105+ -> Event t (PatchDMap k' m)

106+ -> EventWriterT t w m (DMap k' Identity, Event t (PatchDMap k' Identity))

107+ )

108+ -> DMap k (EventWriterT t w m)

109+ -> Event t (PatchDMap k (EventWriterT t w m))

110+ -> EventWriterT t w m (DMap k Identity, Event t (PatchDMap k Identity))

114111sequenceDMapWithAdjustEventWriterTWith f (dm0 :: DMap k (EventWriterT t w m)) dm' = do

115− let inputTransform :: forall a. DMapTransform a k (WrapArg ((,) [Event t w]) k) (EventWriterT t w m) m

112+ let inputTransform :: forall a. DMapTransform a k (WrapArg ((,) (Seq (Event t w))) k) (EventWriterT t w m) m

116113 inputTransform = DMapTransform WrapArg (\(EventWriterT v) -> swap <$> runStateT v mempty)

117114 (children0, children') <- f (mapKeysAndValuesMonotonic inputTransform dm0) $ mapPatchKeysAndValuesMonotonic inputTransform <$> dm'

118115 let result0 = mapKeyValuePairsMonotonic (\(WrapArg k :=> Identity (_, v)) -> k :=> Identity v) children0

119116 result' = ffor children' $ \(PatchDMap p) -> PatchDMap $

120117 mapKeyValuePairsMonotonic (\(WrapArg k :=> ComposeMaybe mv) -> k :=> ComposeMaybe (fmap (Identity . snd . runIdentity) mv)) p

121118 requests0 :: DMap (Const2 (Some k) w) (Event t)

122− requests0 = mapKeyValuePairsMonotonic (\(WrapArg k :=> Identity (r, _)) -> Const2 (Some.This k) :=> mconcat (reverse r)) children0

119+ requests0 = mapKeyValuePairsMonotonic (\(WrapArg k :=> Identity (r, _)) -> Const2 (Some.This k) :=> mconcat (toList r)) children0

123120 requests' :: Event t (PatchDMap (Const2 (Some k) w) (Event t))

124121 requests' = ffor children' $ \(PatchDMap p) -> PatchDMap $

125− mapKeyValuePairsMonotonic (\(WrapArg k :=> ComposeMaybe mv) -> Const2 (Some.This k) :=> ComposeMaybe (fmap (mconcat . reverse . fst . runIdentity) mv)) p

122+ mapKeyValuePairsMonotonic (\(WrapArg k :=> ComposeMaybe mv) -> Const2 (Some.This k) :=> ComposeMaybe (fmap (mconcat . toList . fst . runIdentity) mv)) p

126123 childRequestMap <- holdIncremental requests0 requests'

127124 -- We add these two separately to take advantage of the free merge being done later. The coincidence case must come first so that it has precedence if both fire simultaneously. (Really, we should probably block the 'switch' whenever 'updated' fires, but switchPromptlyDyn has the same issue.)

128− EventWriterT $ modify $ (:) $ coincidence $ ffor requests' $ \(PatchDMap p) -> mconcat $ reverse $ catMaybes $ ffor (DMap.toList p) $ \(Const2 _ :=> ComposeMaybe me) -> me

129− EventWriterT $ modify $ (:) $ ffor (mergeIncremental childRequestMap) $ \m ->

125+ EventWriterT $ modify $ flip (|>) $ coincidence $ ffor requests' $ \(PatchDMap p) -> mconcat $ toList $ catMaybes $ ffor (DMap.toList p) $ \(Const2 _ :=> ComposeMaybe me) -> me

126+ EventWriterT $ modify $ flip (|>) $ ffor (mergeIncremental childRequestMap) $ \m ->

130127 mconcat $ (\(Const2 _ :=> Identity reqs) -> reqs) <$> DMap.toList m

131128 return (result0, result')

132129

src/Reflex/Requester/Base.hs+51−98

@@ -4,12 +4,12 @@

44{-# LANGUAGE ExistentialQuantification #-}

55{-# LANGUAGE FlexibleInstances #-}

66{-# LANGUAGE GeneralizedNewtypeDeriving #-}

7−{-# LANGUAGE KindSignatures #-}

87{-# LANGUAGE MultiParamTypeClasses #-}

98{-# LANGUAGE Rank2Types #-}

109{-# LANGUAGE ScopedTypeVariables #-}

1110{-# LANGUAGE TypeFamilies #-}

1211{-# LANGUAGE UndecidableInstances #-}

12+{-# LANGUAGE StandaloneDeriving #-}

1313#ifdef USE_REFLEX_OPTIMIZER

1414{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}

1515#endif

@@ -21,6 +21,7 @@ module Reflex.Requester.Base

2121 ) where

2222

2323import Reflex.Class

24+import Reflex.EventWriter

2425import Reflex.Host.Class

2526import Reflex.PerformEvent.Class

2627import Reflex.PostBuild.Class

@@ -33,31 +34,34 @@ import Control.Monad.Primitive

3334import Control.Monad.Reader

3435import Control.Monad.Ref

3536import Control.Monad.State.Strict

37+import Data.Coerce

3638import Data.Dependent.Map (DMap, DSum (..))

3739import qualified Data.Dependent.Map as DMap

3840import Data.Functor.Misc

39−import qualified Data.List.NonEmpty as NonEmpty

40−import Data.Maybe

41−import Data.Some (Some)

42−import qualified Data.Some as Some

43−import Data.Tuple

4441import Data.Unique.Tag

4542

4643-- | A basic implementation of 'Requester'.

47−newtype RequesterT t request response m a = RequesterT { unRequesterT :: StateT [Event t (DMap (Tag (PrimState m)) request)] (ReaderT (EventSelector t (WrapArg response (Tag (PrimState m)))) m) a }

44+newtype RequesterT t request response m a = RequesterT { unRequesterT :: EventWriterT t (DMap (Tag (PrimState m)) request) (ReaderT (EventSelector t (WrapArg response (Tag (PrimState m)))) m) a }

4845 deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException)

4946

47+deriving instance MonadSample t m => MonadSample t (RequesterT t request response m)

48+deriving instance MonadHold t m => MonadHold t (RequesterT t request response m)

49+deriving instance PostBuild t m => PostBuild t (RequesterT t request response m)

50+deriving instance TriggerEvent t m => TriggerEvent t (RequesterT t request response m)

51+

5052-- | Run a 'RequesterT' action. The resulting 'Event' will fire whenever

5153-- requests are made, and responses should be provided in the input 'Event'.

5254-- The 'Tag' keys will be used to return the responses to the same place the

5355-- requests were issued.

56+

5457runRequesterT :: (Reflex t, Monad m)

5558 => RequesterT t request response m a

5659 -> Event t (DMap (Tag (PrimState m)) response)

5760 -> m (a, Event t (DMap (Tag (PrimState m)) request))

5861runRequesterT (RequesterT a) responses = do

59− (result, requests) <- runReaderT (runStateT a mempty) $ fan $ mapKeyValuePairsMonotonic (\(t :=> e) -> WrapArg t :=> Identity e) <$> responses

60− return (result, mergeWith DMap.union requests)

62+ (result, requests) <- runReaderT (runEventWriterT a) $ fan $

63+ mapKeyValuePairsMonotonic (\(t :=> e) -> WrapArg t :=> Identity e) <$> responses

64+ return (result, requests)

6165

6266instance (Reflex t, PrimMonad m) => Requester t (RequesterT t request response m) where

6367 type Request (RequesterT t request response m) = request

@@ -66,96 +70,17 @@ instance (Reflex t, PrimMonad m) => Requester t (RequesterT t request response m

6670 t <- lift newTag

6771 s <- RequesterT ask

6872 (req, result) <- a $ select s $ WrapArg t

69− RequesterT $ modify $ (:) $ DMap.singleton t <$> req

73+ RequesterT $ tellEvent $ DMap.singleton t <$> req

7074 return result

7175

7276instance MonadTrans (RequesterT t request response) where

7377 lift = RequesterT . lift . lift

7478

75−instance MonadSample t m => MonadSample t (RequesterT t request response m) where

76− sample = lift . sample

77−

78−instance MonadHold t m => MonadHold t (RequesterT t request response m) where

79− hold v0 = lift . hold v0

80− holdDyn v0 = lift . holdDyn v0

81− holdIncremental v0 = lift . holdIncremental v0

82−

83−instance (Reflex t, MonadAdjust t m, MonadHold t m) => MonadAdjust t (RequesterT t request response m) where

84− runWithReplace = runWithReplaceRequesterTWith $ \dm0 dm' -> lift $ runWithReplace dm0 dm'

85− sequenceDMapWithAdjust = sequenceDMapWithAdjustRequesterTWith $ \dm0 dm' -> lift $ sequenceDMapWithAdjust dm0 dm'

86−

87−-- | Given a function like 'runWithReplace' for the underlying monad, implement

88−-- 'runWithReplace' for 'RequesterT'. This is necessary when the underlying

89−-- monad doesn't have a 'MonadAdjust' instance or to override the default

90−-- 'MonadAdjust' behavior.

91−runWithReplaceRequesterTWith :: forall m t request response a b. (Reflex t, MonadHold t m)

92− => (forall a' b'.

93− m a'

94− -> Event t (m b')

95− -> RequesterT t request response m (a', Event t b')

96− )

97− -> RequesterT t request response m a

98− -> Event t (RequesterT t request response m b)

99− -> RequesterT t request response m (a, Event t b)

100−runWithReplaceRequesterTWith f a0 a' = do

101− response <- RequesterT ask

102− let g :: RequesterT t request response m c -> m (c, [Event t (DMap (Tag (PrimState m)) request)])

103− g (RequesterT r) = runReaderT (runStateT r mempty) response

104− (result0, result') <- f (g a0) $ g <$> a'

105− request <- holdDyn (fmap (mconcat . NonEmpty.toList) $ mergeList $ snd result0) $ fmap (mconcat . NonEmpty.toList) . mergeList . snd <$> result'

106− -- We add these two separately to take advantage of the free merge being done later. The coincidence case must come first so that it has precedence if both fire simultaneously. (Really, we should probably block the 'switch' whenever 'updated' fires, but switchPromptlyDyn has the same issue.)

107− RequesterT $ modify $ (:) $ coincidence $ updated request

108− RequesterT $ modify $ (:) $ switch $ current request

109− return (fst result0, fst <$> result')

110−

111−-- | Like 'runWithReplaceRequesterTWith', but for 'sequenceDMapWithAdjust'.

112−sequenceDMapWithAdjustRequesterTWith :: (GCompare k, Reflex t, MonadHold t m)

113− => (forall k'. GCompare k'

114− => DMap k' m

115− -> Event t (PatchDMap k' m)

116− -> RequesterT t request response m (DMap k' Identity, Event t (PatchDMap k' Identity))

117− )

118− -> DMap k (RequesterT t request response m)

119− -> Event t (PatchDMap k (RequesterT t request response m))

120− -> RequesterT t request response m (DMap k Identity, Event t (PatchDMap k Identity))

121−sequenceDMapWithAdjustRequesterTWith f (dm0 :: DMap k (RequesterT t request response m)) dm' = do

122− response <- RequesterT ask

123− let inputTransform :: forall a. DMapTransform a k (WrapArg ((,) [Event t (DMap (Tag (PrimState m)) request)]) k) (RequesterT t request response m) m

124− inputTransform = DMapTransform WrapArg (\(RequesterT v) -> swap <$> runReaderT (runStateT v mempty) response)

125− (children0, children') <- f (mapKeysAndValuesMonotonic inputTransform dm0) $ mapPatchKeysAndValuesMonotonic inputTransform <$> dm'

126− let result0 = mapKeyValuePairsMonotonic (\(WrapArg k :=> Identity (_, v)) -> k :=> Identity v) children0

127− result' = ffor children' $ \(PatchDMap p) -> PatchDMap $

128− mapKeyValuePairsMonotonic (\(WrapArg k :=> ComposeMaybe mv) -> k :=> ComposeMaybe (fmap (Identity . snd . runIdentity) mv)) p

129− requests0 :: DMap (Const2 (Some k) (DMap (Tag (PrimState m)) request)) (Event t)

130− requests0 = mapKeyValuePairsMonotonic (\(WrapArg k :=> Identity (r, _)) -> Const2 (Some.This k) :=> mergeWith DMap.union r) children0

131− requests' :: Event t (PatchDMap (Const2 (Some k) (DMap (Tag (PrimState m)) request)) (Event t))

132− requests' = ffor children' $ \(PatchDMap p) -> PatchDMap $

133− mapKeyValuePairsMonotonic (\(WrapArg k :=> ComposeMaybe mv) -> Const2 (Some.This k) :=> ComposeMaybe (fmap (mergeWith DMap.union . fst . runIdentity) mv)) p

134− childRequestMap <- holdIncremental requests0 requests'

135− -- We add these two separately to take advantage of the free merge being done later. The coincidence case must come first so that it has precedence if both fire simultaneously. (Really, we should probably block the 'switch' whenever 'updated' fires, but switchPromptlyDyn has the same issue.)

136− RequesterT $ modify $ (:) $ coincidence $ ffor requests' $ \(PatchDMap p) -> mergeWith DMap.union $ catMaybes $ ffor (DMap.toList p) $ \(Const2 _ :=> ComposeMaybe me) -> me

137− RequesterT $ modify $ (:) $ ffor (mergeIncremental childRequestMap) $ \m ->

138− mconcat $ (\(Const2 _ :=> Identity reqs) -> reqs) <$> DMap.toList m

139− return (result0, result')

140−

14179instance PerformEvent t m => PerformEvent t (RequesterT t request response m) where

14280 type Performable (RequesterT t request response m) = Performable m

14381 performEvent_ = lift . performEvent_

14482 performEvent = lift . performEvent

14583

146−instance PostBuild t m => PostBuild t (RequesterT t request response m) where

147− getPostBuild = lift getPostBuild

148−

149−instance TriggerEvent t m => TriggerEvent t (RequesterT t request response m) where

150− newTriggerEvent = lift newTriggerEvent

151− newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete

152− newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete

153−

154−instance MonadReader r m => MonadReader r (RequesterT t request response m) where

155− ask = lift ask

156− local f (RequesterT a) = RequesterT $ mapStateT (mapReaderT $ local f) a

157− reader = lift . reader

158−

15984instance MonadRef m => MonadRef (RequesterT t request response m) where

16085 type Ref (RequesterT t request response m) = Ref m

16186 newRef = lift . newRef

@@ -166,15 +91,43 @@ instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (RequesterT

16691 newEventWithTrigger = lift . newEventWithTrigger

16792 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f

16893

169−--------------------------------------------------------------------------------

170−-- Internal functions

171−--------------------------------------------------------------------------------

94+instance MonadReader r m => MonadReader r (RequesterT t request response m) where

95+ ask = lift ask

96+ local f (RequesterT (EventWriterT a)) = RequesterT $ EventWriterT $ mapStateT (mapReaderT $ local f) a

97+ reader = lift . reader

17298

173−data DMapTransform (a :: *) k k' v v' = forall (b :: *). DMapTransform !(k a -> k' b) !(v a -> v' b)

99+instance (Reflex t, MonadAdjust t m, MonadHold t m) => MonadAdjust t (RequesterT t request response m) where

100+ runWithReplace (RequesterT a) em = RequesterT $ runWithReplace a (coerceEvent em)

101+ sequenceDMapWithAdjust dm edm = RequesterT $ sequenceDMapWithAdjust (coerce dm) (coerceEvent edm)

174102

175−mapPatchKeysAndValuesMonotonic :: (forall a. DMapTransform a k k' v v') -> PatchDMap k v -> PatchDMap k' v'

176−mapPatchKeysAndValuesMonotonic x (PatchDMap p) = PatchDMap $ mapKeyValuePairsMonotonic (\(k :=> ComposeMaybe mv) -> case x of DMapTransform f g -> f k :=> ComposeMaybe (fmap g mv)) p

103+runWithReplaceRequesterTWith :: forall m t request response a b. (Reflex t, MonadHold t m)

104+ => (forall a' b'. m a' -> Event t (m b') -> RequesterT t request response m (a', Event t b'))

105+ -> RequesterT t request response m a

106+ -> Event t (RequesterT t request response m b)

107+ -> RequesterT t request response m (a, Event t b)

108+runWithReplaceRequesterTWith f a0 a' =

109+ let f' :: forall a' b'. ReaderT (EventSelector t (WrapArg response (Tag (PrimState m)))) m a'

110+ -> Event t (ReaderT (EventSelector t (WrapArg response (Tag (PrimState m)))) m b')

111+ -> EventWriterT t (DMap (Tag (PrimState m)) request) (ReaderT (EventSelector t (WrapArg response (Tag (PrimState m)))) m) (a', Event t b')

112+ f' x y = do

113+ r <- EventWriterT $ ask

114+ unRequesterT (f (runReaderT x r) (fmap (`runReaderT` r) y))

115+ in RequesterT $ runWithReplaceEventWriterTWith f' (coerce a0) (coerceEvent a')

177116

178−mapKeysAndValuesMonotonic :: (forall a. DMapTransform a k k' v v') -> DMap k v -> DMap k' v'

179−mapKeysAndValuesMonotonic x = mapKeyValuePairsMonotonic $ \(k :=> v) -> case x of

180− DMapTransform f g -> f k :=> g v

117+sequenceDMapWithAdjustRequesterTWith :: (GCompare k, Reflex t, MonadHold t m)

118+ => (forall k'. GCompare k' => DMap k' m -> Event t (PatchDMap k' m) -> RequesterT t request response m (DMap k' Identity, Event t (PatchDMap k' Identity)))

119+ -> DMap k (RequesterT t request response m)

120+ -> Event t (PatchDMap k (RequesterT t request response m))

121+ -> RequesterT t request response m (DMap k Identity, Event t (PatchDMap k Identity))

122+sequenceDMapWithAdjustRequesterTWith f (dm0 :: DMap k (RequesterT t request response m)) dm' =

123+ let dmapUnwrap r = mapKeyValuePairsMonotonic $ \(k :=> v) -> k :=> runReaderT v r

124+ patchDmapUnwrap r (PatchDMap p) = PatchDMap $ mapKeyValuePairsMonotonic

125+ (\(k :=> ComposeMaybe mv) -> k :=> ComposeMaybe (fmap (`runReaderT` r) mv)) p

126+ f' :: forall k'. GCompare k'

127+ => DMap k' (ReaderT (EventSelector t (WrapArg response (Tag (PrimState m)))) m)

128+ -> Event t (PatchDMap k' (ReaderT (EventSelector t (WrapArg response (Tag (PrimState m)))) m))

129+ -> EventWriterT t (DMap (Tag (PrimState m)) request) (ReaderT (EventSelector t (WrapArg response (Tag (PrimState m)))) m) (DMap k' Identity, Event t (PatchDMap k' Identity))

130+ f' x y = do

131+ r <- EventWriterT $ ask

132+ unRequesterT (f (dmapUnwrap r x) (fmap (patchDmapUnwrap r) y))

133+ in RequesterT $ sequenceDMapWithAdjustEventWriterTWith f' (coerce dm0) (coerceEvent dm')

test/EventWriterT.hsnew file+61

@@ -0,0 +1,61 @@

1+{-# LANGUAGE FlexibleContexts, GADTs #-}

2+module Main where

4+import Control.Monad

5+import Control.Monad.IO.Class

6+import Control.Monad.Ref

7+import Data.Dependent.Sum

8+import Data.IORef

9+import Data.List

10+import Data.Functor.Identity

11+

12+import Reflex

13+import Reflex.EventWriter

14+import Reflex.Host.Class

15+import Reflex.PerformEvent.Base

16+

17+import System.Exit (exitFailure, exitSuccess)

18+

19+main :: IO ()

20+main = do

21+ (Just out1, Nothing) <- runApp app1

22+ print out1

23+ (Just out2, Just (out3, out4)) <- runApp app2

24+ print out2

25+ print out3

26+ print out4

27+ when (sort out1 /= out1 || map (+1) out2 /= out3 || out3 /= out4) exitFailure

28+

29+runApp :: (Show a, t ~ SpiderTimeline Global, m ~ SpiderHost Global)

30+ => (Event t () -> EventWriterT t [a] (PerformEventT t m) (Maybe (Ref m (Maybe (EventTrigger t ())))))

31+ -> IO (Maybe [a], Maybe ([a], [a]))

32+runApp x = runSpiderHost $ do

33+ (pulseE, pulseTriggerRef) <- newEventWithTriggerRef

34+ ((mactuateRef, e), FireCommand fire) <- hostPerformEventT $ runEventWriterT (x pulseE)

35+ hnd <- subscribeEvent e

36+ out1 <- fireEventRefAndRead pulseTriggerRef () hnd

37+ out2 <- fmap join $ forM mactuateRef $ \actuateRef -> do

38+ let readPhase = do

39+ mGetValue <- readEvent hnd

40+ case mGetValue of

41+ Nothing -> return Nothing

42+ Just getValue -> fmap Just getValue

43+ mactuate <- readRef actuateRef

44+ mpulse <- readRef pulseTriggerRef

45+ forM ((,) <$> mactuate <*> mpulse) $ \(actuate, pulse) -> do

46+ _ <- fire [actuate :=> Identity ()] $ return ()

47+ [Just a] <- fire [pulse :=> Identity ()] $ readPhase

48+ [Just b, Nothing] <- fire [actuate :=> Identity (), pulse :=> Identity ()] $ readPhase

49+ return (a,b)

50+ return (out1, out2)

51+

52+app1 :: (Reflex t, Ref m ~ IORef, EventWriter t [Int] m) => Event t () -> m (Maybe (Ref m (Maybe (EventTrigger t ()))))

53+app1 e = do

54+ forM_ [1..10] $ \i -> tellEvent ([i] <$ e)

55+ return Nothing

56+

57+app2 :: (Reflex t, Ref m ~ IORef, EventWriter t [Int] m, MonadAdjust t m, MonadReflexCreateTrigger t m, MonadRef m) => Event t () -> m (Maybe (Ref m (Maybe (EventTrigger t ()))))

58+app2 e = do

59+ (pulse, pulseTriggerRef) <- newEventWithTriggerRef

60+ forM_ [1,3..9] $ \i -> runWithReplace (tellEvent ([i] <$ e)) $ ffor pulse $ \_ -> tellEvent ([i+1] <$ e)

61+ return (Just pulseTriggerRef)

test/RequesterT.hsnew file+70

@@ -0,0 +1,70 @@

1+{-# LANGUAGE FlexibleContexts, GADTs #-}

2+module Main where

4+import Control.Monad

5+import Control.Monad.IO.Class

6+import Control.Monad.Ref

7+import qualified Data.Dependent.Map as DMap

8+import Data.Dependent.Sum

9+import Data.IORef

10+import Data.List

11+import Data.Functor.Identity

12+

13+import Reflex

14+import Reflex.Host.Class

15+import Reflex.PerformEvent.Base

16+import Reflex.Requester.Base

17+import Reflex.Requester.Class

18+

19+import System.Exit (exitFailure, exitSuccess)

20+

21+data RequestInt a where

22+ RequestInt :: Int -> RequestInt Int

23+

24+main :: IO ()

25+main = do

26+ (Just out1, Nothing) <- runApp app1

27+ print out1

28+ (Just out2, Just (out3, out4)) <- runApp app2

29+ print out2

30+ print out3

31+ print out4

32+ when (sort out1 /= out1 || map (+1) out2 /= out3 || out3 /= out4) exitFailure

33+

34+runApp :: (t ~ SpiderTimeline Global, m ~ SpiderHost Global)

35+ => (Event t () -> RequesterT t RequestInt Identity (PerformEventT t m) (Maybe (Ref m (Maybe (EventTrigger t ())))))

36+ -> IO (Maybe [Int], Maybe ([Int], [Int]))

37+runApp x = runSpiderHost $ do

38+ (pulseE, pulseTriggerRef) <- newEventWithTriggerRef

39+ ((mactuateRef, e), FireCommand fire) <- hostPerformEventT $ runRequesterT (x pulseE) never

40+ hnd <- subscribeEvent (map unwrapRequest . DMap.toList <$> e)

41+ out1 <- fireEventRefAndRead pulseTriggerRef () hnd

42+ out2 <- fmap join $ forM mactuateRef $ \actuateRef -> do

43+ let readPhase = do

44+ mGetValue <- readEvent hnd

45+ case mGetValue of

46+ Nothing -> return Nothing

47+ Just getValue -> fmap Just getValue

48+ mactuate <- readRef actuateRef

49+ mpulse <- readRef pulseTriggerRef

50+ forM ((,) <$> mactuate <*> mpulse) $ \(actuate, pulse) -> do

51+ _ <- fire [actuate :=> Identity ()] $ return ()

52+ [Just a] <- fire [pulse :=> Identity ()] $ readPhase

53+ [Just b, Nothing] <- fire [actuate :=> Identity (), pulse :=> Identity ()] $ readPhase

54+ return (a,b)

55+ return (out1, out2)

56+

57+unwrapRequest :: DSum tag RequestInt -> Int

58+unwrapRequest (_ :=> RequestInt i) = i

59+

60+app1 :: (Reflex t, Ref m ~ IORef, Requester t m, Response m ~ Identity, Request m ~ RequestInt) => Event t () -> m (Maybe (Ref m (Maybe (EventTrigger t ()))))

61+app1 e = do

62+ forM_ [1..10] $ \i -> requestingIdentity (RequestInt i <$ e)

63+ return Nothing

64+

65+app2 :: (Reflex t, Ref m ~ IORef, Requester t m, Response m ~ Identity, Request m ~ RequestInt, MonadAdjust t m, MonadReflexCreateTrigger t m, MonadRef m) => Event t () -> m (Maybe (Ref m (Maybe (EventTrigger t ()))))

66+app2 e = do

67+ (pulse, pulseTriggerRef) <- newEventWithTriggerRef

68+ forM_ [1,3..9] $ \i -> runWithReplace (requestingIdentity (RequestInt i <$ e)) $ ffor pulse $ \_ -> requestingIdentity (RequestInt (i+1) <$ e)

69+ return (Just pulseTriggerRef)

70+