a224e72 · reflex · git.iko.soy

git.iko.soy/reflex

on develop help sign in

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

a224e72Daniel Haraj10 years ago

reflex.cabal+21

compare with develop

unifiedsplit

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

118 if impl(ghcjs)

119 buildable: False

120

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+

121benchmark spider-bench

142benchmark spider-bench

122 type: exitcode-stdio-1.0

143 type: exitcode-stdio-1.0

123 hs-source-dirs: bench

144 hs-source-dirs: bench

src/Reflex/EventWriter.hs+29−32

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

18 ( EventWriterT (..)

19 , runEventWriterT

20 , EventWriter(..)

21+ , runWithReplaceEventWriterTWith

22+ , sequenceDMapWithAdjustEventWriterTWith

21 ) where

23 ) where

23import Reflex.Class

25import Reflex.Class

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

33import Control.Monad.State.Strict

35import Control.Monad.State.Strict

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

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

35import qualified Data.Dependent.Map as DMap

37import qualified Data.Dependent.Map as DMap

38+import Data.Foldable

36import Data.Functor.Misc

39import Data.Functor.Misc

37import qualified Data.List.NonEmpty as NonEmpty

40import qualified Data.List.NonEmpty as NonEmpty

38import Data.Maybe

41import Data.Maybe

39import Data.Semigroup

42import Data.Semigroup

43+import Data.Sequence

40import Data.Some (Some)

44import Data.Some (Some)

41import qualified Data.Some as Some

45import qualified Data.Some as Some

42import Data.Tuple

46import Data.Tuple

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

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

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

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

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

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

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

54-- | Run a 'EventWriterT' action.

58-- | Run a 'EventWriterT' action.

55−runEventWriterT

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

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

57− => EventWriterT t w m a

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

59runEventWriterT (EventWriterT a) = do

60runEventWriterT (EventWriterT a) = do

60 (result, requests) <- runStateT a mempty

61 (result, requests) <- runStateT a mempty

61− return (result, mconcat $ reverse requests)

62+ return (result, mconcat $ toList requests)

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

64instance (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)

66instance MonadTrans (EventWriterT t w) where

67instance MonadTrans (EventWriterT t w) where

67 lift = EventWriterT . lift

68 lift = EventWriterT . lift

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

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

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

84-- 'MonadAdjust' behavior.

85-- 'MonadAdjust' behavior.

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

86runWithReplaceEventWriterTWith :: 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')

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

90− )

91− -> EventWriterT t w m a

88+ -> EventWriterT t w m a

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

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

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

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

94runWithReplaceEventWriterTWith f a0 a' = do

91runWithReplaceEventWriterTWith 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))

96 g (EventWriterT r) = runStateT r mempty

93 g (EventWriterT r) = runStateT r mempty

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

94 (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'

99 -- 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.)

96 -- 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

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

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

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

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

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

103

100

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

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

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

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

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

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

107− => DMap k' m

104+ => DMap k' m

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

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

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

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

110− )

107+ )

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

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

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

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

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

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

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

111sequenceDMapWithAdjustEventWriterTWith 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

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

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

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

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

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

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

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

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

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

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

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

118 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

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

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

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

121 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

126 childRequestMap <- holdIncremental requests0 requests'

123 childRequestMap <- holdIncremental requests0 requests'

127 -- 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.)

124 -- 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

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

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

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

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

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

131 return (result0, result')

128 return (result0, result')

132

129

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

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

4{-# LANGUAGE ExistentialQuantification #-}

5{-# LANGUAGE FlexibleInstances #-}

6{-# LANGUAGE GeneralizedNewtypeDeriving #-}

7−{-# LANGUAGE KindSignatures #-}

8{-# LANGUAGE MultiParamTypeClasses #-}

7{-# LANGUAGE MultiParamTypeClasses #-}

9{-# LANGUAGE Rank2Types #-}

8{-# LANGUAGE Rank2Types #-}

10{-# LANGUAGE ScopedTypeVariables #-}

9{-# LANGUAGE ScopedTypeVariables #-}

11{-# LANGUAGE TypeFamilies #-}

10{-# LANGUAGE TypeFamilies #-}

12{-# LANGUAGE UndecidableInstances #-}

11{-# LANGUAGE UndecidableInstances #-}

12+{-# LANGUAGE StandaloneDeriving #-}

13#ifdef USE_REFLEX_OPTIMIZER

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

15#endif

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

21 ) where

23import Reflex.Class

24+import Reflex.EventWriter

24import Reflex.Host.Class

25import Reflex.Host.Class

25import Reflex.PerformEvent.Class

26import Reflex.PerformEvent.Class

26import Reflex.PostBuild.Class

27import Reflex.PostBuild.Class

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

33import Control.Monad.Reader

34import Control.Monad.Reader

34import Control.Monad.Ref

35import Control.Monad.Ref

35import Control.Monad.State.Strict

36import Control.Monad.State.Strict

37+import Data.Coerce

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

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

37import qualified Data.Dependent.Map as DMap

39import qualified Data.Dependent.Map as DMap

38import Data.Functor.Misc

40import 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

44import Data.Unique.Tag

41import Data.Unique.Tag

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

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

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

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

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+

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

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

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

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

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

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

53-- requests were issued.

55-- requests were issued.

56+

54runRequesterT :: (Reflex t, Monad m)

57runRequesterT :: (Reflex t, Monad m)

55 => RequesterT t request response m a

58 => RequesterT t request response m a

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

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

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

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

58runRequesterT (RequesterT a) responses = do

61runRequesterT (RequesterT a) responses = do

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

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

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

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

64+ return (result, requests)

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

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

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

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

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

66 t <- lift newTag

70 t <- lift newTag

67 s <- RequesterT ask

71 s <- RequesterT ask

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

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

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

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

70 return result

74 return result

72instance MonadTrans (RequesterT t request response) where

76instance MonadTrans (RequesterT t request response) where

73 lift = RequesterT . lift . lift

77 lift = RequesterT . lift . lift

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−

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

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

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

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

143 performEvent_ = lift . performEvent_

81 performEvent_ = lift . performEvent_

144 performEvent = lift . performEvent

82 performEvent = lift . performEvent

145

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−

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

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

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

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

161 newRef = lift . newRef

86 newRef = lift . newRef

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

166 newEventWithTrigger = lift . newEventWithTrigger

91 newEventWithTrigger = lift . newEventWithTrigger

167 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f

92 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f

168

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

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

170−-- Internal functions

95+ ask = lift ask

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

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

97+ reader = lift . reader

172

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)

174

102

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

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

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

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

177

116

178−mapKeysAndValuesMonotonic :: (forall a. DMapTransform a k k' v v') -> DMap k v -> DMap k' 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' =

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

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

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

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+