git.iko.soy/reflex
on develop help sign in
Switch to using fake phantom type
commitee9c838fcddb31ffc67bcb79f827a9e1c87698fa authorRyan Trinkle <ryan.trinkle@gmail.com> dateFri 20 Sep 2019, 09:49 (7 years ago) parent06337b7
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
@@ -85,18 +85,18 @@ instance (ReflexHost t, Ref m ~ Ref IO, PrimMonad (HostFrame t)) => PerformEvent
8585
8686instance (ReflexHost t, PrimMonad (HostFrame t)) => Adjustable t (PerformEventT t m) where
8787 runWithReplace a0 a' = PerformEventT $ RequesterT $ do
88− env@(_, _ :: TagGen (PrimState (HostFrame t)) s) <- RequesterInternalT ask
89− let runA :: forall a. PerformEventT t m a -> HostFrame t (a, Event t (Seq (RequestEnvelope s (HostFrame t))))
88+ env@(_, _ :: TagGen (PrimState (HostFrame t)) FakeRequesterStatePhantom) <- RequesterInternalT ask
89+ let runA :: forall a. PerformEventT t m a -> HostFrame t (a, Event t (Seq (RequestEnvelope FakeRequesterStatePhantom (HostFrame t))))
9090 runA (PerformEventT (RequesterT a)) = runEventWriterT $ runReaderT (unRequesterInternalT a) env
9191 (result0, requests0) <- lift $ runA a0
92− newA <- requestingIdentity $ traceEventWith (const "running new widget") $ runA <$> a'
93− requests <- switchHoldPromptOnly requests0 $ traceEventWith (const "updating runWithReplace") $ fmapCheap snd newA
92+ newA <- requestingIdentity $ runA <$> a'
93+ requests <- switchHoldPromptOnly requests0 $ fmapCheap snd newA
9494 --TODO: promptly *prevent* events, then sign up the new ones; this is a serious breaking change to PerformEvent
9595 RequesterInternalT $ tellEvent requests
9696 pure (result0, fmapCheap fst newA)
9797 traverseIntMapWithKeyWithAdjust f a0 a' = PerformEventT $ RequesterT $ do
98− env@(_, _ :: TagGen (PrimState (HostFrame t)) s) <- RequesterInternalT ask
99− let runA :: forall a. PerformEventT t m a -> HostFrame t (a, Event t (Seq (RequestEnvelope s (HostFrame t))))
98+ env@(_, _ :: TagGen (PrimState (HostFrame t)) FakeRequesterStatePhantom) <- RequesterInternalT ask
99+ let runA :: forall a. PerformEventT t m a -> HostFrame t (a, Event t (Seq (RequestEnvelope FakeRequesterStatePhantom (HostFrame t))))
100100 runA (PerformEventT (RequesterT a)) = runEventWriterT $ runReaderT (unRequesterInternalT a) env
101101 children' <- requestingIdentity $ itraverse (\k -> runA . f k) <$> a'
102102 children0 <- lift $ itraverse (\k -> runA . f k) a0
@@ -109,8 +109,8 @@ instance (ReflexHost t, PrimMonad (HostFrame t)) => Adjustable t (PerformEventT
109109 RequesterInternalT $ tellEvent $ fforMaybeCheap requests $ \m -> if null m then Nothing else Just $ fold m
110110 pure (results0, results')
111111 traverseDMapWithKeyWithAdjust (f :: forall a. k a -> v a -> PerformEventT t m (v' a)) (a0 :: DMap k v) a' = PerformEventT $ RequesterT $ do
112− env@(_, _ :: TagGen (PrimState (HostFrame t)) s) <- RequesterInternalT ask
113− let runA :: forall a. k a -> v a -> HostFrame t (Compose ((,) (Event t (Seq (RequestEnvelope s (HostFrame t))))) v' a)
112+ env@(_, _ :: TagGen (PrimState (HostFrame t)) FakeRequesterStatePhantom) <- RequesterInternalT ask
113+ let runA :: forall a. k a -> v a -> HostFrame t (Compose ((,) (Event t (Seq (RequestEnvelope FakeRequesterStatePhantom (HostFrame t))))) v' a)
114114 runA k v = fmap (Compose . swap) $ runEventWriterT $ runReaderT (unRequesterInternalT a) env
115115 where (PerformEventT (RequesterT a)) = f k v
116116 children' <- requestingIdentity $ traversePatchDMapWithKey runA <$> a'
@@ -124,8 +124,8 @@ instance (ReflexHost t, PrimMonad (HostFrame t)) => Adjustable t (PerformEventT
124124 RequesterInternalT $ tellEvent $ fforMaybeCheap requests $ \m -> if null m then Nothing else Just $ fold m
125125 pure (results0, results')
126126 traverseDMapWithKeyWithAdjustWithMove (f :: forall a. k a -> v a -> PerformEventT t m (v' a)) (a0 :: DMap k v) a' = PerformEventT $ RequesterT $ do
127− env@(_, _ :: TagGen (PrimState (HostFrame t)) s) <- RequesterInternalT ask
128− let runA :: forall a. k a -> v a -> HostFrame t (Compose ((,) (Event t (Seq (RequestEnvelope s (HostFrame t))))) v' a)
127+ env@(_, _ :: TagGen (PrimState (HostFrame t)) FakeRequesterStatePhantom) <- RequesterInternalT ask
128+ let runA :: forall a. k a -> v a -> HostFrame t (Compose ((,) (Event t (Seq (RequestEnvelope FakeRequesterStatePhantom (HostFrame t))))) v' a)
129129 runA k v = fmap (Compose . swap) $ runEventWriterT $ runReaderT (unRequesterInternalT a) env
130130 where (PerformEventT (RequesterT a)) = f k v
131131 children' <- requestingIdentity $ traversePatchDMapWithMoveWithKey runA <$> a'
src/Reflex/Requester/Base/Internal.hs+7−26
@@ -63,6 +63,8 @@ import Data.GADT.Compare
6363import Data.Witherable
6464import Data.Foldable
6565
66+import Unsafe.Coerce
67+
6668import Debug.Trace
6769
6870--TODO: The use of Seq in this module could probably be replaced with something
@@ -90,7 +92,7 @@ runRequesterT :: forall t request response m a
9092 -> m (a, Event t (RequestData (PrimState m) request))
9193runRequesterT (RequesterT a) wrappedResponses = withRequesterInternalT $ \(requests :: Event t (Seq (RequestEnvelope s request))) -> do
9294 (_, tg) <- RequesterInternalT ask
93− result <- a
95+ result <- (unsafeCoerce :: RequesterInternalT FakeRequesterStatePhantom t request response m a -> RequesterInternalT s t request response m a) a
9496 let responses = fforMaybe wrappedResponses $ \(ResponseData tg' m) -> case tg `geq` tg' of
9597 Nothing -> trace ("runRequesterT: bad TagGen: expected " <> show tg <> " but got " <> show tg') Nothing --TODO: Warn somehow
9698 Just Refl -> Just m
@@ -120,32 +122,11 @@ withRequesterInternalT f = withTagGen $ \tg -> do
120122
121123data RequestEnvelope s request = forall a. RequestEnvelope {-# UNPACK #-} !(Maybe (Tag s a)) !(request a)
122124
123−newtype RequesterT t (request :: * -> *) (response :: * -> *) m a = RequesterT { unRequesterT :: forall s. RequesterInternalT s t request response m a }
124−
125−instance Functor m => Functor (RequesterT t request response m) where
126− fmap f (RequesterT x) = RequesterT $ fmap f x
127−
128−instance Monad m => Applicative (RequesterT t request response m) where
129− pure x = RequesterT $ pure x
130− RequesterT f <*> RequesterT x = RequesterT $ f <*> x
131− liftA2 f (RequesterT a) (RequesterT b) = RequesterT $ liftA2 f a b
132− RequesterT f <* RequesterT x = RequesterT $ f <* x
133− RequesterT f *> RequesterT x = RequesterT $ f *> x
134−
135−instance Monad m => Monad (RequesterT t request response m) where
136− return = pure
137− RequesterT mx >>= f = RequesterT $ mx >>= \x -> case f x of
138− RequesterT y -> y
139−
140−instance MonadFix m => MonadFix (RequesterT t request response m) where
141− mfix f = RequesterT $ mfix $ \x -> case f x of
142− RequesterT a -> a
143−
144−instance MonadIO m => MonadIO (RequesterT t request respnose m) where
145− liftIO a = RequesterT $ liftIO a
125+-- This is because using forall ruins inlining
126+data FakeRequesterStatePhantom
146127
147−instance MonadException m => MonadException (RequesterT t request respnose m) where
148− throw e = RequesterT $ throw e
128+newtype RequesterT t (request :: * -> *) (response :: * -> *) m a = RequesterT { unRequesterT :: RequesterInternalT FakeRequesterStatePhantom t request response m a }
129+ deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException)
149130
150131newtype 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 }
151132 deriving