From e6369769106421d7bc8b3826be8639caccfefc2e Mon Sep 17 00:00:00 2001
From: Jens Nolte <git@queezle.net>
Date: Tue, 1 Sep 2020 23:45:00 +0200
Subject: [PATCH] Implement joinObservable
---
src/lib/Qd/Observable.hs | 34 ++++++++++++++++++++++++++++++++++
1 file changed, 34 insertions(+)
diff --git a/src/lib/Qd/Observable.hs b/src/lib/Qd/Observable.hs
index db95457..e5b0594 100644
--- a/src/lib/Qd/Observable.hs
+++ b/src/lib/Qd/Observable.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE UndecidableInstances #-}
+
module Qd.Observable (
SomeObservable(..),
Observable(..),
@@ -11,6 +13,7 @@ module Qd.Observable (
mkBasicObservable,
setBasicObservable,
updateBasicObservable,
+ joinObservable,
) where
import Control.Concurrent.MVar
@@ -95,3 +98,34 @@ updateBasicObservable (BasicObservable mvar) f =
let newState = (\v -> f v) <$> oldState
mapM_ (\callback -> callback (Update, newState)) subscribers
return (newState, subscribers)
+
+newtype JoinedObservable o = JoinedObservable o
+instance forall o i v. (Observable i o, Observable v i) => Observable v (JoinedObservable o) where
+ getValue :: JoinedObservable o -> IO (ObservableState v)
+ getValue (JoinedObservable outer) = do
+ state <- getValue outer
+ case state of
+ Just inner -> getValue inner
+ Nothing -> return Nothing
+ subscribe :: (JoinedObservable o) -> (ObservableMessage v -> IO ()) -> IO SubscriptionHandle
+ subscribe (JoinedObservable outer) handler = do
+ innerSubscriptionMVar <- newMVar dummySubscription
+ outerSubscription <- subscribe outer (outerHandler innerSubscriptionMVar)
+ return $ SubscriptionHandle{unsubscribe = unsubscribe' outerSubscription}
+ where
+ dummySubscription = SubscriptionHandle { unsubscribe = return () }
+ outerHandler innerSubscriptionMVar = outerHandler'
+ where
+ outerHandler' (_, Just inner) = do
+ unsubscribe =<< takeMVar innerSubscriptionMVar
+ innerSubscription <- subscribe inner handler
+ putMVar innerSubscriptionMVar innerSubscription
+ outerHandler' (reason, Nothing) = do
+ unsubscribe =<< takeMVar innerSubscriptionMVar
+ handler (reason, Nothing)
+ putMVar innerSubscriptionMVar dummySubscription
+ unsubscribe' outerSubscription = do
+ unsubscribe outerSubscription
+
+joinObservable :: (Observable i o, Observable v i) => o -> SomeObservable v
+joinObservable outer = SomeObservable $ JoinedObservable outer
--
GitLab