develop...44cfdfa · reflex

git.iko.soy/reflex

on 44cfdfa help sign in

reflex.cabal+1

since splitsnapshots

unifiedsplit

@@ -57,6 +57,7 @@ library

57 containers >= 0.6 && < 0.7,

58 data-default >= 0.5 && < 0.8,

59 dependent-map >= 0.3 && < 0.4,

60+ dlist == 0.8.*,

60 exception-transformers == 0.4.*,

61 exception-transformers == 0.4.*,

61 profunctors >= 5.3 && < 5.5,

62 profunctors >= 5.3 && < 5.5,

62 lens >= 4.7 && < 5,

63 lens >= 4.7 && < 5,

src/Data/TagMap.hsnew file+35

@@ -0,0 +1,35 @@

1+{-# LANGUAGE PolyKinds #-}

2+{-# LANGUAGE ScopedTypeVariables #-}

3+module Data.TagMap

4+ ( TagMap

5+ , unTagMap

6+ , fromDMap

7+ , toDMap

8+ , fromList

9+ , insert

10+ ) where

11+

12+import Data.IntMap (IntMap)

13+import qualified Data.IntMap as IntMap

14+import Data.Dependent.Map (DMap)

15+import qualified Data.Dependent.Map as DMap

16+import Data.Dependent.Sum (DSum (..))

17+import Data.Unique.Tag.Local

18+

19+import GHC.Exts (Any)

20+import Unsafe.Coerce

21+

22+-- | Like DMap, but with 'Data.Unique.Tag.Tag' as the keys. Implemented using 'Data.IntMap.IntMap' under the hood.

23+newtype TagMap x (v :: k -> *) = TagMap { unTagMap :: IntMap Any }

24+

25+fromDMap :: forall k x (v :: k -> *). DMap (Tag x) v -> TagMap x v

26+fromDMap = TagMap . IntMap.fromDistinctAscList . fmap (\((k :: Tag x (a :: k)) :=> v) -> (tagId k, (unsafeCoerce :: v a -> Any) v)) . DMap.toAscList

27+

28+toDMap :: forall x v. TagMap x v -> DMap (Tag x) v

29+toDMap = DMap.fromDistinctAscList . fmap (\(k, v) -> (unsafeTagFromId k :=> (unsafeCoerce :: Any -> v a) v)) . IntMap.toAscList . unTagMap

30+

31+insert :: forall x a v. Tag x a -> v a -> TagMap x v -> TagMap x v

32+insert k v = TagMap . IntMap.insert (tagId k) ((unsafeCoerce :: v a -> Any) v) . unTagMap

33+

34+fromList :: [DSum (Tag x) v] -> TagMap x v

35+fromList = TagMap . IntMap.fromList . fmap (\(t :=> v) -> (tagId t, (unsafeCoerce :: v a -> Any) v))

src/Data/Unique/Tag/Local.hsnew file+11

@@ -0,0 +1,11 @@

1+module Data.Unique.Tag.Local

2+ ( Tag

3+ , TagGen (..)

4+ , tagId

5+ , unsafeTagFromId

6+ , newTag

7+ , newTagGen

8+ , withTagGen

9+ ) where

10+

11+import Data.Unique.Tag.Local.Internal

src/Data/Unique/Tag/Local/Internal.hsnew file+53

@@ -0,0 +1,53 @@

1+-- | The type-safety of this module depends on two assumptions:

2+-- 1. If the `s` parameters on two `TagGen`s can unify, then they contain the same MutVar

3+-- 2. Two Tag values made from the same TagGen never contain the same Int

5+{-# LANGUAGE EmptyDataDecls #-}

6+{-# LANGUAGE DeriveFunctor #-}

7+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

8+{-# LANGUAGE TypeFamilies #-}

9+{-# LANGUAGE PolyKinds #-}

10+{-# LANGUAGE RankNTypes #-}

11+{-# LANGUAGE ScopedTypeVariables #-}

12+module Data.Unique.Tag.Local.Internal where

13+

14+import Control.Monad.Exception

15+import Control.Monad.Primitive

16+import Control.Monad.Reader

17+import Data.Primitive.MutVar

18+import Data.GADT.Compare

19+import Data.Some

20+import Unsafe.Coerce

21+

22+newtype Tag x a = Tag Int

23+

24+tagId :: Tag x a -> Int

25+tagId (Tag n) = n

26+

27+-- | WARNING: If you construct a tag with the wrong type, it will result in

28+-- incorrect unsafeCoerce applications, which can segfault or cause arbitrary

29+-- other damage to your program

30+unsafeTagFromId :: Int -> Tag x a

31+unsafeTagFromId n = Tag n

32+

33+-- We use Int because it is supported by e.g. IntMap

34+newtype TagGen ps s = TagGen { unTagGen :: MutVar ps Int }

35+

36+instance GEq (TagGen ps) where

37+ TagGen a `geq` TagGen b =

38+ if a == b

39+ then Nothing

40+ else Just $ unsafeCoerce Refl

41+

42+newTag :: PrimMonad m => TagGen (PrimState m) s -> m (Tag s a)

43+newTag (TagGen r) = do

44+ n <- atomicModifyMutVar' r $ \x -> (succ x, x)

45+ pure $ Tag n

46+

47+newTagGen :: PrimMonad m => m (Some (TagGen (PrimState m)))

48+newTagGen = Some . TagGen <$> newMutVar minBound

49+

50+withTagGen :: PrimMonad m => (forall s. TagGen (PrimState m) s -> m a) -> m a

51+withTagGen f = do

52+ g <- newTagGen

53+ withSome g f

src/Reflex/FanTag.hsnew file+23

@@ -0,0 +1,23 @@

1+{-# LANGUAGE PolyKinds #-}

2+{-# LANGUAGE ScopedTypeVariables #-}

3+module Reflex.FanTag

4+ ( EventSelectorTag

5+ , unEventSelectorTag

6+ , fanTag

7+ , selectTag

8+ ) where

10+import Data.Unique.Tag.Local

11+import Data.TagMap

12+import Reflex.Class

13+

14+import GHC.Exts (Any)

15+import Unsafe.Coerce

16+

17+newtype EventSelectorTag t x (v :: k -> *) = EventSelectorTag { unEventSelectorTag :: EventSelectorInt t Any }

18+

19+fanTag :: Reflex t => Event t (TagMap x v) -> EventSelectorTag t x v

20+fanTag = EventSelectorTag . fanInt . fmapCheap unTagMap

21+

22+selectTag :: forall t x v a. Reflex t => EventSelectorTag t x v -> Tag x a -> Event t (v a)

23+selectTag (EventSelectorTag s) = fmapCheap (unsafeCoerce :: Any -> v a) . selectInt s . tagId

src/Reflex/PerformEvent/Base.hs+28−2

@@ -28,7 +28,7 @@ import Reflex.Class

28import Reflex.Adjustable.Class

29import Reflex.Host.Class

30import Reflex.PerformEvent.Class

31−import Reflex.Requester.Base

31+import Reflex.Requester.Base.Internal

32import Reflex.Requester.Class

34import Control.Lens

@@ -68,13 +68,37 @@ instance (PrimMonad (HostFrame t), ReflexHost t) => PrimMonad (PerformEventT t m

68 type PrimState (PerformEventT t m) = PrimState (HostFrame t)

69 primitive = PerformEventT . lift . primitive

71−instance (ReflexHost t, Ref m ~ Ref IO) => PerformEvent t (PerformEventT t m) where

71+instance (ReflexHost t, Ref m ~ Ref IO, PrimMonad (HostFrame t)) => PerformEvent t (PerformEventT t m) where

72 type Performable (PerformEventT t m) = HostFrame t

73 {-# INLINABLE performEvent_ #-}

74 performEvent_ = PerformEventT . requesting_

75 {-# INLINABLE performEvent #-}

76 performEvent = PerformEventT . requestingIdentity

78+-- | An Adjustable instance where "adjusting" just runs the new thing - nothing is done with the old thing

79+newtype NullAdjustable t m a = NullAdjustable { unNullAdjustable :: m a }

80+ deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException)

81+

82+instance PrimMonad m => PrimMonad (NullAdjustable t m) where

83+ type PrimState (NullAdjustable t m) = PrimState m

84+

85+instance (ReflexHost t, PrimMonad (HostFrame t)) => Adjustable t (PerformEventT t m) where

86+ runWithReplace (PerformEventT (RequesterT a0)) a' = PerformEventT $ RequesterT $ do

87+ (s, tg) <- RequesterInternalT ask

88+ newA <- requestingIdentity $ undefined <$> a'

89+ runWithReplace a0 never

90+

91+instance Adjustable t (NullAdjustable t m) where

92+ runWithReplace a0 a' = NullAdjustable $ do

93+ return (result0, result')

94+ traverseDMapWithKeyWithAdjust = defaultAdjustBase traversePatchDMapWithKey

95+ traverseDMapWithKeyWithAdjustWithMove = defaultAdjustBase traversePatchDMapWithMoveWithKey

96+

97+{-

98+ traverseIntMapWithKeyWithAdjust = defaultAdjustIntBase traverseIntMapPatchWithKey

99+-}

100+

101+{-

78instance (ReflexHost t, PrimMonad (HostFrame t)) => Adjustable t (PerformEventT t m) where

102instance (ReflexHost t, PrimMonad (HostFrame t)) => Adjustable t (PerformEventT t m) where

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

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

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

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

@@ -85,6 +109,7 @@ instance (ReflexHost t, PrimMonad (HostFrame t)) => Adjustable t (PerformEventT

85 traverseIntMapWithKeyWithAdjust f outerDm0 outerDm' = PerformEventT $ traverseIntMapWithKeyWithAdjustRequesterTWith (defaultAdjustIntBase traverseIntMapPatchWithKey) patchIntMapNewElementsMap mergeIntIncremental (\k v -> unPerformEventT $ f k v) (coerce outerDm0) (coerceEvent outerDm')

109 traverseIntMapWithKeyWithAdjust f outerDm0 outerDm' = PerformEventT $ traverseIntMapWithKeyWithAdjustRequesterTWith (defaultAdjustIntBase traverseIntMapPatchWithKey) patchIntMapNewElementsMap mergeIntIncremental (\k v -> unPerformEventT $ f k v) (coerce outerDm0) (coerceEvent outerDm')

86 traverseDMapWithKeyWithAdjust f outerDm0 outerDm' = PerformEventT $ traverseDMapWithKeyWithAdjustRequesterTWith (defaultAdjustBase traversePatchDMapWithKey) mapPatchDMap weakenPatchDMapWith patchMapNewElementsMap mergeMapIncremental (\k v -> unPerformEventT $ f k v) (coerce outerDm0) (coerceEvent outerDm')

110 traverseDMapWithKeyWithAdjust f outerDm0 outerDm' = PerformEventT $ traverseDMapWithKeyWithAdjustRequesterTWith (defaultAdjustBase traversePatchDMapWithKey) mapPatchDMap weakenPatchDMapWith patchMapNewElementsMap mergeMapIncremental (\k v -> unPerformEventT $ f k v) (coerce outerDm0) (coerceEvent outerDm')

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

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

112+-}

113

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

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

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

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

@@ -124,6 +149,7 @@ hostPerformEventT :: forall t m a.

124 , MonadReflexHost t m

149 , MonadReflexHost t m

125 , MonadRef m

150 , MonadRef m

126 , Ref m ~ Ref IO

151 , Ref m ~ Ref IO

152+ , PrimMonad (HostFrame t)

127 )

153 )

128 => PerformEventT t m a

154 => PerformEventT t m a

129 -> m (a, FireCommand t m)

155 -> m (a, FireCommand t m)

src/Reflex/Requester/Base.hs+12−530

@@ -1,537 +1,19 @@

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

2-- 'Requester'.

3−{-# LANGUAGE AllowAmbiguousTypes #-}

4−{-# LANGUAGE CPP #-}

5−{-# LANGUAGE EmptyDataDecls #-}

6−{-# LANGUAGE ExistentialQuantification #-}

7−{-# LANGUAGE FlexibleInstances #-}

8−{-# LANGUAGE GADTs #-}

9−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

10−{-# LANGUAGE MultiParamTypeClasses #-}

11−{-# LANGUAGE Rank2Types #-}

12−{-# LANGUAGE RecursiveDo #-}

13−{-# LANGUAGE ScopedTypeVariables #-}

14−{-# LANGUAGE StandaloneDeriving #-}

15−{-# LANGUAGE TypeFamilies #-}

16−{-# LANGUAGE TypeOperators #-}

17−{-# LANGUAGE UndecidableInstances #-}

18−#ifdef USE_REFLEX_OPTIMIZER

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

20−#endif

21module Reflex.Requester.Base

3module Reflex.Requester.Base

22 ( RequesterT (..)

4 ( RequesterT (..)

23 , runRequesterT

5 , runRequesterT

24− , withRequesterT

6+-- , withRequesterT

25− , runWithReplaceRequesterTWith

26− , traverseIntMapWithKeyWithAdjustRequesterTWith

27− , traverseDMapWithKeyWithAdjustRequesterTWith

28− , RequesterData

7+-- , RequesterData

29− , RequesterDataKey

8+-- , RequesterDataKey

30− , traverseRequesterData

9+-- , traverseRequesterData

31− , forRequesterData

10+-- , forRequesterData

32− , requesterDataToList

11+-- , requesterDataToList

33− , singletonRequesterData

12+-- , singletonRequesterData

34− , matchResponsesWithRequests

13+-- , matchResponsesWithRequests

35− , multiEntry

14+-- , multiEntry

36− , unMultiEntry

15+-- , unMultiEntry

37− , requesting'

16+-- , requesting'

38 ) where

17 ) where

40−import Reflex.Class

19+import Reflex.Requester.Base.Internal

41−import Reflex.Adjustable.Class

42−import Reflex.Dynamic

43−import Reflex.Host.Class

44−import Reflex.PerformEvent.Class

45−import Reflex.PostBuild.Class

46−import Reflex.Requester.Class

47−import Reflex.TriggerEvent.Class

48−

49−import Control.Applicative (liftA2)

50−import Control.Monad.Exception

51−import Control.Monad.Identity

52−import Control.Monad.Primitive

53−import Control.Monad.Reader

54−import Control.Monad.Ref

55−import Control.Monad.State.Strict

56−import Data.Bits

57−import Data.Coerce

58−import Data.Dependent.Map (DMap, DSum (..))

59−import qualified Data.Dependent.Map as DMap

60−import Data.Functor.Compose

61−import Data.Functor.Misc

62−import Data.IntMap.Strict (IntMap)

63−import qualified Data.IntMap.Strict as IntMap

64−import Data.Map (Map)

65−import qualified Data.Map as Map

66−import Data.Monoid ((<>))

67−import Data.Proxy

68−import qualified Data.Semigroup as S

69−import Data.Some (Some(Some))

70−import Data.Type.Equality

71−import Data.Unique.Tag

72−

73−import GHC.Exts (Any)

74−import Unsafe.Coerce

75−

76−--TODO: Make this module type-safe

77−

78−newtype TagMap (f :: * -> *) = TagMap (IntMap Any)

79−

80−newtype RequesterData f = RequesterData (TagMap (Entry f))

81−

82−data RequesterDataKey a where

83− RequesterDataKey_Single :: {-# UNPACK #-} !(MyTag (Single a)) -> RequesterDataKey a

84− RequesterDataKey_Multi :: {-# UNPACK #-} !(MyTag Multi) -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a --TODO: Don't put a second Int here (or in the other Multis); use a single Int instead

85− RequesterDataKey_Multi2 :: {-# UNPACK #-} !(MyTag (Multi2 k)) -> !(Some k) -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a

86− RequesterDataKey_Multi3 :: {-# UNPACK #-} !(MyTag Multi3) -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a

87−

88−singletonRequesterData :: RequesterDataKey a -> f a -> RequesterData f

89−singletonRequesterData rdk v = case rdk of

90− RequesterDataKey_Single k -> RequesterData $ singletonTagMap k $ Entry v

91− RequesterDataKey_Multi k k' k'' -> RequesterData $ singletonTagMap k $ Entry $ IntMap.singleton k' $ singletonRequesterData k'' v

92− RequesterDataKey_Multi2 k k' k'' k''' -> RequesterData $ singletonTagMap k $ Entry $ Map.singleton k' $ IntMap.singleton k'' $ singletonRequesterData k''' v

93− RequesterDataKey_Multi3 k k' k'' k''' -> RequesterData $ singletonTagMap k $ Entry $ IntMap.singleton k' $ IntMap.singleton k'' $ singletonRequesterData k''' v

94−

95−requesterDataToList :: RequesterData f -> [DSum RequesterDataKey f]

96−requesterDataToList (RequesterData m) = do

97− k :=> Entry e <- tagMapToList m

98− case myKeyType k of

99− MyTagType_Single -> return $ RequesterDataKey_Single k :=> e

100− MyTagType_Multi -> do

101− (k', e') <- IntMap.toList e

102− k'' :=> e'' <- requesterDataToList e'

103− return $ RequesterDataKey_Multi k k' k'' :=> e''

104− MyTagType_Multi2 -> do

105− (k', e') <- Map.toList e

106− (k'', e'') <- IntMap.toList e'

107− k''' :=> e''' <- requesterDataToList e''

108− return $ RequesterDataKey_Multi2 k k' k'' k''' :=> e'''

109− MyTagType_Multi3 -> do

110− (k', e') <- IntMap.toList e

111− (k'', e'') <- IntMap.toList e'

112− k''' :=> e''' <- requesterDataToList e''

113− return $ RequesterDataKey_Multi3 k k' k'' k''' :=> e'''

114−

115−singletonTagMap :: forall f a. MyTag a -> f a -> TagMap f

116−singletonTagMap (MyTag k) v = TagMap $ IntMap.singleton k $ (unsafeCoerce :: f a -> Any) v

117−

118−tagMapToList :: forall f. TagMap f -> [DSum MyTag f]

119−tagMapToList (TagMap m) = f <$> IntMap.toList m

120− where f :: (Int, Any) -> DSum MyTag f

121− f (k, v) = MyTag k :=> (unsafeCoerce :: Any -> f a) v

122−

123−traverseTagMapWithKey :: forall t f g. Applicative t => (forall a. MyTag a -> f a -> t (g a)) -> TagMap f -> t (TagMap g)

124−traverseTagMapWithKey f (TagMap m) = TagMap <$> IntMap.traverseWithKey g m

125− where

126− g :: Int -> Any -> t Any

127− g k v = (unsafeCoerce :: g a -> Any) <$> f (MyTag k) ((unsafeCoerce :: Any -> f a) v)

128−

129−-- | Runs in reverse to accommodate for the fact that we accumulate it in reverse

130−traverseRequesterData :: forall m request response. Applicative m => (forall a. request a -> m (response a)) -> RequesterData request -> m (RequesterData response)

131−traverseRequesterData f (RequesterData m) = RequesterData <$> traverseTagMapWithKey go m --TODO: reverse this, since our tags are in reverse order

132− where go :: forall x. MyTag x -> Entry request x -> m (Entry response x)

133− go k (Entry request) = Entry <$> case myKeyType k of

134− MyTagType_Single -> f request

135− MyTagType_Multi -> traverse (traverseRequesterData f) request

136− MyTagType_Multi2 -> traverse (traverse (traverseRequesterData f)) request

137− MyTagType_Multi3 -> traverse (traverse (traverseRequesterData f)) request

138−

139−-- | 'traverseRequesterData' with its arguments flipped

140−forRequesterData :: forall request response m. Applicative m => RequesterData request -> (forall a. request a -> m (response a)) -> m (RequesterData response)

141−forRequesterData r f = traverseRequesterData f r

142−

143−data MyTagType :: * -> * where

144− MyTagType_Single :: MyTagType (Single a)

145− MyTagType_Multi :: MyTagType Multi

146− MyTagType_Multi2 :: MyTagType (Multi2 k)

147− MyTagType_Multi3 :: MyTagType Multi3

148−

149−myKeyType :: MyTag x -> MyTagType x

150−myKeyType (MyTag k) = case k .&. 0x3 of

151− 0x0 -> unsafeCoerce MyTagType_Single

152− 0x1 -> unsafeCoerce MyTagType_Multi

153− 0x2 -> unsafeCoerce MyTagType_Multi2

154− 0x3 -> unsafeCoerce MyTagType_Multi3

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

156−

157−data Single a

158−data Multi

159−data Multi2 (k :: * -> *)

160−data Multi3

161−

162−class MyTagTypeOffset x where

163− myTagTypeOffset :: proxy x -> Int

164−

165−instance MyTagTypeOffset (Single a) where

166− myTagTypeOffset _ = 0x0

167−

168−instance MyTagTypeOffset Multi where

169− myTagTypeOffset _ = 0x1

170−

171−instance MyTagTypeOffset (Multi2 k) where

172− myTagTypeOffset _ = 0x2

173−

174−instance MyTagTypeOffset Multi3 where

175− myTagTypeOffset _ = 0x3

176−

177−type family EntryContents request a where

178− EntryContents request (Single a) = request a

179− EntryContents request Multi = IntMap (RequesterData request)

180− EntryContents request (Multi2 k) = Map (Some k) (IntMap (RequesterData request))

181− EntryContents request Multi3 = IntMap (IntMap (RequesterData request))

182−

183−newtype Entry request x = Entry { unEntry :: EntryContents request x }

184−

185−{-# INLINE singleEntry #-}

186−singleEntry :: f a -> Entry f (Single a)

187−singleEntry = Entry

188−

189−{-# INLINE multiEntry #-}

190−multiEntry :: IntMap (RequesterData f) -> Entry f Multi

191−multiEntry = Entry

192−

193−{-# INLINE unMultiEntry #-}

194−unMultiEntry :: Entry f Multi -> IntMap (RequesterData f)

195−unMultiEntry = unEntry

196−

197−-- | 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

198−-- 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

199−newtype MyTag x = MyTag Int deriving (Show, Eq, Ord, Enum)

200−

201−newtype MyTagWrap (f :: * -> *) x = MyTagWrap Int deriving (Show, Eq, Ord, Enum)

202−

203−{-# INLINE castMyTagWrap #-}

204−castMyTagWrap :: MyTagWrap f (Entry f x) -> MyTagWrap g (Entry g x)

205−castMyTagWrap = coerce

206−

207−instance GEq MyTag where

208− (MyTag a) `geq` (MyTag b) =

209− if a == b

210− then Just $ unsafeCoerce Refl

211− else Nothing

212−

213−instance GCompare MyTag where

214− (MyTag a) `gcompare` (MyTag b) =

215− case a `compare` b of

216− LT -> GLT

217− EQ -> unsafeCoerce GEQ

218− GT -> GGT

219−

220−instance GEq (MyTagWrap f) where

221− (MyTagWrap a) `geq` (MyTagWrap b) =

222− if a == b

223− then Just $ unsafeCoerce Refl

224− else Nothing

225−

226−instance GCompare (MyTagWrap f) where

227− (MyTagWrap a) `gcompare` (MyTagWrap b) =

228− case a `compare` b of

229− LT -> GLT

230− EQ -> unsafeCoerce GEQ

231− GT -> GGT

232−

233−data RequesterState t (request :: * -> *) = RequesterState

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

235− , _requesterState_requests :: ![(Int, Event t Any)]

236− }

237−

238−-- | A basic implementation of 'Requester'.

239−newtype RequesterT t request (response :: * -> *) m a = RequesterT { unRequesterT :: StateT (RequesterState t request) (ReaderT (EventSelectorInt t Any) m) a }

240− deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException

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

242−#if MIN_VERSION_base(4,9,1)

243− , MonadAsyncException

244−#endif

245− )

246−

247−deriving instance MonadSample t m => MonadSample t (RequesterT t request response m)

248−deriving instance MonadHold t m => MonadHold t (RequesterT t request response m)

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

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

251−

252−instance PrimMonad m => PrimMonad (RequesterT t request response m) where

253− type PrimState (RequesterT t request response m) = PrimState m

254− primitive = lift . primitive

255−

256−-- TODO: Monoid and Semigroup can likely be derived once StateT has them.

257−instance (Monoid a, Monad m) => Monoid (RequesterT t request response m a) where

258− mempty = pure mempty

259− mappend = liftA2 mappend

260−

261−instance (S.Semigroup a, Monad m) => S.Semigroup (RequesterT t request response m a) where

262− (<>) = liftA2 (S.<>)

263−

264−

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

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

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

268−-- requests were issued.

269−runRequesterT :: (Reflex t, Monad m)

270− => RequesterT t request response m a

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

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

273−runRequesterT (RequesterT a) responses = do

274− (result, s) <- runReaderT (runStateT a $ RequesterState (-4) []) $ fanInt $

275− coerceEvent responses

276− return (result, fmapCheap (RequesterData . TagMap) $ mergeInt $ IntMap.fromDistinctAscList $ _requesterState_requests s)

277−

278−-- | Map a function over the request and response of a 'RequesterT'

279−withRequesterT

280− :: (Reflex t, MonadFix m)

281− => (forall x. req x -> req' x) -- ^ The function to map over the request

282− -> (forall x. rsp' x -> rsp x) -- ^ The function to map over the response

283− -> RequesterT t req rsp m a -- ^ The internal 'RequesterT' whose input and output will be transformed

284− -> RequesterT t req' rsp' m a -- ^ The resulting 'RequesterT'

285−withRequesterT freq frsp child = do

286− rec let rsp = fmap (runIdentity . traverseRequesterData (Identity . frsp)) rsp'

287− (a, req) <- lift $ runRequesterT child rsp

288− rsp' <- fmap (flip selectInt 0 . fanInt . fmapCheap unMultiEntry) $ requesting' $

289− fmapCheap (multiEntry . IntMap.singleton 0) $ fmap (runIdentity . traverseRequesterData (Identity . freq)) req

290− return a

291−

292−instance (Reflex t, Monad m) => Requester t (RequesterT t request response m) where

293− type Request (RequesterT t request response m) = request

294− type Response (RequesterT t request response m) = response

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

296− requesting_ = void . tagRequest . fmapCheap singleEntry

297−

298−{-# INLINE tagRequest #-}

299−tagRequest :: forall m x t request response. (Monad m, MyTagTypeOffset x) => Event t (Entry request x) -> RequesterT t request response m (MyTagWrap request (Entry request x))

300−tagRequest req = do

301− old <- RequesterT get

302− let n = _requesterState_nextMyTag old .|. myTagTypeOffset (Proxy :: Proxy x)

303− t = MyTagWrap n

304− RequesterT $ put $ RequesterState

305− { _requesterState_nextMyTag = _requesterState_nextMyTag old - 0x4

306− , _requesterState_requests = (n, (unsafeCoerce :: Event t (Entry request x) -> Event t Any) req) : _requesterState_requests old

307− }

308− return t

309−

310−{-# INLINE responseFromTag #-}

311−responseFromTag :: Monad m => MyTagWrap response (Entry response x) -> RequesterT t request response m (Event t (Entry response x))

312−responseFromTag (MyTagWrap t) = do

313− responses :: EventSelectorInt t Any <- RequesterT ask

314− return $ (unsafeCoerce :: Event t Any -> Event t (Entry response x)) $ selectInt responses t

315−

316−instance MonadTrans (RequesterT t request response) where

317− lift = RequesterT . lift . lift

318−

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

320− type Performable (RequesterT t request response m) = Performable m

321− performEvent_ = lift . performEvent_

322− performEvent = lift . performEvent

323−

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

325− type Ref (RequesterT t request response m) = Ref m

326− newRef = lift . newRef

327− readRef = lift . readRef

328− writeRef r = lift . writeRef r

329−

330−instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (RequesterT t request response m) where

331− newEventWithTrigger = lift . newEventWithTrigger

332− newFanEventWithTrigger f = lift $ newFanEventWithTrigger f

333−

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

335− ask = lift ask

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

337− reader = lift . reader

338−

339−instance (Reflex t, Adjustable t m, MonadHold t m, MonadFix m) => Adjustable t (RequesterT t request response m) where

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

341− traverseIntMapWithKeyWithAdjust = traverseIntMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseIntMapWithKeyWithAdjust f dm0 dm') patchIntMapNewElementsMap mergeIntIncremental

342− {-# INLINABLE traverseDMapWithKeyWithAdjust #-}

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

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

345−

346−requesting' :: (MyTagTypeOffset x, Monad m) => Event t (Entry request x) -> RequesterT t request response m (Event t (Entry response x))

347−requesting' = responseFromTag . castMyTagWrap <=< tagRequest

348−

349−{-# INLINABLE runWithReplaceRequesterTWith #-}

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

351− , MonadFix m

352− )

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

354− -> RequesterT t request response m a

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

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

357−runWithReplaceRequesterTWith f a0 a' = do

358− rec na' <- numberOccurrencesFrom 1 a'

359− responses <- fmap (fmapCheap unMultiEntry) $ requesting' $ fmapCheap multiEntry $ switchPromptlyDyn requests --TODO: Investigate whether we can really get rid of the prompt stuff here

360− let responses' = fanInt responses

361− ((result0, requests0), v') <- f (runRequesterT a0 (selectInt responses' 0)) $ fmapCheap (\(n, a) -> fmap ((,) n) $ runRequesterT a $ selectInt responses' n) na'

362− requests <- holdDyn (fmapCheap (IntMap.singleton 0) requests0) $ fmapCheap (\(n, (_, reqs)) -> fmapCheap (IntMap.singleton n) reqs) v'

363− return (result0, fmapCheap (fst . snd) v')

364−

365−{-# INLINE traverseIntMapWithKeyWithAdjustRequesterTWith #-}

366−traverseIntMapWithKeyWithAdjustRequesterTWith :: forall t request response m v v' p.

367− ( Reflex t

368− , MonadHold t m

369− , PatchTarget (p (Event t (IntMap (RequesterData request)))) ~ IntMap (Event t (IntMap (RequesterData request)))

370− , Patch (p (Event t (IntMap (RequesterData request))))

371− , Functor p

372− , MonadFix m

373− )

374− => ( (IntMap.Key -> (IntMap.Key, v) -> m (Event t (IntMap (RequesterData request)), v'))

375− -> IntMap (IntMap.Key, v)

376− -> Event t (p (IntMap.Key, v))

377− -> RequesterT t request response m (IntMap (Event t (IntMap (RequesterData request)), v'), Event t (p (Event t (IntMap (RequesterData request)), v')))

378− )

379− -> (p (Event t (IntMap (RequesterData request))) -> IntMap (Event t (IntMap (RequesterData request))))

380− -> (Incremental t (p (Event t (IntMap (RequesterData request)))) -> Event t (IntMap (IntMap (RequesterData request))))

381− -> (IntMap.Key -> v -> RequesterT t request response m v')

382− -> IntMap v

383− -> Event t (p v)

384− -> RequesterT t request response m (IntMap v', Event t (p v'))

385−traverseIntMapWithKeyWithAdjustRequesterTWith base patchNewElements mergePatchIncremental f dm0 dm' = do

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

387− let responses :: EventSelectorInt t (IntMap (RequesterData response))

388− responses = fanInt $ fmapCheap unpack response

389− unpack :: Entry response Multi3 -> IntMap (IntMap (RequesterData response))

390− unpack = unEntry

391− pack :: IntMap (IntMap (RequesterData request)) -> Entry request Multi3

392− pack = Entry

393− f' :: IntMap.Key -> (Int, v) -> m (Event t (IntMap (RequesterData request)), v')

394− f' k (n, v) = do

395− (result, myRequests) <- runRequesterT (f k v) $ mapMaybeCheap (IntMap.lookup n) $ selectInt responses k --TODO: Instead of doing mapMaybeCheap, can we share a fanInt across all instances of a given key, or at least the ones that are adjacent in time?

396− return (fmapCheap (IntMap.singleton n) myRequests, result)

397− ndm' <- numberOccurrencesFrom 1 dm'

398− (children0, children') <- base f' (fmap ((,) 0) dm0) $ fmap (\(n, dm) -> fmap ((,) n) dm) ndm' --TODO: Avoid this somehow, probably by adding some sort of per-cohort information passing to Adjustable

399− let result0 = fmap snd children0

400− result' = fforCheap children' $ fmap snd

401− requests0 :: IntMap (Event t (IntMap (RequesterData request)))

402− requests0 = fmap fst children0

403− requests' :: Event t (p (Event t (IntMap (RequesterData request))))

404− requests' = fforCheap children' $ fmap fst

405− promptRequests :: Event t (IntMap (IntMap (RequesterData request)))

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

407− requests <- holdIncremental requests0 requests'

408− return (result0, result')

409−

410−{-# INLINE traverseDMapWithKeyWithAdjustRequesterTWith #-}

411−traverseDMapWithKeyWithAdjustRequesterTWith :: forall k t request response m v v' p p'.

412− ( GCompare k

413− , Reflex t

414− , MonadHold t m

415− , PatchTarget (p' (Some k) (Event t (IntMap (RequesterData request)))) ~ Map (Some k) (Event t (IntMap (RequesterData request)))

416− , Patch (p' (Some k) (Event t (IntMap (RequesterData request))))

417− , MonadFix m

418− )

419− => (forall k' v1 v2. GCompare k'

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

421− -> DMap k' v1

422− -> Event t (p k' v1)

423− -> RequesterT t request response m (DMap k' v2, Event t (p k' v2))

424− )

425− -> (forall v1 v2. (forall a. v1 a -> v2 a) -> p k v1 -> p k v2)

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

427− -> (forall v2. p' (Some k) v2 -> Map (Some k) v2)

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

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

430− -> DMap k v

431− -> Event t (p k v)

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

433−traverseDMapWithKeyWithAdjustRequesterTWith base mapPatch weakenPatchWith patchNewElements mergePatchIncremental f dm0 dm' = do

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

435− let responses :: EventSelector t (Const2 (Some k) (IntMap (RequesterData response)))

436− responses = fanMap $ fmapCheap unpack response

437− unpack :: Entry response (Multi2 k) -> Map (Some k) (IntMap (RequesterData response))

438− unpack = unEntry

439− pack :: Map (Some k) (IntMap (RequesterData request)) -> Entry request (Multi2 k)

440− pack = Entry

441− f' :: forall a. k a -> Compose ((,) Int) v a -> m (Compose ((,) (Event t (IntMap (RequesterData request)))) v' a)

442− f' k (Compose (n, v)) = do

443− (result, myRequests) <- runRequesterT (f k v) $ mapMaybeCheap (IntMap.lookup n) $ select responses (Const2 (Some k))

444− return $ Compose (fmapCheap (IntMap.singleton n) myRequests, result)

445− ndm' <- numberOccurrencesFrom 1 dm'

446− (children0, children') <- base f' (DMap.map (\v -> Compose (0, v)) dm0) $ fmap (\(n, dm) -> mapPatch (\v -> Compose (n, v)) dm) ndm'

447− let result0 = DMap.map (snd . getCompose) children0

448− result' = fforCheap children' $ mapPatch $ snd . getCompose

449− requests0 :: Map (Some k) (Event t (IntMap (RequesterData request)))

450− requests0 = weakenDMapWith (fst . getCompose) children0

451− requests' :: Event t (p' (Some k) (Event t (IntMap (RequesterData request))))

452− requests' = fforCheap children' $ weakenPatchWith $ fst . getCompose

453− promptRequests :: Event t (Map (Some k) (IntMap (RequesterData request)))

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

455− requests <- holdIncremental requests0 requests'

456− return (result0, result')

457−

458−data Decoder rawResponse response =

459− forall a. Decoder (RequesterDataKey a) (rawResponse -> response a)

460−

461−-- | Matches incoming responses with previously-sent requests

462−-- and uses the provided request "decoder" function to process

463−-- incoming responses.

464−matchResponsesWithRequests

465− :: forall t rawRequest rawResponse request response m.

466− ( MonadFix m

467− , MonadHold t m

468− , Reflex t

469− )

470− => (forall a. request a -> (rawRequest, rawResponse -> response a))

471− -- ^ Given a request (from 'Requester'), produces the wire format of the

472− -- request and a function used to process the associated response

473− -> Event t (RequesterData request)

474− -- ^ The outgoing requests

475− -> Event t (Int, rawResponse)

476− -- ^ The incoming responses, tagged by an identifying key

477− -> m ( Event t (Map Int rawRequest)

478− , Event t (RequesterData response)

479− )

480− -- ^ A map of outgoing wire-format requests and an event of responses keyed

481− -- by the 'RequesterData' key of the associated outgoing request

482−matchResponsesWithRequests f send recv = do

483− rec nextId <- hold 1 $ fmap (\(next, _, _) -> next) outgoing

484− waitingFor :: Incremental t (PatchMap Int (Decoder rawResponse response)) <-

485− holdIncremental mempty $ leftmost

486− [ fmap (\(_, outstanding, _) -> outstanding) outgoing

487− , snd <$> incoming

488− ]

489− let outgoing = processOutgoing nextId send

490− incoming = processIncoming waitingFor recv

491− return (fmap (\(_, _, rawReqs) -> rawReqs) outgoing, fst <$> incoming)

492− where

493− -- Tags each outgoing request with an identifying integer key

494− -- and returns the next available key, a map of response decoders

495− -- for requests for which there are outstanding responses, and the

496− -- raw requests to be sent out.

497− processOutgoing

498− :: Behavior t Int

499− -- The next available key

500− -> Event t (RequesterData request)

501− -- The outgoing request

502− -> Event t ( Int

503− , PatchMap Int (Decoder rawResponse response)

504− , Map Int rawRequest )

505− -- The new next-available-key, a map of requests expecting responses, and the tagged raw requests

506− processOutgoing nextId out = flip pushAlways out $ \dm -> do

507− oldNextId <- sample nextId

508− let (result, newNextId) = flip runState oldNextId $ forM (requesterDataToList dm) $ \(k :=> v) -> do

509− n <- get

510− put $ succ n

511− let (rawReq, rspF) = f v

512− return (n, rawReq, Decoder k rspF)

513− patchWaitingFor = PatchMap $ Map.fromList $

514− (\(n, _, dec) -> (n, Just dec)) <$> result

515− toSend = Map.fromList $ (\(n, rawReq, _) -> (n, rawReq)) <$> result

516− return (newNextId, patchWaitingFor, toSend)

517− -- Looks up the each incoming raw response in a map of response

518− -- decoders and returns the decoded response and a patch that can

519− -- be used to clear the ID of the consumed response out of the queue

520− -- of expected responses.

521− processIncoming

522− :: Incremental t (PatchMap Int (Decoder rawResponse response))

523− -- A map of outstanding expected responses

524− -> Event t (Int, rawResponse)

525− -- A incoming response paired with its identifying key

526− -> Event t (RequesterData response, PatchMap Int v)

527− -- The decoded response and a patch that clears the outstanding responses queue

528− processIncoming waitingFor inc = flip push inc $ \(n, rawRsp) -> do

529− wf <- sample $ currentIncremental waitingFor

530− case Map.lookup n wf of

531− Nothing -> return Nothing -- TODO How should lookup failures be handled here? They shouldn't ever happen..

532− Just (Decoder k rspF) -> do

533− let rsp = rspF rawRsp

534− return $ Just

535− ( singletonRequesterData k rsp

536− , PatchMap $ Map.singleton n Nothing

537− )

src/Reflex/Requester/Base/Internal.hsnew file+661

@@ -0,0 +1,661 @@

1+{-# LANGUAGE AllowAmbiguousTypes #-}

2+{-# LANGUAGE CPP #-}

3+{-# LANGUAGE EmptyDataDecls #-}

4+{-# LANGUAGE ExistentialQuantification #-}

5+{-# LANGUAGE FlexibleInstances #-}

6+{-# LANGUAGE GADTs #-}

7+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

8+{-# LANGUAGE MultiParamTypeClasses #-}

9+{-# LANGUAGE Rank2Types #-}

10+{-# LANGUAGE RecursiveDo #-}

11+{-# LANGUAGE ScopedTypeVariables #-}

12+{-# LANGUAGE StandaloneDeriving #-}

13+{-# LANGUAGE TypeFamilies #-}

14+{-# LANGUAGE TypeOperators #-}

15+{-# LANGUAGE UndecidableInstances #-}

16+{-# LANGUAGE InstanceSigs #-}

17+#ifdef USE_REFLEX_OPTIMIZER

18+{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}

19+#endif

20+module Reflex.Requester.Base.Internal where

21+

22+import Reflex.Class

23+import Reflex.Adjustable.Class

24+import Reflex.Dynamic

25+import Reflex.Host.Class

26+import Reflex.PerformEvent.Class

27+import Reflex.PostBuild.Class

28+import Reflex.Requester.Class

29+import Reflex.TriggerEvent.Class

30+import Reflex.EventWriter.Base

31+import Reflex.EventWriter.Class

32+

33+import Control.Applicative (liftA2)

34+import Control.Monad.Exception

35+import Control.Monad.Identity

36+import Control.Monad.Primitive

37+import Control.Monad.Reader

38+import Control.Monad.Ref

39+import Control.Monad.State.Strict

40+import Data.Bits

41+import Data.Coerce

42+import Data.Dependent.Map (DMap, DSum (..))

43+import qualified Data.Dependent.Map as DMap

44+import Data.Functor.Compose

45+import Data.Functor.Misc

46+import Data.IntMap.Strict (IntMap)

47+import qualified Data.IntMap.Strict as IntMap

48+import Data.Map (Map)

49+import qualified Data.Map as Map

50+import Data.Monoid ((<>))

51+import Data.Proxy

52+import qualified Data.Semigroup as S

53+import Data.Some (Some(Some))

54+import Data.Type.Equality

55+import Data.Sequence (Seq)

56+import qualified Data.Sequence as Seq

57+import Data.TagMap (TagMap)

58+import qualified Data.TagMap as TagMap

59+import Reflex.FanTag

60+import Data.Unique.Tag.Local

61+import qualified Data.Unique.Tag as Global

62+import Data.GADT.Compare

63+import Data.Witherable

64+import Data.Foldable

65+

66+data RequestData ps request = forall s. RequestData !(TagGen ps s) !(Seq (RequestEnvelope s request))

67+data ResponseData ps response = forall s. ResponseData !(TagGen ps s) !(TagMap s response)

68+

69+traverseRequesterData :: forall m request response. Applicative m => (forall a. request a -> m (response a)) -> RequestData (PrimState m) request -> m (ResponseData (PrimState m) response)

70+traverseRequesterData f (RequestData tg es) = ResponseData tg . TagMap.fromList <$> wither g (toList es)

71+ where g (RequestEnvelope mt req) = case mt of

72+ Just t -> (\rsp -> Just $ t :=> rsp) <$> f req

73+ Nothing -> Nothing <$ f req

74+

75+runRequesterT :: forall t request response m a

76+ . ( Reflex t

77+ , PrimMonad m

78+ , MonadFix m

79+ )

80+ => RequesterT t request response m a

81+ -> Event t (ResponseData (PrimState m) response)

82+ -> m (a, Event t (RequestData (PrimState m) request))

83+runRequesterT (RequesterT a) wrappedResponses = withRequesterInternalT $ \(requests :: Event t (Seq (RequestEnvelope s request))) -> do

84+ (_, tg) <- RequesterInternalT ask

85+ result <- a

86+ let responses = fforMaybe wrappedResponses $ \(ResponseData tg' m) -> case tg `geq` tg' of

87+ Nothing -> Nothing --TODO: Warn somehow

88+ Just Refl -> Just m

89+ pure (responses, (result, fmapCheap (RequestData tg) requests))

90+

91+instance MonadTrans (RequesterInternalT s t request response) where

92+ lift = RequesterInternalT . lift . lift

93+

94+instance MonadTrans (RequesterT t request response) where

95+ lift a = RequesterT $ RequesterInternalT $ lift $ lift a

96+

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

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

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

100+-- requests were issued.

101+withRequesterInternalT

102+ :: ( Reflex t

103+ , PrimMonad m

104+ , MonadFix m

105+ )

106+ => (forall s. Event t (Seq (RequestEnvelope s request)) -> RequesterInternalT s t request response m (Event t (TagMap s response), a))

107+ -> m a

108+withRequesterInternalT f = withTagGen $ \tg -> do

109+ rec let RequesterInternalT a = f requests

110+ ((responses, result), requests) <- runEventWriterT $ runReaderT a (fanTag responses, tg)

111+ pure result

112+

113+data RequestEnvelope s request = forall a. RequestEnvelope {-# UNPACK #-} !(Maybe (Tag s a)) !(request a)

114+

115+newtype RequesterT t (request :: * -> *) (response :: * -> *) m a = RequesterT { unRequesterT :: forall s. RequesterInternalT s t request response m a }

116+

117+instance Functor m => Functor (RequesterT t request response m) where

118+ fmap f (RequesterT x) = RequesterT $ fmap f x

119+

120+instance Monad m => Applicative (RequesterT t request response m) where

121+ pure x = RequesterT $ pure x

122+ RequesterT f <*> RequesterT x = RequesterT $ f <*> x

123+ liftA2 f (RequesterT a) (RequesterT b) = RequesterT $ liftA2 f a b

124+ RequesterT f <* RequesterT x = RequesterT $ f <* x

125+ RequesterT f *> RequesterT x = RequesterT $ f *> x

126+

127+instance Monad m => Monad (RequesterT t request response m) where

128+ return = pure

129+ RequesterT mx >>= f = RequesterT $ mx >>= \x -> case f x of

130+ RequesterT y -> y

131+

132+instance MonadFix m => MonadFix (RequesterT t request response m) where

133+ mfix f = RequesterT $ mfix $ \x -> case f x of

134+ RequesterT a -> a

135+

136+instance MonadIO m => MonadIO (RequesterT t request respnose m) where

137+ liftIO a = RequesterT $ liftIO a

138+

139+instance MonadException m => MonadException (RequesterT t request respnose m) where

140+ throw e = RequesterT $ throw e

141+

142+newtype RequesterInternalT s t request response m a = RequesterInternalT { unRequesterInternalT :: ReaderT (EventSelectorTag t s response, TagGen (PrimState m) s) (EventWriterT t (Seq (RequestEnvelope s request)) m) a }

143+ deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException)

144+

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

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

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

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

149+

150+instance PrimMonad m => PrimMonad (RequesterT t request response m) where

151+ type PrimState (RequesterT t request response m) = PrimState m

152+ primitive = lift . primitive

153+

154+-- TODO: Monoid and Semigroup can likely be derived once StateT has them.

155+instance (Monoid a, Monad m) => Monoid (RequesterT t request response m a) where

156+ mempty = pure mempty

157+ mappend = liftA2 mappend

158+

159+instance (S.Semigroup a, Monad m) => S.Semigroup (RequesterT t request response m a) where

160+ (<>) = liftA2 (S.<>)

161+

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

163+ type Performable (RequesterT t request response m) = Performable m

164+ performEvent_ = lift . performEvent_

165+ performEvent = lift . performEvent

166+

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

168+ type Ref (RequesterT t request response m) = Ref m

169+ newRef = lift . newRef

170+ readRef = lift . readRef

171+ writeRef r = lift . writeRef r

172+

173+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (RequesterT t request response m) where

174+ newEventWithTrigger = lift . newEventWithTrigger

175+ newFanEventWithTrigger f = lift $ newFanEventWithTrigger f

176+

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

178+ ask = lift ask

179+ local f (RequesterT a) = RequesterT $ RequesterInternalT $ mapReaderT (mapEventWriterT $ local f) $ unRequesterInternalT a

180+ reader = lift . reader

181+

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

183+ type Request (RequesterT t request response m) = request

184+ type Response (RequesterT t request response m) = response

185+ requesting e = RequesterT $ requesting e

186+ requesting_ e = RequesterT $ requesting_ e

187+

188+instance (Reflex t, PrimMonad m) => Requester t (RequesterInternalT s t request response m) where

189+ type Request (RequesterInternalT s t request response m) = request

190+ type Response (RequesterInternalT s t request response m) = response

191+ requesting e = RequesterInternalT $ do

192+ (s, tg) <- ask

193+ t <- lift $ lift $ newTag tg

194+ tellEvent $ fmapCheap (Seq.singleton . RequestEnvelope (Just t)) e

195+ pure $ selectTag s t

196+ requesting_ e = RequesterInternalT $ do

197+ tellEvent $ fmapCheap (Seq.singleton . RequestEnvelope Nothing) e

198+

199+instance Adjustable t m => Adjustable t (RequesterInternalT s t request response m)

200+

201+{-# INLINABLE runWithReplaceRequesterTWith #-}

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

203+ , MonadFix m

204+ )

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

206+ -> RequesterT t request response m a

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

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

209+runWithReplaceRequesterTWith f (RequesterT a0) a' = RequesterT $ do

210+ pure undefined

211+

212+{-

213+import GHC.Exts (Any)

214+import Unsafe.Coerce

215+

216+--TODO: Make this module type-safe

217+

218+newtype TagMap (f :: * -> *) = TagMap (IntMap Any)

219+

220+newtype RequesterData f = RequesterData (TagMap (Entry f))

221+

222+data RequesterDataKey a where

223+ RequesterDataKey_Single :: {-# UNPACK #-} !(MyTag (Single a)) -> RequesterDataKey a

224+ RequesterDataKey_Multi :: {-# UNPACK #-} !(MyTag Multi) -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a --TODO: Don't put a second Int here (or in the other Multis); use a single Int instead

225+ RequesterDataKey_Multi2 :: {-# UNPACK #-} !(MyTag (Multi2 k)) -> !(Some k) -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a

226+ RequesterDataKey_Multi3 :: {-# UNPACK #-} !(MyTag Multi3) -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a

227+

228+singletonRequesterData :: RequesterDataKey a -> f a -> RequesterData f

229+singletonRequesterData rdk v = case rdk of

230+ RequesterDataKey_Single k -> RequesterData $ singletonTagMap k $ Entry v

231+ RequesterDataKey_Multi k k' k'' -> RequesterData $ singletonTagMap k $ Entry $ IntMap.singleton k' $ singletonRequesterData k'' v

232+ RequesterDataKey_Multi2 k k' k'' k''' -> RequesterData $ singletonTagMap k $ Entry $ Map.singleton k' $ IntMap.singleton k'' $ singletonRequesterData k''' v

233+ RequesterDataKey_Multi3 k k' k'' k''' -> RequesterData $ singletonTagMap k $ Entry $ IntMap.singleton k' $ IntMap.singleton k'' $ singletonRequesterData k''' v

234+

235+requesterDataToList :: RequesterData f -> [DSum RequesterDataKey f]

236+requesterDataToList (RequesterData m) = do

237+ k :=> Entry e <- tagMapToList m

238+ case myKeyType k of

239+ MyTagType_Single -> return $ RequesterDataKey_Single k :=> e

240+ MyTagType_Multi -> do

241+ (k', e') <- IntMap.toList e

242+ k'' :=> e'' <- requesterDataToList e'

243+ return $ RequesterDataKey_Multi k k' k'' :=> e''

244+ MyTagType_Multi2 -> do

245+ (k', e') <- Map.toList e

246+ (k'', e'') <- IntMap.toList e'

247+ k''' :=> e''' <- requesterDataToList e''

248+ return $ RequesterDataKey_Multi2 k k' k'' k''' :=> e'''

249+ MyTagType_Multi3 -> do

250+ (k', e') <- IntMap.toList e

251+ (k'', e'') <- IntMap.toList e'

252+ k''' :=> e''' <- requesterDataToList e''

253+ return $ RequesterDataKey_Multi3 k k' k'' k''' :=> e'''

254+

255+singletonTagMap :: forall f a. MyTag a -> f a -> TagMap f

256+singletonTagMap (MyTag k) v = TagMap $ IntMap.singleton k $ (unsafeCoerce :: f a -> Any) v

257+

258+tagMapToList :: forall f. TagMap f -> [DSum MyTag f]

259+tagMapToList (TagMap m) = f <$> IntMap.toList m

260+ where f :: (Int, Any) -> DSum MyTag f

261+ f (k, v) = MyTag k :=> (unsafeCoerce :: Any -> f a) v

262+

263+traverseTagMapWithKey :: forall t f g. Applicative t => (forall a. MyTag a -> f a -> t (g a)) -> TagMap f -> t (TagMap g)

264+traverseTagMapWithKey f (TagMap m) = TagMap <$> IntMap.traverseWithKey g m

265+ where

266+ g :: Int -> Any -> t Any

267+ g k v = (unsafeCoerce :: g a -> Any) <$> f (MyTag k) ((unsafeCoerce :: Any -> f a) v)

268+

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

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

271+traverseRequesterData f (RequesterData m) = RequesterData <$> traverseTagMapWithKey go m --TODO: reverse this, since our tags are in reverse order

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

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

274+ MyTagType_Single -> f request

275+ MyTagType_Multi -> traverse (traverseRequesterData f) request

276+ MyTagType_Multi2 -> traverse (traverse (traverseRequesterData f)) request

277+ MyTagType_Multi3 -> traverse (traverse (traverseRequesterData f)) request

278+

279+-- | 'traverseRequesterData' with its arguments flipped

280+forRequesterData :: forall request response m. Applicative m => RequesterData request -> (forall a. request a -> m (response a)) -> m (RequesterData response)

281+forRequesterData r f = traverseRequesterData f r

282+

283+data MyTagType :: * -> * where

284+ MyTagType_Single :: MyTagType (Single a)

285+ MyTagType_Multi :: MyTagType Multi

286+ MyTagType_Multi2 :: MyTagType (Multi2 k)

287+ MyTagType_Multi3 :: MyTagType Multi3

288+

289+myKeyType :: MyTag x -> MyTagType x

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

291+ 0x0 -> unsafeCoerce MyTagType_Single

292+ 0x1 -> unsafeCoerce MyTagType_Multi

293+ 0x2 -> unsafeCoerce MyTagType_Multi2

294+ 0x3 -> unsafeCoerce MyTagType_Multi3

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

296+

297+data Single a

298+data Multi

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

300+data Multi3

301+

302+class MyTagTypeOffset x where

303+ myTagTypeOffset :: proxy x -> Int

304+

305+instance MyTagTypeOffset (Single a) where

306+ myTagTypeOffset _ = 0x0

307+

308+instance MyTagTypeOffset Multi where

309+ myTagTypeOffset _ = 0x1

310+

311+instance MyTagTypeOffset (Multi2 k) where

312+ myTagTypeOffset _ = 0x2

313+

314+instance MyTagTypeOffset Multi3 where

315+ myTagTypeOffset _ = 0x3

316+

317+type family EntryContents request a where

318+ EntryContents request (Single a) = request a

319+ EntryContents request Multi = IntMap (RequesterData request)

320+ EntryContents request (Multi2 k) = Map (Some k) (IntMap (RequesterData request))

321+ EntryContents request Multi3 = IntMap (IntMap (RequesterData request))

322+

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

324+

325+{-# INLINE singleEntry #-}

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

327+singleEntry = Entry

328+

329+{-# INLINE multiEntry #-}

330+multiEntry :: IntMap (RequesterData f) -> Entry f Multi

331+multiEntry = Entry

332+

333+{-# INLINE unMultiEntry #-}

334+unMultiEntry :: Entry f Multi -> IntMap (RequesterData f)

335+unMultiEntry = unEntry

336+

337+-- | 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

338+-- 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

339+newtype MyTag x = MyTag Int deriving (Show, Eq, Ord, Enum)

340+

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

342+

343+{-# INLINE castMyTagWrap #-}

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

345+castMyTagWrap = coerce

346+

347+instance GEq MyTag where

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

349+ if a == b

350+ then Just $ unsafeCoerce Refl

351+ else Nothing

352+

353+instance GCompare MyTag where

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

355+ case a `compare` b of

356+ LT -> GLT

357+ EQ -> unsafeCoerce GEQ

358+ GT -> GGT

359+

360+instance GEq (MyTagWrap f) where

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

362+ if a == b

363+ then Just $ unsafeCoerce Refl

364+ else Nothing

365+

366+instance GCompare (MyTagWrap f) where

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

368+ case a `compare` b of

369+ LT -> GLT

370+ EQ -> unsafeCoerce GEQ

371+ GT -> GGT

372+

373+data RequesterState t (request :: * -> *) = RequesterState

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

375+ , _requesterState_requests :: ![(Int, Event t Any)]

376+ }

377+

378+-- | A basic implementation of 'Requester'.

379+newtype RequesterT t request (response :: * -> *) m a = RequesterT { unRequesterT :: StateT (RequesterState t request) (ReaderT (EventSelectorInt t Any) m) a }

380+ deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException

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

382+#if MIN_VERSION_base(4,9,1)

383+ , MonadAsyncException

384+#endif

385+ )

386+

387+

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

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

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

391+-- requests were issued.

392+runRequesterT :: (Reflex t, Monad m)

393+ => RequesterT t request response m a

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

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

396+runRequesterT (RequesterT a) responses = do

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

398+ coerceEvent responses

399+ return (result, fmapCheap (RequesterData . TagMap) $ mergeInt $ IntMap.fromDistinctAscList $ _requesterState_requests s)

400+

401+-- | Map a function over the request and response of a 'RequesterT'

402+withRequesterT

403+ :: (Reflex t, MonadFix m)

404+ => (forall x. req x -> req' x) -- ^ The function to map over the request

405+ -> (forall x. rsp' x -> rsp x) -- ^ The function to map over the response

406+ -> RequesterT t req rsp m a -- ^ The internal 'RequesterT' whose input and output will be transformed

407+ -> RequesterT t req' rsp' m a -- ^ The resulting 'RequesterT'

408+withRequesterT freq frsp child = do

409+ rec let rsp = fmap (runIdentity . traverseRequesterData (Identity . frsp)) rsp'

410+ (a, req) <- lift $ runRequesterT child rsp

411+ rsp' <- fmap (flip selectInt 0 . fanInt . fmapCheap unMultiEntry) $ requesting' $

412+ fmapCheap (multiEntry . IntMap.singleton 0) $ fmap (runIdentity . traverseRequesterData (Identity . freq)) req

413+ return a

414+

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

416+ type Request (RequesterT t request response m) = request

417+ type Response (RequesterT t request response m) = response

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

419+ requesting_ = void . tagRequest . fmapCheap singleEntry

420+

421+{-# INLINE tagRequest #-}

422+tagRequest :: forall m x t request response. (Monad m, MyTagTypeOffset x) => Event t (Entry request x) -> RequesterT t request response m (MyTagWrap request (Entry request x))

423+tagRequest req = do

424+ old <- RequesterT get

425+ let n = _requesterState_nextMyTag old .|. myTagTypeOffset (Proxy :: Proxy x)

426+ t = MyTagWrap n

427+ RequesterT $ put $ RequesterState

428+ { _requesterState_nextMyTag = _requesterState_nextMyTag old - 0x4

429+ , _requesterState_requests = (n, (unsafeCoerce :: Event t (Entry request x) -> Event t Any) req) : _requesterState_requests old

430+ }

431+ return t

432+

433+{-# INLINE responseFromTag #-}

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

435+responseFromTag (MyTagWrap t) = do

436+ responses :: EventSelectorInt t Any <- RequesterT ask

437+ return $ (unsafeCoerce :: Event t Any -> Event t (Entry response x)) $ selectInt responses t

438+

439+instance MonadTrans (RequesterT t request response) where

440+ lift = RequesterT . lift . lift

441+

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

443+ type Performable (RequesterT t request response m) = Performable m

444+ performEvent_ = lift . performEvent_

445+ performEvent = lift . performEvent

446+

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

448+ type Ref (RequesterT t request response m) = Ref m

449+ newRef = lift . newRef

450+ readRef = lift . readRef

451+ writeRef r = lift . writeRef r

452+

453+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (RequesterT t request response m) where

454+ newEventWithTrigger = lift . newEventWithTrigger

455+ newFanEventWithTrigger f = lift $ newFanEventWithTrigger f

456+

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

458+ ask = lift ask

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

460+ reader = lift . reader

461+

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

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

464+ traverseIntMapWithKeyWithAdjust = traverseIntMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseIntMapWithKeyWithAdjust f dm0 dm') patchIntMapNewElementsMap mergeIntIncremental

465+ {-# INLINABLE traverseDMapWithKeyWithAdjust #-}

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

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

468+

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

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

471+

472+{-# INLINABLE runWithReplaceRequesterTWith #-}

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

474+ , MonadFix m

475+ )

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

477+ -> RequesterT t request response m a

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

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

480+runWithReplaceRequesterTWith f a0 a' = do

481+ rec na' <- numberOccurrencesFrom 1 a'

482+ responses <- fmap (fmapCheap unMultiEntry) $ requesting' $ fmapCheap multiEntry $ switchPromptlyDyn requests --TODO: Investigate whether we can really get rid of the prompt stuff here

483+ let responses' = fanInt responses

484+ ((result0, requests0), v') <- f (runRequesterT a0 (selectInt responses' 0)) $ fmapCheap (\(n, a) -> fmap ((,) n) $ runRequesterT a $ selectInt responses' n) na'

485+ requests <- holdDyn (fmapCheap (IntMap.singleton 0) requests0) $ fmapCheap (\(n, (_, reqs)) -> fmapCheap (IntMap.singleton n) reqs) v'

486+ return (result0, fmapCheap (fst . snd) v')

487+

488+{-# INLINE traverseIntMapWithKeyWithAdjustRequesterTWith #-}

489+traverseIntMapWithKeyWithAdjustRequesterTWith :: forall t request response m v v' p.

490+ ( Reflex t

491+ , MonadHold t m

492+ , PatchTarget (p (Event t (IntMap (RequesterData request)))) ~ IntMap (Event t (IntMap (RequesterData request)))

493+ , Patch (p (Event t (IntMap (RequesterData request))))

494+ , Functor p

495+ , MonadFix m

496+ )

497+ => ( (IntMap.Key -> (IntMap.Key, v) -> m (Event t (IntMap (RequesterData request)), v'))

498+ -> IntMap (IntMap.Key, v)

499+ -> Event t (p (IntMap.Key, v))

500+ -> RequesterT t request response m (IntMap (Event t (IntMap (RequesterData request)), v'), Event t (p (Event t (IntMap (RequesterData request)), v')))

501+ )

502+ -> (p (Event t (IntMap (RequesterData request))) -> IntMap (Event t (IntMap (RequesterData request))))

503+ -> (Incremental t (p (Event t (IntMap (RequesterData request)))) -> Event t (IntMap (IntMap (RequesterData request))))

504+ -> (IntMap.Key -> v -> RequesterT t request response m v')

505+ -> IntMap v

506+ -> Event t (p v)

507+ -> RequesterT t request response m (IntMap v', Event t (p v'))

508+traverseIntMapWithKeyWithAdjustRequesterTWith base patchNewElements mergePatchIncremental f dm0 dm' = do

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

510+ let responses :: EventSelectorInt t (IntMap (RequesterData response))

511+ responses = fanInt $ fmapCheap unpack response

512+ unpack :: Entry response Multi3 -> IntMap (IntMap (RequesterData response))

513+ unpack = unEntry

514+ pack :: IntMap (IntMap (RequesterData request)) -> Entry request Multi3

515+ pack = Entry

516+ f' :: IntMap.Key -> (Int, v) -> m (Event t (IntMap (RequesterData request)), v')

517+ f' k (n, v) = do

518+ (result, myRequests) <- runRequesterT (f k v) $ mapMaybeCheap (IntMap.lookup n) $ selectInt responses k --TODO: Instead of doing mapMaybeCheap, can we share a fanInt across all instances of a given key, or at least the ones that are adjacent in time?

519+ return (fmapCheap (IntMap.singleton n) myRequests, result)

520+ ndm' <- numberOccurrencesFrom 1 dm'

521+ (children0, children') <- base f' (fmap ((,) 0) dm0) $ fmap (\(n, dm) -> fmap ((,) n) dm) ndm' --TODO: Avoid this somehow, probably by adding some sort of per-cohort information passing to Adjustable

522+ let result0 = fmap snd children0

523+ result' = fforCheap children' $ fmap snd

524+ requests0 :: IntMap (Event t (IntMap (RequesterData request)))

525+ requests0 = fmap fst children0

526+ requests' :: Event t (p (Event t (IntMap (RequesterData request))))

527+ requests' = fforCheap children' $ fmap fst

528+ promptRequests :: Event t (IntMap (IntMap (RequesterData request)))

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

530+ requests <- holdIncremental requests0 requests'

531+ return (result0, result')

532+

533+{-# INLINE traverseDMapWithKeyWithAdjustRequesterTWith #-}

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

535+ ( GCompare k

536+ , Reflex t

537+ , MonadHold t m

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

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

540+ , MonadFix m

541+ )

542+ => (forall k' v1 v2. GCompare k'

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

544+ -> DMap k' v1

545+ -> Event t (p k' v1)

546+ -> RequesterT t request response m (DMap k' v2, Event t (p k' v2))

547+ )

548+ -> (forall v1 v2. (forall a. v1 a -> v2 a) -> p k v1 -> p k v2)

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

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

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

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

553+ -> DMap k v

554+ -> Event t (p k v)

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

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

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

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

559+ responses = fanMap $ fmapCheap unpack response

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

561+ unpack = unEntry

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

563+ pack = Entry

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

565+ f' k (Compose (n, v)) = do

566+ (result, myRequests) <- runRequesterT (f k v) $ mapMaybeCheap (IntMap.lookup n) $ select responses (Const2 (Some k))

567+ return $ Compose (fmapCheap (IntMap.singleton n) myRequests, result)

568+ ndm' <- numberOccurrencesFrom 1 dm'

569+ (children0, children') <- base f' (DMap.map (\v -> Compose (0, v)) dm0) $ fmap (\(n, dm) -> mapPatch (\v -> Compose (n, v)) dm) ndm'

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

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

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

573+ requests0 = weakenDMapWith (fst . getCompose) children0

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

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

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

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

578+ requests <- holdIncremental requests0 requests'

579+ return (result0, result')

580+

581+data Decoder rawResponse response =

582+ forall a. Decoder (RequesterDataKey a) (rawResponse -> response a)

583+

584+-- | Matches incoming responses with previously-sent requests

585+-- and uses the provided request "decoder" function to process

586+-- incoming responses.

587+matchResponsesWithRequests

588+ :: forall t rawRequest rawResponse request response m.

589+ ( MonadFix m

590+ , MonadHold t m

591+ , Reflex t

592+ )

593+ => (forall a. request a -> (rawRequest, rawResponse -> response a))

594+ -- ^ Given a request (from 'Requester'), produces the wire format of the

595+ -- request and a function used to process the associated response

596+ -> Event t (RequesterData request)

597+ -- ^ The outgoing requests

598+ -> Event t (Int, rawResponse)

599+ -- ^ The incoming responses, tagged by an identifying key

600+ -> m ( Event t (Map Int rawRequest)

601+ , Event t (RequesterData response)

602+ )

603+ -- ^ A map of outgoing wire-format requests and an event of responses keyed

604+ -- by the 'RequesterData' key of the associated outgoing request

605+matchResponsesWithRequests f send recv = do

606+ rec nextId <- hold 1 $ fmap (\(next, _, _) -> next) outgoing

607+ waitingFor :: Incremental t (PatchMap Int (Decoder rawResponse response)) <-

608+ holdIncremental mempty $ leftmost

609+ [ fmap (\(_, outstanding, _) -> outstanding) outgoing

610+ , snd <$> incoming

611+ ]

612+ let outgoing = processOutgoing nextId send

613+ incoming = processIncoming waitingFor recv

614+ return (fmap (\(_, _, rawReqs) -> rawReqs) outgoing, fst <$> incoming)

615+ where

616+ -- Tags each outgoing request with an identifying integer key

617+ -- and returns the next available key, a map of response decoders

618+ -- for requests for which there are outstanding responses, and the

619+ -- raw requests to be sent out.

620+ processOutgoing

621+ :: Behavior t Int

622+ -- The next available key

623+ -> Event t (RequesterData request)

624+ -- The outgoing request

625+ -> Event t ( Int

626+ , PatchMap Int (Decoder rawResponse response)

627+ , Map Int rawRequest )

628+ -- The new next-available-key, a map of requests expecting responses, and the tagged raw requests

629+ processOutgoing nextId out = flip pushAlways out $ \dm -> do

630+ oldNextId <- sample nextId

631+ let (result, newNextId) = flip runState oldNextId $ forM (requesterDataToList dm) $ \(k :=> v) -> do

632+ n <- get

633+ put $ succ n

634+ let (rawReq, rspF) = f v

635+ return (n, rawReq, Decoder k rspF)

636+ patchWaitingFor = PatchMap $ Map.fromList $

637+ (\(n, _, dec) -> (n, Just dec)) <$> result

638+ toSend = Map.fromList $ (\(n, rawReq, _) -> (n, rawReq)) <$> result

639+ return (newNextId, patchWaitingFor, toSend)

640+ -- Looks up the each incoming raw response in a map of response

641+ -- decoders and returns the decoded response and a patch that can

642+ -- be used to clear the ID of the consumed response out of the queue

643+ -- of expected responses.

644+ processIncoming

645+ :: Incremental t (PatchMap Int (Decoder rawResponse response))

646+ -- A map of outstanding expected responses

647+ -> Event t (Int, rawResponse)

648+ -- A incoming response paired with its identifying key

649+ -> Event t (RequesterData response, PatchMap Int v)

650+ -- The decoded response and a patch that clears the outstanding responses queue

651+ processIncoming waitingFor inc = flip push inc $ \(n, rawRsp) -> do

652+ wf <- sample $ currentIncremental waitingFor

653+ case Map.lookup n wf of

654+ Nothing -> return Nothing -- TODO How should lookup failures be handled here? They shouldn't ever happen..

655+ Just (Decoder k rspF) -> do

656+ let rsp = rspF rawRsp

657+ return $ Just

658+ ( singletonRequesterData k rsp

659+ , PatchMap $ Map.singleton n Nothing

660+ )

661+-}

src/Reflex/Requester/Class.hs+1−1

@@ -40,7 +40,7 @@ class (Reflex t, Monad m) => Requester t m | m -> t where

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

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

42 requesting_ :: Event t (Request m a) -> m ()

43−

43+--TODO: Make Requester polykinded, where Request m and Response m both take an argument of the same kind

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

46 type Request (ReaderT r m) = Request m