From cb14a90e8a6b1a98cf76242dae301a7b5952ce51 Mon Sep 17 00:00:00 2001 From: Madeline Trotter Date: Wed, 22 Jul 2020 19:06:23 -0700 Subject: [PATCH] SuspenseStore refactor to allow caching of any HasBackend instance members --- src/React/Basic/Hooks/Suspense.purs | 4 + src/React/Basic/Hooks/Suspense/Store.purs | 133 +++++++++++++++------- test/Test/Main.purs | 82 +++++++++++++ 3 files changed, 176 insertions(+), 43 deletions(-) create mode 100644 test/Test/Main.purs diff --git a/src/React/Basic/Hooks/Suspense.purs b/src/React/Basic/Hooks/Suspense.purs index 4d49aaf..a44452c 100644 --- a/src/React/Basic/Hooks/Suspense.purs +++ b/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_ diff --git a/src/React/Basic/Hooks/Suspense/Store.purs b/src/React/Basic/Hooks/Suspense/Store.purs index 4adec51..88779a0 100644 --- a/src/React/Basic/Hooks/Suspense/Store.purs +++ b/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 diff --git a/test/Test/Main.purs b/test/Test/Main.purs new file mode 100644 index 0000000..b6f298e --- /dev/null +++ b/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 } pFad - Phonifier reborn

Pfad - The Proxy pFad of © 2024 Garber Painting. All rights reserved.

Note: This service is not intended for secure transactions such as banking, social media, email, or purchasing. Use at your own risk. We assume no liability whatsoever for broken pages.


Alternative Proxies:

Alternative Proxy

pFad Proxy

pFad v3 Proxy

pFad v4 Proxy