@@ -1,3 +1,6 @@
1+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2+{-# LANGUAGE LambdaCase #-}
3+{-# LANGUAGE RankNTypes #-}
1{-# LANGUAGE RecursiveDo #-}
4{-# LANGUAGE RecursiveDo #-}
2{-# LANGUAGE ScopedTypeVariables #-}
5{-# LANGUAGE ScopedTypeVariables #-}
@@ -13,33 +16,55 @@ module Reflex.Workflow (
13 , workflowView
16 , workflowView
14 , mapWorkflow
17 , mapWorkflow
15 , mapWorkflowCheap
18 , mapWorkflowCheap
18import Control.Arrow ((***))
33import Control.Arrow ((***))
19−import Control.Monad.Fix (MonadFix)
34+import Control.Monad ((<=<))
20−
35+import Control.Monad.Cont (MonadCont, callCC)
36+import Control.Monad.Fix (MonadFix, fix)
37+import Control.Monad.Free.Church
38+import Data.Bifunctor (bimap)
39+import Data.Functor.Compose (Compose(..))
21import Reflex.Class
40import Reflex.Class
22import Reflex.Adjustable.Class
41import Reflex.Adjustable.Class
24−import Reflex.NotReady.Class
25import Reflex.PostBuild.Class
42import Reflex.PostBuild.Class
44+--------------------------------------------------------------------------------
46+--------------------------------------------------------------------------------
27-- | A widget in a workflow
47-- | A widget in a workflow
28-- 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.
48-- 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.
29newtype Workflow t m a = Workflow { unWorkflow :: m (a, Event t (Workflow t m a)) }
49newtype Workflow t m a = Workflow { unWorkflow :: m (a, Event t (Workflow t m a)) }
31−-- | 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).
51+-- | Runs a 'Workflow' and returns the initial value together with an 'Event' that fires whenever one 'Workflow' is replaced by another.
32−workflow :: forall t m a. (Reflex t, Adjustable t m, MonadFix m, MonadHold t m) => Workflow t m a -> m (Dynamic t a)
52+runWorkflow :: (Adjustable t m, MonadFix m, MonadHold t m) => Workflow t m a -> m (a, Event t a)
33−workflow w0 = do
53+runWorkflow w0 = mdo
34− rec eResult <- networkHold (unWorkflow w0) $ fmap unWorkflow $ switch $ snd <$> current eResult
54+ ((a, e0), eResult) <- runWithReplace (unWorkflow w0) (fmap unWorkflow eReplace)
55+ eReplace <- switchHold e0 $ fmap snd eResult
35− return $ fmap fst eResult
56+ return (a, fmap fst eResult)
58+-- | Similar to 'runWorkflow' but combines the result into a 'Dynamic'.
59+workflow :: (Adjustable t m, MonadFix m, MonadHold t m) => Workflow t m a -> m (Dynamic t a)
60+workflow = uncurry holdDyn <=< runWorkflow
37−-- | Similar to 'workflow', but outputs an 'Event' that fires at post-build time and whenever the current 'Workflow' is replaced by the next 'Workflow'.
62+-- | Similar to 'runWorkflow', but also puts the initial value in the 'Event'.
38−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)
63+workflowView :: (Adjustable t m, MonadFix m, MonadHold t m, PostBuild t m) => Workflow t m a -> m (Event t a)
39−workflowView w0 = do
64+workflowView w = do
40− rec eResult <- networkView . fmap unWorkflow =<< holdDyn w0 eReplace
65+ postBuildEv <- getPostBuild
41− eReplace <- fmap switch $ hold never $ fmap snd eResult
66+ (initialValue, replaceEv) <- runWorkflow w
42− return $ fmap fst eResult
67+ pure $ leftmost [initialValue <$ postBuildEv, replaceEv]
44-- | Map a function over a 'Workflow', possibly changing the return type.
69-- | Map a function over a 'Workflow', possibly changing the return type.
45mapWorkflow :: (Reflex t, Functor m) => (a -> b) -> Workflow t m a -> Workflow t m b
70mapWorkflow :: (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)
48-- | Map a "cheap" function over a 'Workflow'. Refer to the documentation for 'pushCheap' for more information and performance considerations.
73-- | Map a "cheap" function over a 'Workflow'. Refer to the documentation for 'pushCheap' for more information and performance considerations.
49mapWorkflowCheap :: (Reflex t, Functor m) => (a -> b) -> Workflow t m a -> Workflow t m b
74mapWorkflowCheap :: (Reflex t, Functor m) => (a -> b) -> Workflow t m a -> Workflow t m b
50mapWorkflowCheap f (Workflow x) = Workflow (fmap (f *** fmapCheap (mapWorkflowCheap f)) x)
75mapWorkflowCheap f (Workflow x) = Workflow (fmap (f *** fmapCheap (mapWorkflowCheap f)) x)
77+--------------------------------------------------------------------------------
79+--------------------------------------------------------------------------------
80+nowOrLater :: PostBuild t m => Either (Event t a) a -> m (Event t a)
83+ Right n -> (n <$) <$> getPostBuild
85+lateOrLater :: (MonadHold t m, Reflex t) => Event t (Either (Event t a) a) -> m (Event t a)
87+ let (ltrEv, lt) = fanEither ev
88+ ltr <- switchHold never ltrEv
89+ pure $ leftmost [lt, ltr]
91+--------------------------------------------------------------------------------
93+--------------------------------------------------------------------------------
94+newtype Step t m a = Step { unStep :: m (Either (Event t a) a) }
95+instance (Reflex t, Functor m) => Functor (Step t m) where
96+ fmap f = Step . fmap (bimap (fmap f) f) . unStep
98+runStep :: PostBuild t m => Step t m a -> m (Event t a)
99+runStep = nowOrLater <=< unStep
101+newtype Machine t m a = Machine { unMachine :: F (Compose m (Event t)) a } deriving (Functor, Applicative, Monad)
104+ :: forall t m a. PostBuild t m
105+ => (forall x. Step t m (Step t m x) -> Step t m x)
106+ -> Machine t m a -> m (Event t a)
107+bottomUp f mm = runStep $ runF root leaf branch
109+ root :: F (Compose m (Event t)) a
112+ leaf :: a -> Step t m a
113+ leaf = Step . pure . Right
115+ branch :: Compose m (Event t) (Step t m a) -> Step t m a
116+ branch = f . Step . fmap Left . getCompose
118+--------------------------------------------------------------------------------
120+--------------------------------------------------------------------------------
121+-- | Machine with a single step
122+step :: (Functor m, Reflex t) => m (Event t a) -> Machine t m a
123+step = Machine . wrap . fmap pure . Compose
125+-- | Machine with a single step and no transitions
126+stop :: (Reflex t, Applicative m) => Machine t m a
127+stop = step $ pure never
129+-- TODO: Use upstream when https://github.com/haskell/mtl/pull/87 is merged
130+{- | Introduces a recursive binding to the continuation.
131+Due to the use of @callCC@, calling the continuation will interrupt execution
132+of the current block creating an effect similar to goto/setjmp in C.
134+label :: MonadCont m => a -> m (a -> m b, a)
135+label a = callCC $ \k -> let go b = k (go, b) in return (go, a)
137+{- | Simplified version of `label` without arguments -}
138+label_ :: MonadCont m => m (m a)
139+label_ = callCC $ return . fix
141+--------------------------------------------------------------------------------
143+--------------------------------------------------------------------------------
144+-- | A wizard only has a single step active at any given point, and any new step replaces its predecessor
145+wizard :: forall t m a. (Adjustable t m, MonadFix m, MonadHold t m, PostBuild t m) => Machine t m a -> m (Event t a)
146+wizard = bottomUp $ \m -> Step $ mdo
147+ (nl, ll) <- runWithReplace (unStep m) (unStep <$> replacement)
148+ replacement <- nowOrLater nl
149+ Left <$> lateOrLater ll
151+-- | A stack can have all steps active at a time, and the first one is always active.
152+-- When a step triggers, it replaces the (possibly empty) pile on top of itself with a single new step
153+stack :: forall t m a. (Adjustable t m, MonadHold t m, PostBuild t m) => Machine t m a -> m (Event t a)
154+stack = bottomUp $ \m -> Step $ do
155+ replacement <- runStep m
156+ ((), ll) <- runWithReplace (pure ()) (unStep <$> replacement)
157+ Left <$> lateOrLater ll