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 }