diff --git a/reflex.cabal b/reflex.cabal index f1d71126..bcd059d4 100644 --- a/reflex.cabal +++ b/reflex.cabal @@ -79,6 +79,7 @@ library data-default >= 0.5 && < 0.8, dependent-map >= 0.3 && < 0.5, exception-transformers == 0.4.*, + free == 5.1.*, lens >= 4.7 && < 5, mmorph >= 1.0 && < 1.2, monad-control >= 1.0.1 && < 1.1, diff --git a/src/Reflex/Workflow.hs b/src/Reflex/Workflow.hs index faba2353..806a8eb6 100644 --- a/src/Reflex/Workflow.hs +++ b/src/Reflex/Workflow.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecursiveDo #-} {-# LANGUAGE ScopedTypeVariables #-} -- | @@ -13,33 +16,55 @@ module Reflex.Workflow ( , workflowView , mapWorkflow , mapWorkflowCheap + , runWorkflow + + -- Combinators + , step + , stop + , label + , label_ + + -- Runners + , stack + , wizard + ) where import Control.Arrow ((***)) -import Control.Monad.Fix (MonadFix) - +import Control.Monad ((<=<)) +import Control.Monad.Cont (MonadCont, callCC) +import Control.Monad.Fix (MonadFix, fix) +import Control.Monad.Free.Church +import Data.Bifunctor (bimap) +import Data.Functor.Compose (Compose(..)) import Reflex.Class import Reflex.Adjustable.Class -import Reflex.Network -import Reflex.NotReady.Class import Reflex.PostBuild.Class +-------------------------------------------------------------------------------- +-- Workflow +-------------------------------------------------------------------------------- -- | A widget in a workflow -- When the 'Event' returned by a 'Workflow' fires, the current 'Workflow' is replaced by the one inside the firing 'Event'. A series of 'Workflow's must share the same return type. newtype Workflow t m a = Workflow { unWorkflow :: m (a, Event t (Workflow t m a)) } --- | Runs a 'Workflow' and returns the 'Dynamic' result of the 'Workflow' (i.e., a 'Dynamic' of the value produced by the current 'Workflow' node, and whose update 'Event' fires whenever one 'Workflow' is replaced by another). -workflow :: forall t m a. (Reflex t, Adjustable t m, MonadFix m, MonadHold t m) => Workflow t m a -> m (Dynamic t a) -workflow w0 = do - rec eResult <- networkHold (unWorkflow w0) $ fmap unWorkflow $ switch $ snd <$> current eResult - return $ fmap fst eResult +-- | Runs a 'Workflow' and returns the initial value together with an 'Event' that fires whenever one 'Workflow' is replaced by another. +runWorkflow :: (Adjustable t m, MonadFix m, MonadHold t m) => Workflow t m a -> m (a, Event t a) +runWorkflow w0 = mdo + ((a, e0), eResult) <- runWithReplace (unWorkflow w0) (fmap unWorkflow eReplace) + eReplace <- switchHold e0 $ fmap snd eResult + return (a, fmap fst eResult) + +-- | Similar to 'runWorkflow' but combines the result into a 'Dynamic'. +workflow :: (Adjustable t m, MonadFix m, MonadHold t m) => Workflow t m a -> m (Dynamic t a) +workflow = uncurry holdDyn <=< runWorkflow --- | Similar to 'workflow', but outputs an 'Event' that fires at post-build time and whenever the current 'Workflow' is replaced by the next 'Workflow'. -workflowView :: forall t m a. (Reflex t, NotReady t m, Adjustable t m, MonadFix m, MonadHold t m, PostBuild t m) => Workflow t m a -> m (Event t a) -workflowView w0 = do - rec eResult <- networkView . fmap unWorkflow =<< holdDyn w0 eReplace - eReplace <- fmap switch $ hold never $ fmap snd eResult - return $ fmap fst eResult +-- | Similar to 'runWorkflow', but also puts the initial value in the 'Event'. +workflowView :: (Adjustable t m, MonadFix m, MonadHold t m, PostBuild t m) => Workflow t m a -> m (Event t a) +workflowView w = do + postBuildEv <- getPostBuild + (initialValue, replaceEv) <- runWorkflow w + pure $ leftmost [initialValue <$ postBuildEv, replaceEv] -- | Map a function over a 'Workflow', possibly changing the return type. mapWorkflow :: (Reflex t, Functor m) => (a -> b) -> Workflow t m a -> Workflow t m b @@ -48,3 +73,85 @@ mapWorkflow f (Workflow x) = Workflow (fmap (f *** fmap (mapWorkflow f)) x) -- | Map a "cheap" function over a 'Workflow'. Refer to the documentation for 'pushCheap' for more information and performance considerations. mapWorkflowCheap :: (Reflex t, Functor m) => (a -> b) -> Workflow t m a -> Workflow t m b mapWorkflowCheap f (Workflow x) = Workflow (fmap (f *** fmapCheap (mapWorkflowCheap f)) x) + +-------------------------------------------------------------------------------- +-- Internal utils +-------------------------------------------------------------------------------- +nowOrLater :: PostBuild t m => Either (Event t a) a -> m (Event t a) +nowOrLater = \case + Left l -> pure l + Right n -> (n <$) <$> getPostBuild + +lateOrLater :: (MonadHold t m, Reflex t) => Event t (Either (Event t a) a) -> m (Event t a) +lateOrLater ev = mdo + let (ltrEv, lt) = fanEither ev + ltr <- switchHold never ltrEv + pure $ leftmost [lt, ltr] + +-------------------------------------------------------------------------------- +-- Replacements layer +-------------------------------------------------------------------------------- +newtype Step t m a = Step { unStep :: m (Either (Event t a) a) } +instance (Reflex t, Functor m) => Functor (Step t m) where + fmap f = Step . fmap (bimap (fmap f) f) . unStep + +runStep :: PostBuild t m => Step t m a -> m (Event t a) +runStep = nowOrLater <=< unStep + +newtype Machine t m a = Machine { unMachine :: F (Compose m (Event t)) a } deriving (Functor, Applicative, Monad) + +bottomUp + :: forall t m a. PostBuild t m + => (forall x. Step t m (Step t m x) -> Step t m x) + -> Machine t m a -> m (Event t a) +bottomUp f mm = runStep $ runF root leaf branch + where + root :: F (Compose m (Event t)) a + root = unMachine mm + + leaf :: a -> Step t m a + leaf = Step . pure . Right + + branch :: Compose m (Event t) (Step t m a) -> Step t m a + branch = f . Step . fmap Left . getCompose + +-------------------------------------------------------------------------------- +-- Combinators +-------------------------------------------------------------------------------- +-- | Machine with a single step +step :: (Functor m, Reflex t) => m (Event t a) -> Machine t m a +step = Machine . wrap . fmap pure . Compose + +-- | Machine with a single step and no transitions +stop :: (Reflex t, Applicative m) => Machine t m a +stop = step $ pure never + +-- TODO: Use upstream when https://github.com/haskell/mtl/pull/87 is merged +{- | Introduces a recursive binding to the continuation. +Due to the use of @callCC@, calling the continuation will interrupt execution +of the current block creating an effect similar to goto/setjmp in C. +-} +label :: MonadCont m => a -> m (a -> m b, a) +label a = callCC $ \k -> let go b = k (go, b) in return (go, a) + +{- | Simplified version of `label` without arguments -} +label_ :: MonadCont m => m (m a) +label_ = callCC $ return . fix + +-------------------------------------------------------------------------------- +-- Runners +-------------------------------------------------------------------------------- +-- | A wizard only has a single step active at any given point, and any new step replaces its predecessor +wizard :: forall t m a. (Adjustable t m, MonadFix m, MonadHold t m, PostBuild t m) => Machine t m a -> m (Event t a) +wizard = bottomUp $ \m -> Step $ mdo + (nl, ll) <- runWithReplace (unStep m) (unStep <$> replacement) + replacement <- nowOrLater nl + Left <$> lateOrLater ll + +-- | A stack can have all steps active at a time, and the first one is always active. +-- When a step triggers, it replaces the (possibly empty) pile on top of itself with a single new step +stack :: forall t m a. (Adjustable t m, MonadHold t m, PostBuild t m) => Machine t m a -> m (Event t a) +stack = bottomUp $ \m -> Step $ do + replacement <- runStep m + ((), ll) <- runWithReplace (pure ()) (unStep <$> replacement) + Left <$> lateOrLater ll