git.iko.soy/reflex
on develop help sign in
Merge branch 'requester-simple-fix-fake-phantom' into requester-simple-fix-nonempty-deferred
b511a57Ryan Trinkle
src/Reflex/PerformEvent/Base.hs+10−10
compare with develop
unifiedsplit
@@ -91,18 +91,18 @@ instance (ReflexHost t, Ref m ~ Ref IO, PrimMonad (HostFrame t)) => PerformEvent
91
91
92instance (ReflexHost t, PrimMonad (HostFrame t)) => Adjustable t (PerformEventT t m) where
92instance (ReflexHost t, PrimMonad (HostFrame t)) => Adjustable t (PerformEventT t m) where
93 runWithReplace a0 a' = PerformEventT $ RequesterT $ do
93 runWithReplace a0 a' = PerformEventT $ RequesterT $ do
94− env@(_, _ :: TagGen (PrimState (HostFrame t)) s) <- RequesterInternalT ask
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 s (HostFrame t))))
95+ let runA :: forall a. PerformEventT t m a -> HostFrame t (a, Event t (NonEmptyDeferred (RequestEnvelope FakeRequesterStatePhantom (HostFrame t))))
96 runA (PerformEventT (RequesterT a)) = runEventWriterT $ runReaderT (unRequesterInternalT a) env
96 runA (PerformEventT (RequesterT a)) = runEventWriterT $ runReaderT (unRequesterInternalT a) env
97 (result0, requests0) <- lift $ runA a0
97 (result0, requests0) <- lift $ runA a0
98− newA <- requestingIdentity $ traceEventWith (const "running new widget") $ runA <$> a'
98+ newA <- requestingIdentity $ runA <$> a'
99− requests <- switchHoldPromptOnly requests0 $ traceEventWith (const "updating runWithReplace") $ fmapCheap snd newA
99+ requests <- switchHoldPromptOnly requests0 $ fmapCheap snd newA
100 --TODO: promptly *prevent* events, then sign up the new ones; this is a serious breaking change to PerformEvent
100 --TODO: promptly *prevent* events, then sign up the new ones; this is a serious breaking change to PerformEvent
101 RequesterInternalT $ tellEvent requests
101 RequesterInternalT $ tellEvent requests
102 pure (result0, fmapCheap fst newA)
102 pure (result0, fmapCheap fst newA)
103 traverseIntMapWithKeyWithAdjust f a0 a' = PerformEventT $ RequesterT $ do
103 traverseIntMapWithKeyWithAdjust f a0 a' = PerformEventT $ RequesterT $ do
104− env@(_, _ :: TagGen (PrimState (HostFrame t)) s) <- RequesterInternalT ask
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 s (HostFrame t))))
105+ let runA :: forall a. PerformEventT t m a -> HostFrame t (a, Event t (NonEmptyDeferred (RequestEnvelope FakeRequesterStatePhantom (HostFrame t))))
106 runA (PerformEventT (RequesterT a)) = runEventWriterT $ runReaderT (unRequesterInternalT a) env
106 runA (PerformEventT (RequesterT a)) = runEventWriterT $ runReaderT (unRequesterInternalT a) env
107 children' <- requestingIdentity $ itraverse (\k -> runA . f k) <$> a'
107 children' <- requestingIdentity $ itraverse (\k -> runA . f k) <$> a'
108 children0 <- lift $ itraverse (\k -> runA . f k) a0
108 children0 <- lift $ itraverse (\k -> runA . f k) a0
@@ -115,8 +115,8 @@ instance (ReflexHost t, PrimMonad (HostFrame t)) => Adjustable t (PerformEventT
115 RequesterInternalT $ tellEvent $ fforMaybeCheap requests concatIntMapMaybe
115 RequesterInternalT $ tellEvent $ fforMaybeCheap requests concatIntMapMaybe
116 pure (results0, results')
116 pure (results0, results')
117 traverseDMapWithKeyWithAdjust (f :: forall a. k a -> v a -> PerformEventT t m (v' a)) (a0 :: DMap k v) a' = PerformEventT $ RequesterT $ do
117 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
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 s (HostFrame t))))) v' a)
119+ let runA :: forall a. k a -> v a -> HostFrame t (Compose ((,) (Event t (NonEmptyDeferred (RequestEnvelope FakeRequesterStatePhantom (HostFrame t))))) v' a)
120 runA k v = fmap (Compose . swap) $ runEventWriterT $ runReaderT (unRequesterInternalT a) env
120 runA k v = fmap (Compose . swap) $ runEventWriterT $ runReaderT (unRequesterInternalT a) env
121 where (PerformEventT (RequesterT a)) = f k v
121 where (PerformEventT (RequesterT a)) = f k v
122 children' <- requestingIdentity $ traversePatchDMapWithKey runA <$> a'
122 children' <- requestingIdentity $ traversePatchDMapWithKey runA <$> a'
@@ -130,8 +130,8 @@ instance (ReflexHost t, PrimMonad (HostFrame t)) => Adjustable t (PerformEventT
130 RequesterInternalT $ tellEvent $ fforMaybeCheap requests concatMapMaybe
130 RequesterInternalT $ tellEvent $ fforMaybeCheap requests concatMapMaybe
131 pure (results0, results')
131 pure (results0, results')
132 traverseDMapWithKeyWithAdjustWithMove (f :: forall a. k a -> v a -> PerformEventT t m (v' a)) (a0 :: DMap k v) a' = PerformEventT $ RequesterT $ do
132 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
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 s (HostFrame t))))) v' a)
134+ let runA :: forall a. k a -> v a -> HostFrame t (Compose ((,) (Event t (NonEmptyDeferred (RequestEnvelope FakeRequesterStatePhantom (HostFrame t))))) v' a)
135 runA k v = fmap (Compose . swap) $ runEventWriterT $ runReaderT (unRequesterInternalT a) env
135 runA k v = fmap (Compose . swap) $ runEventWriterT $ runReaderT (unRequesterInternalT a) env
136 where (PerformEventT (RequesterT a)) = f k v
136 where (PerformEventT (RequesterT a)) = f k v
137 children' <- requestingIdentity $ traversePatchDMapWithMoveWithKey runA <$> a'
137 children' <- requestingIdentity $ traversePatchDMapWithMoveWithKey runA <$> a'
src/Reflex/Requester/Base/Internal.hs+7−26
@@ -66,6 +66,8 @@ import Data.GADT.Compare
66import Data.Witherable
66import Data.Witherable
67import Data.Foldable
67import Data.Foldable
68
68
69+import Unsafe.Coerce
70+
69import Debug.Trace
71import Debug.Trace
70
72
71data RequestData ps request = forall s. RequestData !(TagGen ps s) !(NonEmptyDeferred (RequestEnvelope s request))
73data RequestData ps request = forall s. RequestData !(TagGen ps s) !(NonEmptyDeferred (RequestEnvelope s request))
@@ -87,7 +89,7 @@ runRequesterT :: forall t request response m a
87 -> m (a, Event t (RequestData (PrimState m) request))
89 -> m (a, Event t (RequestData (PrimState m) request))
88runRequesterT (RequesterT a) wrappedResponses = withRequesterInternalT $ \(requests :: Event t (NonEmptyDeferred (RequestEnvelope s request))) -> do
90runRequesterT (RequesterT a) wrappedResponses = withRequesterInternalT $ \(requests :: Event t (NonEmptyDeferred (RequestEnvelope s request))) -> do
89 (_, tg) <- RequesterInternalT ask
91 (_, tg) <- RequesterInternalT ask
90− result <- a
92+ result <- (unsafeCoerce :: RequesterInternalT FakeRequesterStatePhantom t request response m a -> RequesterInternalT s t request response m a) a
91 let responses = fforMaybe wrappedResponses $ \(ResponseData tg' m) -> case tg `geq` tg' of
93 let responses = fforMaybe wrappedResponses $ \(ResponseData tg' m) -> case tg `geq` tg' of
92 Nothing -> trace ("runRequesterT: bad TagGen: expected " <> show tg <> " but got " <> show tg') Nothing --TODO: Warn somehow
94 Nothing -> trace ("runRequesterT: bad TagGen: expected " <> show tg <> " but got " <> show tg') Nothing --TODO: Warn somehow
93 Just Refl -> Just m
95 Just Refl -> Just m
@@ -117,32 +119,11 @@ withRequesterInternalT f = withTagGen $ \tg -> do
117
119
118data RequestEnvelope s request = forall a. RequestEnvelope {-# UNPACK #-} !(Maybe (Tag s a)) !(request a)
120data RequestEnvelope s request = forall a. RequestEnvelope {-# UNPACK #-} !(Maybe (Tag s a)) !(request a)
119
121
120−newtype RequesterT t (request :: * -> *) (response :: * -> *) m a = RequesterT { unRequesterT :: forall s. RequesterInternalT s t request response m a }
122+-- This is because using forall ruins inlining
121−
123+data FakeRequesterStatePhantom
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
143
124
144−instance MonadException m => MonadException (RequesterT t request respnose m) where
125+newtype RequesterT t (request :: * -> *) (response :: * -> *) m a = RequesterT { unRequesterT :: RequesterInternalT FakeRequesterStatePhantom t request response m a }
145− throw e = RequesterT $ throw e
126+ deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException)
146
127
147newtype 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 }
128newtype 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 }
148 deriving
129 deriving