git.iko.soy/reflex
on develop help sign in
Merge branch 'requester-simple-fix-fake-phantom' into requester-simple-fix-nonempty-deferred

# Conflicts: # src/Reflex/PerformEvent/Base.hs

commitb511a57537620020fd7e9306d2f37c2709a9d83f authorRyan Trinkle <ryan.trinkle@gmail.com> dateFri 20 Sep 2019, 19:51 (7 years ago) parent677ce27ee9c838
2 files changed+17−36
compare with develop
unifiedsplit
src/Reflex/PerformEvent/Base.hs+10−10 src/Reflex/Requester/Base/Internal.hs+7−26
src/Reflex/PerformEvent/Base.hs+10−10
@@ -91,18 +91,18 @@ instance (ReflexHost t, Ref m ~ Ref IO, PrimMonad (HostFrame t)) => PerformEvent
9191
9292instance (ReflexHost t, PrimMonad (HostFrame t)) => Adjustable t (PerformEventT t m) where
9393 runWithReplace a0 a' = PerformEventT $ RequesterT $ do
94− env@(_, _ :: TagGen (PrimState (HostFrame t)) s) <- RequesterInternalT ask
95− let runA :: forall a. PerformEventT t m a -> HostFrame t (a, Event t (NonEmptyDeferred (RequestEnvelope s (HostFrame t))))
94+ env@(_, _ :: TagGen (PrimState (HostFrame t)) FakeRequesterStatePhantom) <- RequesterInternalT ask
95+ let runA :: forall a. PerformEventT t m a -> HostFrame t (a, Event t (NonEmptyDeferred (RequestEnvelope FakeRequesterStatePhantom (HostFrame t))))
9696 runA (PerformEventT (RequesterT a)) = runEventWriterT $ runReaderT (unRequesterInternalT a) env
9797 (result0, requests0) <- lift $ runA a0
98− newA <- requestingIdentity $ traceEventWith (const "running new widget") $ runA <$> a'
99− requests <- switchHoldPromptOnly requests0 $ traceEventWith (const "updating runWithReplace") $ fmapCheap snd newA
98+ newA <- requestingIdentity $ runA <$> a'
99+ requests <- switchHoldPromptOnly requests0 $ fmapCheap snd newA
100100 --TODO: promptly *prevent* events, then sign up the new ones; this is a serious breaking change to PerformEvent
101101 RequesterInternalT $ tellEvent requests
102102 pure (result0, fmapCheap fst newA)
103103 traverseIntMapWithKeyWithAdjust f a0 a' = PerformEventT $ RequesterT $ do
104− env@(_, _ :: TagGen (PrimState (HostFrame t)) s) <- RequesterInternalT ask
105− let runA :: forall a. PerformEventT t m a -> HostFrame t (a, Event t (NonEmptyDeferred (RequestEnvelope s (HostFrame t))))
104+ env@(_, _ :: TagGen (PrimState (HostFrame t)) FakeRequesterStatePhantom) <- RequesterInternalT ask
105+ let runA :: forall a. PerformEventT t m a -> HostFrame t (a, Event t (NonEmptyDeferred (RequestEnvelope FakeRequesterStatePhantom (HostFrame t))))
106106 runA (PerformEventT (RequesterT a)) = runEventWriterT $ runReaderT (unRequesterInternalT a) env
107107 children' <- requestingIdentity $ itraverse (\k -> runA . f k) <$> a'
108108 children0 <- lift $ itraverse (\k -> runA . f k) a0
@@ -115,8 +115,8 @@ instance (ReflexHost t, PrimMonad (HostFrame t)) => Adjustable t (PerformEventT
115115 RequesterInternalT $ tellEvent $ fforMaybeCheap requests concatIntMapMaybe
116116 pure (results0, results')
117117 traverseDMapWithKeyWithAdjust (f :: forall a. k a -> v a -> PerformEventT t m (v' a)) (a0 :: DMap k v) a' = PerformEventT $ RequesterT $ do
118− env@(_, _ :: TagGen (PrimState (HostFrame t)) s) <- RequesterInternalT ask
119− let runA :: forall a. k a -> v a -> HostFrame t (Compose ((,) (Event t (NonEmptyDeferred (RequestEnvelope s (HostFrame t))))) v' a)
118+ env@(_, _ :: TagGen (PrimState (HostFrame t)) FakeRequesterStatePhantom) <- RequesterInternalT ask
119+ let runA :: forall a. k a -> v a -> HostFrame t (Compose ((,) (Event t (NonEmptyDeferred (RequestEnvelope FakeRequesterStatePhantom (HostFrame t))))) v' a)
120120 runA k v = fmap (Compose . swap) $ runEventWriterT $ runReaderT (unRequesterInternalT a) env
121121 where (PerformEventT (RequesterT a)) = f k v
122122 children' <- requestingIdentity $ traversePatchDMapWithKey runA <$> a'
@@ -130,8 +130,8 @@ instance (ReflexHost t, PrimMonad (HostFrame t)) => Adjustable t (PerformEventT
130130 RequesterInternalT $ tellEvent $ fforMaybeCheap requests concatMapMaybe
131131 pure (results0, results')
132132 traverseDMapWithKeyWithAdjustWithMove (f :: forall a. k a -> v a -> PerformEventT t m (v' a)) (a0 :: DMap k v) a' = PerformEventT $ RequesterT $ do
133− env@(_, _ :: TagGen (PrimState (HostFrame t)) s) <- RequesterInternalT ask
134− let runA :: forall a. k a -> v a -> HostFrame t (Compose ((,) (Event t (NonEmptyDeferred (RequestEnvelope s (HostFrame t))))) v' a)
133+ env@(_, _ :: TagGen (PrimState (HostFrame t)) FakeRequesterStatePhantom) <- RequesterInternalT ask
134+ let runA :: forall a. k a -> v a -> HostFrame t (Compose ((,) (Event t (NonEmptyDeferred (RequestEnvelope FakeRequesterStatePhantom (HostFrame t))))) v' a)
135135 runA k v = fmap (Compose . swap) $ runEventWriterT $ runReaderT (unRequesterInternalT a) env
136136 where (PerformEventT (RequesterT a)) = f k v
137137 children' <- requestingIdentity $ traversePatchDMapWithMoveWithKey runA <$> a'
src/Reflex/Requester/Base/Internal.hs+7−26
@@ -66,6 +66,8 @@ import Data.GADT.Compare
6666import Data.Witherable
6767import Data.Foldable
6868
69+import Unsafe.Coerce
70+
6971import Debug.Trace
7072
7173data RequestData ps request = forall s. RequestData !(TagGen ps s) !(NonEmptyDeferred (RequestEnvelope s request))
@@ -87,7 +89,7 @@ runRequesterT :: forall t request response m a
8789 -> m (a, Event t (RequestData (PrimState m) request))
8890runRequesterT (RequesterT a) wrappedResponses = withRequesterInternalT $ \(requests :: Event t (NonEmptyDeferred (RequestEnvelope s request))) -> do
8991 (_, tg) <- RequesterInternalT ask
90− result <- a
92+ result <- (unsafeCoerce :: RequesterInternalT FakeRequesterStatePhantom t request response m a -> RequesterInternalT s t request response m a) a
9193 let responses = fforMaybe wrappedResponses $ \(ResponseData tg' m) -> case tg `geq` tg' of
9294 Nothing -> trace ("runRequesterT: bad TagGen: expected " <> show tg <> " but got " <> show tg') Nothing --TODO: Warn somehow
9395 Just Refl -> Just m
@@ -117,32 +119,11 @@ withRequesterInternalT f = withTagGen $ \tg -> do
117119
118120data RequestEnvelope s request = forall a. RequestEnvelope {-# UNPACK #-} !(Maybe (Tag s a)) !(request a)
119121
120−newtype RequesterT t (request :: * -> *) (response :: * -> *) m a = RequesterT { unRequesterT :: forall s. RequesterInternalT s t request response m a }
121−
122−instance Functor m => Functor (RequesterT t request response m) where
123− fmap f (RequesterT x) = RequesterT $ fmap f x
124−
125−instance Monad m => Applicative (RequesterT t request response m) where
126− pure x = RequesterT $ pure x
127− RequesterT f <*> RequesterT x = RequesterT $ f <*> x
128− liftA2 f (RequesterT a) (RequesterT b) = RequesterT $ liftA2 f a b
129− RequesterT f <* RequesterT x = RequesterT $ f <* x
130− RequesterT f *> RequesterT x = RequesterT $ f *> x
131−
132−instance Monad m => Monad (RequesterT t request response m) where
133− return = pure
134− RequesterT mx >>= f = RequesterT $ mx >>= \x -> case f x of
135− RequesterT y -> y
136−
137−instance MonadFix m => MonadFix (RequesterT t request response m) where
138− mfix f = RequesterT $ mfix $ \x -> case f x of
139− RequesterT a -> a
140−
141−instance MonadIO m => MonadIO (RequesterT t request respnose m) where
142− liftIO a = RequesterT $ liftIO a
122+-- This is because using forall ruins inlining
123+data FakeRequesterStatePhantom
143124
144−instance MonadException m => MonadException (RequesterT t request respnose m) where
145− throw e = RequesterT $ throw e
125+newtype RequesterT t (request :: * -> *) (response :: * -> *) m a = RequesterT { unRequesterT :: RequesterInternalT FakeRequesterStatePhantom t request response m a }
126+ deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException)
146127
147128newtype RequesterInternalT s t request response m a = RequesterInternalT { unRequesterInternalT :: ReaderT (EventSelectorTag t s response, TagGen (PrimState m) s) (EventWriterT t (NonEmptyDeferred (RequestEnvelope s request)) m) a }
148129 deriving