Add cache functions to ObservableMap and ObservableList

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))

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
 

quasar/src/Quasar/Observable/Map.hs

@@ -11,6 +11,7 @@ module Quasar.Observable.Map (
   liftObservableMap,
   IsObservableMap(..),
   query,
+  cache,
 
   -- ** Delta types
   MapDelta(..),
@@ -69,13 +70,15 @@ 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
 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