From 8d905326d91d874308fd96961ac87cfcd0d574b1 Mon Sep 17 00:00:00 2001
From: Jens Nolte <git@queezle.net>
Date: Sun, 24 Apr 2022 19:38:02 +0200
Subject: [PATCH] Remove pingObservable because of inconsistent semantics
How to efficiently enforce a roundtrip through `observe` has to be
reevaluated later.
---
src/Quasar/Observable.hs | 28 +---------------------------
1 file changed, 1 insertion(+), 27 deletions(-)
diff --git a/src/Quasar/Observable.hs b/src/Quasar/Observable.hs
index 43be655..79c5fcc 100644
--- a/src/Quasar/Observable.hs
+++ b/src/Quasar/Observable.hs
@@ -96,19 +96,13 @@ class IsRetrievable r a => IsObservable r a | a -> r where
-> m Disposer
observe observable = observe (toObservable observable)
- pingObservable
- :: (MonadQuasar m, MonadIO m)
- => a -- ^ observable
- -> m ()
- pingObservable observable = pingObservable (toObservable observable)
-
toObservable :: a -> Observable r
toObservable = Observable
mapObservable :: (r -> r2) -> a -> Observable r2
mapObservable f = Observable . MappedObservable f . toObservable
- {-# MINIMAL toObservable | observe, pingObservable #-}
+ {-# MINIMAL toObservable | observe #-}
observe_
@@ -251,7 +245,6 @@ instance IsObservable a (ConstObservable a) where
observe (ConstObservable x) callback = liftQuasarSTM do
callback $ ObservableValue x
pure trivialDisposer
- pingObservable _ = pure ()
newtype ThrowObservable a = ThrowObservable SomeException
@@ -261,7 +254,6 @@ instance IsObservable a (ThrowObservable a) where
observe (ThrowObservable ex) callback = liftQuasarSTM do
callback $ ObservableNotAvailable ex
pure trivialDisposer
- pingObservable _ = pure ()
data MappedObservable a = forall b. MappedObservable (b -> a) (Observable b)
@@ -269,7 +261,6 @@ instance IsRetrievable a (MappedObservable a) where
retrieve (MappedObservable f observable) = f <$> retrieve observable
instance IsObservable a (MappedObservable a) where
observe (MappedObservable fn observable) callback = observe observable (callback . fmap fn)
- pingObservable (MappedObservable _ observable) = pingObservable observable
mapObservable f1 (MappedObservable f2 upstream) = toObservable $ MappedObservable (f1 . f2) upstream
@@ -297,12 +288,6 @@ instance IsObservable a (LiftA2Observable a) where
dy <- observe fy (\update -> liftSTM (writeTVar var1 (Just update)) >> callCallback)
pure $ dx <> dy
- pingObservable (LiftA2Observable _ fx fy) = liftQuasarIO do
- -- LATER: keep backpressure for parallel network requests
- future <- async $ pingObservable fy
- pingObservable fx
- await future
-
mapObservable f1 (LiftA2Observable f2 fx fy) = toObservable $ LiftA2Observable (\x y -> f1 (f2 x y)) fx fy
@@ -342,10 +327,6 @@ instance IsObservable a (BindObservable a) where
activeKey <- readTVar keyVar
when (callbackKey == activeKey) (callback rmsg)
- pingObservable (BindObservable fx fn) = do
- x <- retrieve fx
- pingObservable (fn x)
-
mapObservable f (BindObservable fx fn) = toObservable $ BindObservable fx (f <<$>> fn)
@@ -381,9 +362,6 @@ instance IsObservable a (CatchObservable e a) where
activeKey <- readTVar keyVar
when (callbackKey == activeKey) (callback rmsg)
- pingObservable (CatchObservable fx fn) = do
- pingObservable fx `catch` \ex -> pingObservable (fn ex)
-
newtype ObserverRegistry a = ObserverRegistry (TVar (HM.HashMap Unique (ObservableState a -> STM ())))
@@ -419,8 +397,6 @@ instance IsObservable a (ObservableVar a) where
observe (ObservableVar var registry) callback = liftQuasarSTM do
registerObserver registry callback . ObservableValue =<< readTVar var
- pingObservable _ = pure ()
-
newObservableVar :: MonadSTM m => a -> m (ObservableVar a)
newObservableVar x = liftSTM $ ObservableVar <$> newTVar x <*> newObserverRegistry
@@ -462,8 +438,6 @@ instance IsObservable a (ObservablePrim a) where
observe (ObservablePrim var registry) callback = liftQuasarSTM do
registerObserver registry callback =<< readTVar var
- pingObservable _ = pure ()
-
newObservablePrim :: MonadSTM m => ObservableState a -> m (ObservablePrim a)
newObservablePrim x = liftSTM $ ObservablePrim <$> newTVar x <*> newObserverRegistry
--
GitLab