git.iko.soy/reflex
on develop help sign in
Switch to using fake phantom type
ee9c838Ryan Trinkle
src/Reflex/PerformEvent/Base.hs+10−10
compare with develop
unifiedsplit
@@ -85,18 +85,18 @@ instance (ReflexHost t, Ref m ~ Ref IO, PrimMonad (HostFrame t)) => PerformEvent
85
85
86instance (ReflexHost t, PrimMonad (HostFrame t)) => Adjustable t (PerformEventT t m) where
86instance (ReflexHost t, PrimMonad (HostFrame t)) => Adjustable t (PerformEventT t m) where
87 runWithReplace a0 a' = PerformEventT $ RequesterT $ do
87 runWithReplace a0 a' = PerformEventT $ RequesterT $ do
88− env@(_, _ :: TagGen (PrimState (HostFrame t)) s) <- RequesterInternalT ask
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 s (HostFrame t))))
89+ let runA :: forall a. PerformEventT t m a -> HostFrame t (a, Event t (Seq (RequestEnvelope FakeRequesterStatePhantom (HostFrame t))))
90 runA (PerformEventT (RequesterT a)) = runEventWriterT $ runReaderT (unRequesterInternalT a) env
90 runA (PerformEventT (RequesterT a)) = runEventWriterT $ runReaderT (unRequesterInternalT a) env
91 (result0, requests0) <- lift $ runA a0
91 (result0, requests0) <- lift $ runA a0
92− newA <- requestingIdentity $ traceEventWith (const "running new widget") $ runA <$> a'
92+ newA <- requestingIdentity $ runA <$> a'
93− requests <- switchHoldPromptOnly requests0 $ traceEventWith (const "updating runWithReplace") $ fmapCheap snd newA
93+ requests <- switchHoldPromptOnly requests0 $ fmapCheap snd newA
94 --TODO: promptly *prevent* events, then sign up the new ones; this is a serious breaking change to PerformEvent
94 --TODO: promptly *prevent* events, then sign up the new ones; this is a serious breaking change to PerformEvent
95 RequesterInternalT $ tellEvent requests
95 RequesterInternalT $ tellEvent requests
96 pure (result0, fmapCheap fst newA)
96 pure (result0, fmapCheap fst newA)
97 traverseIntMapWithKeyWithAdjust f a0 a' = PerformEventT $ RequesterT $ do
97 traverseIntMapWithKeyWithAdjust f a0 a' = PerformEventT $ RequesterT $ do
98− env@(_, _ :: TagGen (PrimState (HostFrame t)) s) <- RequesterInternalT ask
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 s (HostFrame t))))
99+ let runA :: forall a. PerformEventT t m a -> HostFrame t (a, Event t (Seq (RequestEnvelope FakeRequesterStatePhantom (HostFrame t))))
100 runA (PerformEventT (RequesterT a)) = runEventWriterT $ runReaderT (unRequesterInternalT a) env
100 runA (PerformEventT (RequesterT a)) = runEventWriterT $ runReaderT (unRequesterInternalT a) env
101 children' <- requestingIdentity $ itraverse (\k -> runA . f k) <$> a'
101 children' <- requestingIdentity $ itraverse (\k -> runA . f k) <$> a'
102 children0 <- lift $ itraverse (\k -> runA . f k) a0
102 children0 <- lift $ itraverse (\k -> runA . f k) a0
@@ -109,8 +109,8 @@ instance (ReflexHost t, PrimMonad (HostFrame t)) => Adjustable t (PerformEventT
109 RequesterInternalT $ tellEvent $ fforMaybeCheap requests $ \m -> if null m then Nothing else Just $ fold m
109 RequesterInternalT $ tellEvent $ fforMaybeCheap requests $ \m -> if null m then Nothing else Just $ fold m
110 pure (results0, results')
110 pure (results0, results')
111 traverseDMapWithKeyWithAdjust (f :: forall a. k a -> v a -> PerformEventT t m (v' a)) (a0 :: DMap k v) a' = PerformEventT $ RequesterT $ do
111 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
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 s (HostFrame t))))) v' a)
113+ let runA :: forall a. k a -> v a -> HostFrame t (Compose ((,) (Event t (Seq (RequestEnvelope FakeRequesterStatePhantom (HostFrame t))))) v' a)
114 runA k v = fmap (Compose . swap) $ runEventWriterT $ runReaderT (unRequesterInternalT a) env
114 runA k v = fmap (Compose . swap) $ runEventWriterT $ runReaderT (unRequesterInternalT a) env
115 where (PerformEventT (RequesterT a)) = f k v
115 where (PerformEventT (RequesterT a)) = f k v
116 children' <- requestingIdentity $ traversePatchDMapWithKey runA <$> a'
116 children' <- requestingIdentity $ traversePatchDMapWithKey runA <$> a'
@@ -124,8 +124,8 @@ instance (ReflexHost t, PrimMonad (HostFrame t)) => Adjustable t (PerformEventT
124 RequesterInternalT $ tellEvent $ fforMaybeCheap requests $ \m -> if null m then Nothing else Just $ fold m
124 RequesterInternalT $ tellEvent $ fforMaybeCheap requests $ \m -> if null m then Nothing else Just $ fold m
125 pure (results0, results')
125 pure (results0, results')
126 traverseDMapWithKeyWithAdjustWithMove (f :: forall a. k a -> v a -> PerformEventT t m (v' a)) (a0 :: DMap k v) a' = PerformEventT $ RequesterT $ do
126 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
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 s (HostFrame t))))) v' a)
128+ let runA :: forall a. k a -> v a -> HostFrame t (Compose ((,) (Event t (Seq (RequestEnvelope FakeRequesterStatePhantom (HostFrame t))))) v' a)
129 runA k v = fmap (Compose . swap) $ runEventWriterT $ runReaderT (unRequesterInternalT a) env
129 runA k v = fmap (Compose . swap) $ runEventWriterT $ runReaderT (unRequesterInternalT a) env
130 where (PerformEventT (RequesterT a)) = f k v
130 where (PerformEventT (RequesterT a)) = f k v
131 children' <- requestingIdentity $ traversePatchDMapWithMoveWithKey runA <$> a'
131 children' <- requestingIdentity $ traversePatchDMapWithMoveWithKey runA <$> a'
src/Reflex/Requester/Base/Internal.hs+7−26
@@ -63,6 +63,8 @@ import Data.GADT.Compare
63import Data.Witherable
63import Data.Witherable
64import Data.Foldable
64import Data.Foldable
65
65
66+import Unsafe.Coerce
67+
66import Debug.Trace
68import Debug.Trace
67
69
68--TODO: The use of Seq in this module could probably be replaced with something
70--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
90 -> m (a, Event t (RequestData (PrimState m) request))
92 -> m (a, Event t (RequestData (PrimState m) request))
91runRequesterT (RequesterT a) wrappedResponses = withRequesterInternalT $ \(requests :: Event t (Seq (RequestEnvelope s request))) -> do
93runRequesterT (RequesterT a) wrappedResponses = withRequesterInternalT $ \(requests :: Event t (Seq (RequestEnvelope s request))) -> do
92 (_, tg) <- RequesterInternalT ask
94 (_, tg) <- RequesterInternalT ask
93− result <- a
95+ result <- (unsafeCoerce :: RequesterInternalT FakeRequesterStatePhantom t request response m a -> RequesterInternalT s t request response m a) a
94 let responses = fforMaybe wrappedResponses $ \(ResponseData tg' m) -> case tg `geq` tg' of
96 let responses = fforMaybe wrappedResponses $ \(ResponseData tg' m) -> case tg `geq` tg' of
95 Nothing -> trace ("runRequesterT: bad TagGen: expected " <> show tg <> " but got " <> show tg') Nothing --TODO: Warn somehow
97 Nothing -> trace ("runRequesterT: bad TagGen: expected " <> show tg <> " but got " <> show tg') Nothing --TODO: Warn somehow
96 Just Refl -> Just m
98 Just Refl -> Just m
@@ -120,32 +122,11 @@ withRequesterInternalT f = withTagGen $ \tg -> do
120
122
121data RequestEnvelope s request = forall a. RequestEnvelope {-# UNPACK #-} !(Maybe (Tag s a)) !(request a)
123data RequestEnvelope s request = forall a. RequestEnvelope {-# UNPACK #-} !(Maybe (Tag s a)) !(request a)
122
124
123−newtype RequesterT t (request :: * -> *) (response :: * -> *) m a = RequesterT { unRequesterT :: forall s. RequesterInternalT s t request response m a }
125+-- This is because using forall ruins inlining
124−
126+data FakeRequesterStatePhantom
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
146
127
147−instance MonadException m => MonadException (RequesterT t request respnose m) where
128+newtype RequesterT t (request :: * -> *) (response :: * -> *) m a = RequesterT { unRequesterT :: RequesterInternalT FakeRequesterStatePhantom t request response m a }
148− throw e = RequesterT $ throw e
129+ deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException)
149
130
150newtype 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 }
131newtype 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 }
151 deriving
132 deriving