diff --git a/src/lib/Qd/Observable.hs b/src/lib/Qd/Observable.hs index 95e6b898a1f9b9c6f0cd7313e30c3e30b2ce388a..db9545714cb9d01d0968f646b741f391c2fa3677 100644 --- a/src/lib/Qd/Observable.hs +++ b/src/lib/Qd/Observable.hs @@ -1,6 +1,6 @@ module Qd.Observable ( SomeObservable(..), - IsObservable(..), + Observable(..), subscribe', SubscriptionHandle(..), Callback, @@ -36,20 +36,20 @@ mapObservableMessage f (r, s) = (r, ) <$> mapObservableState f s newtype SubscriptionHandle = SubscriptionHandle { unsubscribe :: IO () } -class IsObservable v o | o -> v where +class Observable v o | o -> v where getValue :: o -> IO (ObservableState v) subscribe :: o -> (ObservableMessage v -> IO ()) -> IO SubscriptionHandle mapObservable :: (v -> IO a) -> o -> SomeObservable a mapObservable f = SomeObservable . MappedObservable f -subscribe' :: IsObservable v o => o -> (SubscriptionHandle -> ObservableMessage v -> IO ()) -> IO SubscriptionHandle +subscribe' :: Observable v o => o -> (SubscriptionHandle -> ObservableMessage v -> IO ()) -> IO SubscriptionHandle subscribe' observable callback = mfix $ \subscription -> subscribe observable (callback subscription) type Callback v = ObservableMessage v -> IO () -- | Existential quantification wrapper for the Observable type class. -data SomeObservable v = forall o. IsObservable v o => SomeObservable o -instance IsObservable v (SomeObservable v) where +data SomeObservable v = forall o. Observable v o => SomeObservable o +instance Observable v (SomeObservable v) where getValue (SomeObservable o) = getValue o subscribe (SomeObservable o) = subscribe o mapObservable f (SomeObservable o) = mapObservable f o @@ -57,15 +57,15 @@ instance IsObservable v (SomeObservable v) where instance Functor SomeObservable where fmap f = mapObservable (return . f) -data MappedObservable b = forall a o. IsObservable a o => MappedObservable (a -> IO b) o -instance IsObservable v (MappedObservable v) where +data MappedObservable b = forall a o. Observable a o => MappedObservable (a -> IO b) o +instance Observable v (MappedObservable v) where getValue (MappedObservable f observable) = mapObservableState f =<< getValue observable subscribe (MappedObservable f observable) callback = subscribe observable (callback <=< mapObservableMessage f) mapObservable f1 (MappedObservable f2 upstream) = SomeObservable $ MappedObservable (f1 <=< f2) upstream newtype BasicObservable v = BasicObservable (MVar (ObservableState v, HM.HashMap Unique (Callback v))) -instance IsObservable v (BasicObservable v) where +instance Observable v (BasicObservable v) where getValue (BasicObservable mvar) = fst <$> readMVar mvar subscribe (BasicObservable mvar) callback = do key <- newUnique