@@ -15,26 +15,24 @@
1515{-# LANGUAGE TypeFamilies #-}
1616{-# LANGUAGE TypeOperators #-}
1717{-# LANGUAGE UndecidableInstances #-}
18+{-# LANGUAGE InstanceSigs #-}
1819#ifdef USE_REFLEX_OPTIMIZER
1920{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
2021#endif
2122module Reflex.Requester.Base
2223 ( RequesterT (..)
2324 , runRequesterT
24− , withRequesterT
25− , runWithReplaceRequesterTWith
26− , traverseIntMapWithKeyWithAdjustRequesterTWith
27− , traverseDMapWithKeyWithAdjustRequesterTWith
28− , RequesterData
29− , RequesterDataKey
30− , traverseRequesterData
31− , forRequesterData
32− , requesterDataToList
33− , singletonRequesterData
34− , matchResponsesWithRequests
35− , multiEntry
36− , unMultiEntry
37− , requesting'
25+-- , withRequesterT
26+-- , RequesterData
27+-- , RequesterDataKey
28+-- , traverseRequesterData
29+-- , forRequesterData
30+-- , requesterDataToList
31+-- , singletonRequesterData
32+-- , matchResponsesWithRequests
33+-- , multiEntry
34+-- , unMultiEntry
35+-- , requesting'
3836 ) where
3937
4038import Reflex.Class
@@ -45,6 +43,8 @@ import Reflex.PerformEvent.Class
4543import Reflex.PostBuild.Class
4644import Reflex.Requester.Class
4745import Reflex.TriggerEvent.Class
46+import Reflex.EventWriter.Base
47+import Reflex.EventWriter.Class
4848
4949import Control.Applicative (liftA2)
5050import Control.Monad.Exception
@@ -68,8 +68,144 @@ import Data.Proxy
6868import qualified Data.Semigroup as S
6969import Data.Some (Some(Some))
7070import Data.Type.Equality
71−import Data.Unique.Tag
71+import Data.Sequence (Seq)
72+import qualified Data.Sequence as Seq
73+import Data.TagMap
74+import Reflex.FanTag
75+import Data.Unique.Tag.Local
76+import qualified Data.Unique.Tag as Global
77+import Data.GADT.Compare
78+
79+data RequestData m request = forall s. RequestData !(Global.Tag (PrimState m) s) !(Seq (RequestEnvelope s request))
80+data ResponseData m response = forall s. ResponseData !(Global.Tag (PrimState m) s) !(TagMap s response)
81+
82+runRequesterT :: forall t request response m a
83+ . ( Reflex t
84+ , PrimMonad m
85+ , MonadFix m
86+ )
87+ => RequesterT t request response m a
88+ -> Event t (ResponseData m response)
89+ -> m (a, Event t (RequestData m request))
90+runRequesterT (RequesterT a) wrappedResponses = withRequesterInternalT $ \(requests :: Event t (Seq (RequestEnvelope s request))) -> do
91+ t :: Global.Tag (PrimState m) s <- lift Global.newTag
92+ result <- a
93+ let responses = fforMaybe wrappedResponses $ \(ResponseData s m) -> case s `geq` t of
94+ Nothing -> Nothing --TODO: Warn somehow
95+ Just Refl -> Just m
96+ pure (responses, (result, fmap (RequestData t) requests))
97+
98+instance MonadTrans (RequesterInternalT s t request response) where
99+ lift = RequesterInternalT . lift . lift . lift
100+
101+instance MonadTrans (RequesterT t request response) where
102+ lift a = RequesterT $ RequesterInternalT $ lift $ lift $ lift a
103+
104+-- | Run a 'RequesterT' action. The resulting 'Event' will fire whenever
105+-- requests are made, and responses should be provided in the input 'Event'.
106+-- The 'Tag' keys will be used to return the responses to the same place the
107+-- requests were issued.
108+withRequesterInternalT :: (Reflex t, PrimMonad m, MonadFix m)
109+ => (forall s. Event t (Seq (RequestEnvelope s request)) -> RequesterInternalT s t request response m (Event t (TagMap s response), a))
110+ -> m a
111+withRequesterInternalT f = runTagGenT $ do
112+ rec let RequesterInternalT a = f requests
113+ ((responses, result), requests) <- runEventWriterT $ runReaderT a (fanTag responses)
114+ pure result
115+
116+data RequestEnvelope s request = forall a. RequestEnvelope {-# UNPACK #-} !(Maybe (Tag s a)) !(request a)
117+
118+newtype RequesterT t (request :: * -> *) (response :: * -> *) m a = RequesterT { unRequesterT :: forall s. RequesterInternalT s t request response m a }
119+
120+instance Functor m => Functor (RequesterT t request response m) where
121+ fmap f (RequesterT x) = RequesterT $ fmap f x
122+
123+instance Monad m => Applicative (RequesterT t request response m) where
124+ pure x = RequesterT $ pure x
125+ RequesterT f <*> RequesterT x = RequesterT $ f <*> x
126+ liftA2 f (RequesterT a) (RequesterT b) = RequesterT $ liftA2 f a b
127+ RequesterT f <* RequesterT x = RequesterT $ f <* x
128+ RequesterT f *> RequesterT x = RequesterT $ f *> x
129+
130+instance Monad m => Monad (RequesterT t request response m) where
131+ return = pure
132+ RequesterT mx >>= f = RequesterT $ mx >>= \x -> case f x of
133+ RequesterT y -> y
134+
135+instance MonadFix m => MonadFix (RequesterT t request response m) where
136+ mfix f = RequesterT $ mfix $ \x -> case f x of
137+ RequesterT a -> a
138+
139+instance MonadIO m => MonadIO (RequesterT t request respnose m) where
140+ liftIO a = RequesterT $ liftIO a
141+
142+instance MonadException m => MonadException (RequesterT t request respnose m) where
143+ throw e = RequesterT $ throw e
144+
145+newtype RequesterInternalT s t request response m a = RequesterInternalT { unRequesterInternalT :: ReaderT (EventSelectorTag t s response) (EventWriterT t (Seq (RequestEnvelope s request)) (TagGenT s m)) a }
146+ deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException)
147+
148+instance MonadSample t m => MonadSample t (RequesterT t request response m)
149+instance MonadHold t m => MonadHold t (RequesterT t request response m)
150+instance PostBuild t m => PostBuild t (RequesterT t request response m)
151+instance TriggerEvent t m => TriggerEvent t (RequesterT t request response m)
152+
153+instance PrimMonad m => PrimMonad (RequesterT t request response m) where
154+ type PrimState (RequesterT t request response m) = PrimState m
155+ primitive = lift . primitive
156+
157+-- TODO: Monoid and Semigroup can likely be derived once StateT has them.
158+instance (Monoid a, Monad m) => Monoid (RequesterT t request response m a) where
159+ mempty = pure mempty
160+ mappend = liftA2 mappend
72161
162+instance (S.Semigroup a, Monad m) => S.Semigroup (RequesterT t request response m a) where
163+ (<>) = liftA2 (S.<>)
164+
165+instance PerformEvent t m => PerformEvent t (RequesterT t request response m) where
166+ type Performable (RequesterT t request response m) = Performable m
167+ performEvent_ = lift . performEvent_
168+ performEvent = lift . performEvent
169+
170+instance MonadRef m => MonadRef (RequesterT t request response m) where
171+ type Ref (RequesterT t request response m) = Ref m
172+ newRef = lift . newRef
173+ readRef = lift . readRef
174+ writeRef r = lift . writeRef r
175+
176+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (RequesterT t request response m) where
177+ newEventWithTrigger = lift . newEventWithTrigger
178+ newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
179+
180+instance MonadReader r m => MonadReader r (RequesterT t request response m) where
181+ ask = lift ask
182+ local f (RequesterT a) = RequesterT $ RequesterInternalT $ mapReaderT (mapEventWriterT $ mapTagGenT $ local f) $ unRequesterInternalT a
183+ reader = lift . reader
184+
185+instance (Reflex t, PrimMonad m) => Requester t (RequesterT t request response m) where
186+ type Request (RequesterT t request response m) = request
187+ type Response (RequesterT t request response m) = response
188+ requesting e = RequesterT $ RequesterInternalT $ do
189+ t <- lift $ lift mkTag
190+ tellEvent $ fmapCheap (Seq.singleton . RequestEnvelope (Just t)) e
191+ s <- ask
192+ pure $ selectTag s t
193+ requesting_ e = RequesterT $ RequesterInternalT $ do
194+ tellEvent $ fmapCheap (Seq.singleton . RequestEnvelope Nothing) e
195+
196+
197+{-# INLINABLE runWithReplaceRequesterTWith #-}
198+runWithReplaceRequesterTWith :: forall m t request response a b. (Reflex t, MonadHold t m
199+ , MonadFix m
200+ )
201+ => (forall a' b'. m a' -> Event t (m b') -> RequesterT t request response m (a', Event t b'))
202+ -> RequesterT t request response m a
203+ -> Event t (RequesterT t request response m b)
204+ -> RequesterT t request response m (a, Event t b)
205+runWithReplaceRequesterTWith f (RequesterT a0) a' = RequesterT $ do
206+ pure undefined
207+
208+{-
73209import GHC.Exts (Any)
74210import Unsafe.Coerce
75211
@@ -244,23 +380,6 @@ newtype RequesterT t request (response :: * -> *) m a = RequesterT { unRequester
244380#endif
245381 )
246382
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−
264383
265384-- | Run a 'RequesterT' action. The resulting 'Event' will fire whenever
266385-- requests are made, and responses should be provided in the input 'Event'.
@@ -535,3 +654,4 @@ matchResponsesWithRequests f send recv = do
535654 ( singletonRequesterData k rsp
536655 , PatchMap $ Map.singleton n Nothing
537656 )
657+-}