diff --git a/.gitignore b/.gitignore index 37448ff..493c79f 100644 --- a/.gitignore +++ b/.gitignore @@ -15,3 +15,5 @@ html/index.js .cache dist /.psc-ide-port +.devenv +.devenv.flake.nix diff --git a/src/Concur/Core/Patterns.purs b/src/Concur/Core/Patterns.purs index 0e7101e..edbf4ef 100644 --- a/src/Concur/Core/Patterns.purs +++ b/src/Concur/Core/Patterns.purs @@ -1,24 +1,30 @@ module Concur.Core.Patterns where import Concur.Core (Result(..), Widget, mkWidget) +import Concur.Core.Types (runWidget) import Control.Alt (class Alt, (<|>)) import Control.Applicative (pure) import Control.Bind (bind, discard, (>>=)) import Control.Monad (class Monad) +import Control.MonadFix (fixEffect) import Control.Plus (class Plus) import Data.Array as Array import Data.Either (Either(..), either) -import Data.Function (flip, ($), (<<<), (>>>)) +import Data.Foldable (fold) +import Data.Function (applyFlipped, flip, (#), ($), (<<<), (>>>)) import Data.Functor ((<$>)) import Data.Lens (Lens') import Data.Lens as L -import Data.Monoid (class Monoid) +import Data.Maybe (fromMaybe) +import Data.Monoid (class Monoid, mempty) import Data.Newtype (class Newtype, un) import Data.Semigroup ((<>)) import Data.Traversable (traverse_) +import Data.TraversableWithIndex (forWithIndex) import Data.Unit (Unit, unit) import Effect (Effect) import Effect.Class (class MonadEffect, liftEffect) +import Effect.Ref (Ref) import Effect.Ref as Ref import Unsafe.Reference (unsafeRefEq) @@ -151,3 +157,50 @@ with wire f = do res <- (Left <$> f a) <|> (Right <$> receive wire) either pure go res +--- +-- RESUMABLE WIDGETS (WIP) + +type ResumableWidget v a = + { handlerRef :: Ref (Result v a -> Effect Unit) + , view :: Ref v + , canceler :: Effect Unit + } + +resumeResumable :: forall v a. ResumableWidget v a -> Widget v a +resumeResumable { handlerRef, view, canceler } = mkWidget \cb -> do + Ref.write cb handlerRef + v <- Ref.read view + cb (View v) + pure canceler + +suspendResumable :: forall v a. ResumableWidget v a -> Effect Unit +suspendResumable { handlerRef } = Ref.write mempty handlerRef + +cancelResumable :: forall v a. ResumableWidget v a -> Effect Unit +cancelResumable { canceler } = canceler + +runToResumable :: forall v a. Widget v a -> Ref v -> (Result v a -> Effect Unit) -> Effect (ResumableWidget v a) +runToResumable w view handler = do + handlerRef <- Ref.new handler + canceler <- runWidget w \res -> Ref.read handlerRef >>= applyFlipped res + pure { handlerRef, view, canceler } + +resumableOrr :: forall v a. Monoid v => Array (Widget v a) -> Widget v { val :: a, others :: Array (ResumableWidget v a) } +resumableOrr widgets = mkWidget \cb -> do + viewsRef <- Ref.new (Array.replicate (Array.length widgets) mempty) + resumables <- fixEffect \resumables -> forWithIndex widgets \i w -> do + viewRef <- Ref.new mempty + fixEffect \s -> runToResumable w viewRef case _ of + View v -> do + Ref.write v viewRef + views <- Ref.read viewsRef + Array.updateAt i v views # traverse_ \newViews -> do + Ref.write newViews viewsRef + cb (View (fold newViews)) + Completed val -> do + cancelResumable (s unit) + let others = fromMaybe (resumables unit) $ Array.deleteAt i (resumables unit) + traverse_ suspendResumable others + cb (Completed { val, others }) + pure do traverse_ cancelResumable resumables +