@@ -1,3 +1,6 @@
1+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2+{-# LANGUAGE LambdaCase #-}
3+{-# LANGUAGE RankNTypes #-}
14{-# LANGUAGE RecursiveDo #-}
25{-# LANGUAGE ScopedTypeVariables #-}
36-- |
@@ -13,33 +16,55 @@ module Reflex.Workflow (
1316 , workflowView
1417 , mapWorkflow
1518 , mapWorkflowCheap
19+ , runWorkflow
20+
21+ -- Combinators
22+ , step
23+ , stop
24+ , label
25+ , label_
26+
27+ -- Runners
28+ , stack
29+ , wizard
30+
1631 ) where
1732
1833import Control.Arrow ((***))
19−import Control.Monad.Fix (MonadFix)
20−
34+import Control.Monad ((<=<))
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(..))
2140import Reflex.Class
2241import Reflex.Adjustable.Class
23−import Reflex.Network
24−import Reflex.NotReady.Class
2542import Reflex.PostBuild.Class
2643
44+--------------------------------------------------------------------------------
45+-- Workflow
46+--------------------------------------------------------------------------------
2747-- | A widget in a workflow
2848-- 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.
2949newtype Workflow t m a = Workflow { unWorkflow :: m (a, Event t (Workflow t m a)) }
3050
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).
32−workflow :: forall t m a. (Reflex t, Adjustable t m, MonadFix m, MonadHold t m) => Workflow t m a -> m (Dynamic t a)
33−workflow w0 = do
34− rec eResult <- networkHold (unWorkflow w0) $ fmap unWorkflow $ switch $ snd <$> current eResult
35− return $ fmap fst eResult
51+-- | Runs a 'Workflow' and returns the initial value together with an 'Event' that fires whenever one 'Workflow' is replaced by another.
52+runWorkflow :: (Adjustable t m, MonadFix m, MonadHold t m) => Workflow t m a -> m (a, Event t a)
53+runWorkflow w0 = mdo
54+ ((a, e0), eResult) <- runWithReplace (unWorkflow w0) (fmap unWorkflow eReplace)
55+ eReplace <- switchHold e0 $ fmap snd eResult
56+ return (a, fmap fst eResult)
57+
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
3661
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'.
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)
39−workflowView w0 = do
40− rec eResult <- networkView . fmap unWorkflow =<< holdDyn w0 eReplace
41− eReplace <- fmap switch $ hold never $ fmap snd eResult
42− return $ fmap fst eResult
62+-- | Similar to 'runWorkflow', but also puts the initial value in the 'Event'.
63+workflowView :: (Adjustable t m, MonadFix m, MonadHold t m, PostBuild t m) => Workflow t m a -> m (Event t a)
64+workflowView w = do
65+ postBuildEv <- getPostBuild
66+ (initialValue, replaceEv) <- runWorkflow w
67+ pure $ leftmost [initialValue <$ postBuildEv, replaceEv]
4368
4469-- | Map a function over a 'Workflow', possibly changing the return type.
4570mapWorkflow :: (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)
4873-- | Map a "cheap" function over a 'Workflow'. Refer to the documentation for 'pushCheap' for more information and performance considerations.
4974mapWorkflowCheap :: (Reflex t, Functor m) => (a -> b) -> Workflow t m a -> Workflow t m b
5075mapWorkflowCheap f (Workflow x) = Workflow (fmap (f *** fmapCheap (mapWorkflowCheap f)) x)
76+
77+--------------------------------------------------------------------------------
78+-- Internal utils
79+--------------------------------------------------------------------------------
80+nowOrLater :: PostBuild t m => Either (Event t a) a -> m (Event t a)
81+nowOrLater = \case
82+ Left l -> pure l
83+ Right n -> (n <$) <$> getPostBuild
84+
85+lateOrLater :: (MonadHold t m, Reflex t) => Event t (Either (Event t a) a) -> m (Event t a)
86+lateOrLater ev = mdo
87+ let (ltrEv, lt) = fanEither ev
88+ ltr <- switchHold never ltrEv
89+ pure $ leftmost [lt, ltr]
90+
91+--------------------------------------------------------------------------------
92+-- Replacements layer
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
97+
98+runStep :: PostBuild t m => Step t m a -> m (Event t a)
99+runStep = nowOrLater <=< unStep
100+
101+newtype Machine t m a = Machine { unMachine :: F (Compose m (Event t)) a } deriving (Functor, Applicative, Monad)
102+
103+bottomUp
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
108+ where
109+ root :: F (Compose m (Event t)) a
110+ root = unMachine mm
111+
112+ leaf :: a -> Step t m a
113+ leaf = Step . pure . Right
114+
115+ branch :: Compose m (Event t) (Step t m a) -> Step t m a
116+ branch = f . Step . fmap Left . getCompose
117+
118+--------------------------------------------------------------------------------
119+-- Combinators
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
124+
125+-- | Machine with a single step and no transitions
126+stop :: (Reflex t, Applicative m) => Machine t m a
127+stop = step $ pure never
128+
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.
133+-}
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)
136+
137+{- | Simplified version of `label` without arguments -}
138+label_ :: MonadCont m => m (m a)
139+label_ = callCC $ return . fix
140+
141+--------------------------------------------------------------------------------
142+-- Runners
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
150+
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