From 5f9d55a1498093de2f44e6ac0b4ba9cb87511d1c Mon Sep 17 00:00:00 2001
From: Jens Nolte <git@queezle.net>
Date: Sun, 13 Mar 2022 01:16:48 +0100
Subject: [PATCH] Add ObservableVar draft

---
 src/Quasar/Observable.hs | 61 +++++++++++++++++++++++++++++++++++-----
 1 file changed, 54 insertions(+), 7 deletions(-)

diff --git a/src/Quasar/Observable.hs b/src/Quasar/Observable.hs
index 2b35a69..9d77370 100644
--- a/src/Quasar/Observable.hs
+++ b/src/Quasar/Observable.hs
@@ -6,12 +6,12 @@ module Quasar.Observable (
   ObservableState(..),
   --toObservableUpdate,
 
-  ---- * ObservableVar
-  --ObservableVar,
-  --newObservableVar,
-  --setObservableVar,
-  --modifyObservableVar,
-  --stateObservableVar,
+  -- * ObservableVar
+  ObservableVar,
+  newObservableVar,
+  setObservableVar,
+  modifyObservableVar,
+  stateObservableVar,
 
   ---- * Helper functions
   --observeWhile,
@@ -347,7 +347,54 @@ instance IsObservable r (LiftA2Observable r) where
 --          (\currentKey -> when (key == currentKey) $ callback message)
 --
 --
---
+
+newtype ObserverRegistry a = ObserverRegistry (TVar (HM.HashMap Unique (ObservableCallback a)))
+
+newObserverRegistry :: STM (ObserverRegistry a)
+newObserverRegistry = ObserverRegistry <$> newTVar mempty
+
+newObserverRegistryIO :: MonadIO m => m (ObserverRegistry a)
+newObserverRegistryIO = liftIO $ ObserverRegistry <$> newTVarIO mempty
+
+registerObserver :: ObserverRegistry a -> ObservableCallback a -> ObservableState a -> QuasarSTM ()
+registerObserver (ObserverRegistry var) callback currentState = do
+  quasar <- askQuasar
+  key <- ensureSTM newUniqueSTM
+  ensureSTM $ modifyTVar var (HM.insert key (execForeignQuasarSTM quasar . callback))
+  registerDisposeTransaction_ $ modifyTVar var (HM.delete key)
+  callback currentState
+
+updateObservers :: ObserverRegistry a -> ObservableState a -> QuasarSTM ()
+updateObservers (ObserverRegistry var) newState =
+  mapM_ ($ newState) . HM.elems =<< ensureSTM (readTVar var)
+
+
+data ObservableVar a = ObservableVar (TVar a) (ObserverRegistry a)
+
+instance IsRetrievable a (ObservableVar a) where
+  retrieve (ObservableVar var _registry) = liftIO $ readTVarIO var
+
+instance IsObservable a (ObservableVar a) where
+  observe (ObservableVar var registry) callback = ensureQuasarSTM do
+    registerObserver registry callback . ObservableValue =<< ensureSTM (readTVar var)
+
+  pingObservable _ = pure ()
+
+newObservableVar :: a -> STM (ObservableVar a)
+newObservableVar x = ObservableVar <$> newTVar x <*> newObserverRegistry
+
+newObservableVarIO :: MonadIO m => a -> m (ObservableVar a)
+newObservableVarIO x = liftIO $ ObservableVar <$> newTVarIO x <*> newObserverRegistryIO
+
+setObservableVar :: MonadQuasar m => ObservableVar a -> a -> m ()
+setObservableVar var = modifyObservableVar var . const
+
+modifyObservableVar :: MonadQuasar m => ObservableVar a -> (a -> a) -> m ()
+modifyObservableVar var f = stateObservableVar var (((), ) . f)
+
+stateObservableVar :: MonadQuasar m => ObservableVar a -> (a -> (r, a)) -> m r
+stateObservableVar (ObservableVar var registry) f = undefined
+
 --newtype ObservableVar v = ObservableVar (MVar (v, HM.HashMap Unique (ObservableCallback v)))
 --instance IsRetrievable v (ObservableVar v) where
 --  retrieve (ObservableVar mvar) = liftIO $ pure . fst <$> readMVar mvar
-- 
GitLab