@@ -1,5 +1,6 @@
1−{-# LANGUAGE ScopedTypeVariables #-}
1+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
22{-# LANGUAGE RecursiveDo #-}
3+{-# LANGUAGE ScopedTypeVariables #-}
34module Reflex.Workflow (
45 -- * Workflows
56 Workflow (..)
@@ -7,10 +8,16 @@ module Reflex.Workflow (
78 , workflowView
89 , mapWorkflow
910 , mapWorkflowCheap
11+ -- * Better workflows
12+ , W (..)
13+ , runW
14+ , prompt
1015 ) where
1116
1217import Control.Arrow ((***))
1318import Control.Monad.Fix (MonadFix)
19+import Control.Monad.Free.Church
20+import Data.Functor.Compose
1421
1522import Reflex.Class
1623import Reflex.Network
@@ -35,3 +42,23 @@ mapWorkflow f (Workflow x) = Workflow (fmap (f *** fmap (mapWorkflow f)) x)
3542
3643mapWorkflowCheap :: (Reflex t, Functor m) => (a -> b) -> Workflow t m a -> Workflow t m b
3744mapWorkflowCheap f (Workflow x) = Workflow (fmap (f *** fmapCheap (mapWorkflowCheap f)) x)
45+
46+--------------------------------------------------------------------------------
47+-- Workflow monad
48+--------------------------------------------------------------------------------
49+
50+type WInternal t m = F (Compose m (Event t))
51+newtype W t m a = W { unW :: WInternal t m a } deriving (Functor, Applicative, Monad)
52+
53+runW :: forall t m a. (Adjustable t m, MonadHold t m, MonadFix m, PostBuild t m) => W t m a -> m (Event t a)
54+runW (W w0) = do
55+ let go :: WInternal t m a -> m (Event t (WInternal t m a))
56+ go w = runF w
57+ (\l -> (return l <$) <$> getPostBuild) --TODO: Can this just be blank?
58+ (\(Compose r) -> fmap (fmapCheap (wrap . Compose)) r)
59+ rec (next0, built) <- runWithReplace (go w0) $ go <$> next
60+ next <- switch <$> hold next0 built
61+ return $ fmapMaybe (\w -> runF w Just (const Nothing)) next
62+
63+prompt :: (Reflex t, Functor m) => m (Event t a) -> W t m a
64+prompt = W . wrap . fmap return . Compose