SuspenseStore refactor to allow caching of any HasBackend instance members

src/React/Basic/Hooks/Suspense.purs

@@ -41,11 +41,15 @@ suspend (Suspended e) = React.do
 newtype Suspended a
   = Suspended (Effect (SuspenseResult a))
 
+derive instance functorSuspended :: Functor Suspended
+
 data SuspenseResult a
   = InProgress (Fiber a)
   | Failed Error
   | Complete a
 
+derive instance functorSuspenseResult :: Functor SuspenseResult
+
 suspense :: { fallback :: JSX, children :: Array JSX } -> JSX
 suspense = element suspense_
 

src/React/Basic/Hooks/Suspense/Store.purs

@@ -1,41 +1,55 @@
 module React.Basic.Hooks.Suspense.Store
-  ( mkSuspenseStore
-  , SuspenseStore
+  ( SuspenseStore
+  , mkSuspenseStore
   , get
   , get'
+  , class HasBackend
+  , fromKey
+  , backend
   ) where
 
 import Prelude
 import Control.Alt ((<|>))
-import Data.DateTime.Instant (Instant, unInstant)
+import Data.DateTime.Instant (unInstant)
 import Data.Either (Either(..))
+import Data.Function (on)
 import Data.Int (ceil)
-import Data.Map (Map)
 import Data.Map as Map
 import Data.Maybe (Maybe(..))
 import Data.Newtype (un)
+import Data.Ord (greaterThan)
+import Data.String (joinWith)
+import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
 import Data.Time.Duration (Milliseconds(..))
+import Data.Tuple (fst, snd)
 import Effect (Effect)
 import Effect.Aff (Aff, attempt, launchAff, throwError)
 import Effect.Class (liftEffect)
 import Effect.Console (warn)
 import Effect.Exception (try)
 import Effect.Now (now)
-import Effect.Ref (Ref)
 import Effect.Ref as Ref
-import React.Basic.Hooks (type (/\), (/\))
+import React.Basic.Hooks ((/\))
 import React.Basic.Hooks.Suspense (Suspended(..), SuspenseResult(..))
+import Unsafe.Coerce (unsafeCoerce)
 import Web.HTML (window)
 import Web.HTML.Window (requestIdleCallback)
 
--- | Simple key-based cache.
+get :: forall k v s. HasBackend k v s => SuspenseStore -> k -> Suspended v
+get s k = _get s Nothing k
+
+get' :: forall k v s. HasBackend k v s => SuspenseStore -> Milliseconds -> k -> Suspended v
+get' s d k = _get s (Just d) k
+
+class
+  IsSymbol s <= HasBackend k v (s :: Symbol) | k -> v s where
+  fromKey :: k -> String
+  backend :: k -> Aff v
+
 mkSuspenseStore ::
-  forall k v.
-  Ord k =>
   Maybe Milliseconds ->
-  (k -> Aff v) ->
-  Effect (SuspenseStore k v)
-mkSuspenseStore defaultMaxAge backend = do
+  Effect SuspenseStore
+mkSuspenseStore defaultMaxAge = do
   ref <- Ref.new mempty
   let
     isExpired maxAge now' (_ /\ d) = unInstant now' < unInstant d <> maxAge
@@ -68,59 +82,92 @@ mkSuspenseStore defaultMaxAge backend = do
               else
                 pure (Just r)
 
-    getCacheOrBackend itemMaxAge k = do
+    insertIfNewer =
+      Map.insertWith \r' r ->
+        let
+          gt = greaterThan `on` snd
+        in
+          if r `gt` r' then r else r'
+
+    getCacheOrBackend :: Maybe Milliseconds -> StoreKey -> Effect (SuspenseResult Opaque)
+    getCacheOrBackend itemMaxAge storable = do
+      let
+        k = toKey storable
       c <- tryFromCache itemMaxAge k
       case c of
         Just v -> pure v
         Nothing -> do
           fiber <-
             launchAff do
-              r <- attempt do backend k
+              r <- attempt do toAff storable
               liftEffect do
                 let
                   v = case r of
                     Left e -> Failed e
                     Right v' -> Complete v'
                 d <- now
-                _ <-
-                  ref
-                    # Ref.modify
-                        ( k
-                            # Map.alter case _ of
-                                Nothing -> Just (v /\ d)
-                                Just r'@(v' /\ d') ->
-                                  if d > d' then
-                                    Just (v /\ d)
-                                  else
-                                    Just r'
-                        )
+                _ <- ref # Ref.modify (insertIfNewer k (v /\ d))
                 case r of
                   Left e -> throwError e
                   Right v' -> pure v'
-          let
-            v = InProgress fiber
-          d <- now
-          _ <- ref # Ref.modify (Map.insert k (v /\ d))
-          pure v
+          syncV <- map fst <$> Map.lookup k <$> Ref.read ref
+          case syncV of
+            -- `Just v` means the backend `Aff` ran synchronously so
+            -- we just return that result
+            Just v -> pure v
+            Nothing -> do
+              let
+                v = InProgress fiber
+              d <- now
+              _ <- ref # Ref.modify (insertIfNewer k (v /\ d))
+              pure v
   do
     r <- try pruneCache
     case r of
       Left _ -> warn "Failed to initialize the suspense store cleanup task. Ensure you're using it in a browser with `requestIdleCallback` support."
       Right _ -> pure unit
-  pure
-    $ SuspenseStore
-        { cache: ref
-        , get: map Suspended <<< getCacheOrBackend
-        }
+  pure $ SuspenseStore { get: getCacheOrBackend }
 
-newtype SuspenseStore k v
+newtype SuspenseStore
   = SuspenseStore
-  { cache :: Ref (Map k (SuspenseResult v /\ Instant))
-  , get :: Maybe Milliseconds -> k -> Suspended v
+  { get :: Maybe Milliseconds -> StoreKey -> Effect (SuspenseResult Opaque)
   }
 
-get :: forall k v. SuspenseStore k v -> k -> Suspended v
-get (SuspenseStore s) = s.get Nothing
+_get :: forall k v s. HasBackend k v s => SuspenseStore -> Maybe Milliseconds -> k -> Suspended v
+_get (SuspenseStore s) d k =
+  Suspended do
+    let
+      storable = mkStorable k
+    r <- s.get d storable
+    pure (map (fromOpaque k) r)
+
+-- An opaque "cacheable". `StoreKey` packages up a `HasBackend` instance
+-- so the cache can use its `k -> String` and `k -> Aff v` functions
+-- without knowing about the internal types stored within the cache.
+data StoreKey
+  = StoreKey
+    (forall x. (forall k v s. HasBackend k v s => k -> x) -> x)
+
+mkStorable :: forall k v s. HasBackend k v s => k -> StoreKey
+mkStorable k = StoreKey \f -> f k
+
+class Storable k where
+  toKey :: k -> String
+  toAff :: k -> Aff Opaque
+
+instance storableStoreKey :: Storable StoreKey where
+  toKey (StoreKey impl) = impl \k -> joinWith "" [ typeKey k, "[ ", fromKey k, " ]" ]
+    where
+    typeKey :: forall k v s. HasBackend k v s => k -> String
+    typeKey _ = reflectSymbol (SProxy :: _ s)
+  toAff (StoreKey impl) = impl \k -> map (toOpaque k) (backend k)
+
+data Opaque
+
+class HasOpaque k v | k -> v where
+  toOpaque :: k -> v -> Opaque
+  fromOpaque :: k -> Opaque -> v
 
-get' :: forall k v. SuspenseStore k v -> Milliseconds -> k -> Suspended v
-get' (SuspenseStore s) d = s.get (Just d)
+instance hasOpaque :: HasBackend k v s => HasOpaque k v where
+  toOpaque _ = unsafeCoerce
+  fromOpaque _ = unsafeCoerce

test/Test/Main.purs

@@ -0,0 +1,82 @@
+module Test.Main where
+
+import Prelude
+import Data.Maybe (Maybe(..))
+import Effect (Effect)
+import Effect.Aff (Milliseconds(..), delay, launchAff_)
+import Effect.Class (liftEffect)
+import Effect.Console (log)
+import React.Basic.Hooks.Suspense (Suspended(..), SuspenseResult)
+import React.Basic.Hooks.Suspense.Store (class HasBackend, fromKey, get, mkSuspenseStore)
+import Unsafe.Coerce (unsafeCoerce)
+
+main :: Effect Unit
+main = do
+  store <- mkSuspenseStore (Just $ Milliseconds 200.0)
+  let
+    runGet :: forall k v s. HasBackend k v s => k -> Effect (SuspenseResult v)
+    runGet k = case get store k of Suspended r' -> r'
+
+    c1 = Key "1" :: Key Cat
+
+    c2 = Key "2" :: Key Cat
+
+    d1 = Key "1" :: Key Dog
+
+    d2 = Key "2" :: Key Dog
+
+    go = do
+      c1' <- runGet c1
+      d1' <- runGet d1
+      c2' <- runGet c2
+      d2' <- runGet d2
+      c1'' <- runGet c1
+      d1'' <- runGet d1
+      c2'' <- runGet c2
+      d2'' <- runGet d2
+      l c1'
+      l c1''
+      l c2'
+      l c2''
+      l d1'
+      l d1''
+      l d2'
+      l d2''
+  go
+  launchAff_ do
+    delay (Milliseconds 100.0)
+    liftEffect go
+    delay (Milliseconds 200.0)
+    liftEffect go
+    liftEffect go
+  where
+  l :: forall v. v -> Effect Unit
+  l v = do
+    log (unsafeCoerce v)
+
+newtype Key v
+  = Key String
+
+derive instance eqKey :: Eq (Key v)
+
+data Cat
+  = Cat { name :: String }
+
+derive instance eqCat :: Eq Cat
+
+data Dog
+  = Dog { name :: String }
+
+derive instance eqDog :: Eq Dog
+
+instance backendCat :: HasBackend (Key Cat) Cat "Cat" where
+  fromKey (Key key) = key
+  backend key = do
+    delay $ Milliseconds 0.0
+    pure $ Cat { name: fromKey key }
+
+instance backendDog :: HasBackend (Key Dog) Dog "Dog" where
+  fromKey (Key key) = key
+  backend key = do
+    delay $ Milliseconds 0.0
+    pure $ Dog { name: fromKey key }