git.iko.soy/reflex
on develop help sign in
Try using NonEmptyDeferred
commitd9144d69c4b3416f476b8e2876e1c6c8ffdb7c75 authorRyan Trinkle <ryan.trinkle@gmail.com> dateFri 20 Sep 2019, 10:54 (7 years ago) parent06337b7
3 files changed+59−14
compare with develop
unifiedsplit
src/Data/List/NonEmpty/Deferred.hs+26 src/Reflex/PerformEvent/Base.hs+23−7 src/Reflex/Requester/Base/Internal.hs+10−7
src/Data/List/NonEmpty/Deferred.hsnew file+26
@@ -0,0 +1,26 @@
1+-- | Uses a non-associative internal structure to represent a NonEmpty list, but
2+-- prevents external observers from observing the non-associativity. This
3+-- allows O(1) '(<>)'.
4+
5+{-# LANGUAGE LambdaCase #-}
6+module Data.List.NonEmpty.Deferred where
7+
8+import Data.List.NonEmpty (NonEmpty (..))
9+import qualified Data.List.NonEmpty as NonEmpty
10+
11+data NonEmptyDeferred a
12+ = NonEmptyDeferred_Singleton a
13+ | NonEmptyDeferred_Append !(NonEmptyDeferred a) !(NonEmptyDeferred a)
14+
15+singleton :: a -> NonEmptyDeferred a
16+singleton = NonEmptyDeferred_Singleton
17+
18+{-# INLINE toNonEmpty #-}
19+toNonEmpty :: NonEmptyDeferred a -> NonEmpty a
20+toNonEmpty = go []
21+ where go t = \case
22+ NonEmptyDeferred_Singleton a -> a :| t
23+ NonEmptyDeferred_Append a b -> go (NonEmpty.toList $ go t b) a
24+
25+instance Semigroup (NonEmptyDeferred a) where
26+ (<>) = NonEmptyDeferred_Append
src/Reflex/PerformEvent/Base.hs+23−7
@@ -47,6 +47,12 @@ import Data.Functor.Compose
4747import Data.Functor.Misc
4848import Data.IntMap.Strict (IntMap)
4949import qualified Data.IntMap.Strict as IntMap
50+import Data.List.NonEmpty (NonEmpty (..))
51+import Data.List.NonEmpty.Deferred (NonEmptyDeferred)
52+import qualified Data.List.NonEmpty.Deferred as NonEmptyDeferred
53+import Data.Map (Map)
54+import qualified Data.Map as Map
55+import Data.Semigroup (Semigroup (sconcat))
5056import qualified Data.Semigroup as S
5157import Data.Unique.Tag.Local
5258import Data.Sequence (Seq)
@@ -86,7 +92,7 @@ instance (ReflexHost t, Ref m ~ Ref IO, PrimMonad (HostFrame t)) => PerformEvent
8692instance (ReflexHost t, PrimMonad (HostFrame t)) => Adjustable t (PerformEventT t m) where
8793 runWithReplace a0 a' = PerformEventT $ RequesterT $ do
8894 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))))
95+ let runA :: forall a. PerformEventT t m a -> HostFrame t (a, Event t (NonEmptyDeferred (RequestEnvelope s (HostFrame t))))
9096 runA (PerformEventT (RequesterT a)) = runEventWriterT $ runReaderT (unRequesterInternalT a) env
9197 (result0, requests0) <- lift $ runA a0
9298 newA <- requestingIdentity $ traceEventWith (const "running new widget") $ runA <$> a'
@@ -96,7 +102,7 @@ instance (ReflexHost t, PrimMonad (HostFrame t)) => Adjustable t (PerformEventT
96102 pure (result0, fmapCheap fst newA)
97103 traverseIntMapWithKeyWithAdjust f a0 a' = PerformEventT $ RequesterT $ do
98104 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))))
105+ let runA :: forall a. PerformEventT t m a -> HostFrame t (a, Event t (NonEmptyDeferred (RequestEnvelope s (HostFrame t))))
100106 runA (PerformEventT (RequesterT a)) = runEventWriterT $ runReaderT (unRequesterInternalT a) env
101107 children' <- requestingIdentity $ itraverse (\k -> runA . f k) <$> a'
102108 children0 <- lift $ itraverse (\k -> runA . f k) a0
@@ -106,11 +112,11 @@ instance (ReflexHost t, PrimMonad (HostFrame t)) => Adjustable t (PerformEventT
106112 requests' = fmap snd `fmapCheap` children'
107113 requests <- switchHoldPromptOnlyIncremental mergeIntIncremental coincidencePatchIntMap requests0 $ requests'
108114 --TODO: promptly *prevent* events, then sign up the new ones; this is a serious breaking change to PerformEvent
109− RequesterInternalT $ tellEvent $ fforMaybeCheap requests $ \m -> if null m then Nothing else Just $ fold m
115+ RequesterInternalT $ tellEvent $ fforMaybeCheap requests concatIntMapMaybe
110116 pure (results0, results')
111117 traverseDMapWithKeyWithAdjust (f :: forall a. k a -> v a -> PerformEventT t m (v' a)) (a0 :: DMap k v) a' = PerformEventT $ RequesterT $ do
112118 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)
119+ let runA :: forall a. k a -> v a -> HostFrame t (Compose ((,) (Event t (NonEmptyDeferred (RequestEnvelope s (HostFrame t))))) v' a)
114120 runA k v = fmap (Compose . swap) $ runEventWriterT $ runReaderT (unRequesterInternalT a) env
115121 where (PerformEventT (RequesterT a)) = f k v
116122 children' <- requestingIdentity $ traversePatchDMapWithKey runA <$> a'
@@ -121,11 +127,11 @@ instance (ReflexHost t, PrimMonad (HostFrame t)) => Adjustable t (PerformEventT
121127 requests' = weakenPatchDMapWith (fst . getCompose) `fmapCheap` children'
122128 requests <- switchHoldPromptOnlyIncremental mergeMapIncremental coincidencePatchMap requests0 $ requests'
123129 --TODO: promptly *prevent* events, then sign up the new ones; this is a serious breaking change to PerformEvent
124− RequesterInternalT $ tellEvent $ fforMaybeCheap requests $ \m -> if null m then Nothing else Just $ fold m
130+ RequesterInternalT $ tellEvent $ fforMaybeCheap requests concatMapMaybe
125131 pure (results0, results')
126132 traverseDMapWithKeyWithAdjustWithMove (f :: forall a. k a -> v a -> PerformEventT t m (v' a)) (a0 :: DMap k v) a' = PerformEventT $ RequesterT $ do
127133 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)
134+ let runA :: forall a. k a -> v a -> HostFrame t (Compose ((,) (Event t (NonEmptyDeferred (RequestEnvelope s (HostFrame t))))) v' a)
129135 runA k v = fmap (Compose . swap) $ runEventWriterT $ runReaderT (unRequesterInternalT a) env
130136 where (PerformEventT (RequesterT a)) = f k v
131137 children' <- requestingIdentity $ traversePatchDMapWithMoveWithKey runA <$> a'
@@ -136,9 +142,19 @@ instance (ReflexHost t, PrimMonad (HostFrame t)) => Adjustable t (PerformEventT
136142 requests' = weakenPatchDMapWithMoveWith (fst . getCompose) `fmapCheap` children'
137143 requests <- switchHoldPromptOnlyIncremental mergeMapIncrementalWithMove coincidencePatchMapWithMove requests0 $ requests'
138144 --TODO: promptly *prevent* events, then sign up the new ones; this is a serious breaking change to PerformEvent
139− RequesterInternalT $ tellEvent $ fforMaybeCheap requests $ \m -> if null m then Nothing else Just $ fold m
145+ RequesterInternalT $ tellEvent $ fforMaybeCheap requests concatMapMaybe
140146 pure (results0, results')
141147
148+concatIntMapMaybe :: Semigroup a => IntMap a -> Maybe a
149+concatIntMapMaybe m = case IntMap.elems m of
150+ [] -> Nothing
151+ h : t -> Just $ sconcat $ h :| t
152+
153+concatMapMaybe :: Semigroup a => Map k a -> Maybe a
154+concatMapMaybe m = case Map.elems m of
155+ [] -> Nothing
156+ h : t -> Just $ sconcat $ h :| t
157+
142158defaultAdjustBase :: forall t v v2 k' p. (Monad (HostFrame t), PrimMonad (HostFrame t), Reflex t)
143159 => ((forall a. k' a -> v a -> HostFrame t (v2 a)) -> p k' v -> HostFrame t (p k' v2))
144160 -> (forall a. k' a -> v a -> HostFrame t (v2 a))
src/Reflex/Requester/Base/Internal.hs+10−7
@@ -45,6 +45,9 @@ import Data.Functor.Compose
4545import Data.Functor.Misc
4646import Data.IntMap.Strict (IntMap)
4747import qualified Data.IntMap.Strict as IntMap
48+import qualified Data.List.NonEmpty as NonEmpty
49+import Data.List.NonEmpty.Deferred (NonEmptyDeferred)
50+import qualified Data.List.NonEmpty.Deferred as NonEmptyDeferred
4851import Data.Map (Map)
4952import qualified Data.Map as Map
5053import Data.Monoid ((<>))
@@ -71,11 +74,11 @@ import Debug.Trace
7174--implemented as a binary tree whose representation isn't associative, but which
7275--doesn't allow any external party to observe the lack of associativity.
7376
74−data RequestData ps request = forall s. RequestData !(TagGen ps s) !(Seq (RequestEnvelope s request))
77+data RequestData ps request = forall s. RequestData !(TagGen ps s) !(NonEmptyDeferred (RequestEnvelope s request))
7578data ResponseData ps response = forall s. ResponseData !(TagGen ps s) !(TagMap s response)
7679
7780traverseRequesterData :: forall m request response. Applicative m => (forall a. request a -> m (response a)) -> RequestData (PrimState m) request -> m (ResponseData (PrimState m) response)
78−traverseRequesterData f (RequestData tg es) = ResponseData tg . TagMap.fromList <$> wither g (toList es)
81+traverseRequesterData f (RequestData tg es) = ResponseData tg . TagMap.fromList <$> wither g (NonEmpty.toList $ NonEmptyDeferred.toNonEmpty es)
7982 where g (RequestEnvelope mt req) = case mt of
8083 Just t -> Just . (t :=>) <$> f req
8184 Nothing -> Nothing <$ f req
@@ -88,7 +91,7 @@ runRequesterT :: forall t request response m a
8891 => RequesterT t request response m a
8992 -> Event t (ResponseData (PrimState m) response)
9093 -> m (a, Event t (RequestData (PrimState m) request))
91−runRequesterT (RequesterT a) wrappedResponses = withRequesterInternalT $ \(requests :: Event t (Seq (RequestEnvelope s request))) -> do
94+runRequesterT (RequesterT a) wrappedResponses = withRequesterInternalT $ \(requests :: Event t (NonEmptyDeferred (RequestEnvelope s request))) -> do
9295 (_, tg) <- RequesterInternalT ask
9396 result <- a
9497 let responses = fforMaybe wrappedResponses $ \(ResponseData tg' m) -> case tg `geq` tg' of
@@ -111,7 +114,7 @@ withRequesterInternalT
111114 , PrimMonad m
112115 , MonadFix m
113116 )
114− => (forall s. Event t (Seq (RequestEnvelope s request)) -> RequesterInternalT s t request response m (Event t (TagMap s response), a))
117+ => (forall s. Event t (NonEmptyDeferred (RequestEnvelope s request)) -> RequesterInternalT s t request response m (Event t (TagMap s response), a))
115118 -> m a
116119withRequesterInternalT f = withTagGen $ \tg -> do
117120 rec let RequesterInternalT a = f requests
@@ -147,7 +150,7 @@ instance MonadIO m => MonadIO (RequesterT t request respnose m) where
147150instance MonadException m => MonadException (RequesterT t request respnose m) where
148151 throw e = RequesterT $ throw e
149152
150−newtype 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 }
153+newtype 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 }
151154 deriving
152155 ( Functor, Applicative, Monad, MonadFix, MonadIO, MonadException
153156#if MIN_VERSION_base(4,9,1)
@@ -215,10 +218,10 @@ instance (Reflex t, PrimMonad m) => Requester t (RequesterInternalT s t request
215218 requesting e = RequesterInternalT $ do
216219 (s, tg) <- ask
217220 t <- lift $ lift $ newTag tg
218− tellEvent $ fmapCheap (Seq.singleton . RequestEnvelope (Just t)) e
221+ tellEvent $ fmapCheap (NonEmptyDeferred.singleton . RequestEnvelope (Just t)) e
219222 pure $ selectTag s t
220223 requesting_ e = RequesterInternalT $ do
221− tellEvent $ fmapCheap (Seq.singleton . RequestEnvelope Nothing) e
224+ tellEvent $ fmapCheap (NonEmptyDeferred.singleton . RequestEnvelope Nothing) e
222225
223226instance (Adjustable t m, MonadHold t m) => Adjustable t (RequesterInternalT s t request response m) where
224227 {-# INLINABLE runWithReplace #-}