Skip to content
Snippets Groups Projects
Commit 8d905326 authored by Jens Nolte's avatar Jens Nolte
Browse files

Remove pingObservable because of inconsistent semantics

How to efficiently enforce a roundtrip through `observe` has to be
reevaluated later.
parent d6888e96
No related branches found
No related tags found
No related merge requests found
...@@ -96,19 +96,13 @@ class IsRetrievable r a => IsObservable r a | a -> r where ...@@ -96,19 +96,13 @@ class IsRetrievable r a => IsObservable r a | a -> r where
-> m Disposer -> m Disposer
observe observable = observe (toObservable observable) observe observable = observe (toObservable observable)
pingObservable
:: (MonadQuasar m, MonadIO m)
=> a -- ^ observable
-> m ()
pingObservable observable = pingObservable (toObservable observable)
toObservable :: a -> Observable r toObservable :: a -> Observable r
toObservable = Observable toObservable = Observable
mapObservable :: (r -> r2) -> a -> Observable r2 mapObservable :: (r -> r2) -> a -> Observable r2
mapObservable f = Observable . MappedObservable f . toObservable mapObservable f = Observable . MappedObservable f . toObservable
{-# MINIMAL toObservable | observe, pingObservable #-} {-# MINIMAL toObservable | observe #-}
observe_ observe_
...@@ -251,7 +245,6 @@ instance IsObservable a (ConstObservable a) where ...@@ -251,7 +245,6 @@ instance IsObservable a (ConstObservable a) where
observe (ConstObservable x) callback = liftQuasarSTM do observe (ConstObservable x) callback = liftQuasarSTM do
callback $ ObservableValue x callback $ ObservableValue x
pure trivialDisposer pure trivialDisposer
pingObservable _ = pure ()
newtype ThrowObservable a = ThrowObservable SomeException newtype ThrowObservable a = ThrowObservable SomeException
...@@ -261,7 +254,6 @@ instance IsObservable a (ThrowObservable a) where ...@@ -261,7 +254,6 @@ instance IsObservable a (ThrowObservable a) where
observe (ThrowObservable ex) callback = liftQuasarSTM do observe (ThrowObservable ex) callback = liftQuasarSTM do
callback $ ObservableNotAvailable ex callback $ ObservableNotAvailable ex
pure trivialDisposer pure trivialDisposer
pingObservable _ = pure ()
data MappedObservable a = forall b. MappedObservable (b -> a) (Observable b) data MappedObservable a = forall b. MappedObservable (b -> a) (Observable b)
...@@ -269,7 +261,6 @@ instance IsRetrievable a (MappedObservable a) where ...@@ -269,7 +261,6 @@ instance IsRetrievable a (MappedObservable a) where
retrieve (MappedObservable f observable) = f <$> retrieve observable retrieve (MappedObservable f observable) = f <$> retrieve observable
instance IsObservable a (MappedObservable a) where instance IsObservable a (MappedObservable a) where
observe (MappedObservable fn observable) callback = observe observable (callback . fmap fn) 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 mapObservable f1 (MappedObservable f2 upstream) = toObservable $ MappedObservable (f1 . f2) upstream
...@@ -297,12 +288,6 @@ instance IsObservable a (LiftA2Observable a) where ...@@ -297,12 +288,6 @@ instance IsObservable a (LiftA2Observable a) where
dy <- observe fy (\update -> liftSTM (writeTVar var1 (Just update)) >> callCallback) dy <- observe fy (\update -> liftSTM (writeTVar var1 (Just update)) >> callCallback)
pure $ dx <> dy 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 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 ...@@ -342,10 +327,6 @@ instance IsObservable a (BindObservable a) where
activeKey <- readTVar keyVar activeKey <- readTVar keyVar
when (callbackKey == activeKey) (callback rmsg) 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) mapObservable f (BindObservable fx fn) = toObservable $ BindObservable fx (f <<$>> fn)
...@@ -381,9 +362,6 @@ instance IsObservable a (CatchObservable e a) where ...@@ -381,9 +362,6 @@ instance IsObservable a (CatchObservable e a) where
activeKey <- readTVar keyVar activeKey <- readTVar keyVar
when (callbackKey == activeKey) (callback rmsg) 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 ()))) newtype ObserverRegistry a = ObserverRegistry (TVar (HM.HashMap Unique (ObservableState a -> STM ())))
...@@ -419,8 +397,6 @@ instance IsObservable a (ObservableVar a) where ...@@ -419,8 +397,6 @@ instance IsObservable a (ObservableVar a) where
observe (ObservableVar var registry) callback = liftQuasarSTM do observe (ObservableVar var registry) callback = liftQuasarSTM do
registerObserver registry callback . ObservableValue =<< readTVar var registerObserver registry callback . ObservableValue =<< readTVar var
pingObservable _ = pure ()
newObservableVar :: MonadSTM m => a -> m (ObservableVar a) newObservableVar :: MonadSTM m => a -> m (ObservableVar a)
newObservableVar x = liftSTM $ ObservableVar <$> newTVar x <*> newObserverRegistry newObservableVar x = liftSTM $ ObservableVar <$> newTVar x <*> newObserverRegistry
...@@ -462,8 +438,6 @@ instance IsObservable a (ObservablePrim a) where ...@@ -462,8 +438,6 @@ instance IsObservable a (ObservablePrim a) where
observe (ObservablePrim var registry) callback = liftQuasarSTM do observe (ObservablePrim var registry) callback = liftQuasarSTM do
registerObserver registry callback =<< readTVar var registerObserver registry callback =<< readTVar var
pingObservable _ = pure ()
newObservablePrim :: MonadSTM m => ObservableState a -> m (ObservablePrim a) newObservablePrim :: MonadSTM m => ObservableState a -> m (ObservablePrim a)
newObservablePrim x = liftSTM $ ObservablePrim <$> newTVar x <*> newObserverRegistry newObservablePrim x = liftSTM $ ObservablePrim <$> newTVar x <*> newObserverRegistry
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment