4ee236b · reflex-dom · git.iko.soy

git.iko.soy/reflex-dom

on develop help sign in

Starts moving Workflow across to reflex

4ee236bDave Laing9 years ago

reflex-dom-core/src/Reflex/Dom/Builder/Class.hs+3−15

compare with develop

unifiedsplit

@@ -26,6 +26,7 @@

26module Reflex.Dom.Builder.Class

27 ( module Reflex.Dom.Builder.Class

28 , module Reflex.Dom.Builder.Class.Events

29+ , module Reflex.NotReady.Class

29 ) where

30 ) where

31import Reflex.Class as Reflex

32import Reflex.Class as Reflex

@@ -35,6 +36,7 @@ import Reflex.Dom.Builder.Class.TH

35#endif

36#endif

36import Reflex.DynamicWriter

37import Reflex.DynamicWriter

37import Reflex.EventWriter

38import Reflex.EventWriter

39+import Reflex.NotReady.Class

38import Reflex.PerformEvent.Class

40import Reflex.PerformEvent.Class

39import Reflex.PostBuild.Base

41import Reflex.PostBuild.Base

40import Reflex.Query.Base

42import Reflex.Query.Base

@@ -70,7 +72,7 @@ class Default (EventSpec d EventResult) => DomSpace d where

71-- | @'DomBuilder' t m@ indicates that @m@ is a 'Monad' capable of building

73-- | @'DomBuilder' t m@ indicates that @m@ is a 'Monad' capable of building

72-- dynamic DOM in the 'Reflex' timeline @t@

74-- dynamic DOM in the 'Reflex' timeline @t@

73−class (Monad m, Reflex t, DomSpace (DomBuilderSpace m), Adjustable t m) => DomBuilder t m | m -> t where

75+class (Monad m, Reflex t, DomSpace (DomBuilderSpace m), NotReady t m, Adjustable t m) => DomBuilder t m | m -> t where

74 type DomBuilderSpace m :: *

76 type DomBuilderSpace m :: *

75 textNode :: TextNodeConfig t -> m (TextNode (DomBuilderSpace m) t)

77 textNode :: TextNodeConfig t -> m (TextNode (DomBuilderSpace m) t)

76 default textNode :: ( MonadTrans f

78 default textNode :: ( MonadTrans f

@@ -140,20 +142,6 @@ class (Monad m, Reflex t, DomSpace (DomBuilderSpace m), Adjustable t m) => DomBu

140 { _rawElementConfig_eventSpec = _rawElementConfig_eventSpec cfg

142 { _rawElementConfig_eventSpec = _rawElementConfig_eventSpec cfg

141 }

143 }

142 {-# INLINABLE wrapRawElement #-}

144 {-# INLINABLE wrapRawElement #-}

143− notReadyUntil :: Event t a -> m ()

144− default notReadyUntil :: ( MonadTrans f

145− , m ~ f m'

146− , DomBuilder t m'

147− )

148− => Event t a -> m ()

149− notReadyUntil = lift . notReadyUntil

150− notReady :: m ()

151− default notReady :: ( MonadTrans f

152− , m ~ f m'

153− , DomBuilder t m'

154− )

155− => m ()

156− notReady = lift notReady

157

145

158class DomBuilder t m => MountableDomBuilder t m where

146class DomBuilder t m => MountableDomBuilder t m where

159 type DomFragment m :: *

147 type DomFragment m :: *

reflex-dom-core/src/Reflex/Dom/Builder/Immediate.hs+17−15

@@ -469,6 +469,23 @@ instance er ~ EventResult => Default (GhcjsEventSpec er) where

469 runReaderT (defaultDomEventHandler e en) evt

470 }

471

472+instance SupportsImmediateDomBuilder t m => NotReady t (ImmediateDomBuilderT t m) where

473+ notReadyUntil e = do

474+ eOnce <- headE e

475+ env <- ImmediateDomBuilderT ask

476+ let unreadyChildren = _immediateDomBuilderEnv_unreadyChildren env

477+ liftIO $ modifyIORef' unreadyChildren succ

478+ let ready = do

479+ old <- liftIO $ readIORef unreadyChildren

480+ let new = pred old

481+ liftIO $ writeIORef unreadyChildren $! new

482+ when (new == 0) $ _immediateDomBuilderEnv_commitAction env

483+ requestDomAction_ $ ready <$ eOnce

484+ notReady = do

485+ env <- ImmediateDomBuilderT ask

486+ let unreadyChildren = _immediateDomBuilderEnv_unreadyChildren env

487+ liftIO $ modifyIORef' unreadyChildren succ

488+

472instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t m) where

489instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t m) where

473 type DomBuilderSpace (ImmediateDomBuilderT t m) = GhcjsDomSpace

490 type DomBuilderSpace (ImmediateDomBuilderT t m) = GhcjsDomSpace

474 {-# INLINABLE textNode #-}

491 {-# INLINABLE textNode #-}

@@ -583,21 +600,6 @@ instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t

583 return (wrapped, result)

600 return (wrapped, result)

584 placeRawElement = append . toNode

601 placeRawElement = append . toNode

585 wrapRawElement = wrap

602 wrapRawElement = wrap

586− notReadyUntil e = do

587− eOnce <- headE e

588− env <- ImmediateDomBuilderT ask

589− let unreadyChildren = _immediateDomBuilderEnv_unreadyChildren env

590− liftIO $ modifyIORef' unreadyChildren succ

591− let ready = do

592− old <- liftIO $ readIORef unreadyChildren

593− let new = pred old

594− liftIO $ writeIORef unreadyChildren $! new

595− when (new == 0) $ _immediateDomBuilderEnv_commitAction env

596− requestDomAction_ $ ready <$ eOnce

597− notReady = do

598− env <- ImmediateDomBuilderT ask

599− let unreadyChildren = _immediateDomBuilderEnv_unreadyChildren env

600− liftIO $ modifyIORef' unreadyChildren succ

601

603

602data FragmentState

604data FragmentState

603 = FragmentState_Unmounted

605 = FragmentState_Unmounted

reflex-dom-core/src/Reflex/Dom/Builder/InputDisabled.hs+4

@@ -81,6 +81,10 @@ instance Adjustable t m => Adjustable t (InputDisabledT m) where

81 traverseDMapWithKeyWithAdjust f dm0 dm' = InputDisabledT $ traverseDMapWithKeyWithAdjust (\k v -> runInputDisabledT $ f k v) (coerce dm0) (coerceEvent dm')

82 traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = InputDisabledT $ traverseDMapWithKeyWithAdjustWithMove (\k v -> runInputDisabledT $ f k v) (coerce dm0) (coerceEvent dm')

84+instance NotReady t m => NotReady t (InputDisabledT m) where

85+ notReadyUntil = lift . notReadyUntil

86+ notReady = lift notReady

87+

84instance DomBuilder t m => DomBuilder t (InputDisabledT m) where

88instance DomBuilder t m => DomBuilder t (InputDisabledT m) where

85 type DomBuilderSpace (InputDisabledT m) = DomBuilderSpace m

89 type DomBuilderSpace (InputDisabledT m) = DomBuilderSpace m

86 inputElement cfg = lift $ inputElement $ cfg

90 inputElement cfg = lift $ inputElement $ cfg

reflex-dom-core/src/Reflex/Dom/Builder/Static.hs+4−2

@@ -189,6 +189,10 @@ hoistDMapWithKeyWithAdjust base mapPatch f dm0 dm' = do

189 sample o

190 return (result0, result')

191

192+instance SupportsStaticDomBuilder t m => NotReady t (StaticDomBuilderT t m) where

193+ notReadyUntil _ = pure ()

194+ notReady = pure ()

195+

192-- TODO: the uses of illegal lenses in this instance causes it to be somewhat less efficient than it can be. replacing them with explicit cases to get the underlying Maybe Event and working with those is ideal.

196-- TODO: the uses of illegal lenses in this instance causes it to be somewhat less efficient than it can be. replacing them with explicit cases to get the underlying Maybe Event and working with those is ideal.

193instance SupportsStaticDomBuilder t m => DomBuilder t (StaticDomBuilderT t m) where

197instance SupportsStaticDomBuilder t m => DomBuilder t (StaticDomBuilderT t m) where

194 type DomBuilderSpace (StaticDomBuilderT t m) = StaticDomSpace

198 type DomBuilderSpace (StaticDomBuilderT t m) = StaticDomSpace

@@ -277,8 +281,6 @@ instance SupportsStaticDomBuilder t m => DomBuilder t (StaticDomBuilderT t m) wh

277 return (wrapped, result)

281 return (wrapped, result)

278 placeRawElement () = return ()

282 placeRawElement () = return ()

279 wrapRawElement () _ = return $ Element (EventSelector $ const never) ()

283 wrapRawElement () _ = return $ Element (EventSelector $ const never) ()

280− notReadyUntil _ = return () --TODO: Do we need to support this somehow?

281− notReady = return () --TODO: Do we need to support this somehow?

282

284

283--TODO: Make this more abstract --TODO: Put the WithWebView underneath PerformEventT - I think this would perform better

285--TODO: Make this more abstract --TODO: Put the WithWebView underneath PerformEventT - I think this would perform better

284type StaticWidget x = PostBuildT Spider (StaticDomBuilderT Spider (PerformEventT Spider (SpiderHost Global)))

286type StaticWidget x = PostBuildT Spider (StaticDomBuilderT Spider (PerformEventT Spider (SpiderHost Global)))

reflex-dom-core/src/Reflex/Dom/Widget/Basic.hs+7−45

@@ -20,7 +20,6 @@ module Reflex.Dom.Widget.Basic

20 , button

21 , dyn

22 , widgetHold

23− , untilReady

25 -- * Creating DOM Elements

24 -- * Creating DOM Elements

26 , el

25 , el

@@ -47,20 +46,14 @@ module Reflex.Dom.Widget.Basic

47 , dtdd

46 , dtdd

48 , blank

47 , blank

50− -- * Workflows

51− , Workflow (..)

52− , workflow

53− , workflowView

54− , mapWorkflow

55− , mapWorkflowCheap

56−

57 -- * Tables and Lists

49 -- * Tables and Lists

58 , tableDynAttr

50 , tableDynAttr

59 , tabDisplay

51 , tabDisplay

61 , HasAttributes (..)

53 , HasAttributes (..)

62− , module Reflex.Collection

63 , module Data.Map.Misc

54 , module Data.Map.Misc

55+ , module Reflex.Collection

56+ , module Reflex.Workflow

64 ) where

57 ) where

66import Reflex.Class

59import Reflex.Class

@@ -68,7 +61,10 @@ import Reflex.Collection

68import Reflex.Dom.Builder.Class

61import Reflex.Dom.Builder.Class

69import Reflex.Dom.Class

62import Reflex.Dom.Class

70import Reflex.Dynamic

63import Reflex.Dynamic

64+import Reflex.Network

65+import Reflex.NotReady.Class

71import Reflex.PostBuild.Class

66import Reflex.PostBuild.Class

67+import Reflex.Workflow

73import Control.Arrow

69import Control.Arrow

74import Control.Lens hiding (children, element)

70import Control.Lens hiding (children, element)

@@ -89,9 +85,6 @@ import Data.These

89import Data.Traversable

85import Data.Traversable

90import Prelude hiding (mapM, mapM_, sequence, sequence_)

86import Prelude hiding (mapM, mapM_, sequence, sequence_)

92−widgetHoldInternal :: forall t m a b. DomBuilder t m => m a -> Event t (m b) -> m (a, Event t b)

93−widgetHoldInternal = runWithReplace

94−

95-- | Breaks the given Map into pieces based on the given Set. Each piece will contain only keys that are less than the key of the piece, and greater than or equal to the key of the piece with the next-smaller key. There will be one additional piece containing all keys from the original Map that are larger or equal to the largest key in the Set.

88-- | Breaks the given Map into pieces based on the given Set. Each piece will contain only keys that are less than the key of the piece, and greater than or equal to the key of the piece with the next-smaller key. There will be one additional piece containing all keys from the original Map that are larger or equal to the largest key in the Set.

96-- Either k () is used instead of Maybe k so that the resulting map of pieces is sorted so that the additional piece has the largest key.

89-- Either k () is used instead of Maybe k so that the resulting map of pieces is sorted so that the additional piece has the largest key.

97-- No empty pieces will be included in the output.

90-- No empty pieces will be included in the output.

@@ -137,25 +130,13 @@ button t = do

137-- The returned Event of widget results occurs when the Dynamic does.

130-- The returned Event of widget results occurs when the Dynamic does.

138-- 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').

131-- 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').

139dyn :: (DomBuilder t m, PostBuild t m) => Dynamic t (m a) -> m (Event t a)

132dyn :: (DomBuilder t m, PostBuild t m) => Dynamic t (m a) -> m (Event t a)

140−dyn child = do

133+dyn = networkView

141− postBuild <- getPostBuild

142− let newChild = leftmost [updated child, tagCheap (current child) postBuild]

143− snd <$> widgetHoldInternal notReady newChild

144

134

145-- | Given an initial widget and an Event of widget-creating actions, create a widget that is recreated whenever the Event fires.

135-- | Given an initial widget and an Event of widget-creating actions, create a widget that is recreated whenever the Event fires.

146-- The returned Dynamic of widget results occurs when the Event does.

136-- The returned Dynamic of widget results occurs when the Event does.

147-- Note: Often, the type 'a' is an Event, in which case the return value is a Dynamic-of-Events that would typically be flattened.

137-- Note: Often, the type 'a' is an Event, in which case the return value is a Dynamic-of-Events that would typically be flattened.

148widgetHold :: (DomBuilder t m, MonadHold t m) => m a -> Event t (m a) -> m (Dynamic t a)

138widgetHold :: (DomBuilder t m, MonadHold t m) => m a -> Event t (m a) -> m (Dynamic t a)

149−widgetHold child0 newChild = do

139+widgetHold = networkHold

150− (result0, newResult) <- widgetHoldInternal child0 newChild

151− holdDyn result0 newResult

152−

153−-- | Render a placeholder widget to be shown while another widget is not yet

154−-- done rendering

155−untilReady :: (DomBuilder t m, PostBuild t m) => m a -> m b -> m (a, Event t b)

156−untilReady a b = do

157− postBuild <- getPostBuild

158− runWithReplace a $ b <$ postBuild

159

140

160-- | Create a DOM element

141-- | Create a DOM element

161-- > el "div" (text "Hello World")

142-- > el "div" (text "Hello World")

@@ -295,25 +276,6 @@ dtdd h w = do

295blank :: forall m. Monad m => m ()

276blank :: forall m. Monad m => m ()

296blank = return ()

277blank = return ()

297

278

298−newtype Workflow t m a = Workflow { unWorkflow :: m (a, Event t (Workflow t m a)) }

299−

300−workflow :: forall t m a. (DomBuilder t m, MonadFix m, MonadHold t m) => Workflow t m a -> m (Dynamic t a)

301−workflow w0 = do

302− rec eResult <- widgetHold (unWorkflow w0) $ fmap unWorkflow $ switch $ snd <$> current eResult

303− return $ fmap fst eResult

304−

305−workflowView :: forall t m a. (DomBuilder t m, MonadFix m, MonadHold t m, PostBuild t m) => Workflow t m a -> m (Event t a)

306−workflowView w0 = do

307− rec eResult <- dyn . fmap unWorkflow =<< holdDyn w0 eReplace

308− eReplace <- fmap switch $ hold never $ fmap snd eResult

309− return $ fmap fst eResult

310−

311−mapWorkflow :: (DomBuilder t m) => (a -> b) -> Workflow t m a -> Workflow t m b

312−mapWorkflow f (Workflow x) = Workflow (fmap (f *** fmap (mapWorkflow f)) x)

313−

314−mapWorkflowCheap :: (DomBuilder t m) => (a -> b) -> Workflow t m a -> Workflow t m b

315−mapWorkflowCheap f (Workflow x) = Workflow (fmap (f *** fmapCheap (mapWorkflowCheap f)) x)

316−

317-- | A widget to display a table with static columns and dynamic rows.

279-- | A widget to display a table with static columns and dynamic rows.

318tableDynAttr :: forall t m r k v. (Ord k, DomBuilder t m, MonadHold t m, PostBuild t m, MonadFix m)

280tableDynAttr :: forall t m r k v. (Ord k, DomBuilder t m, MonadHold t m, PostBuild t m, MonadFix m)

319 => Text -- ^ Class applied to <table> element

281 => Text -- ^ Class applied to <table> element