68d62e4 · patch · git.iko.soy

git.iko.soy/patch

on develop help sign in

WIP: RequesterT is mostly working, but doesn't have a good way of dealing with dynamic lists

68d62e4Ryan Trinkle9 years ago

reflex.cabal+1

compare with develop

unifiedsplit

@@ -212,6 +212,7 @@ test-suite RequesterT

212 , transformers

213 , reflex

214 , ref-tf

215+ buildable: False

215

216

216test-suite QueryT

217test-suite QueryT

217 type: exitcode-stdio-1.0

218 type: exitcode-stdio-1.0

src/Data/FastWeakBag.hs+6−5

@@ -26,18 +26,19 @@ module Data.FastWeakBag

26#endif

27 ) where

29−import Control.Exception

30import Control.Monad hiding (forM_, mapM_)

29import Control.Monad hiding (forM_, mapM_)

31import Control.Monad.IO.Class

30import Control.Monad.IO.Class

31+

32+#ifdef ghcjs_HOST_OS

33+import GHCJS.Types

34+import Reflex.FastWeak (unsafeFromRawJSVal, unsafeToRawJSVal, js_isNull)

35+#else

36+import Control.Exception

32import Data.Foldable (forM_, mapM_)

37import Data.Foldable (forM_, mapM_)

33import Data.IntMap.Strict (IntMap)

38import Data.IntMap.Strict (IntMap)

34import qualified Data.IntMap.Strict as IntMap

39import qualified Data.IntMap.Strict as IntMap

35import Data.IORef

40import Data.IORef

36import System.Mem.Weak

41import System.Mem.Weak

37−

38−#ifdef ghcjs_HOST_OS

39−import GHCJS.Types

40−import Reflex.FastWeak (unsafeFromRawJSVal, unsafeToRawJSVal, js_isNull)

41#endif

42#endif

43import Prelude hiding (mapM_, traverse)

44import Prelude hiding (mapM_, traverse)

src/Data/Functor/Misc.hs+1

@@ -7,6 +7,7 @@

7{-# LANGUAGE KindSignatures #-}

8{-# LANGUAGE LambdaCase #-}

9{-# LANGUAGE MultiParamTypeClasses #-}

10+{-# LANGUAGE PatternSynonyms #-}

10{-# LANGUAGE PolyKinds #-}

11{-# LANGUAGE PolyKinds #-}

11{-# LANGUAGE RankNTypes #-}

12{-# LANGUAGE RankNTypes #-}

12{-# LANGUAGE ScopedTypeVariables #-}

13{-# LANGUAGE ScopedTypeVariables #-}

src/Reflex/DynamicWriter.hs+2−1

@@ -188,4 +188,5 @@ withDynamicWriterT f dw = do

188instance Requester t m => Requester t (DynamicWriterT t w m) where

189 type Request (DynamicWriterT t w m) = Request m

190 type Response (DynamicWriterT t w m) = Response m

191− withRequesting f = DynamicWriterT $ withRequesting $ unDynamicWriterT . f

191+ requesting = lift . requesting

192+ requesting_ = lift . requesting_

src/Reflex/EventWriter.hs+4−4

@@ -58,7 +58,7 @@ class (Monad m, Semigroup w) => EventWriter t w m | m -> t w where

58{-# DEPRECATED TellId "Do not construct this directly; use tellId instead" #-}

59newtype TellId w x

60 = TellId Int -- ^ WARNING: Do not construct this directly; use 'TellId' instead

61− deriving (Show, Read, Eq, Ord, Enum)

61+ deriving (Show, Eq, Ord, Enum)

63tellId :: Int -> TellId w w

64tellId = TellId

@@ -105,7 +105,7 @@ runEventWriterT (EventWriterT a) = do

105 combineResults = sconcat

106 . (\(h : t) -> h :| t) -- Unconditional; 'merge' guarantees that it will only fire with non-empty DMaps

107 . DMap.foldlWithKey (\vs tid (Identity v) -> withTellIdRefl tid $ v : vs) [] -- This is where we finally reverse the DMap to get things in the correct order

108− return (result, fmap combineResults $ merge $ DMap.fromDistinctAscList $ _eventWriterState_told requests)

108+ return (result, fmap combineResults $ merge $ DMap.fromDistinctAscList $ _eventWriterState_told requests) --TODO: We can probably make this fromDistinctAscList more efficient by knowing the length in advance, but this will require exposing internals of DMap; also converting it to use a strict list might help

109

110instance (Reflex t, Monad m, Semigroup w) => EventWriter t w (EventWriterT t w m) where

111 tellEvent w = EventWriterT $ modify $ \old ->

@@ -137,8 +137,8 @@ instance (Reflex t, MonadAdjust t m, MonadHold t m, Semigroup w, Semigroup w) =>

137instance Requester t m => Requester t (EventWriterT t w m) where

138 type Request (EventWriterT t w m) = Request m

139 type Response (EventWriterT t w m) = Response m

140− withRequesting f = EventWriterT $ withRequesting $ unEventWriterT . f

140+ requesting = lift . requesting

141−

141+ requesting_ = lift . requesting_

142

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

144-- 'runWithReplace' for 'EventWriterT'. This is necessary when the underlying

src/Reflex/Patch.hs+1−1

@@ -10,7 +10,7 @@ import Reflex.Patch.Class as X

10import Reflex.Patch.DMap as X

11import Reflex.Patch.DMapWithMove as X (PatchDMapWithMove, const2PatchDMapWithMoveWith, patchDMapWithMoveToPatchMapWithMoveWith, mapPatchDMapWithMove, weakenPatchDMapWithMoveWith, traversePatchDMapWithMoveWithKey, unsafePatchDMapWithMove, unPatchDMapWithMove)

12import Reflex.Patch.Map as X

13−import Reflex.Patch.MapWithMove as X (PatchMapWithMove, patchMapWithMoveNewElements, unsafePatchMapWithMove, unPatchMapWithMove)

13+import Reflex.Patch.MapWithMove as X (PatchMapWithMove, patchMapWithMoveNewElementsMap, patchMapWithMoveNewElements, unsafePatchMapWithMove, unPatchMapWithMove)

15import Data.Semigroup (Semigroup (..), (<>))

src/Reflex/Patch/Map.hs+3

@@ -46,3 +46,6 @@ instance Functor (PatchMap k) where

46patchMapNewElements :: PatchMap k v -> [v]

47patchMapNewElements (PatchMap p) = catMaybes $ Map.elems p

49+-- | Returns all the new elements that will be added to the 'Map'

50+patchMapNewElementsMap :: PatchMap k v -> Map k v

51+patchMapNewElementsMap (PatchMap p) = Map.mapMaybe id p

src/Reflex/Patch/MapWithMove.hs+4−1

@@ -62,7 +62,10 @@ instance Ord k => Patch (PatchMapWithMove k v) where

63-- | Returns all the new elements that will be added to the 'Map'

64patchMapWithMoveNewElements :: PatchMapWithMove k v -> [v]

65−patchMapWithMoveNewElements (PatchMapWithMove p) = catMaybes $ f <$> Map.elems p

65+patchMapWithMoveNewElements = Map.elems . patchMapWithMoveNewElementsMap

66+

67+patchMapWithMoveNewElementsMap :: PatchMapWithMove k v -> Map k v

68+patchMapWithMoveNewElementsMap (PatchMapWithMove p) = Map.mapMaybe f p

66 where f ni = case _nodeInfo_from ni of

69 where f ni = case _nodeInfo_from ni of

67 From_Insert v -> Just v

70 From_Insert v -> Just v

68 From_Move _ -> Nothing

71 From_Move _ -> Nothing

src/Reflex/PerformEvent/Base.hs+3−3

@@ -76,8 +76,8 @@ instance (ReflexHost t, PrimMonad (HostFrame t)) => MonadAdjust t (PerformEventT

76 result0 <- lift a0

77 result' <- requestingIdentity a'

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

79+ traverseDMapWithKeyWithAdjust f outerDm0 outerDm' = PerformEventT $ traverseDMapWithKeyWithAdjustRequesterTWith (defaultAdjustBase traversePatchDMapWithKey) mapPatchDMap weakenPatchDMapWith patchMapNewElementsMap 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')

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

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

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

@@ -123,7 +123,7 @@ hostPerformEventT a = do

123 case mToPerform of

124 Nothing -> return [result']

125 Just toPerform -> do

126− responses <- runHostFrame $ DMap.traverseWithKey (\_ v -> Identity <$> v) toPerform

126+ responses <- runHostFrame $ traverseRequesterData (\v -> Identity <$> v) toPerform

127 mrt <- readRef responseTrigger

128 let followupEventTriggers = case mrt of

129 Just rt -> [rt :=> Identity responses]

src/Reflex/PostBuild/Class.hs+8

@@ -19,6 +19,8 @@ module Reflex.PostBuild.Class

19import Reflex.Class

21import Control.Monad.Reader

22+import Control.Monad.State

23+import qualified Control.Monad.State.Strict as Strict

23-- | 'PostBuild' represents an action that is notified via an 'Event' when it

25-- | 'PostBuild' represents an action that is notified via an 'Event' when it

24-- has finished executing. Note that the specific definition of "finished" is

26-- has finished executing. Note that the specific definition of "finished" is

@@ -32,3 +34,9 @@ class (Reflex t, Monad m) => PostBuild t m | m -> t where

33instance PostBuild t m => PostBuild t (ReaderT r m) where

35instance PostBuild t m => PostBuild t (ReaderT r m) where

34 getPostBuild = lift getPostBuild

36 getPostBuild = lift getPostBuild

37+

38+instance PostBuild t m => PostBuild t (StateT s m) where

39+ getPostBuild = lift getPostBuild

40+

41+instance PostBuild t m => PostBuild t (Strict.StateT s m) where

42+ getPostBuild = lift getPostBuild

src/Reflex/Query/Base.hs+2−1

@@ -268,7 +268,8 @@ instance (Monad m, Group q, Additive q, Query q, Reflex t) => MonadQuery t q (Qu

268instance Requester t m => Requester t (QueryT t q m) where

269 type Request (QueryT t q m) = Request m

270 type Response (QueryT t q m) = Response m

271− withRequesting f = QueryT $ withRequesting $ unQueryT . f

271+ requesting = lift . requesting

272+ requesting_ = lift . requesting_

272

273

273instance EventWriter t w m => EventWriter t w (QueryT t q m) where

274instance EventWriter t w m => EventWriter t w (QueryT t q m) where

274 tellEvent = lift . tellEvent

275 tellEvent = lift . tellEvent

src/Reflex/Requester/Base.hs+180−47

@@ -1,16 +1,20 @@

1-- | This module provides 'RequesterT', the standard implementation of

2-- 'Requester'.

3−{-# LANGUAGE BangPatterns #-}

3+{-# LANGUAGE AllowAmbiguousTypes #-}

4{-# LANGUAGE CPP #-}

5+{-# LANGUAGE EmptyDataDecls #-}

5{-# LANGUAGE ExistentialQuantification #-}

6{-# LANGUAGE ExistentialQuantification #-}

6{-# LANGUAGE FlexibleInstances #-}

7{-# LANGUAGE FlexibleInstances #-}

8+{-# LANGUAGE GADTs #-}

7{-# LANGUAGE GeneralizedNewtypeDeriving #-}

9{-# LANGUAGE GeneralizedNewtypeDeriving #-}

8{-# LANGUAGE MultiParamTypeClasses #-}

10{-# LANGUAGE MultiParamTypeClasses #-}

9{-# LANGUAGE Rank2Types #-}

11{-# LANGUAGE Rank2Types #-}

12+{-# LANGUAGE RecursiveDo #-}

10{-# LANGUAGE ScopedTypeVariables #-}

13{-# LANGUAGE ScopedTypeVariables #-}

14+{-# LANGUAGE StandaloneDeriving #-}

11{-# LANGUAGE TypeFamilies #-}

15{-# LANGUAGE TypeFamilies #-}

16+{-# LANGUAGE TypeOperators #-}

12{-# LANGUAGE UndecidableInstances #-}

17{-# LANGUAGE UndecidableInstances #-}

13−{-# LANGUAGE StandaloneDeriving #-}

14#ifdef USE_REFLEX_OPTIMIZER

18#ifdef USE_REFLEX_OPTIMIZER

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

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

16#endif

20#endif

@@ -18,11 +22,13 @@ module Reflex.Requester.Base

18 ( RequesterT (..)

22 ( RequesterT (..)

19 , runRequesterT

23 , runRequesterT

20 , runWithReplaceRequesterTWith

24 , runWithReplaceRequesterTWith

21− , sequenceDMapWithAdjustRequesterTWith

25+ , traverseDMapWithKeyWithAdjustRequesterTWith

26+ , RequesterData

27+ , traverseRequesterData

22 ) where

28 ) where

24import Reflex.Class

30import Reflex.Class

25−import Reflex.EventWriter

31+import Reflex.Dynamic

26import Reflex.Host.Class

32import Reflex.Host.Class

27import Reflex.PerformEvent.Class

33import Reflex.PerformEvent.Class

28import Reflex.PostBuild.Class

34import Reflex.PostBuild.Class

@@ -31,20 +37,111 @@ import Reflex.TriggerEvent.Class

32import Control.Monad.Exception

38import Control.Monad.Exception

33import Control.Monad.Identity

39import Control.Monad.Identity

34−import Control.Monad.Primitive

35import Control.Monad.Reader

40import Control.Monad.Reader

36import Control.Monad.Ref

41import Control.Monad.Ref

37import Control.Monad.State.Strict

42import Control.Monad.State.Strict

43+import Data.Bits

38import Data.Coerce

44import Data.Coerce

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

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

40import qualified Data.Dependent.Map as DMap

46import qualified Data.Dependent.Map as DMap

47+import qualified Data.Some as Some

48+import Data.Functor.Compose

41import Data.Functor.Misc

49import Data.Functor.Misc

50+import Data.Int

42import Data.Map (Map)

51import Data.Map (Map)

52+import Data.Monoid

43import Data.Unique.Tag

53import Data.Unique.Tag

44import Data.Some (Some)

54import Data.Some (Some)

55+import Data.Tuple

56+import Data.Type.Equality

57+

58+import Unsafe.Coerce

59+

60+newtype RequesterData f = RequesterData { unRequesterData :: DMap MyTag (Entry f) }

61+

62+-- | Runs in reverse to accommodate for the fact that we accumulate it in reverse

63+traverseRequesterData :: forall m request response. Applicative m => (forall a. request a -> m (response a)) -> RequesterData request -> m (RequesterData response)

64+traverseRequesterData f (RequesterData m) = RequesterData <$> DMap.traverseWithKey go m --TODO: reverse

65+ where go :: forall x. MyTag x -> Entry request x -> m (Entry response x)

66+ go k (Entry request) = Entry <$> case myKeyType k of

67+ MyTagType_Single -> f request

68+ MyTagType_Multi -> traverseRequesterData f request

69+ MyTagType_Multi2 -> traverse (traverseRequesterData f) request

70+

71+data MyTagType :: * -> * where

72+ MyTagType_Single :: MyTagType (Single a)

73+ MyTagType_Multi :: MyTagType Multi

74+ MyTagType_Multi2 :: MyTagType (Multi2 k)

75+

76+myKeyType :: MyTag x -> MyTagType x

77+myKeyType (MyTag k) = case k .&. 0x3 of

78+ 0x0 -> unsafeCoerce MyTagType_Single

79+ 0x1 -> unsafeCoerce MyTagType_Multi

80+ 0x2 -> unsafeCoerce MyTagType_Multi2

81+ t -> error $ "Reflex.Requester.Base.myKeyType: no such key type" <> show t

82+

83+data Single a

84+data Multi

85+data Multi2 (k :: * -> *)

86+

87+type family EntryContents request a where

88+ EntryContents request (Single a) = request a

89+ EntryContents request Multi = RequesterData request

90+ EntryContents request (Multi2 k) = Map (Some k) (RequesterData request)

91+

92+newtype Entry request x = Entry { unEntry :: EntryContents request x }

93+

94+{-# INLINE singleEntry #-}

95+singleEntry :: f a -> Entry f (Single a)

96+singleEntry = Entry

97+

98+{-# INLINE multiEntry #-}

99+multiEntry :: RequesterData f -> Entry f Multi

100+multiEntry = Entry

101+

102+-- | We use a hack here to pretend we have x ~ request a; we don't want to use a GADT, because GADTs (even with zero-size existential contexts) can't be newtypes

103+-- WARNING: This type should never be exposed. In particular, this is extremely unsound if a MyTag from one run of runRequesterT is ever compared against a MyTag from another

104+newtype MyTag x = MyTag Int32 deriving (Show, Eq, Ord, Enum)

105+

106+newtype MyTagWrap (f :: * -> *) x = MyTagWrap Int32 deriving (Show, Eq, Ord, Enum)

107+

108+{-# INLINE castMyTagWrap #-}

109+castMyTagWrap :: MyTagWrap f (Entry f x) -> MyTagWrap g (Entry g x)

110+castMyTagWrap = coerce

111+

112+instance GEq MyTag where

113+ (MyTag a) `geq` (MyTag b) =

114+ if a == b

115+ then Just $ unsafeCoerce Refl

116+ else Nothing

117+

118+instance GCompare MyTag where

119+ (MyTag a) `gcompare` (MyTag b) =

120+ case a `compare` b of

121+ LT -> GLT

122+ EQ -> unsafeCoerce GEQ

123+ GT -> GGT

124+

125+instance GEq (MyTagWrap f) where

126+ (MyTagWrap a) `geq` (MyTagWrap b) =

127+ if a == b

128+ then Just $ unsafeCoerce Refl

129+ else Nothing

130+

131+instance GCompare (MyTagWrap f) where

132+ (MyTagWrap a) `gcompare` (MyTagWrap b) =

133+ case a `compare` b of

134+ LT -> GLT

135+ EQ -> unsafeCoerce GEQ

136+ GT -> GGT

137+

138+data RequesterState t request = RequesterState

139+ { _requesterState_nextMyTag :: {-# UNPACK #-} !Int32 -- Starts at -4 and goes down by 4 each time, to accommodate two 'type' bits at the bottom

140+ , _requesterState_requests :: ![DSum (MyTagWrap request) (Event t)]

141+ }

142

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

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

47−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 }

144+newtype RequesterT t request response m a = RequesterT { unRequesterT :: StateT (RequesterState t request) (ReaderT (EventSelector t (MyTagWrap response)) m) a }

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

145 deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException

49-- MonadAsyncException can't be derived on ghc-8.0.1; we use base-4.9.1 as a proxy for ghc-8.0.2

146-- MonadAsyncException can't be derived on ghc-8.0.1; we use base-4.9.1 as a proxy for ghc-8.0.2

50#if MIN_VERSION_base(4,9,1)

147#if MIN_VERSION_base(4,9,1)

@@ -57,6 +154,14 @@ deriving instance MonadHold t m => MonadHold t (RequesterT t request response m)

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

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

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

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

156

157+{-# INLINE wrapMyTags #-}

158+wrapMyTags :: DMap MyTag (Entry f) -> DMap (MyTagWrap f) Identity

159+wrapMyTags = unsafeCoerce

160+

161+{-# INLINE unwrapMyTags #-}

162+unwrapMyTags :: DMap (MyTagWrap f) Identity -> DMap MyTag (Entry f)

163+unwrapMyTags = unsafeCoerce

164+

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

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

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

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

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

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

@@ -64,22 +169,36 @@ deriving instance TriggerEvent t m => TriggerEvent t (RequesterT t request respo

169

65runRequesterT :: (Reflex t, Monad m)

170runRequesterT :: (Reflex t, Monad m)

66 => RequesterT t request response m a

171 => RequesterT t request response m a

67− -> Event t (DMap (Tag (PrimState m)) response)

172+ -> Event t (RequesterData response) --TODO: This DMap will be in reverse order, so we need to make sure the caller traverses it in reverse

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

173+ -> m (a, Event t (RequesterData request)) --TODO: we need to hide these 'MyTag's here, because they're unsafe to mix in the wild

69runRequesterT (RequesterT a) responses = do

174runRequesterT (RequesterT a) responses = do

70− (result, requests) <- runReaderT (runEventWriterT a) $ fan $

175+ (result, s) <- runReaderT (runStateT a $ RequesterState (-4) []) $ fan $

71− mapKeyValuePairsMonotonic (\(t :=> e) -> WrapArg t :=> Identity e) <$> responses

176+ fmapCheap (wrapMyTags . unRequesterData) responses

72− return (result, requests)

177+ return (result, fmapCheap (RequesterData . unwrapMyTags) $ merge $ DMap.fromDistinctAscList $ _requesterState_requests s)

178

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

179+instance (Reflex t, Monad m) => Requester t (RequesterT t request response m) where

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

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

76 type Response (RequesterT t request response m) = response

181 type Response (RequesterT t request response m) = response

77− withRequesting a = do

182+ requesting = fmap coerceEvent . responseFromTag . castMyTagWrap <=< tagRequest . (coerceEvent :: Event t (request a) -> Event t (Entry request (Single a)))

78− !t <- lift newTag --TODO: Fix this upstream

183+ requesting_ = void . tagRequest . fmapCheap singleEntry

79− s <- RequesterT ask

184+

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

185+{-# INLINE tagRequest #-}

81− RequesterT $ tellEvent $ fmapCheap (DMap.singleton t) req

186+tagRequest :: Monad m => Event t (Entry request x) -> RequesterT t request response m (MyTagWrap request (Entry request x))

82− return result

187+tagRequest req = do

188+ old <- RequesterT get

189+ let n = _requesterState_nextMyTag old

190+ t = MyTagWrap n

191+ RequesterT $ put $ RequesterState

192+ { _requesterState_nextMyTag = n - 0x4

193+ , _requesterState_requests = (t :=> req) : _requesterState_requests old

194+ }

195+ return t

196+

197+{-# INLINE responseFromTag #-}

198+responseFromTag :: (Monad m, Reflex t) => MyTagWrap response (Entry response x) -> RequesterT t request response m (Event t (Entry response x))

199+responseFromTag t = do

200+ responses :: EventSelector t (MyTagWrap response) <- RequesterT ask

201+ return $ select responses t

202

84instance MonadTrans (RequesterT t request response) where

203instance MonadTrans (RequesterT t request response) where

85 lift = RequesterT . lift . lift

204 lift = RequesterT . lift . lift

@@ -101,34 +220,37 @@ instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (RequesterT

101

220

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

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

103 ask = lift ask

222 ask = lift ask

104− local f (RequesterT (EventWriterT a)) = RequesterT $ EventWriterT $ mapStateT (mapReaderT $ local f) a

223+ local f (RequesterT a) = RequesterT $ mapStateT (mapReaderT $ local f) a

105 reader = lift . reader

224 reader = lift . reader

106

225

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

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

108− runWithReplace (RequesterT a) em = RequesterT $ runWithReplace a (coerceEvent em)

227+ runWithReplace = runWithReplaceRequesterTWith $ \dm0 dm' -> lift $ runWithReplace dm0 dm'

109− traverseDMapWithKeyWithAdjust f dm edm = RequesterT $ traverseDMapWithKeyWithAdjust (\k v -> unRequesterT $ f k v) (coerce dm) (coerceEvent edm)

228+ traverseDMapWithKeyWithAdjust = traverseDMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjust f dm0 dm') mapPatchDMap weakenPatchDMapWith patchMapNewElementsMap mergeMapIncremental

110− traverseDMapWithKeyWithAdjustWithMove f dm edm = RequesterT $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unRequesterT $ f k v) (coerce dm) (coerceEvent edm)

229+ traverseDMapWithKeyWithAdjustWithMove = traverseDMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjustWithMove f dm0 dm') mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElementsMap mergeMapIncrementalWithMove

230+

231+requesting' :: (Monad m, Reflex t) => Event t (Entry request x) -> RequesterT t request response m (Event t (Entry response x))

232+requesting' = responseFromTag . castMyTagWrap <=< tagRequest

111

233

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

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

235+ , MonadFix m

236+ )

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

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

114 -> RequesterT t request response m a

238 -> RequesterT t request response m a

115 -> Event t (RequesterT t request response m b)

239 -> Event t (RequesterT t request response m b)

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

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

117−runWithReplaceRequesterTWith f a0 a' =

241+runWithReplaceRequesterTWith f a0 a' = do

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

242+ rec response <- fmap (fmapCheap unEntry) $ requesting' $ fmapCheap multiEntry $ switchPromptlyDyn requests --TODO: Investigate whether we can really get rid of the prompt stuff here

119− -> Event t (ReaderT (EventSelector t (WrapArg response (Tag (PrimState m)))) m b')

243+ ((result0, requests0), v') <- f (runRequesterT a0 response) $ fmapCheap (`runRequesterT` response) a'

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

244+ requests <- holdDyn requests0 $ fmapCheap snd v'

121− f' x y = do

245+ return (result0, fmapCheap fst v')

122− r <- EventWriterT $ ask

246+

123− unRequesterT (f (runReaderT x r) (fmapCheap (`runReaderT` r) y))

124− in RequesterT $ runWithReplaceEventWriterTWith f' (coerce a0) (coerceEvent a')

125−

126−sequenceDMapWithAdjustRequesterTWith :: forall k t request response m v v' p p'.

247+traverseDMapWithKeyWithAdjustRequesterTWith :: forall k t request response m v v' p p'.

127 ( GCompare k

248 ( GCompare k

128 , Reflex t

249 , Reflex t

129 , MonadHold t m

250 , MonadHold t m

130− , PatchTarget (p' (Some k) (Event t (DMap (Tag (PrimState m)) request))) ~ Map (Some k) (Event t (DMap (Tag (PrimState m)) request))

251+ , PatchTarget (p' (Some k) (Event t (RequesterData request))) ~ Map (Some k) (Event t (RequesterData request))

131− , Patch (p' (Some k) (Event t (DMap (Tag (PrimState m)) request)))

252+ , Patch (p' (Some k) (Event t (RequesterData request)))

253+ , MonadFix m

132 )

254 )

133 => (forall k' v1 v2. GCompare k'

255 => (forall k' v1 v2. GCompare k'

134 => (forall a. k' a -> v1 a -> m (v2 a))

256 => (forall a. k' a -> v1 a -> m (v2 a))

@@ -138,19 +260,30 @@ sequenceDMapWithAdjustRequesterTWith :: forall k t request response m v v' p p'.

138 )

260 )

139 -> (forall v1. (forall a. v1 a -> v' a) -> p k v1 -> p k v')

261 -> (forall v1. (forall a. v1 a -> v' a) -> p k v1 -> p k v')

140 -> (forall v1 v2. (forall a. v1 a -> v2) -> p k v1 -> p' (Some k) v2)

262 -> (forall v1 v2. (forall a. v1 a -> v2) -> p k v1 -> p' (Some k) v2)

141− -> (forall v2. p' (Some k) v2 -> [v2])

263+ -> (forall v2. p' (Some k) v2 -> Map (Some k) v2)

142 -> (forall a. Incremental t (p' (Some k) (Event t a)) -> Event t (Map (Some k) a))

264 -> (forall a. Incremental t (p' (Some k) (Event t a)) -> Event t (Map (Some k) a))

143 -> (forall a. k a -> v a -> RequesterT t request response m (v' a))

265 -> (forall a. k a -> v a -> RequesterT t request response m (v' a))

144 -> DMap k v

266 -> DMap k v

145 -> Event t (p k v)

267 -> Event t (p k v)

146 -> RequesterT t request response m (DMap k v', Event t (p k v'))

268 -> RequesterT t request response m (DMap k v', Event t (p k v'))

147−sequenceDMapWithAdjustRequesterTWith base mapPatch weakenPatchWith patchNewElements mergePatchIncremental f dm0 dm' =

269+traverseDMapWithKeyWithAdjustRequesterTWith base mapPatch weakenPatchWith patchNewElements mergePatchIncremental f dm0 dm' = do

148− let base' :: forall v1 v2.

270+ rec response <- requesting' $ fmapCheap pack $ promptRequests `mappend` mergePatchIncremental requests --TODO: Investigate whether we can really get rid of the prompt stuff here

149− (forall a. k a -> v1 a -> ReaderT (EventSelector t (WrapArg response (Tag (PrimState m)))) m (v2 a))

271+ let responses :: EventSelector t (Const2 (Some k) (RequesterData response))

150− -> DMap k v1

272+ responses = fanMap $ fmapCheap unpack response

151− -> Event t (p k v1)

273+ unpack :: Entry response (Multi2 k) -> Map (Some k) (RequesterData response)

152− -> EventWriterT t (DMap (Tag (PrimState m)) request) (ReaderT (EventSelector t (WrapArg response (Tag (PrimState m)))) m) (DMap k v2, Event t (p k v2))

274+ unpack = unEntry

153− base' f' x y = do

275+ pack :: Map (Some k) (RequesterData request) -> Entry request (Multi2 k)

154− r <- EventWriterT ask

276+ pack = Entry

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

277+ f' :: forall a. k a -> v a -> m (Compose ((,) (Event t (RequesterData request))) v' a)

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

278+ f' k v = fmap (Compose . swap) $ runRequesterT (f k v) $ select responses (Const2 (Some.This k))

279+ (children0, children') <- base f' dm0 dm'

280+ let result0 = DMap.map (snd . getCompose) children0

281+ result' = fforCheap children' $ mapPatch $ snd . getCompose

282+ requests0 :: Map (Some k) (Event t (RequesterData request))

283+ requests0 = weakenDMapWith (fst . getCompose) children0

284+ requests' :: Event t (p' (Some k) (Event t (RequesterData request)))

285+ requests' = fforCheap children' $ weakenPatchWith $ fst . getCompose

286+ promptRequests :: Event t (Map (Some k) (RequesterData request))

287+ promptRequests = coincidence $ fmapCheap (mergeMap . patchNewElements) requests' --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'

288+ requests <- holdIncremental requests0 requests'

289+ return (result0, result')

src/Reflex/Requester/Class.hs+20−34

@@ -7,6 +7,7 @@

7{-# LANGUAGE FlexibleInstances #-}

8{-# LANGUAGE FunctionalDependencies #-}

9{-# LANGUAGE MultiParamTypeClasses #-}

10+{-# LANGUAGE RecursiveDo #-}

10{-# LANGUAGE TypeFamilies #-}

11{-# LANGUAGE TypeFamilies #-}

11{-# LANGUAGE UndecidableInstances #-}

12{-# LANGUAGE UndecidableInstances #-}

12#ifdef USE_REFLEX_OPTIMIZER

13#ifdef USE_REFLEX_OPTIMIZER

@@ -14,8 +15,7 @@

14#endif

15#endif

15module Reflex.Requester.Class

16module Reflex.Requester.Class

16 ( Requester (..)

17 ( Requester (..)

17− , requesting

18+ , withRequesting

18− , requesting_

19 , requestingIdentity

20 ) where

@@ -36,52 +36,38 @@ class (Reflex t, Monad m) => Requester t m | m -> t where

36 type Request m :: * -> *

37 -- | The type of responses that this 'Requester' can receive

38 type Response m :: * -> *

39− -- | Usually, end-user code should use 'requesting', 'requesting_', or

39+ -- | Emit a request whenever the given 'Event' fires, and return responses in

40− -- 'requestingIdentity'. For implementers of 'Requester', this function

40+ -- the resulting 'Event'.

41− -- provides a convenient way to define instances of the typeclass that

41+ requesting :: Event t (Request m a) -> m (Event t (Response m a))

42− -- efficiently support the underlying operations without needing to use

42+ -- | Emit a request whenever the given 'Event' fires, and ignore all responses.

43− -- 'Control.Monad.Fix.MonadFix'.

43+ requesting_ :: Event t (Request m a) -> m ()

44− withRequesting :: (Event t (Response m a) -> m (Event t (Request m a), r)) -> m r

44+

46instance Requester t m => Requester t (ReaderT r m) where

47 type Request (ReaderT r m) = Request m

48 type Response (ReaderT r m) = Response m

49− withRequesting f = do

49+ requesting = lift . requesting

50− r <- ask

50+ requesting_ = lift . requesting_

51− lift $ withRequesting $ (`runReaderT` r) . f

53instance Requester t m => Requester t (StateT s m) where

52instance Requester t m => Requester t (StateT s m) where

54 type Request (StateT s m) = Request m

53 type Request (StateT s m) = Request m

55 type Response (StateT s m) = Response m

54 type Response (StateT s m) = Response m

56− withRequesting f = do

55+ requesting = lift . requesting

57− old <- get

56+ requesting_ = lift . requesting_

58− (result, new) <- lift $ withRequesting $ \x -> do

59− ((request, result), new) <- runStateT (f x) old

60− return (request, (result, new))

61− put new

62− return result

64instance Requester t m => Requester t (Lazy.StateT s m) where

58instance Requester t m => Requester t (Lazy.StateT s m) where

65 type Request (Lazy.StateT s m) = Request m

59 type Request (Lazy.StateT s m) = Request m

66 type Response (Lazy.StateT s m) = Response m

60 type Response (Lazy.StateT s m) = Response m

67− withRequesting f = do

61+ requesting = lift . requesting

68− old <- Lazy.get

62+ requesting_ = lift . requesting_

69− (result, new) <- lift $ withRequesting $ \x -> do

70− ((request, result), new) <- Lazy.runStateT (f x) old

71− return (request, (result, new))

72− Lazy.put new

73− return result

74−

75−-- | Emit a request whenever the given 'Event' fires, and return responses in

76−-- the resulting 'Event'.

77−requesting :: Requester t m => Event t (Request m a) -> m (Event t (Response m a))

78−requesting req = withRequesting $ return . (,) req

79−

80−-- | Emit a request whenever the given 'Event' fires, and ignore all responses.

81−requesting_ :: Requester t m => Event t (Request m a) -> m ()

82−requesting_ req = withRequesting $ \_ -> return (req, ())

84-- | Emit a request whenever the given 'Event' fires, and unwrap the responses

64-- | Emit a request whenever the given 'Event' fires, and unwrap the responses

85-- before returning them. @Response m@ must be 'Identity'.

65-- before returning them. @Response m@ must be 'Identity'.

86requestingIdentity :: (Requester t m, Response m ~ Identity) => Event t (Request m a) -> m (Event t a)

66requestingIdentity :: (Requester t m, Response m ~ Identity) => Event t (Request m a) -> m (Event t a)

87requestingIdentity = fmap coerceEvent . requesting

67requestingIdentity = fmap coerceEvent . requesting

68+

69+withRequesting :: (Requester t m, MonadFix m) => (Event t (Response m a) -> m (Event t (Request m a), r)) -> m r

70+withRequesting f = do

71+ rec response <- requesting request

72+ (request, result) <- f response

73+ return result

src/Reflex/Spider/Internal.hs+3−3

@@ -241,9 +241,9 @@ subscribeAndRead = unEvent

241-- | Construct an 'Event' equivalent to that constructed by 'push', but with no

242-- caching; if the computation function is very cheap, this is (much) more

243-- efficient than 'push'

244−{-# NOINLINE pushCheap #-}

244+{-# INLINE [1] pushCheap #-}

245pushCheap :: HasSpiderTimeline x => (a -> ComputeM x (Maybe b)) -> Event x a -> Event x b

246−pushCheap f e = Event $ \sub -> do

246+pushCheap !f e = Event $ \sub -> do

247 (subscription, occ) <- subscribeAndRead e $ sub

248 { subscriberPropagate = \a -> do

249 mb <- runComputeM $ f a

@@ -1122,7 +1122,7 @@ instance HasSpiderTimeline x => FunctorMaybe (Event x) where

1122

1123instance HasSpiderTimeline x => Align (Event x) where

1124 nil = eventNever

1125− align ea eb = fmapMaybe dmapToThese $ merge $ dynamicConst $ DMap.fromList [LeftTag :=> ea, RightTag :=> eb]

1125+ align ea eb = fmapMaybe dmapToThese $ merge $ dynamicConst $ DMap.fromDistinctAscList [LeftTag :=> ea, RightTag :=> eb]

1126

1127newtype Dyn x p = Dyn { unDyn :: IORef (Either (BehaviorM x (PatchTarget p), Event x p) (Hold x p)) }

1128

src/Reflex/TriggerEvent/Class.hs+12

@@ -11,6 +11,8 @@ module Reflex.TriggerEvent.Class

11import Reflex.Class

13import Control.Monad.Reader

14+import Control.Monad.State

15+import qualified Control.Monad.State.Strict as Strict

15--TODO: Shouldn't have IO hard-coded

17--TODO: Shouldn't have IO hard-coded

16-- | 'TriggerEvent' represents actions that can create 'Event's that can be

18-- | 'TriggerEvent' represents actions that can create 'Event's that can be

@@ -36,3 +38,13 @@ instance TriggerEvent t m => TriggerEvent t (ReaderT r m) where

36 newTriggerEvent = lift newTriggerEvent

38 newTriggerEvent = lift newTriggerEvent

37 newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete

39 newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete

38 newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete

40 newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete

41+

42+instance TriggerEvent t m => TriggerEvent t (StateT s m) where

43+ newTriggerEvent = lift newTriggerEvent

44+ newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete

45+ newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete

46+

47+instance TriggerEvent t m => TriggerEvent t (Strict.StateT s m) where

48+ newTriggerEvent = lift newTriggerEvent

49+ newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete

50+ newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete