From 35524730ab23a42089dfcf0385eb7ff24e3a2b5c Mon Sep 17 00:00:00 2001
From: Jens Nolte <git@queezle.net>
Date: Fri, 25 Sep 2020 20:12:05 +0200
Subject: [PATCH] Implement ObservableMap

---
 src/lib/Qd/Observable.hs               |  38 +++++++---
 src/lib/Qd/Observable/ObservableMap.hs | 100 +++++++++++++++++++++++++
 2 files changed, 128 insertions(+), 10 deletions(-)
 create mode 100644 src/lib/Qd/Observable/ObservableMap.hs

diff --git a/src/lib/Qd/Observable.hs b/src/lib/Qd/Observable.hs
index e5b0594..78a175f 100644
--- a/src/lib/Qd/Observable.hs
+++ b/src/lib/Qd/Observable.hs
@@ -14,6 +14,7 @@ module Qd.Observable (
   setBasicObservable,
   updateBasicObservable,
   joinObservable,
+  FnObservable(..),
 ) where
 
 import Control.Concurrent.MVar
@@ -30,39 +31,44 @@ instance Binary MessageReason
 type ObservableState v = Maybe v
 type ObservableMessage v = (MessageReason, ObservableState v)
 
-mapObservableState :: Monad m => (a -> m b) -> ObservableState a -> m (ObservableState b)
-mapObservableState _ Nothing = return Nothing
-mapObservableState f (Just v) = Just <$> f v
-
-mapObservableMessage :: Monad m => (a -> m b) -> ObservableMessage a -> m (ObservableMessage b)
-mapObservableMessage f (r, s) = (r, ) <$> mapObservableState f s
+mapObservableMessage :: Monad m => (Maybe a -> m (Maybe b)) -> ObservableMessage a -> m (ObservableMessage b)
+mapObservableMessage f (r, s) = (r, ) <$> f s
 
 newtype SubscriptionHandle = SubscriptionHandle { unsubscribe :: IO () }
 
 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 :: (ObservableState v -> IO (ObservableState a)) -> o -> SomeObservable a
   mapObservable f = SomeObservable . MappedObservable f
+  mapObservable' :: forall a. (v -> IO a) -> o -> SomeObservable a
+  mapObservable' f = mapObservable wrapped
+    where
+      wrapped :: (ObservableState v -> IO (ObservableState a))
+      wrapped Nothing = return Nothing
+      wrapped (Just v) = Just <$> f v
 
 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. 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
+  mapObservable' f (SomeObservable o) = mapObservable' f o
 
 instance Functor SomeObservable where
-  fmap f = mapObservable (return . f)
+  fmap f = mapObservable' (return . f)
 
-data MappedObservable b = forall a o. Observable a o => MappedObservable (a -> IO b) o
+
+data MappedObservable b = forall a o. Observable a o => MappedObservable (ObservableState a -> IO (ObservableState b)) o
 instance Observable v (MappedObservable v) where
-  getValue (MappedObservable f observable) = mapObservableState f =<< getValue observable
+  getValue (MappedObservable f observable) = f =<< getValue observable
   subscribe (MappedObservable f observable) callback = subscribe observable (callback <=< mapObservableMessage f)
   mapObservable f1 (MappedObservable f2 upstream) = SomeObservable $ MappedObservable (f1 <=< f2) upstream
 
@@ -129,3 +135,15 @@ instance forall o i v. (Observable i o, Observable v i) => Observable v (JoinedO
 
 joinObservable :: (Observable i o, Observable v i) => o -> SomeObservable v
 joinObservable outer = SomeObservable $ JoinedObservable outer
+
+data FnObservable v = FnObservable {
+  getValueFn :: IO (ObservableState v),
+  subscribeFn :: (ObservableMessage v -> IO ()) -> IO SubscriptionHandle
+}
+instance Observable v (FnObservable v) where
+  getValue o = getValueFn o
+  subscribe o = subscribeFn o
+  mapObservable f FnObservable{getValueFn, subscribeFn} = SomeObservable $ FnObservable {
+    getValueFn = getValueFn >>= f,
+    subscribeFn = \listener -> subscribeFn (mapObservableMessage f >=> listener)
+  }
diff --git a/src/lib/Qd/Observable/ObservableMap.hs b/src/lib/Qd/Observable/ObservableMap.hs
new file mode 100644
index 0000000..6e46ddf
--- /dev/null
+++ b/src/lib/Qd/Observable/ObservableMap.hs
@@ -0,0 +1,100 @@
+{-# LANGUAGE ViewPatterns #-}
+
+module Qd.Observable.ObservableMap (
+  ObservableMap,
+  create,
+  observeKey,
+  insert,
+  delete,
+  lookupDelete,
+) where
+
+import Qd.Observable
+
+import Control.Concurrent.MVar
+import Control.Monad.State.Lazy
+import Data.Hashable (Hashable)
+import qualified Data.HashMap.Strict as HM
+import Data.Unique
+import Prelude hiding (lookup, lookupDelete)
+
+newtype ObservableMap k v = ObservableMap (MVar (HM.HashMap k (ObservableValue v)))
+
+data ObservableValue v = ObservableValue {
+  value :: Maybe v,
+  subscribers :: (HM.HashMap Unique (ObservableMessage v -> IO ()))
+}
+
+modifyValue :: forall k v a. (Eq k, Hashable k) => (ObservableValue v -> IO (ObservableValue v, a)) -> k -> ObservableMap k v -> IO a
+modifyValue f k (ObservableMap mvar) = modifyMVar mvar $ \hashmap -> runStateT (HM.alterF update k hashmap) impossibleCodePath
+  where
+    update :: Maybe (ObservableValue v) -> StateT a IO (Maybe (ObservableValue v))
+    update mov = do
+      let ov = fromMaybe emptyObservableValue mov
+      (ov', ret) <- liftIO $ f ov
+      put ret
+      return $ toMaybe ov'
+    emptyObservableValue :: ObservableValue v
+    emptyObservableValue = ObservableValue Nothing HM.empty
+    toMaybe :: ObservableValue v -> Maybe (ObservableValue v)
+    toMaybe (ObservableValue Nothing (HM.null -> True)) = Nothing
+    toMaybe ov = Just ov
+
+modifyValue_ :: forall k v. (Eq k, Hashable k) => (ObservableValue v -> IO (ObservableValue v)) -> k -> ObservableMap k v -> IO ()
+modifyValue_ f k (ObservableMap mvar) = modifyMVar_ mvar $ HM.alterF update k
+  where
+    update :: Maybe (ObservableValue v) -> IO (Maybe (ObservableValue v))
+    update = fmap toMaybe . f . fromMaybe emptyObservableValue
+    emptyObservableValue :: ObservableValue v
+    emptyObservableValue = ObservableValue Nothing HM.empty
+    toMaybe :: ObservableValue v -> Maybe (ObservableValue v)
+    toMaybe (ObservableValue Nothing (HM.null -> True)) = Nothing
+    toMaybe ov = Just ov
+
+modifySubscribers :: (HM.HashMap Unique (ObservableMessage v -> IO ()) -> HM.HashMap Unique (ObservableMessage v -> IO ())) -> ObservableValue v -> ObservableValue v
+modifySubscribers f ov@ObservableValue{subscribers} = ov{subscribers=f subscribers}
+
+create :: IO (ObservableMap k v)
+create = ObservableMap <$> newMVar HM.empty
+
+observeKey :: forall k v. (Eq k, Hashable k) => k -> ObservableMap k v -> SomeObservable v
+observeKey key om@(ObservableMap mvar) = SomeObservable FnObservable{getValueFn, subscribeFn}
+  where
+    getValueFn :: IO (ObservableState v)
+    getValueFn = (value <=< HM.lookup key) <$> readMVar mvar
+    subscribeFn :: ((ObservableMessage v -> IO ()) -> IO SubscriptionHandle)
+    subscribeFn callback = do
+      subscriptionKey <- newUnique
+      modifyValue_ (subscribeFn' subscriptionKey) key om
+      return $ SubscriptionHandle $ unsubscribe subscriptionKey
+      where
+        subscribeFn' :: Unique -> ObservableValue v -> IO (ObservableValue v)
+        subscribeFn' subKey ov@ObservableValue{value} = do
+          callback (Current, value)
+          return $ modifySubscribers (HM.insert subKey callback) ov
+        unsubscribe :: Unique -> IO ()
+        unsubscribe subKey = modifyValue_ (return . modifySubscribers (HM.delete subKey)) key om
+
+insert :: forall k v. (Eq k, Hashable k) => k -> v -> ObservableMap k v -> IO ()
+insert key value = modifyValue_ fn key
+  where
+    fn :: ObservableValue v -> IO (ObservableValue v)
+    fn ov@ObservableValue{subscribers} = do
+      mapM_ ($ (Update, Just value)) $ HM.elems subscribers
+      return ov{value=Just value}
+
+delete :: forall k v. (Eq k, Hashable k) => k -> ObservableMap k v -> IO ()
+delete = modifyValue_ fn
+  where
+    fn :: ObservableValue v -> IO (ObservableValue v)
+    fn ov@ObservableValue{subscribers} = do
+      mapM_ ($ (Update, Nothing)) $ HM.elems subscribers
+      return ov{value=Nothing}
+
+lookupDelete :: forall k v. (Eq k, Hashable k) => k -> ObservableMap k v -> IO (Maybe v)
+lookupDelete = modifyValue fn
+  where
+    fn :: ObservableValue v -> IO (ObservableValue v, Maybe v)
+    fn ov@ObservableValue{value=oldValue, subscribers} = do
+      mapM_ ($ (Update, Nothing)) $ HM.elems subscribers
+      return (ov{value=Nothing}, oldValue)
-- 
GitLab