git.iko.soy/reflex
on develop help sign in
WIP: Workflow monad
7ea831dRyan Trinkle
reflex.cabal+1
compare with develop
unifiedsplit
@@ -59,6 +59,7 @@ library
59 data-default >= 0.5 && < 0.8,
59 data-default >= 0.5 && < 0.8,
60 dependent-map >= 0.2.4 && < 0.3,
60 dependent-map >= 0.2.4 && < 0.3,
61 exception-transformers == 0.4.*,
61 exception-transformers == 0.4.*,
62+ free == 4.12.*,
62 lens >= 4.7 && < 5,
63 lens >= 4.7 && < 5,
63 monad-control >= 1.0.1 && < 1.1,
64 monad-control >= 1.0.1 && < 1.1,
64 mtl >= 2.1 && < 2.3,
65 mtl >= 2.1 && < 2.3,
src/Reflex/Workflow.hs+28−1
@@ -1,5 +1,6 @@
1−{-# LANGUAGE ScopedTypeVariables #-}
1+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2{-# LANGUAGE RecursiveDo #-}
2{-# LANGUAGE RecursiveDo #-}
3+{-# LANGUAGE ScopedTypeVariables #-}
3module Reflex.Workflow (
4module Reflex.Workflow (
4 -- * Workflows
5 -- * Workflows
5 Workflow (..)
6 Workflow (..)
@@ -7,10 +8,16 @@ module Reflex.Workflow (
7 , workflowView
8 , workflowView
8 , mapWorkflow
9 , mapWorkflow
9 , mapWorkflowCheap
10 , mapWorkflowCheap
11+ -- * Better workflows
12+ , W (..)
13+ , runW
14+ , prompt
10 ) where
15 ) where
11
16
12import Control.Arrow ((***))
17import Control.Arrow ((***))
13import Control.Monad.Fix (MonadFix)
18import Control.Monad.Fix (MonadFix)
19+import Control.Monad.Free.Church
20+import Data.Functor.Compose
14
21
15import Reflex.Class
22import Reflex.Class
16import Reflex.Network
23import Reflex.Network
@@ -35,3 +42,23 @@ mapWorkflow f (Workflow x) = Workflow (fmap (f *** fmap (mapWorkflow f)) x)
35
42
36mapWorkflowCheap :: (Reflex t, Functor m) => (a -> b) -> Workflow t m a -> Workflow t m b
43mapWorkflowCheap :: (Reflex t, Functor m) => (a -> b) -> Workflow t m a -> Workflow t m b
37mapWorkflowCheap f (Workflow x) = Workflow (fmap (f *** fmapCheap (mapWorkflowCheap f)) x)
44mapWorkflowCheap 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