402ad56 · reflex-dom · git.iko.soy

git.iko.soy/reflex-dom

on develop help sign in

Merge develop into jsaddle

402ad56Hamish Mackenzie10 years ago

reflex-dom-core/reflex-dom-core.cabal+8

compare with develop

unifiedsplit

@@ -26,6 +26,11 @@ flag use-reflex-optimizer

26 default: False

27 manual: True

29+flag expose-all-unfoldings

30+ description: Build the library with -fexpose-all-unfoldings which can help client code specialize better

31+ default: False

32+ manual: True

33+

29library

34library

30 hs-source-dirs: src

35 hs-source-dirs: src

31 build-depends:

36 build-depends:

@@ -97,6 +102,9 @@ library

102

98 ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 -ferror-spans

103 ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 -ferror-spans

104

105+ if flag(expose-all-unfoldings)

106+ ghc-options: -fexpose-all-unfoldings

107+

100 if flag(use-reflex-optimizer)

108 if flag(use-reflex-optimizer)

101 ghc-options: -fplugin=Reflex.Optimizer

109 ghc-options: -fplugin=Reflex.Optimizer

102

110

reflex-dom-core/src/Foreign/JavaScript/TH.hs+12−3

@@ -28,6 +28,7 @@ module Foreign.JavaScript.TH ( module Foreign.JavaScript.TH

28import Prelude hiding((!!))

29import Reflex.Class

30import Reflex.DynamicWriter

31+import Reflex.EventWriter

31import Reflex.Host.Class

32import Reflex.Host.Class

32import Reflex.PerformEvent.Base

33import Reflex.PerformEvent.Base

33import Reflex.PerformEvent.Class

34import Reflex.PerformEvent.Class

@@ -116,8 +117,12 @@ instance (ReflexHost t, HasJSContext (HostFrame t)) => HasJSContext (PerformEven

116 type JSContextPhantom (PerformEventT t m) = JSContextPhantom (HostFrame t)

117 type JSContextPhantom (PerformEventT t m) = JSContextPhantom (HostFrame t)

117 askJSContext = PerformEventT $ lift askJSContext

118 askJSContext = PerformEventT $ lift askJSContext

118

119

119−instance HasJSContext m => HasJSContext (DynamicWriterT t w m) where

120+instance HasJSContext m => HasJSContext (EventWriterT t w m) where

120− type JSContextPhantom (DynamicWriterT t w m) = JSContextPhantom m

121+ type JSContextPhantom (EventWriterT t w m) = JSContextPhantom m

122+ askJSContext = lift askJSContext

123+

124+instance HasJSContext m => HasJSContext (RequesterT t request response m) where

125+ type JSContextPhantom (RequesterT t request response m) = JSContextPhantom m

121 askJSContext = lift askJSContext

126 askJSContext = lift askJSContext

122

127

123newtype WithJSContextSingleton x m a = WithJSContextSingleton { unWithJSContextSingleton :: ReaderT (JSContextSingleton x) m a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadTrans, MonadException, MonadAsyncException)

128newtype WithJSContextSingleton x m a = WithJSContextSingleton { unWithJSContextSingleton :: ReaderT (JSContextSingleton x) m a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadTrans, MonadException, MonadAsyncException)

@@ -192,7 +197,11 @@ instance MonadAtomicRef m => MonadAtomicRef (WithJSContextSingleton x m) where

192withJSContextSingleton :: MonadJSM m => (forall x. JSContextSingleton x -> m r) -> m r

197withJSContextSingleton :: MonadJSM m => (forall x. JSContextSingleton x -> m r) -> m r

193withJSContextSingleton f = askJSM >>= f . JSContextSingleton

198withJSContextSingleton f = askJSM >>= f . JSContextSingleton

194

199

200+-- | Warning: `withJSContextSingletonMono` does not provide the same guarantees that `withJSContextSingleton` does.

201+withJSContextSingletonMono :: MonadJSM m => (JSContextSingleton () -> m r) -> m r

202+withJSContextSingletonMono f = askJSM >>= f . JSContextSingleton

203+

195−-- | A singleton type for a given JS Context; we use this to statically guarantee that different JSContexts (and thus different javscript contexts) don't get mixed up

204+-- | A singleton type for a given JSContext; we use this to statically guarantee that different JSContexts don't get mixed up

196newtype JSContextSingleton x = JSContextSingleton { unJSContextSingleton :: JSContextRef }

205newtype JSContextSingleton x = JSContextSingleton { unJSContextSingleton :: JSContextRef }

197

206

198#ifdef __GHCJS__

207#ifdef __GHCJS__

reflex-dom-core/src/Reflex/Dom/Builder/Class.hs+27

@@ -490,6 +490,10 @@ instance InitialAttributes (TextAreaElementConfig er t m) where

490 {-# INLINABLE initialAttributes #-}

491 initialAttributes = textAreaElementConfig_elementConfig . elementConfig_initialAttributes

492

493+instance InitialAttributes (SelectElementConfig er t m) where

494+ {-# INLINABLE initialAttributes #-}

495+ initialAttributes = selectElementConfig_elementConfig . elementConfig_initialAttributes

496+

493class ModifyAttributes t a | a -> t where

497class ModifyAttributes t a | a -> t where

494 modifyAttributes :: Lens' a (Event t (Map AttributeName (Maybe Text)))

498 modifyAttributes :: Lens' a (Event t (Map AttributeName (Maybe Text)))

495

499

@@ -505,6 +509,10 @@ instance ModifyAttributes t (TextAreaElementConfig er t m) where

505 {-# INLINABLE modifyAttributes #-}

509 {-# INLINABLE modifyAttributes #-}

506 modifyAttributes = textAreaElementConfig_elementConfig . elementConfig_modifyAttributes

510 modifyAttributes = textAreaElementConfig_elementConfig . elementConfig_modifyAttributes

507

511

512+instance ModifyAttributes t (SelectElementConfig er t m) where

513+ {-# INLINABLE modifyAttributes #-}

514+ modifyAttributes = selectElementConfig_elementConfig . elementConfig_modifyAttributes

515+

508instance ModifyAttributes t (RawElementConfig er t m) where

516instance ModifyAttributes t (RawElementConfig er t m) where

509 {-# INLINABLE modifyAttributes #-}

517 {-# INLINABLE modifyAttributes #-}

510 modifyAttributes = rawElementConfig_modifyAttributes

518 modifyAttributes = rawElementConfig_modifyAttributes

@@ -573,6 +581,25 @@ instance (DomBuilder t m, MonadHold t m, MonadFix m) => DomBuilder t (RequesterT

573 { _rawElementConfig_eventSpec = _rawElementConfig_eventSpec cfg

581 { _rawElementConfig_eventSpec = _rawElementConfig_eventSpec cfg

574 }

582 }

575

583

584+instance (DomBuilder t m, MonadHold t m, MonadFix m, Semigroup w, Monoid w) => DomBuilder t (EventWriterT t w m) where

585+ type DomBuilderSpace (EventWriterT t w m) = DomBuilderSpace m

586+ textNode = liftTextNode

587+ element elementTag cfg child = do

588+ let cfg' = liftElementConfig cfg

589+ (el, (a, e)) <- lift $ element elementTag cfg' $ runEventWriterT child

590+ tellEvent e

591+ return (el, a)

592+ inputElement cfg = lift $ inputElement $ cfg & inputElementConfig_elementConfig %~ liftElementConfig

593+ textAreaElement cfg = lift $ textAreaElement $ cfg & textAreaElementConfig_elementConfig %~ liftElementConfig

594+ selectElement cfg child = do

595+ let cfg' = cfg & selectElementConfig_elementConfig %~ liftElementConfig

596+ (el, (a, e)) <- lift $ selectElement cfg' $ runEventWriterT child

597+ tellEvent e

598+ return (el, a)

599+ placeRawElement = lift . placeRawElement

600+ wrapRawElement e cfg = lift $ wrapRawElement e $ cfg

601+ { _rawElementConfig_eventSpec = _rawElementConfig_eventSpec cfg

602+ }

576

603

577-- * Convenience functions

604-- * Convenience functions

578

605

reflex-dom-core/src/Reflex/Dom/Builder/Class/Events.hs+4−4

@@ -157,10 +157,10 @@ type family EventResultType (en :: EventTag) :: * where

157 EventResultType 'ResetTag = ()

158 EventResultType 'SearchTag = ()

159 EventResultType 'SelectstartTag = ()

160− EventResultType 'TouchstartTag = ()

160+ EventResultType 'TouchstartTag = [(Int, Int)]

161− EventResultType 'TouchmoveTag = ()

161+ EventResultType 'TouchmoveTag = [(Int, Int)]

162− EventResultType 'TouchendTag = ()

162+ EventResultType 'TouchendTag = [(Int, Int)]

163− EventResultType 'TouchcancelTag = ()

163+ EventResultType 'TouchcancelTag = [(Int, Int)]

164 EventResultType 'WheelTag = ()

165

166#ifdef USE_TEMPLATE_HASKELL

reflex-dom-core/src/Reflex/Dom/Builder/Immediate.hs+25−8

@@ -65,6 +65,9 @@ import qualified GHCJS.DOM.HTMLInputElement as Input

65import qualified GHCJS.DOM.HTMLSelectElement as Select

66import qualified GHCJS.DOM.HTMLTextAreaElement as TextArea

67import GHCJS.DOM.MouseEvent

68+import qualified GHCJS.DOM.Touch as Touch

69+import qualified GHCJS.DOM.TouchEvent as TouchEvent

70+import qualified GHCJS.DOM.TouchList as TouchList

68import GHCJS.DOM.Node (appendChild_, getOwnerDocumentUnchecked, getParentNodeUnchecked,

71import GHCJS.DOM.Node (appendChild_, getOwnerDocumentUnchecked, getParentNodeUnchecked,

69 setNodeValue, toNode)

72 setNodeValue, toNode)

70import qualified GHCJS.DOM.Node as DOM (insertBefore_)

73import qualified GHCJS.DOM.Node as DOM (insertBefore_)

@@ -665,10 +668,10 @@ defaultDomEventHandler e evt = fmap (Just . EventResult) $ case evt of

665 Reset -> return ()

668 Reset -> return ()

666 Search -> return ()

669 Search -> return ()

667 Selectstart -> return ()

670 Selectstart -> return ()

668− Touchstart -> return ()

671+ Touchstart -> getTouchEventCoords

669− Touchmove -> return ()

672+ Touchmove -> getTouchEventCoords

670− Touchend -> return ()

673+ Touchend -> getTouchEventCoords

671− Touchcancel -> return ()

674+ Touchcancel -> getTouchEventCoords

672 Mousewheel -> return ()

675 Mousewheel -> return ()

673 Wheel -> return ()

676 Wheel -> return ()

674

677

@@ -715,10 +718,10 @@ defaultDomWindowEventHandler w evt = fmap (Just . EventResult) $ case evt of

715 Reset -> return ()

718 Reset -> return ()

716 Search -> return ()

719 Search -> return ()

717 Selectstart -> return ()

720 Selectstart -> return ()

718− Touchstart -> return ()

721+ Touchstart -> getTouchEventCoords

719− Touchmove -> return ()

722+ Touchmove -> getTouchEventCoords

720− Touchend -> return ()

723+ Touchend -> getTouchEventCoords

721− Touchcancel -> return ()

724+ Touchcancel -> getTouchEventCoords

722 Mousewheel -> return ()

725 Mousewheel -> return ()

723 Wheel -> return ()

726 Wheel -> return ()

724

727

@@ -979,6 +982,20 @@ getMouseEventCoords = do

979 e <- event

982 e <- event

980 bisequence (getClientX e, getClientY e)

983 bisequence (getClientX e, getClientY e)

981

984

985+{-# INLINABLE getTouchEventCoords #-}

986+getTouchEventCoords :: EventM e TouchEvent [(Int, Int)]

987+getTouchEventCoords = do

988+ e <- event

989+ mTouchList <- TouchEvent.getTouches e

990+ case mTouchList of

991+ Just touchList -> do

992+ touchListLength <- TouchList.getLength touchList

993+ mTouchCoords <- forM [0..touchListLength - 1] $ \i -> do

994+ mTouch <- TouchList.item touchList i

995+ return $ fmap (\t -> bisequence (Touch.getClientX t, Touch.getClientY t)) mTouch

996+ sequence $ catMaybes mTouchCoords

997+ _ -> return []

998+

982instance MonadSample t m => MonadSample t (ImmediateDomBuilderT t m) where

999instance MonadSample t m => MonadSample t (ImmediateDomBuilderT t m) where

983 {-# INLINABLE sample #-}

1000 {-# INLINABLE sample #-}

984 sample = lift . sample

1001 sample = lift . sample

reflex-dom-core/src/Reflex/Dom/Builder/Static.hs+30−12

@@ -36,6 +36,7 @@ import Data.Functor.Misc

36import qualified Data.Map as Map

37import Data.Monoid

38import qualified Data.Set as Set

39+import Data.Text (Text)

39import Data.Text.Encoding

40import Data.Text.Encoding

40import Data.Tuple

41import Data.Tuple

41import GHC.Generics

42import GHC.Generics

@@ -50,10 +51,17 @@ import Reflex.PostBuild.Base

50import Reflex.Spider

51import Reflex.Spider

51import Reflex.TriggerEvent.Class

52import Reflex.TriggerEvent.Class

53−data StaticDomBuilderEnv = StaticDomBuilderEnv { _staticDomBuilderEnv_shouldEscape :: Bool }

54+data StaticDomBuilderEnv t = StaticDomBuilderEnv

55+ { _staticDomBuilderEnv_shouldEscape :: Bool

56+ , _staticDomBuilderEnv_selectValue :: Maybe (Behavior t Text)

57+ -- ^ When the parent element is a "select" whose value has been set, this value tells us the current value.

58+ -- We use this to add a "selected" attribute to the appropriate "option" child element.

59+ -- This is not yet a perfect simulation of what the browser does, but it is much closer than doing nothing.

60+ -- TODO: Handle edge cases, e.g. setting to a value for which there is no option, then adding that option dynamically afterwards.

61+ }

55newtype StaticDomBuilderT t m a = StaticDomBuilderT

63newtype StaticDomBuilderT t m a = StaticDomBuilderT

56− { unStaticDomBuilderT :: ReaderT StaticDomBuilderEnv (StateT [Behavior t Builder] m) a -- Accumulated Html will be in reversed order

64+ { unStaticDomBuilderT :: ReaderT (StaticDomBuilderEnv t) (StateT [Behavior t Builder] m) a -- Accumulated Html will be in reversed order

57 }

65 }

58 deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)

66 deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)

@@ -64,7 +72,7 @@ instance PrimMonad m => PrimMonad (StaticDomBuilderT x m) where

64instance MonadTrans (StaticDomBuilderT t) where

72instance MonadTrans (StaticDomBuilderT t) where

65 lift = StaticDomBuilderT . lift . lift

73 lift = StaticDomBuilderT . lift . lift

67−runStaticDomBuilderT :: (Monad m, Reflex t) => StaticDomBuilderT t m a -> StaticDomBuilderEnv -> m (a, Behavior t Builder)

75+runStaticDomBuilderT :: (Monad m, Reflex t) => StaticDomBuilderT t m a -> StaticDomBuilderEnv t -> m (a, Behavior t Builder)

68runStaticDomBuilderT (StaticDomBuilderT a) e = do

76runStaticDomBuilderT (StaticDomBuilderT a) e = do

69 (result, a') <- runStateT (runReaderT a e) []

77 (result, a') <- runStateT (runReaderT a e) []

70 return (result, mconcat $ reverse a')

78 return (result, mconcat $ reverse a')

@@ -139,9 +147,9 @@ instance (Reflex t, MonadAdjust t m, MonadHold t m) => MonadAdjust t (StaticDomB

139 runWithReplace a0 a' = do

147 runWithReplace a0 a' = do

140 e <- StaticDomBuilderT ask

148 e <- StaticDomBuilderT ask

141 (result0, result') <- lift $ runWithReplace (runStaticDomBuilderT a0 e) (flip runStaticDomBuilderT e <$> a')

149 (result0, result') <- lift $ runWithReplace (runStaticDomBuilderT a0 e) (flip runStaticDomBuilderT e <$> a')

142− o <- hold (snd result0) $ snd <$> result'

150+ o <- hold (snd result0) $ fmapCheap snd result'

143 StaticDomBuilderT $ modify $ (:) $ join o

151 StaticDomBuilderT $ modify $ (:) $ join o

144− return (fst result0, fst <$> result')

152+ return (fst result0, fmapCheap fst result')

145 sequenceDMapWithAdjust (dm0 :: DMap k (StaticDomBuilderT t m)) dm' = do

153 sequenceDMapWithAdjust (dm0 :: DMap k (StaticDomBuilderT t m)) dm' = do

146 e <- StaticDomBuilderT ask

154 e <- StaticDomBuilderT ask

147 let loweredDm0 = mapKeyValuePairsMonotonic (\(k :=> v) -> WrapArg k :=> fmap swap (runStaticDomBuilderT v e)) dm0

155 let loweredDm0 = mapKeyValuePairsMonotonic (\(k :=> v) -> WrapArg k :=> fmap swap (runStaticDomBuilderT v e)) dm0

@@ -170,7 +178,7 @@ instance SupportsStaticDomBuilder t m => DomBuilder t (StaticDomBuilderT t m) wh

170 --TODO: Do not escape quotation marks; see https://stackoverflow.com/questions/25612166/what-characters-must-be-escaped-in-html-5

178 --TODO: Do not escape quotation marks; see https://stackoverflow.com/questions/25612166/what-characters-must-be-escaped-in-html-5

171 shouldEscape <- asks _staticDomBuilderEnv_shouldEscape

179 shouldEscape <- asks _staticDomBuilderEnv_shouldEscape

172 let escape = if shouldEscape then fromHtmlEscapedText else byteString . encodeUtf8

180 let escape = if shouldEscape then fromHtmlEscapedText else byteString . encodeUtf8

173− modify . (:) <=< hold (escape initialContents) $ fmap escape setContents

181+ modify . (:) <=< hold (escape initialContents) $ fmapCheap escape setContents --Only because it doesn't get optimized when profiling is on

174 return $ TextNode ()

182 return $ TextNode ()

175 {-# INLINABLE element #-}

183 {-# INLINABLE element #-}

176 element elementTag cfg child = do

184 element elementTag cfg child = do

@@ -181,14 +189,21 @@ instance SupportsStaticDomBuilder t m => DomBuilder t (StaticDomBuilderT t m) wh

181 es <- newFanEventWithTrigger $ \_ _ -> return (return ())

189 es <- newFanEventWithTrigger $ \_ _ -> return (return ())

182 StaticDomBuilderT $ do

190 StaticDomBuilderT $ do

183 let shouldEscape = elementTag `Set.notMember` noEscapeElements

191 let shouldEscape = elementTag `Set.notMember` noEscapeElements

184− (result, innerHtml) <- lift $ lift $ runStaticDomBuilderT child $ StaticDomBuilderEnv shouldEscape

192+ (result, innerHtml) <- lift $ lift $ runStaticDomBuilderT child $ StaticDomBuilderEnv shouldEscape Nothing

185 attrs0 <- foldDyn applyMap (cfg ^. initialAttributes) (cfg ^. modifyAttributes)

193 attrs0 <- foldDyn applyMap (cfg ^. initialAttributes) (cfg ^. modifyAttributes)

194+ selectValue <- asks _staticDomBuilderEnv_selectValue

195+ let addSelectedAttr attrs sel = case Map.lookup "value" attrs of

196+ Just v | v == sel -> attrs <> Map.singleton "selected" ""

197+ _ -> Map.delete "selected" attrs

198+ let attrs1 = case (elementTag, selectValue) of

199+ ("option", Just sv) -> pull $ addSelectedAttr <$> sample (current attrs0) <*> sample sv

200+ _ -> current attrs0

186− let attrs1 = ffor (current attrs0) $ mconcat . fmap (\(k, v) -> " " <> toAttr k v) . Map.toList

201+ let attrs2 = ffor attrs1 $ mconcat . fmap (\(k, v) -> " " <> toAttr k v) . Map.toList

187 let tagBS = encodeUtf8 elementTag

202 let tagBS = encodeUtf8 elementTag

188 if Set.member elementTag voidElements

203 if Set.member elementTag voidElements

189− then modify $ (:) $ mconcat [constant ("<" <> byteString tagBS), attrs1, constant (byteString " />")]

204+ then modify $ (:) $ mconcat [constant ("<" <> byteString tagBS), attrs2, constant (byteString " />")]

190 else do

205 else do

191− let open = mconcat [constant ("<" <> byteString tagBS), attrs1, constant (byteString ">")]

206+ let open = mconcat [constant ("<" <> byteString tagBS), attrs2, constant (byteString ">")]

192 let close = constant $ byteString $ "</" <> tagBS <> ">"

207 let close = constant $ byteString $ "</" <> tagBS <> ">"

193 modify $ (:) $ mconcat [open, innerHtml, close]

208 modify $ (:) $ mconcat [open, innerHtml, close]

194 return (Element es (), result)

209 return (Element es (), result)

@@ -222,8 +237,11 @@ instance SupportsStaticDomBuilder t m => DomBuilder t (StaticDomBuilderT t m) wh

222 , _textAreaElement_raw = ()

237 , _textAreaElement_raw = ()

223 }

238 }

224 selectElement cfg child = do

239 selectElement cfg child = do

225− (e, result) <- element "select" (_selectElementConfig_elementConfig cfg) child

226 v <- holdDyn (cfg ^. selectElementConfig_initialValue) (cfg ^. selectElementConfig_setValue)

240 v <- holdDyn (cfg ^. selectElementConfig_initialValue) (cfg ^. selectElementConfig_setValue)

241+ (e, result) <- element "select" (_selectElementConfig_elementConfig cfg) $ do

242+ (a, innerHtml) <- StaticDomBuilderT $ lift $ lift $ runStaticDomBuilderT child $ StaticDomBuilderEnv False $ Just (current v)

243+ StaticDomBuilderT $ lift $ modify $ (:) innerHtml

244+ return a

227 let wrapped = SelectElement

245 let wrapped = SelectElement

228 { _selectElement_value = v

246 { _selectElement_value = v

229 , _selectElement_change = never

247 , _selectElement_change = never

@@ -243,7 +261,7 @@ renderStatic :: StaticWidget x a -> IO (a, ByteString)

243renderStatic w = do

261renderStatic w = do

244 runSpiderHost $ do

262 runSpiderHost $ do

245 (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef

263 (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef

246− let env0 = StaticDomBuilderEnv True

264+ let env0 = StaticDomBuilderEnv True Nothing

247 ((res, bs), FireCommand fire) <- hostPerformEventT $ runStaticDomBuilderT (runPostBuildT w postBuild) env0

265 ((res, bs), FireCommand fire) <- hostPerformEventT $ runStaticDomBuilderT (runPostBuildT w postBuild) env0

248 mPostBuildTrigger <- readRef postBuildTriggerRef

266 mPostBuildTrigger <- readRef postBuildTriggerRef

249 forM_ mPostBuildTrigger $ \postBuildTrigger -> fire [postBuildTrigger :=> Identity ()] $ return ()

267 forM_ mPostBuildTrigger $ \postBuildTrigger -> fire [postBuildTrigger :=> Identity ()] $ return ()

reflex-dom-core/src/Reflex/Dom/Main.hs+62−45

@@ -17,7 +17,6 @@ module Reflex.Dom.Main where

18import Prelude hiding (concat, mapM, mapM_, sequence, sequence_)

20−import qualified Reflex as R

21import Reflex.Dom.Builder.Immediate

20import Reflex.Dom.Builder.Immediate

22import Reflex.Dom.Class

21import Reflex.Dom.Class

23import Reflex.Host.Class

22import Reflex.Host.Class

@@ -90,41 +89,57 @@ instance MonadJSM m => MonadJSM (PostBuildT t m) where

91{-# INLINABLE attachWidget #-}

90{-# INLINABLE attachWidget #-}

92attachWidget :: DOM.IsElement e => e -> JSContextSingleton x -> Widget x a -> JSM a

91attachWidget :: DOM.IsElement e => e -> JSContextSingleton x -> Widget x a -> JSM a

93−attachWidget rootElement wv w = liftIO $ fst <$> attachWidget' rootElement wv w

92+attachWidget rootElement wv w = fst <$> attachWidget' rootElement wv w

94−

93+

94+-- | Warning: `mainWidgetWithHead'` is provided only as performance tweak. It is expected to disappear in future releases.

95−mainWidgetWithHead' :: (forall x. (a -> Widget x b, b -> Widget x a)) -> JSM ()

95+mainWidgetWithHead' :: (a -> Widget () b, b -> Widget () a) -> JSM ()

96−mainWidgetWithHead' widgets = withJSContextSingleton $ \jsSing -> do

96+mainWidgetWithHead' widgets = withJSContextSingletonMono $ \jsSing -> do

97− doc <- currentDocumentUnchecked

97+ doc <- currentDocumentUnchecked

98− headElement <- getHeadUnchecked doc

98+ headElement <- getHeadUnchecked doc

99+ headFragment <- createDocumentFragmentUnchecked doc

99− bodyElement <- getBodyUnchecked doc

100+ bodyElement <- getBodyUnchecked doc

100−-- runWebGUI $ \webView -> withWebViewSingleton webView $ \wv ->

101+ bodyFragment <- createDocumentFragmentUnchecked doc

101− liftIO $ fmap fst $ attachWidget'' $ \events -> do

102+ (events, fc) <- liftIO . attachWidget'' $ \events -> do

102− let (headWidget, bodyWidget) = widgets

103+ let (headWidget, bodyWidget) = widgets

103− (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef

104+ (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef

104− rec b <- unsafeReplaceElementContentsWithWidget events postBuild headElement jsSing $ headWidget a

105+ let go :: forall c. Widget () c -> DOM.DocumentFragment -> PerformEventT Spider (SpiderHost Global) c

105− a <- unsafeReplaceElementContentsWithWidget events postBuild bodyElement jsSing $ bodyWidget b

106+ go w df = do

106− return ((), postBuildTriggerRef)

107−

108−unsafeReplaceElementContentsWithWidget :: DOM.IsElement e => EventChannel -> R.Event Spider () -> e -> JSContextSingleton x -> Widget x a -> PerformEventT Spider (SpiderHost Global) a

109−unsafeReplaceElementContentsWithWidget events postBuild rootElement jsSing w = (`runWithJSContextSingleton` jsSing) $ do

110− doc <- getOwnerDocumentUnchecked rootElement

111− df <- createDocumentFragmentUnchecked doc

112− let builderEnv = ImmediateDomBuilderEnv

107+ let builderEnv = ImmediateDomBuilderEnv

113− { _immediateDomBuilderEnv_document = doc

108+ { _immediateDomBuilderEnv_document = toDocument doc

114− , _immediateDomBuilderEnv_parent = toNode df

109+ , _immediateDomBuilderEnv_parent = toNode df

115− , _immediateDomBuilderEnv_events = events

110+ , _immediateDomBuilderEnv_events = events

116− }

111+ }

117− result <- runImmediateDomBuilderT (runPostBuildT w postBuild) builderEnv

112+ runWithJSContextSingleton (runImmediateDomBuilderT (runPostBuildT w postBuild) builderEnv) jsSing

113+ rec b <- go (headWidget a) headFragment

114+ a <- go (bodyWidget b) bodyFragment

115+ return (events, postBuildTriggerRef)

116+ replaceElementContents headElement headFragment

117+ replaceElementContents bodyElement bodyFragment

118+ liftIO $ processAsyncEvents events fc

119+

120+replaceElementContents :: DOM.IsElement e => e -> DOM.DocumentFragment -> JSM ()

121+replaceElementContents e df = do

118− setInnerHTML rootElement $ Just ("" :: String)

122+ setInnerHTML e $ Just ("" :: String)

119− _ <- appendChildUnchecked rootElement $ Just df

123+ _ <- appendChildUnchecked e $ Just df

120− return result

124+ return ()

121

125

122{-# INLINABLE attachWidget' #-}

126{-# INLINABLE attachWidget' #-}

123−attachWidget' :: DOM.IsElement e => e -> JSContextSingleton x -> Widget x a -> IO (a, FireCommand Spider (SpiderHost Global))

127+attachWidget' :: DOM.IsElement e => e -> JSContextSingleton x -> Widget x a -> JSM (a, FireCommand Spider (SpiderHost Global))

124−attachWidget' rootElement jsSing w = attachWidget'' $ \events -> do

128+attachWidget' rootElement jsSing w = do

129+ doc <- getOwnerDocumentUnchecked rootElement

130+ df <- createDocumentFragmentUnchecked doc

131+ ((a, events), fc) <- liftIO . attachWidget'' $ \events -> do

125− (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef

132+ (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef

126− result <- unsafeReplaceElementContentsWithWidget events postBuild rootElement jsSing w

133+ let builderEnv = ImmediateDomBuilderEnv

127− return (result, postBuildTriggerRef)

134+ { _immediateDomBuilderEnv_document = toDocument doc

135+ , _immediateDomBuilderEnv_parent = toNode df

136+ , _immediateDomBuilderEnv_events = events

137+ }

138+ a <- runWithJSContextSingleton (runImmediateDomBuilderT (runPostBuildT w postBuild) builderEnv) jsSing

139+ return ((a, events), postBuildTriggerRef)

140+ replaceElementContents rootElement df

141+ liftIO $ processAsyncEvents events fc

142+ return (a, fc)

128

143

129type EventChannel = Chan [DSum (TriggerRef Spider) TriggerInvocation]

144type EventChannel = Chan [DSum (TriggerRef Spider) TriggerInvocation]

130

145

@@ -132,21 +147,23 @@ type EventChannel = Chan [DSum (TriggerRef Spider) TriggerInvocation]

132attachWidget'' :: (EventChannel -> PerformEventT Spider (SpiderHost Global) (a, IORef (Maybe (EventTrigger Spider ())))) -> IO (a, FireCommand Spider (SpiderHost Global))

147attachWidget'' :: (EventChannel -> PerformEventT Spider (SpiderHost Global) (a, IORef (Maybe (EventTrigger Spider ())))) -> IO (a, FireCommand Spider (SpiderHost Global))

133attachWidget'' w = do

148attachWidget'' w = do

134 events <- newChan

149 events <- newChan

135− (result, fc@(FireCommand fire)) <- runSpiderHost $ do

150+ runSpiderHost $ do

136 ((result, postBuildTriggerRef), fc@(FireCommand fire)) <- hostPerformEventT $ w events

151 ((result, postBuildTriggerRef), fc@(FireCommand fire)) <- hostPerformEventT $ w events

137 mPostBuildTrigger <- readRef postBuildTriggerRef

152 mPostBuildTrigger <- readRef postBuildTriggerRef

138 forM_ mPostBuildTrigger $ \postBuildTrigger -> fire [postBuildTrigger :=> Identity ()] $ return ()

153 forM_ mPostBuildTrigger $ \postBuildTrigger -> fire [postBuildTrigger :=> Identity ()] $ return ()

139 return (result, fc)

154 return (result, fc)

155+

156+processAsyncEvents :: EventChannel -> FireCommand Spider (SpiderHost Global) -> IO ()

140− void $ forkIO $ forever $ do

157+processAsyncEvents events (FireCommand fire) = void $ forkIO $ forever $ do

141− ers <- readChan events

158+ ers <- readChan events

142− _ <- runSpiderHost $ do

159+ _ <- runSpiderHost $ do

143− mes <- liftIO $ forM ers $ \(TriggerRef er :=> TriggerInvocation a _) -> do

160+ mes <- liftIO $ forM ers $ \(TriggerRef er :=> TriggerInvocation a _) -> do

144− me <- readIORef er

161+ me <- readIORef er

145− return $ fmap (\e -> e :=> Identity a) me

162+ return $ fmap (\e -> e :=> Identity a) me

146− _ <- fire (catMaybes mes) $ return ()

163+ _ <- fire (catMaybes mes) $ return ()

147− liftIO $ forM_ ers $ \(_ :=> TriggerInvocation _ cb) -> cb

164+ liftIO $ forM_ ers $ \(_ :=> TriggerInvocation _ cb) -> cb

148− return ()

149− return (result, fc)

165+ return ()

166+

150

167

151-- | Run a reflex-dom application inside of an existing DOM element with the given ID

168-- | Run a reflex-dom application inside of an existing DOM element with the given ID

152mainWidgetInElementById :: Text -> (forall x. Widget x ()) -> JSM ()

169mainWidgetInElementById :: Text -> (forall x. Widget x ()) -> JSM ()

reflex-dom-core/src/Reflex/Dom/Widget/Basic.hs+5−1

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

71 , workflow

72 , workflowView

73 , mapWorkflow

74+ , mapWorkflowCheap

75 -- * Tables and Lists

76 -- * Tables and Lists

76 , tableDynAttr

77 , tableDynAttr

@@ -159,7 +160,7 @@ button t = do

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

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

160dyn child = do

161dyn child = do

161 postBuild <- getPostBuild

162 postBuild <- getPostBuild

162− let newChild = leftmost [updated child, tag (current child) postBuild]

163+ let newChild = leftmost [updated child, tagCheap (current child) postBuild]

163 snd <$> widgetHoldInternal (return ()) newChild

164 snd <$> widgetHoldInternal (return ()) newChild

164

165

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

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

@@ -422,6 +423,9 @@ workflowView w0 = do

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

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

423mapWorkflow f (Workflow x) = Workflow (fmap (f *** fmap (mapWorkflow f)) x)

424mapWorkflow f (Workflow x) = Workflow (fmap (f *** fmap (mapWorkflow f)) x)

424

425

426+mapWorkflowCheap :: (DomBuilder t m) => (a -> b) -> Workflow t m a -> Workflow t m b

427+mapWorkflowCheap f (Workflow x) = Workflow (fmap (f *** fmapCheap (mapWorkflowCheap f)) x)

428+

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

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

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

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

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

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

reflex-dom-core/src/Reflex/Dom/Widget/Resize.hs+2−1

@@ -10,6 +10,7 @@ import Reflex.Class

10import Reflex.Dom.Builder.Class

11import Reflex.Dom.Builder.Immediate

12import Reflex.Dom.Class

13+import Reflex.Dom.Time

13import Reflex.Dom.Widget.Basic

14import Reflex.Dom.Widget.Basic

14import Reflex.PerformEvent.Class

15import Reflex.PerformEvent.Class

15import Reflex.PostBuild.Class

16import Reflex.PostBuild.Class

@@ -76,7 +77,7 @@ resizeDetectorWithAttrs attrs w = do

76 if ds == (Just pow, Just poh)

77 if ds == (Just pow, Just poh)

77 then return Nothing

78 then return Nothing

78 else fmap Just reset

79 else fmap Just reset

79− pb <- getPostBuild

80+ pb <- delay 0 =<< getPostBuild

80 expandScroll <- wrapDomEvent (_element_raw expand) (`on` scroll) $ return ()

81 expandScroll <- wrapDomEvent (_element_raw expand) (`on` scroll) $ return ()

81 shrinkScroll <- wrapDomEvent (_element_raw shrink) (`on` scroll) $ return ()

82 shrinkScroll <- wrapDomEvent (_element_raw shrink) (`on` scroll) $ return ()

82 size0 <- performEvent $ fmap (const $ liftJSM reset) pb

83 size0 <- performEvent $ fmap (const $ liftJSM reset) pb