git.iko.soy/reflex
on develop help sign in
Add some instances and new functions
commitf0eb57a5dceaffaa6d7390c1930948d3fc7ef93b authorRyan Trinkle <ryan.trinkle@gmail.com> dateFri 30 Sep 2016, 12:47 (10 years ago) parent56af6d8
4 files changed+124−15
compare with develop
unifiedsplit
src/Reflex/DynamicWriter.hs+17 src/Reflex/PerformEvent/Base.hs+56−15 src/Reflex/PerformEvent/Class.hs+46 src/Reflex/PostBuild/Class.hs+5
src/Reflex/DynamicWriter.hs+17
@@ -177,3 +177,20 @@ instance (MonadAdjust t m, MonadFix m, Monoid w, MonadHold t m, Reflex t) => Mon
177177 i <- holdIncremental liftedWritten0 liftedWritten'
178178 tellDyn $ join $ fold . dmapToMap <$> incrementalToDynamic i
179179 return (liftedResult0, liftedResult')
180+
181+withDynamicWriterT :: (Monoid w, Reflex t, MonadHold t m, MonadFix m)
182+ => (w -> w')
183+ -> DynamicWriterT t w m a
184+ -> DynamicWriterT t w' m a
185+withDynamicWriterT f dw = do
186+ (r, d) <- lift $ do
187+ (r, d) <- runDynamicWriterT dw
188+ let d' = fmap f d
189+ return (r, d')
190+ tellDyn d
191+ return r
192+
193+instance MonadRequest t m => MonadRequest t (DynamicWriterT t w m) where
194+ type Request (DynamicWriterT t w m) = Request m
195+ type Response (DynamicWriterT t w m) = Response m
196+ withRequesting f = DynamicWriterT $ withRequesting $ unDynamicWriterT . f
src/Reflex/PerformEvent/Base.hs+56−15
@@ -16,6 +16,7 @@ module Reflex.PerformEvent.Base where
1616
1717import Reflex.Class
1818import Reflex.Host.Class
19+import Reflex.PostBuild.Class
1920import Reflex.PerformEvent.Class
2021
2122import Control.Lens
@@ -52,6 +53,10 @@ deriving instance ReflexHost t => MonadFix (PerformEventT t m)
5253deriving instance (ReflexHost t, MonadIO (HostFrame t)) => MonadIO (PerformEventT t m)
5354deriving instance (ReflexHost t, MonadException (HostFrame t)) => MonadException (PerformEventT t m)
5455
56+instance (PrimMonad (HostFrame t), ReflexHost t) => PrimMonad (PerformEventT t m) where
57+ type PrimState (PerformEventT t m) = PrimState (HostFrame t)
58+ primitive = PerformEventT . lift . primitive
59+
5560instance (ReflexHost t, Ref m ~ Ref IO, PrimMonad (HostFrame t)) => PerformEvent t (PerformEventT t m) where
5661 type Performable (PerformEventT t m) = HostFrame t
5762 {-# INLINABLE performEvent_ #-}
@@ -153,21 +158,15 @@ runRequestT (RequestT a) responses = do
153158 (result, requests) <- runReaderT (runStateT a mempty) $ fan $ mapKeyValuePairsMonotonic (\(t :=> e) -> WrapArg t :=> Identity e) <$> responses
154159 return (result, mergeWith DMap.union requests)
155160
156−requesting_ :: (Reflex t, PrimMonad m) => Event t (request a) -> RequestT t request response m ()
157−requesting_ req = do
158− t <- lift newTag
159− RequestT $ modify $ (:) $ DMap.singleton t <$> req
160−
161−withRequesting :: (Reflex t, PrimMonad m) => (Event t (response a) -> RequestT t request response m (Event t (request a), r)) -> RequestT t request response m r
162−withRequesting a = do
163− t <- lift newTag
164− s <- RequestT ask
165− (req, result) <- a $ select s $ WrapArg t
166− RequestT $ modify $ (:) $ DMap.singleton t <$> req
167− return result
168−
169−requesting :: (Reflex t, PrimMonad m) => Event t (request a) -> RequestT t request response m (Event t (response a))
170−requesting req = withRequesting $ return . (,) req
161+instance (Reflex t, PrimMonad m) => MonadRequest t (RequestT t request response m) where
162+ type Request (RequestT t request response m) = request
163+ type Response (RequestT t request response m) = response
164+ withRequesting a = do
165+ t <- lift newTag
166+ s <- RequestT ask
167+ (req, result) <- a $ select s $ WrapArg t
168+ RequestT $ modify $ (:) $ DMap.singleton t <$> req
169+ return result
171170
172171data DMapTransform (a :: *) k k' v v' = forall (b :: *). DMapTransform !(k a -> k' b) !(v a -> v' b)
173172
@@ -217,6 +216,48 @@ sequenceDMapWithAdjustRequestTWith f (dm0 :: DMap k (RequestT t request response
217216-- RequestT $ modify $ (:) $ coincidence $ ffor requests' $ \(PatchDMap p) -> mergeWith DMap.union $ catMaybes $ ffor (DMap.toList p) $ \(Const2 _ :=> Compose me) -> me -- We could make it prompt like this, but this seems to be slower than just delaying the PostBuild event to allow this stuff to settle (which is more similar to the previous behavior anyway)
218217 return (result0, result')
219218
219+instance PerformEvent t m => PerformEvent t (RequestT t request response m) where
220+ type Performable (RequestT t request response m) = Performable m
221+ performEvent_ = lift . performEvent_
222+ performEvent = lift . performEvent
223+
224+instance PostBuild t m => PostBuild t (RequestT t request response m) where
225+ getPostBuild = lift getPostBuild
226+
227+instance TriggerEvent t m => TriggerEvent t (RequestT t request response m) where
228+ newTriggerEvent = lift newTriggerEvent
229+ newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
230+ newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
231+
232+instance MonadReader r m => MonadReader r (RequestT t request response m) where
233+ ask = lift ask
234+ local f (RequestT a) = RequestT $ mapStateT (mapReaderT $ local f) a
235+ reader = lift . reader
236+
237+{-
238+withRequestT :: forall t m a (req :: * -> *) (req' :: * -> *).
239+ (Reflex t, MonadHold t m, MonadFix m)
240+ => (forall x. request x -> request' x)
241+ -> (forall x. response' x -> response x)
242+ -> RequestT t request response m a
243+ -> RequestT t request' response m a
244+withRequestT f g m = RequestT $ hoist (hoist (withDynamicWriterT f')) (unRequestT m)
245+ where
246+ f' :: Event t [(y, Some request)] -> Event t [(y, Some request')]
247+ f' = fmap . fmap . fmap $ \(SomeRequest req) -> SomeRequest $ f req
248+-}
249+
250+instance MonadRef m => MonadRef (RequestT t request response m) where
251+ type Ref (RequestT t request response m) = Ref m
252+ newRef = lift . newRef
253+ readRef = lift . readRef
254+ writeRef r = lift . writeRef r
255+
256+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (RequestT t request response m) where
257+ newEventWithTrigger = lift . newEventWithTrigger
258+ newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
259+
260+
220261--------------------------------------------------------------------------------
221262-- Helpers
222263--------------------------------------------------------------------------------
src/Reflex/PerformEvent/Class.hs+46
@@ -11,7 +11,10 @@ module Reflex.PerformEvent.Class where
1111
1212import Reflex.Class
1313
14+import Control.Monad.Identity
1415import Control.Monad.Reader
16+import qualified Control.Monad.State.Lazy as Lazy
17+import Control.Monad.State.Strict
1518
1619class (Reflex t, Monad (Performable m), Monad m) => PerformEvent t m | m -> t where
1720 type Performable m :: * -> *
@@ -24,6 +27,11 @@ class Monad m => TriggerEvent t m | m -> t where
2427 newTriggerEventWithOnComplete :: m (Event t a, a -> IO () -> IO ()) --TODO: This and newTriggerEvent should be unified somehow
2528 newEventWithLazyTriggerWithOnComplete :: ((a -> IO () -> IO ()) -> IO (IO ())) -> m (Event t a)
2629
30+class (Reflex t, Monad m) => MonadRequest t m | m -> t where
31+ type Request m :: * -> *
32+ type Response m :: * -> *
33+ withRequesting :: (Event t (Response m a) -> m (Event t (Request m a), r)) -> m r
34+
2735{-# INLINABLE performEventAsync #-}
2836performEventAsync :: (TriggerEvent t m, PerformEvent t m) => Event t ((a -> IO ()) -> Performable m ()) -> m (Event t a)
2937performEventAsync e = do
@@ -44,3 +52,41 @@ instance TriggerEvent t m => TriggerEvent t (ReaderT r m) where
4452 newTriggerEvent = lift newTriggerEvent
4553 newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
4654 newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
55+
56+instance MonadRequest t m => MonadRequest t (ReaderT r m) where
57+ type Request (ReaderT r m) = Request m
58+ type Response (ReaderT r m) = Response m
59+ withRequesting f = do
60+ r <- ask
61+ lift $ withRequesting $ (`runReaderT` r) . f
62+
63+instance MonadRequest t m => MonadRequest t (StateT s m) where
64+ type Request (StateT s m) = Request m
65+ type Response (StateT s m) = Response m
66+ withRequesting f = do
67+ old <- get
68+ (result, new) <- lift $ withRequesting $ \x -> do
69+ ((request, result), new) <- runStateT (f x) old
70+ return (request, (result, new))
71+ put new
72+ return result
73+
74+instance MonadRequest t m => MonadRequest t (Lazy.StateT s m) where
75+ type Request (Lazy.StateT s m) = Request m
76+ type Response (Lazy.StateT s m) = Response m
77+ withRequesting f = do
78+ old <- Lazy.get
79+ (result, new) <- lift $ withRequesting $ \x -> do
80+ ((request, result), new) <- Lazy.runStateT (f x) old
81+ return (request, (result, new))
82+ Lazy.put new
83+ return result
84+
85+requesting :: MonadRequest t m => Event t (Request m a) -> m (Event t (Response m a))
86+requesting req = withRequesting $ return . (,) req
87+
88+requesting_ :: MonadRequest t m => Event t (Request m a) -> m ()
89+requesting_ req = withRequesting $ \_ -> return (req, ())
90+
91+requestingIdentity :: (MonadRequest t m, Response m ~ Identity) => Event t (Request m a) -> m (Event t a)
92+requestingIdentity = fmap (fmap runIdentity) . requesting
src/Reflex/PostBuild/Class.hs+5
@@ -11,6 +11,7 @@
1111module Reflex.PostBuild.Class where
1212
1313import Control.Monad.Exception
14+import Control.Monad.Primitive
1415import Control.Monad.Reader
1516import Control.Monad.Ref
1617import Control.Monad.Trans.Control
@@ -25,6 +26,10 @@ class (Reflex t, Monad m) => PostBuild t m | m -> t where
2526
2627newtype PostBuildT t m a = PostBuildT { unPostBuildT :: ReaderT (Event t ()) m a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadTrans, MonadException, MonadAsyncException)
2728
29+instance PrimMonad m => PrimMonad (PostBuildT x m) where
30+ type PrimState (PostBuildT x m) = PrimState m
31+ primitive = lift . primitive
32+
2833instance MonadTransControl (PostBuildT t) where
2934 type StT (PostBuildT t) a = StT (ReaderT (Event t ())) a
3035 {-# INLINABLE liftWith #-}