264b370 · reflex · git.iko.soy

git.iko.soy/reflex

Merge branch 'workflow-move' of https://github.com/dalaing/reflex into develop

commit264b370a26f791eeab3cbea202d85d6fa26da09c authorRyan Trinkle <ryan.trinkle@gmail.com> dateWed 3 Jan 2018, 22:43 (9 years ago) parent9bfe802 bf3e1b2

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,

@@ -115,7 +117,8 @@ library

115117 Reflex.Spider,

116118 Reflex.Spider.Internal,

117119 Reflex.Time,

118− Reflex.Widget.Basic

120+ Reflex.Widget.Basic,

121+ Reflex.Workflow

119122

120123 ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 -fspecialise-aggressively -ddump-simpl -ddump-to-file -dsuppress-coercions -dsuppress-idinfo

121124 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)