From 4f81ab9f5eaed4d2299a8373b2b94113668bf190 Mon Sep 17 00:00:00 2001
From: Jens Nolte <git@queezle.net>
Date: Fri, 7 Jun 2024 01:35:08 +0200
Subject: [PATCH] Add cache functions to ObservableMap and ObservableList

---
 quasar/src/Quasar/Observable/Cache.hs | 25 +++++++++++++++++++++----
 quasar/src/Quasar/Observable/List.hs  | 12 ++++++++++++
 quasar/src/Quasar/Observable/Map.hs   | 14 +++++++++++++-
 3 files changed, 46 insertions(+), 5 deletions(-)

diff --git a/quasar/src/Quasar/Observable/Cache.hs b/quasar/src/Quasar/Observable/Cache.hs
index 8423c2b..58a0278 100644
--- a/quasar/src/Quasar/Observable/Cache.hs
+++ b/quasar/src/Quasar/Observable/Cache.hs
@@ -2,8 +2,14 @@
 {-# LANGUAGE UndecidableInstances #-}
 
 module Quasar.Observable.Cache (
+  -- TODO move to Observable module
   cacheObservable,
   observeCachedObservable,
+
+  cacheObservableT,
+
+  -- ** Observable operation type
+  CachedObservable,
 ) where
 
 import Control.Applicative
@@ -93,11 +99,22 @@ fixInvalidCacheState _cached EvaluatedObservableChangeLoadingUnchanged =
   -- Filtered by `applyEvaluatedObservableChange` in `updateCache`
   impossibleCodePath
 
-cacheObservable :: (ToObservable canLoad exceptions v a, MonadSTMc NoRetry '[] m) => a -> m (Observable canLoad exceptions v)
-cacheObservable (toObservable -> f) =
+cacheObservable ::
+  MonadSTMc NoRetry '[] m =>
+  Observable canLoad exceptions v -> m (Observable canLoad exceptions v)
+cacheObservable (Observable f) = Observable <$> cacheObservableT f
+
+cacheObservableT ::
+  (
+    ObservableContainer c v,
+    ContainerConstraint canLoad exceptions c v (CachedObservable canLoad exceptions c v),
+    MonadSTMc NoRetry '[] m
+  ) =>
+  ObservableT canLoad exceptions c v -> m (ObservableT canLoad exceptions c v)
+cacheObservableT f =
   if isCachedObservable# f
     then pure f
-    else toObservable . CachedObservable <$> newTVar (CacheIdle f)
+    else ObservableT . CachedObservable <$> newTVar (CacheIdle f)
 
 
 -- ** Embedded cache in the Observable monad
@@ -116,7 +133,7 @@ instance IsObservableCore canLoad exceptions Identity (Observable l e v) (CacheO
     pure (mempty, ObservableStateLive (pure cache))
 
 -- | Cache an observable in the `Observable` monad. Use with care! A new cache
--- is created for every outer observable valuation.
+-- is created for every outer observable evaluation.
 observeCachedObservable :: forall canLoad exceptions e l v a. ToObservable l e v a => a -> Observable canLoad exceptions (Observable l e v)
 observeCachedObservable x =
   toObservable (CacheObservableOperation @canLoad @exceptions (toObservable x))
diff --git a/quasar/src/Quasar/Observable/List.hs b/quasar/src/Quasar/Observable/List.hs
index 9ff225a..0c8a593 100644
--- a/quasar/src/Quasar/Observable/List.hs
+++ b/quasar/src/Quasar/Observable/List.hs
@@ -12,6 +12,7 @@ module Quasar.Observable.List (
   validatedListDeltaLength,
   ListDeltaOperation(..),
   Length(..),
+  cache,
 
   -- * Reexports
   FingerTree,
@@ -48,6 +49,7 @@ import Data.FingerTree (FingerTree, Measured(measure), (<|), ViewL(EmptyL, (:<))
 import Data.FingerTree qualified as FT
 import Data.Sequence (Seq(Empty))
 import Data.Sequence qualified as Seq
+import Quasar.Observable.Cache
 import Quasar.Observable.Core
 import Quasar.Observable.Subject
 import Quasar.Observable.Traversable
@@ -373,6 +375,16 @@ attachSimpleListObserver observable callback = do
   case initial of
     ObservableStateLive (ObservableResultTrivial x) -> pure (disposer, x)
 
+
+instance IsObservableList canLoad exceptions v (CachedObservable canLoad exceptions Seq v) where
+
+cache ::
+  MonadSTMc NoRetry '[] m =>
+  ObservableList canLoad exceptions v ->
+  m (ObservableList canLoad exceptions v)
+cache (ObservableList f) = ObservableList <$> cacheObservableT f
+
+
 constObservableList :: ObservableState canLoad (ObservableResult exceptions Seq) v -> ObservableList canLoad exceptions v
 constObservableList = ObservableList . ObservableT
 
diff --git a/quasar/src/Quasar/Observable/Map.hs b/quasar/src/Quasar/Observable/Map.hs
index c8b802a..684fc2f 100644
--- a/quasar/src/Quasar/Observable/Map.hs
+++ b/quasar/src/Quasar/Observable/Map.hs
@@ -11,6 +11,7 @@ module Quasar.Observable.Map (
   liftObservableMap,
   IsObservableMap(..),
   query,
+  cache,
 
   -- ** Delta types
   MapDelta(..),
@@ -69,6 +70,7 @@ module Quasar.Observable.Map (
 import Control.Applicative hiding (empty)
 import Control.Monad.Except
 import Data.Binary (Binary)
+import Data.Foldable (foldl')
 import Data.Map.Merge.Strict qualified as Map
 import Data.Map.Strict (Map)
 import Data.Map.Strict qualified as Map
@@ -76,6 +78,7 @@ import Data.Maybe (mapMaybe)
 import Data.Sequence (Seq)
 import Data.Sequence qualified as Seq
 import GHC.Records (HasField (..))
+import Quasar.Observable.Cache
 import Quasar.Observable.Core
 import Quasar.Observable.Lift
 import Quasar.Observable.List (ObservableList(..), IsObservableList, ListDelta, ListOperation(..))
@@ -85,7 +88,6 @@ import Quasar.Observable.Traversable
 import Quasar.Prelude hiding (filter, lookup)
 import Quasar.Resources.Disposer
 import Quasar.Utils.Map qualified as MapUtils
-import Data.Foldable (foldl')
 
 
 newtype MapDelta k v
@@ -226,6 +228,16 @@ query x = query# (toObservableMap x)
 
 
 
+instance Ord k => IsObservableMap canLoad exceptions k v (CachedObservable canLoad exceptions (Map k) v) where
+
+cache ::
+  (Ord k, MonadSTMc NoRetry '[] m) =>
+  ObservableMap canLoad exceptions k v ->
+  m (ObservableMap canLoad exceptions k v)
+cache (ObservableMap f) = ObservableMap <$> cacheObservableT f
+
+
+
 instance (Ord k, IsObservableCore l e (Map k) v b) => IsObservableMap l e k v (BindObservable l e ea va b) where
   -- TODO