git.iko.soy/reflex
on ae@new-workflows help sign in
reflex/src/Reflex/Workflow.hs
157 lines 6.4 kB history raw
1{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2{-# LANGUAGE LambdaCase #-}
3{-# LANGUAGE RankNTypes #-}
4{-# LANGUAGE RecursiveDo #-}
5{-# LANGUAGE ScopedTypeVariables #-}
6-- |
7-- Module:
8-- Reflex.Workflow
9-- Description:
10-- Provides a convenient way to describe a series of interrelated widgets that
11-- can send data to, invoke, and replace one another. Useful for modeling user interface
12-- "workflows."
13module Reflex.Workflow (
14 Workflow (..)
15 , workflow
16 , workflowView
17 , mapWorkflow
18 , mapWorkflowCheap
19 , runWorkflow
21 -- Combinators
22 , step
23 , stop
24 , label
25 , label_
27 -- Runners
28 , stack
29 , wizard
31 ) where
33import Control.Arrow ((***))
34import Control.Monad ((<=<))
35import Control.Monad.Cont (MonadCont, callCC)
36import Control.Monad.Fix (MonadFix, fix)
37import Control.Monad.Free.Church
38import Data.Bifunctor (bimap)
39import Data.Functor.Compose (Compose(..))
40import Reflex.Class
41import Reflex.Adjustable.Class
42import Reflex.PostBuild.Class
44--------------------------------------------------------------------------------
45-- Workflow
46--------------------------------------------------------------------------------
47-- | A widget in a workflow
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.
49newtype Workflow t m a = Workflow { unWorkflow :: m (a, Event t (Workflow t m a)) }
51-- | Runs a 'Workflow' and returns the initial value together with an 'Event' that fires whenever one 'Workflow' is replaced by another.
52runWorkflow :: (Adjustable t m, MonadFix m, MonadHold t m) => Workflow t m a -> m (a, Event t a)
53runWorkflow 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)
58-- | Similar to 'runWorkflow' but combines the result into a 'Dynamic'.
59workflow :: (Adjustable t m, MonadFix m, MonadHold t m) => Workflow t m a -> m (Dynamic t a)
60workflow = uncurry holdDyn <=< runWorkflow
62-- | Similar to 'runWorkflow', but also puts the initial value in the 'Event'.
63workflowView :: (Adjustable t m, MonadFix m, MonadHold t m, PostBuild t m) => Workflow t m a -> m (Event t a)
64workflowView w = do
65 postBuildEv <- getPostBuild
66 (initialValue, replaceEv) <- runWorkflow w
67 pure $ leftmost [initialValue <$ postBuildEv, replaceEv]
69-- | Map a function over a 'Workflow', possibly changing the return type.
70mapWorkflow :: (Reflex t, Functor m) => (a -> b) -> Workflow t m a -> Workflow t m b
71mapWorkflow f (Workflow x) = Workflow (fmap (f *** fmap (mapWorkflow f)) x)
73-- | Map a "cheap" function over a 'Workflow'. Refer to the documentation for 'pushCheap' for more information and performance considerations.
74mapWorkflowCheap :: (Reflex t, Functor m) => (a -> b) -> Workflow t m a -> Workflow t m b
75mapWorkflowCheap f (Workflow x) = Workflow (fmap (f *** fmapCheap (mapWorkflowCheap f)) x)
77--------------------------------------------------------------------------------
78-- Internal utils
79--------------------------------------------------------------------------------
80nowOrLater :: PostBuild t m => Either (Event t a) a -> m (Event t a)
81nowOrLater = \case
82 Left l -> pure l
83 Right n -> (n <$) <$> getPostBuild
85lateOrLater :: (MonadHold t m, Reflex t) => Event t (Either (Event t a) a) -> m (Event t a)
86lateOrLater ev = mdo
87 let (ltrEv, lt) = fanEither ev
88 ltr <- switchHold never ltrEv
89 pure $ leftmost [lt, ltr]
91--------------------------------------------------------------------------------
92-- Replacements layer
93--------------------------------------------------------------------------------
94newtype Step t m a = Step { unStep :: m (Either (Event t a) a) }
95instance (Reflex t, Functor m) => Functor (Step t m) where
96 fmap f = Step . fmap (bimap (fmap f) f) . unStep
98runStep :: PostBuild t m => Step t m a -> m (Event t a)
99runStep = nowOrLater <=< unStep
101newtype Machine t m a = Machine { unMachine :: F (Compose m (Event t)) a } deriving (Functor, Applicative, Monad)
103bottomUp
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)
107bottomUp f mm = runStep $ runF root leaf branch
108 where
109 root :: F (Compose m (Event t)) a
110 root = unMachine mm
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--------------------------------------------------------------------------------
119-- Combinators
120--------------------------------------------------------------------------------
121-- | Machine with a single step
122step :: (Functor m, Reflex t) => m (Event t a) -> Machine t m a
123step = Machine . wrap . fmap pure . Compose
125-- | Machine with a single step and no transitions
126stop :: (Reflex t, Applicative m) => Machine t m a
127stop = 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.
131Due to the use of @callCC@, calling the continuation will interrupt execution
132of the current block creating an effect similar to goto/setjmp in C.
133-}
134label :: MonadCont m => a -> m (a -> m b, a)
135label a = callCC $ \k -> let go b = k (go, b) in return (go, a)
137{- | Simplified version of `label` without arguments -}
138label_ :: MonadCont m => m (m a)
139label_ = callCC $ return . fix
141--------------------------------------------------------------------------------
142-- Runners
143--------------------------------------------------------------------------------
144-- | A wizard only has a single step active at any given point, and any new step replaces its predecessor
145wizard :: forall t m a. (Adjustable t m, MonadFix m, MonadHold t m, PostBuild t m) => Machine t m a -> m (Event t a)
146wizard = 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
153stack :: forall t m a. (Adjustable t m, MonadHold t m, PostBuild t m) => Machine t m a -> m (Event t a)
154stack = bottomUp $ \m -> Step $ do
155 replacement <- runStep m
156 ((), ll) <- runWithReplace (pure ()) (unStep <$> replacement)
157 Left <$> lateOrLater ll