git.iko.soy/reflex
on develop help sign in
Starts moving Workflow across from reflex-dom
commitbf3e1b22c6fe0d0c4503ca12e5d8664a4c153dc4 authorDave Laing <dave.laing.80@gmail.com> dateThu 2 Nov 2017, 09:58 (9 years ago) parent41c56b6
5 files changed+153−1
compare with develop
unifiedsplit
reflex.cabal+4−1 src/Reflex/Network.hs+40 src/Reflex/NotReady/Class.hs+67 src/Reflex/Spider/Internal.hs+5 src/Reflex/Workflow.hs+37
reflex.cabal+4−1
@@ -94,6 +94,8 @@ library
9494 Reflex.FastWeak,
9595 Reflex.FunctorMaybe,
9696 Reflex.Host.Class,
97+ Reflex.Network,
98+ Reflex.NotReady.Class,
9799 Reflex.Patch,
98100 Reflex.Patch.Class,
99101 Reflex.Patch.DMap,
@@ -114,7 +116,8 @@ library
114116 Reflex.Spider,
115117 Reflex.Spider.Internal,
116118 Reflex.Time,
117− Reflex.Widget.Basic
119+ Reflex.Widget.Basic,
120+ Reflex.Workflow
118121
119122 ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 -fspecialise-aggressively -ddump-simpl -ddump-to-file -dsuppress-coercions -dsuppress-idinfo
120123 ghc-prof-options: -fprof-auto
src/Reflex/Network.hsnew file+40
@@ -0,0 +1,40 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DefaultSignatures #-}
3+{-# LANGUAGE MultiParamTypeClasses #-}
4+{-# LANGUAGE FunctionalDependencies #-}
5+#ifdef USE_REFLEX_OPTIMIZER
6+{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
7+#endif
8+module Reflex.Network
9+ ( networkView
10+ , networkHold
11+ , untilReady
12+ ) where
13+
14+import Reflex.Class
15+import Reflex.NotReady.Class
16+import Reflex.PostBuild.Class
17+
18+-- | Given a Dynamic of network-creating actions, create a network that is recreated whenever the Dynamic updates.
19+-- The returned Event of network results occurs when the Dynamic does.
20+-- Note: Often, the type 'a' is an Event, in which case the return value is an Event-of-Events that would typically be flattened (via 'switchPromptly').
21+networkView :: (Reflex t, NotReady t m, Adjustable t m, PostBuild t m) => Dynamic t (m a) -> m (Event t a)
22+networkView child = do
23+ postBuild <- getPostBuild
24+ let newChild = leftmost [updated child, tagCheap (current child) postBuild]
25+ snd <$> runWithReplace notReady newChild
26+
27+-- | Given an initial network and an Event of network-creating actions, create a network that is recreated whenever the Event fires.
28+-- The returned Dynamic of network results occurs when the Event does.
29+-- Note: Often, the type 'a' is an Event, in which case the return value is a Dynamic-of-Events that would typically be flattened.
30+networkHold :: (Reflex t, Adjustable t m, MonadHold t m) => m a -> Event t (m a) -> m (Dynamic t a)
31+networkHold child0 newChild = do
32+ (result0, newResult) <- runWithReplace child0 newChild
33+ holdDyn result0 newResult
34+
35+-- | Render a placeholder network to be shown while another network is not yet
36+-- done building
37+untilReady :: (Reflex t, Adjustable t m, PostBuild t m) => m a -> m b -> m (a, Event t b)
38+untilReady a b = do
39+ postBuild <- getPostBuild
40+ runWithReplace a $ b <$ postBuild
src/Reflex/NotReady/Class.hsnew file+67
@@ -0,0 +1,67 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DefaultSignatures #-}
3+{-# LANGUAGE MultiParamTypeClasses #-}
4+{-# LANGUAGE FunctionalDependencies #-}
5+{-# LANGUAGE TypeFamilies #-}
6+{-# LANGUAGE FlexibleInstances #-}
7+{-# LANGUAGE UndecidableInstances #-}
8+#ifdef USE_REFLEX_OPTIMIZER
9+{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
10+#endif
11+module Reflex.NotReady.Class
12+ ( NotReady(..)
13+ ) where
14+
15+import Control.Monad.Trans
16+import Control.Monad.Reader (ReaderT)
17+
18+import Reflex.Class
19+import Reflex.Host.Class
20+import Reflex.PostBuild.Base (PostBuildT)
21+import Reflex.EventWriter (EventWriterT)
22+import Reflex.DynamicWriter (DynamicWriterT)
23+import Reflex.Query.Base (QueryT)
24+import Reflex.Requester.Base (RequesterT)
25+import Reflex.PerformEvent.Base (PerformEventT(..))
26+import Reflex.TriggerEvent.Base (TriggerEventT)
27+
28+class Monad m => NotReady t m | m -> t where
29+ notReadyUntil :: Event t a -> m ()
30+ default notReadyUntil :: (MonadTrans f, m ~ f m', NotReady t m') => Event t a -> m ()
31+ notReadyUntil = lift . notReadyUntil
32+
33+ notReady :: m ()
34+ default notReady :: (MonadTrans f, m ~ f m', NotReady t m') => m ()
35+ notReady = lift notReady
36+
37+instance NotReady t m => NotReady t (ReaderT r m) where
38+ notReadyUntil = lift . notReadyUntil
39+ notReady = lift notReady
40+
41+instance NotReady t m => NotReady t (PostBuildT t m) where
42+ notReadyUntil = lift . notReadyUntil
43+ notReady = lift notReady
44+
45+instance NotReady t m => NotReady t (EventWriterT t w m) where
46+ notReadyUntil = lift . notReadyUntil
47+ notReady = lift notReady
48+
49+instance NotReady t m => NotReady t (DynamicWriterT t w m) where
50+ notReadyUntil = lift . notReadyUntil
51+ notReady = lift notReady
52+
53+instance NotReady t m => NotReady t (QueryT t q m) where
54+ notReadyUntil = lift . notReadyUntil
55+ notReady = lift notReady
56+
57+instance (ReflexHost t, NotReady t (HostFrame t)) => NotReady t (PerformEventT t m) where
58+ notReadyUntil = PerformEventT . notReadyUntil
59+ notReady = PerformEventT notReady
60+
61+instance NotReady t m => NotReady t (RequesterT t request response m) where
62+ notReadyUntil = lift . notReadyUntil
63+ notReady = lift notReady
64+
65+instance NotReady t m => NotReady t (TriggerEventT t m) where
66+ notReadyUntil = lift . notReadyUntil
67+ notReady = lift notReady
src/Reflex/Spider/Internal.hs+5
@@ -89,6 +89,7 @@ import qualified Reflex.Class
8989import qualified Reflex.Class as R
9090import qualified Reflex.Host.Class
9191#endif
92+import Reflex.NotReady.Class
9293import Reflex.Patch
9394import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove
9495
@@ -2419,6 +2420,10 @@ instance Monad (SpiderHostFrame x) where
24192420 {-# INLINABLE fail #-}
24202421 fail s = SpiderHostFrame $ fail s
24212422
2423+instance NotReady x (SpiderHostFrame x) where
2424+ notReadyUntil _ = pure ()
2425+ notReady = pure ()
2426+
24222427newEventWithTriggerIO :: (RootTrigger x a -> IO (IO ())) -> IO (Event x a)
24232428newEventWithTriggerIO f = do
24242429 es <- newFanEventWithTriggerIO $ \Refl -> f
src/Reflex/Workflow.hsnew file+37
@@ -0,0 +1,37 @@
1+{-# LANGUAGE ScopedTypeVariables #-}
2+{-# LANGUAGE RecursiveDo #-}
3+module Reflex.Workflow (
4+ -- * Workflows
5+ Workflow (..)
6+ , workflow
7+ , workflowView
8+ , mapWorkflow
9+ , mapWorkflowCheap
10+ ) where
11+
12+import Control.Arrow ((***))
13+import Control.Monad.Fix (MonadFix)
14+
15+import Reflex.Class
16+import Reflex.Network
17+import Reflex.NotReady.Class
18+import Reflex.PostBuild.Class
19+
20+newtype Workflow t m a = Workflow { unWorkflow :: m (a, Event t (Workflow t m a)) }
21+
22+workflow :: forall t m a. (Reflex t, Adjustable t m, MonadFix m, MonadHold t m) => Workflow t m a -> m (Dynamic t a)
23+workflow w0 = do
24+ rec eResult <- networkHold (unWorkflow w0) $ fmap unWorkflow $ switch $ snd <$> current eResult
25+ return $ fmap fst eResult
26+
27+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)
28+workflowView w0 = do
29+ rec eResult <- networkView . fmap unWorkflow =<< holdDyn w0 eReplace
30+ eReplace <- fmap switch $ hold never $ fmap snd eResult
31+ return $ fmap fst eResult
32+
33+mapWorkflow :: (Reflex t, Functor m) => (a -> b) -> Workflow t m a -> Workflow t m b
34+mapWorkflow f (Workflow x) = Workflow (fmap (f *** fmap (mapWorkflow f)) x)
35+
36+mapWorkflowCheap :: (Reflex t, Functor m) => (a -> b) -> Workflow t m a -> Workflow t m b
37+mapWorkflowCheap f (Workflow x) = Workflow (fmap (f *** fmapCheap (mapWorkflowCheap f)) x)