@@ -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+-}