git.iko.soy/reflex-dom
on 8ffb721 help sign in
reflex-dom/src/Reflex/Dom/Widget/Basic.hs
558 lines 26 kB history raw
1{-# LANGUAGE ScopedTypeVariables, LambdaCase, ConstraintKinds, TypeFamilies, FlexibleContexts, MultiParamTypeClasses, FlexibleInstances, RecursiveDo #-}
3module Reflex.Dom.Widget.Basic where
5import Reflex.Dom.Class
6import Reflex.Dom.Internal.Foreign ()
8import Prelude hiding (mapM, mapM_, sequence, sequence_)
9import Reflex
10import Reflex.Host.Class
11import Data.Functor.Misc
12import Data.Map (Map)
13import qualified Data.Map as Map
14import Data.Set (Set)
15import qualified Data.Set as Set
16import Data.Dependent.Sum (DSum (..))
17import Data.Foldable
18import Data.Traversable
19import Control.Monad.Trans
20import Control.Monad.Reader hiding (mapM, mapM_, forM, forM_, sequence, sequence_)
21import Control.Monad.State hiding (state, mapM, mapM_, forM, forM_, sequence, sequence_)
22import GHCJS.DOM.Node
23import GHCJS.DOM.UIEvent
24import GHCJS.DOM.EventM (event, EventM)
25import GHCJS.DOM.Document
26import GHCJS.DOM.Element
27import GHCJS.DOM.HTMLElement
28import GHCJS.DOM.Types hiding (Widget (..), unWidget, Event)
29import GHCJS.DOM.NamedNodeMap
30import Control.Lens hiding (element, children)
31import Data.These
32import Data.Align
34import Data.Maybe
36type AttributeMap = Map String String
38data El t
39 = El { _el_element :: HTMLElement
40 , _el_clicked :: Event t ()
41 , _el_keypress :: Event t Int
42 , _el_scrolled :: Event t Int
43 }
45class Attributes m a where
46 addAttributes :: IsElement e => a -> e -> m ()
48instance MonadIO m => Attributes m AttributeMap where
49 addAttributes curAttrs e = liftIO $ imapM_ (elementSetAttribute e) curAttrs
51instance MonadWidget t m => Attributes m (Dynamic t AttributeMap) where
52 addAttributes attrs e = do
53 schedulePostBuild $ do
54 curAttrs <- sample $ current attrs
55 liftIO $ imapM_ (elementSetAttribute e) curAttrs
56 addVoidAction $ flip fmap (updated attrs) $ \newAttrs -> liftIO $ do
57 oldAttrs <- maybe (return Set.empty) namedNodeMapGetNames =<< elementGetAttributes e
58 forM_ (Set.toList $ oldAttrs `Set.difference` Map.keysSet newAttrs) $ elementRemoveAttribute e
59 imapM_ (elementSetAttribute e) newAttrs --TODO: avoid re-setting unchanged attributes; possibly do the compare using Align in haskell
61buildEmptyElement :: (MonadWidget t m, Attributes m attrs) => String -> attrs -> m HTMLElement
62buildEmptyElement elementTag attrs = do
63 doc <- askDocument
64 p <- askParent
65 Just e <- liftIO $ documentCreateElement doc elementTag
66 addAttributes attrs e
67 _ <- liftIO $ nodeAppendChild p $ Just e
68 return $ castToHTMLElement e
70-- We need to decide what type of attrs we've got statically, because it will often be a recursively defined value, in which case inspecting it will lead to a cycle
71buildElement :: (MonadWidget t m, Attributes m attrs) => String -> attrs -> m a -> m (HTMLElement, a)
72buildElement elementTag attrs child = do
73 e <- buildEmptyElement elementTag attrs
74 result <- subWidget (toNode e) child
75 return (e, result)
77namedNodeMapGetNames :: IsNamedNodeMap self => self -> IO (Set String)
78namedNodeMapGetNames self = do
79 l <- namedNodeMapGetLength self
80 let locations = if l == 0 then [] else [0..l-1] -- Can't use 0..l-1 if l is 0 because l is unsigned and will wrap around
81 liftM Set.fromList $ forM locations $ \i -> do
82 Just n <- namedNodeMapItem self i
83 nodeGetNodeName n
85text :: MonadWidget t m => String -> m ()
86text = void . text'
88--TODO: Wrap the result
89text' :: MonadWidget t m => String -> m Text
90text' s = do
91 doc <- askDocument
92 p <- askParent
93 Just n <- liftIO $ documentCreateTextNode doc s
94 _ <- liftIO $ nodeAppendChild p $ Just n
95 return n
97dynText :: MonadWidget t m => Dynamic t String -> m ()
98dynText s = do
99 n <- text' ""
100 schedulePostBuild $ do
101 curS <- sample $ current s
102 liftIO $ nodeSetNodeValue n curS
103 addVoidAction $ fmap (liftIO . nodeSetNodeValue n) $ updated s
105display :: (MonadWidget t m, Show a) => Dynamic t a -> m ()
106display a = dynText =<< mapDyn show a
108--TODO: Should this be renamed to 'widgetView' for consistency with 'widgetHold'?
109dyn :: MonadWidget t m => Dynamic t (m a) -> m (Event t a)
110dyn child = do
111 startPlaceholder <- text' ""
112 endPlaceholder <- text' ""
113 (newChildBuilt, newChildBuiltTriggerRef) <- newEventWithTriggerRef
114 let e = fmap snd newChildBuilt --TODO: Get rid of this hack
115 childVoidAction <- hold never e
116 performEvent_ $ fmap (const $ return ()) e --TODO: Get rid of this hack
117 addVoidAction $ switch childVoidAction
118 doc <- askDocument
119 runWidget <- getRunWidget
120 let build c = do
121 Just df <- liftIO $ documentCreateDocumentFragment doc
122 (result, postBuild, voidActions) <- runWidget df c
123 runFrameWithTriggerRef newChildBuiltTriggerRef (result, voidActions)
124 postBuild
125 Just p <- liftIO $ nodeGetParentNode endPlaceholder
126 _ <- liftIO $ nodeInsertBefore p (Just df) (Just endPlaceholder)
127 return ()
128 schedulePostBuild $ do
129 c <- sample $ current child
130 build c
131 addVoidAction $ ffor (updated child) $ \newChild -> do
132 liftIO $ deleteBetweenExclusive startPlaceholder endPlaceholder
133 build newChild
134 return $ fmap fst newChildBuilt
136widgetHold :: MonadWidget t m => m a -> Event t (m a) -> m (Dynamic t a)
137widgetHold child0 newChild = do
138 startPlaceholder <- text' ""
139 result0 <- child0 -- I'm pretty sure this is wrong; the void actions should get removed when the child is swapped out
140 endPlaceholder <- text' ""
141 (newChildBuilt, newChildBuiltTriggerRef) <- newEventWithTriggerRef
142 performEvent_ $ fmap (const $ return ()) newChildBuilt --TODO: Get rid of this hack
143 childVoidAction <- hold never $ fmap snd newChildBuilt
144 addVoidAction $ switch childVoidAction --TODO: Should this be a switchPromptly?
145 doc <- askDocument
146 runWidget <- getRunWidget
147 let build c = do
148 Just df <- liftIO $ documentCreateDocumentFragment doc
149 (result, postBuild, voidActions) <- runWidget df c
150 runFrameWithTriggerRef newChildBuiltTriggerRef (result, voidActions)
151 postBuild
152 mp <- liftIO $ nodeGetParentNode endPlaceholder
153 case mp of
154 Nothing -> return () --TODO: Is this right?
155 Just p -> do
156 _ <- liftIO $ nodeInsertBefore p (Just df) (Just endPlaceholder)
157 return ()
158 return ()
159 addVoidAction $ ffor newChild $ \c -> do
160 liftIO $ deleteBetweenExclusive startPlaceholder endPlaceholder
161 build c
162 holdDyn result0 $ fmap fst newChildBuilt
164--TODO: Something better than Dynamic t (Map k v) - we want something where the Events carry diffs, not the whole value
165listWithKey :: (Ord k, MonadWidget t m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m a) -> m (Dynamic t (Map k a))
166listWithKey vals mkChild = do
167 doc <- askDocument
168 endPlaceholder <- text' ""
169 (newChildren, newChildrenTriggerRef) <- newEventWithTriggerRef
170 performEvent_ $ fmap (const $ return ()) newChildren --TODO: Get rid of this hack
171 children <- hold Map.empty newChildren
172 addVoidAction $ switch $ fmap (mergeWith (>>) . map snd . Map.elems) children
173 runWidget <- getRunWidget
174 let buildChild df k v = runWidget df $ do
175 childStart <- text' ""
176 result <- mkChild k =<< holdDyn v (fmapMaybe (Map.lookup k) (updated vals))
177 childEnd <- text' ""
178 return (result, (childStart, childEnd))
179 schedulePostBuild $ do
180 Just df <- liftIO $ documentCreateDocumentFragment doc
181 curVals <- sample $ current vals
182 initialState <- iforM curVals $ \k v -> do
183 (result, postBuild, voidAction) <- buildChild df k v
184 return ((result, voidAction), postBuild)
185 runFrameWithTriggerRef newChildrenTriggerRef $ fmap fst initialState --TODO: Do all these in a single runFrame
186 sequence_ $ fmap snd initialState
187 Just p <- liftIO $ nodeGetParentNode endPlaceholder
188 _ <- liftIO $ nodeInsertBefore p (Just df) (Just endPlaceholder)
189 return ()
190 addVoidAction $ flip fmap (updated vals) $ \newVals -> do
191 curState <- sample children
192 --TODO: Should we remove the parent from the DOM first to avoid reflows?
193 (newState, postBuild) <- flip runStateT (return ()) $ liftM (Map.mapMaybe id) $ iforM (align curState newVals) $ \k -> \case
194 This ((_, (start, end)), _) -> do
195 liftIO $ deleteBetweenInclusive start end
196 return Nothing
197 That v -> do
198 Just df <- liftIO $ documentCreateDocumentFragment doc
199 (childResult, childPostBuild, childVoidAction) <- lift $ buildChild df k v
200 let s = (childResult, childVoidAction)
201 modify (>>childPostBuild)
202 let placeholder = case Map.lookupGT k curState of
203 Nothing -> endPlaceholder
204 Just (_, ((_, (start, _)), _)) -> start
205 Just p <- liftIO $ nodeGetParentNode placeholder
206 _ <- liftIO $ nodeInsertBefore p (Just df) (Just placeholder)
207 return $ Just s
208 These state _ -> do
209 return $ Just state
210 runFrameWithTriggerRef newChildrenTriggerRef newState
211 postBuild
212 holdDyn Map.empty $ fmap (fmap (fst . fst)) newChildren
214listWithKey' :: forall t m k v a. (Ord k, MonadWidget t m) => Map k v -> Event t (Map k (Maybe v)) -> (k -> v -> Event t v -> m a) -> m (Dynamic t (Map k a))
215listWithKey' initialVals valsChanged mkChild = do
216 doc <- askDocument
217 endPlaceholder <- text' ""
218 (newChildren, newChildrenTriggerRef) <- newEventWithTriggerRef
219-- performEvent_ $ fmap (const $ return ()) newChildren --TODO: Get rid of this hack
220 runWidget <- getRunWidget
221 let childValChangedSelector :: EventSelector t (Const2 k v)
222 childValChangedSelector = fanMap $ fmap (Map.mapMaybe id) valsChanged
223 buildChild df k v = runWidget df $ wrapChild k v
224 wrapChild k v = do
225 childStart <- text' ""
226 result <- mkChild k v $ select childValChangedSelector $ Const2 k
227 childEnd <- text' ""
228 return (result, (childStart, childEnd))
229 Just dfOrig <- liftIO $ documentCreateDocumentFragment doc
230 initialState <- iforM initialVals $ \k v -> subWidgetWithVoidActions (toNode dfOrig) $ wrapChild k v --Note: we have to use subWidgetWithVoidActions rather than runWidget here, because running post-build actions during build can cause not-yet-constructed values to be read
231 children <- holdDyn initialState newChildren
232 addVoidAction $ switch $ fmap (mergeWith (>>) . map snd . Map.elems) $ current children
233 Just pOrig <- liftIO $ nodeGetParentNode endPlaceholder
234 _ <- liftIO $ nodeInsertBefore pOrig (Just dfOrig) (Just endPlaceholder)
235 addVoidAction $ flip fmap valsChanged $ \newVals -> do
236 curState <- sample $ current children
237 --TODO: Should we remove the parent from the DOM first to avoid reflows?
238 (newState, postBuild) <- flip runStateT (return ()) $ liftM (Map.mapMaybe id) $ iforM (align curState newVals) $ \k -> \case
239 These ((_, (start, end)), _) Nothing -> do -- Deleting child
240 liftIO $ deleteBetweenInclusive start end
241 return Nothing
242 These ((_, (start, end)), _) (Just v) -> do -- Replacing existing child
243 liftIO $ deleteBetweenExclusive start end
244 Just df <- liftIO $ documentCreateDocumentFragment doc
245 (childResult, childPostBuild, childVoidAction) <- lift $ buildChild df k v
246 let s = (childResult, childVoidAction)
247 modify (>>childPostBuild)
248 Just p <- liftIO $ nodeGetParentNode end
249 _ <- liftIO $ nodeInsertBefore p (Just df) (Just end)
250 return $ Just s
251 That Nothing -> return Nothing -- Deleting non-existent child
252 That (Just v) -> do -- Creating new child
253 Just df <- liftIO $ documentCreateDocumentFragment doc
254 (childResult, childPostBuild, childVoidAction) <- lift $ buildChild df k v
255 let s = (childResult, childVoidAction)
256 modify (>>childPostBuild)
257 let placeholder = case Map.lookupGT k curState of
258 Nothing -> endPlaceholder
259 Just (_, ((_, (start, _)), _)) -> start
260 Just p <- liftIO $ nodeGetParentNode placeholder
261 _ <- liftIO $ nodeInsertBefore p (Just df) (Just placeholder)
262 return $ Just s
263 This state -> do -- No change
264 return $ Just state
265 runFrameWithTriggerRef newChildrenTriggerRef newState
266 postBuild
267 mapDyn (fmap (fst . fst)) children
269--TODO: Something better than Dynamic t (Map k v) - we want something where the Events carry diffs, not the whole value
270listViewWithKey :: (Ord k, MonadWidget t m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m (Event t a)) -> m (Event t (Map k a))
271listViewWithKey vals mkChild = liftM (switch . fmap mergeMap) $ listViewWithKey' vals mkChild
273listViewWithKey' :: (Ord k, MonadWidget t m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m a) -> m (Behavior t (Map k a))
274listViewWithKey' vals mkChild = do
275 doc <- askDocument
276 endPlaceholder <- text' ""
277 (newChildren, newChildrenTriggerRef) <- newEventWithTriggerRef
278 performEvent_ $ fmap (const $ return ()) newChildren --TODO: Get rid of this hack
279 children <- hold Map.empty newChildren
280 addVoidAction $ switch $ fmap (mergeWith (>>) . map snd . Map.elems) children
281 runWidget <- getRunWidget
282 let buildChild df k v = runWidget df $ do
283 childStart <- text' ""
284 result <- mkChild k =<< holdDyn v (fmapMaybe (Map.lookup k) (updated vals))
285 childEnd <- text' ""
286 return (result, (childStart, childEnd))
287 schedulePostBuild $ do
288 Just df <- liftIO $ documentCreateDocumentFragment doc
289 curVals <- sample $ current vals
290 initialState <- iforM curVals $ \k v -> do
291 (result, postBuild, voidAction) <- buildChild df k v
292 return ((result, voidAction), postBuild)
293 runFrameWithTriggerRef newChildrenTriggerRef $ fmap fst initialState --TODO: Do all these in a single runFrame
294 sequence_ $ fmap snd initialState
295 Just p <- liftIO $ nodeGetParentNode endPlaceholder
296 _ <- liftIO $ nodeInsertBefore p (Just df) (Just endPlaceholder)
297 return ()
298 addVoidAction $ flip fmap (updated vals) $ \newVals -> do
299 curState <- sample children
300 --TODO: Should we remove the parent from the DOM first to avoid reflows?
301 (newState, postBuild) <- flip runStateT (return ()) $ liftM (Map.mapMaybe id) $ iforM (align curState newVals) $ \k -> \case
302 This ((_, (start, end)), _) -> do
303 liftIO $ deleteBetweenInclusive start end
304 return Nothing
305 That v -> do
306 Just df <- liftIO $ documentCreateDocumentFragment doc
307 (childResult, childPostBuild, childVoidAction) <- lift $ buildChild df k v
308 let s = (childResult, childVoidAction)
309 modify (>>childPostBuild)
310 let placeholder = case Map.lookupGT k curState of
311 Nothing -> endPlaceholder
312 Just (_, ((_, (start, _)), _)) -> start
313 Just p <- liftIO $ nodeGetParentNode placeholder
314 _ <- liftIO $ nodeInsertBefore p (Just df) (Just placeholder)
315 return $ Just s
316 These state _ -> do
317 return $ Just state
318 runFrameWithTriggerRef newChildrenTriggerRef newState
319 postBuild
320 return $ fmap (fmap (fst . fst)) children
322--TODO: Deduplicate the various list*WithKey* implementations
324selectViewListWithKey_ :: forall t m k v a. (MonadWidget t m, Ord k) => Dynamic t k -> Dynamic t (Map k v) -> (k -> Dynamic t v -> Dynamic t Bool -> m (Event t a)) -> m (Event t k)
325selectViewListWithKey_ selection vals mkChild = do
326 let selectionDemux = demux selection -- For good performance, this value must be shared across all children
327 selectChild <- listWithKey vals $ \k v -> do
328 selected <- getDemuxed selectionDemux k
329 selectSelf <- mkChild k v selected
330 return $ fmap (const k) selectSelf
331 liftM switchPromptlyDyn $ mapDyn (leftmost . Map.elems) selectChild
333--------------------------------------------------------------------------------
334-- Basic DOM manipulation helpers
335--------------------------------------------------------------------------------
337-- | s and e must both be children of the same node and s must precede e
338deleteBetweenExclusive :: (IsNode start, IsNode end) => start -> end -> IO ()
339deleteBetweenExclusive s e = do
340 mCurrentParent <- nodeGetParentNode e -- May be different than it was at initial construction, e.g., because the parent may have dumped us in from a DocumentFragment
341 case mCurrentParent of
342 Nothing -> return () --TODO: Is this the right behavior?
343 Just currentParent -> do
344 let go = do
345 Just x <- nodeGetPreviousSibling e -- This can't be Nothing because we should hit 's' first
346 when (toNode s /= toNode x) $ do
347 _ <- nodeRemoveChild currentParent $ Just x
348 go
349 go
351-- | s and e must both be children of the same node and s must precede e
352deleteBetweenInclusive :: (IsNode start, IsNode end) => start -> end -> IO ()
353deleteBetweenInclusive s e = do
354 mCurrentParent <- nodeGetParentNode e -- May be different than it was at initial construction, e.g., because the parent may have dumped us in from a DocumentFragment
355 case mCurrentParent of
356 Nothing -> return () --TODO: Is this the right behavior?
357 Just currentParent -> do
358 let go = do
359 Just x <- nodeGetPreviousSibling e -- This can't be Nothing because we should hit 's' first
360 _ <- nodeRemoveChild currentParent $ Just x
361 when (toNode s /= toNode x) go
362 go
363 _ <- nodeRemoveChild currentParent $ Just e
364 return ()
366--------------------------------------------------------------------------------
367-- Adapters
368--------------------------------------------------------------------------------
370wrapDomEvent :: (Functor (Event t), MonadIO m, MonadSample t m, MonadReflexCreateTrigger t m, Reflex t, HasPostGui t h m) => e -> (e -> EventM event e () -> IO (IO ())) -> EventM event e a -> m (Event t a)
371wrapDomEvent element elementOnevent getValue = wrapDomEventMaybe element elementOnevent $ liftM Just getValue
373wrapDomEventMaybe :: (Functor (Event t), MonadIO m, MonadSample t m, MonadReflexCreateTrigger t m, Reflex t, HasPostGui t h m) => e -> (e -> EventM event e () -> IO (IO ())) -> EventM event e (Maybe a) -> m (Event t a)
374wrapDomEventMaybe element elementOnevent getValue = do
375 postGui <- askPostGui
376 runWithActions <- askRunWithActions
377 e <- newEventWithTrigger $ \et -> do
378 unsubscribe <- {-# SCC "a" #-} liftIO $ {-# SCC "b" #-} elementOnevent element $ {-# SCC "c" #-} do
379 mv <- {-# SCC "d" #-} getValue
380 forM_ mv $ \v -> liftIO $ postGui $ runWithActions [et :=> v]
381 return $ liftIO $ do
382 {-# SCC "e" #-} unsubscribe
383 return $! {-# SCC "f" #-} e
385getKeyEvent :: EventM UIEvent e Int
386getKeyEvent = do
387 e <- event
388 liftIO $ do
389 which <- uiEventGetWhich e
390 if which /= 0 then return which else do
391 charCode <- uiEventGetCharCode e
392 if charCode /= 0 then return charCode else
393 uiEventGetKeyCode e
395wrapElement :: (Functor (Event t), MonadIO m, MonadSample t m, MonadReflexCreateTrigger t m, Reflex t, HasPostGui t h m) => HTMLElement -> m (El t)
396wrapElement e = do
397 clicked <- wrapDomEvent e elementOnclick (return ())
398 keypress <- wrapDomEvent e elementOnkeypress getKeyEvent
399 scrolled <- wrapDomEvent e elementOnscroll $ liftIO $ elementGetScrollTop e
400 return $ El e clicked keypress scrolled
402elDynAttr' :: forall t m a. MonadWidget t m => String -> Dynamic t (Map String String) -> m a -> m (El t, a)
403elDynAttr' elementTag attrs child = do
404 (e, result) <- buildElement elementTag attrs child
405 e' <- wrapElement e
406 return (e', result)
408{-# INLINABLE elAttr #-}
409elAttr :: forall t m a. MonadWidget t m => String -> Map String String -> m a -> m a
410elAttr elementTag attrs child = do
411 (_, result) <- buildElement elementTag attrs child
412 return result
414{-# INLINABLE el' #-}
415el' :: forall t m a. MonadWidget t m => String -> m a -> m (El t, a)
416el' elementTag child = elAttr' elementTag (Map.empty :: AttributeMap) child
418{-# INLINABLE elAttr' #-}
419elAttr' :: forall t m a. MonadWidget t m => String -> Map String String -> m a -> m (El t, a)
420elAttr' elementTag attrs child = do
421 (e, result) <- buildElement elementTag attrs child
422 e' <- wrapElement e
423 return (e', result)
425{-# INLINABLE elDynAttr #-}
426elDynAttr :: forall t m a. MonadWidget t m => String -> Dynamic t (Map String String) -> m a -> m a
427elDynAttr elementTag attrs child = do
428 (_, result) <- buildElement elementTag attrs child
429 return result
431{-# INLINABLE el #-}
432el :: forall t m a. MonadWidget t m => String -> m a -> m a
433el elementTag child = elAttr elementTag Map.empty child
435elClass :: forall t m a. MonadWidget t m => String -> String -> m a -> m a
436elClass elementTag c child = elAttr elementTag ("class" =: c) child
438--------------------------------------------------------------------------------
439-- Copied and pasted from Reflex.Widget.Class
440--------------------------------------------------------------------------------
442list :: (MonadWidget t m, Ord k) => Dynamic t (Map k v) -> (Dynamic t v -> m a) -> m (Dynamic t (Map k a))
443list dm mkChild = listWithKey dm (\_ dv -> mkChild dv)
445simpleList :: MonadWidget t m => Dynamic t [v] -> (Dynamic t v -> m a) -> m (Dynamic t [a])
446simpleList xs mkChild = mapDyn (map snd . Map.toList) =<< flip list mkChild =<< mapDyn (Map.fromList . zip [(1::Int)..]) xs
448elDynHtml' :: MonadWidget t m => String -> Dynamic t String -> m (El t)
449elDynHtml' elementTag html = do
450 e <- buildEmptyElement elementTag (Map.empty :: Map String String)
451 schedulePostBuild $ liftIO . htmlElementSetInnerHTML e =<< sample (current html)
452 addVoidAction $ fmap (liftIO . htmlElementSetInnerHTML e) $ updated html
453 wrapElement e
455elDynHtmlAttr' :: MonadWidget t m => String -> Map String String -> Dynamic t String -> m (El t)
456elDynHtmlAttr' elementTag attrs html = do
457 e <- buildEmptyElement elementTag attrs
458 schedulePostBuild $ liftIO . htmlElementSetInnerHTML e =<< sample (current html)
459 addVoidAction $ fmap (liftIO . htmlElementSetInnerHTML e) $ updated html
460 wrapElement e
462{-
464--TODO: Update dynamically
465{-# INLINABLE dynHtml #-}
466dynHtml :: MonadWidget t m => Dynamic t String -> m ()
467dynHtml ds = do
468 let mkSelf h = do
469 doc <- askDocument
470 Just e <- liftIO $ liftM (fmap castToHTMLElement) $ documentCreateElement doc "div"
471 liftIO $ htmlElementSetInnerHTML e h
472 return e
473 eCreated <- performEvent . fmap mkSelf . tagDyn ds =<< getEInit
474 putEChildren $ fmap ((:[]) . toNode) eCreated
476-}
478data Link t
479 = Link { _link_clicked :: Event t ()
480 }
482linkClass :: MonadWidget t m => String -> String -> m (Link t)
483linkClass s c = do
484 (l,_) <- elAttr' "a" ("class" =: c) $ text s
485 return $ Link $ _el_clicked l
487link :: MonadWidget t m => String -> m (Link t)
488link s = linkClass s ""
490button :: MonadWidget t m => String -> m (Event t ())
491button s = do
492 (e, _) <- el' "button" $ text s
493 return $ _el_clicked e
495newtype Workflow t m a = Workflow { unWorkflow :: m (a, Event t (Workflow t m a)) }
497workflow :: forall t m a. MonadWidget t m => Workflow t m a -> m (Dynamic t a)
498workflow w0 = do
499 rec eResult <- widgetHold (unWorkflow w0) $ fmap unWorkflow $ switch $ fmap snd $ current eResult
500 mapDyn fst eResult
502workflowView :: forall t m a. MonadWidget t m => Workflow t m a -> m (Event t a)
503workflowView w0 = do
504 rec eResult <- dyn =<< mapDyn unWorkflow =<< holdDyn w0 eReplace
505 eReplace <- liftM switch $ hold never $ fmap snd eResult
506 return $ fmap fst eResult
508divClass :: forall t m a. MonadWidget t m => String -> m a -> m a
509divClass = elClass "div"
511dtdd :: forall t m a. MonadWidget t m => String -> m a -> m a
512dtdd h w = do
513 el "dt" $ text h
514 el "dd" $ w
516blank :: forall t m. MonadWidget t m => m ()
517blank = return ()
519tableDynAttr :: forall t m r k v. (MonadWidget t m, Show k, Ord k) => String -> [(String, k -> Dynamic t r -> m v)] -> Dynamic t (Map k r) -> (k -> m (Dynamic t (Map String String))) -> m (Dynamic t (Map k (El t, [v])))
520tableDynAttr klass cols dRows rowAttrs = elAttr "div" (Map.singleton "style" "zoom: 1; overflow: auto; background: white;") $ do
521 elAttr "table" (Map.singleton "class" klass) $ do
522 el "thead" $ el "tr" $ do
523 mapM_ (\(h, _) -> el "th" $ text h) cols
524 el "tbody" $ do
525 listWithKey dRows (\k r -> do
526 dAttrs <- rowAttrs k
527 elDynAttr' "tr" dAttrs $ mapM (\x -> el "td" $ snd x k r) cols)
529--TODO preselect a tab on open
530tabDisplay :: forall t m k. (MonadFix m, MonadWidget t m, Show k, Ord k) => String -> String -> Map k (String, m ()) -> m ()
531tabDisplay ulClass activeClass tabItems = do
532 rec dCurrentTab <- holdDyn Nothing (updated dTabClicks)
533 dTabClicks :: Dynamic t (Maybe k) <- elAttr "ul" (Map.singleton "class" ulClass) $ do
534 tabClicksList :: [Event t k] <- (liftM Map.elems) $ imapM (\k (s,_) -> headerBarLink s k =<< mapDyn (== (Just k)) dCurrentTab) tabItems
535 let eTabClicks :: Event t k = leftmost tabClicksList
536 holdDyn Nothing $ fmap Just eTabClicks :: m (Dynamic t (Maybe k))
537 divClass "" $ do
538 let dTabs :: Dynamic t (Map k (String, m ())) = constDyn tabItems
539 _ <- listWithKey dTabs (\k dTab -> do
540 dAttrs <- mapDyn (\sel -> do
541 let t1 = listToMaybe $ Map.keys tabItems
542 if sel == Just k || (sel == Nothing && t1 == Just k) then Map.empty else Map.singleton "style" "display:none;") dCurrentTab
543 elDynAttr "div" dAttrs $ dyn =<< mapDyn snd dTab)
544 return ()
545 where
546 headerBarLink :: (MonadWidget t m, Ord k) => String -> k -> Dynamic t Bool -> m (Event t k)
547 headerBarLink x k dBool = do
548 dAttributes <- mapDyn (\b -> if b then Map.singleton "class" activeClass else Map.empty) dBool
549 elDynAttr "li" dAttributes $ do
550 a <- link x
551 return $ fmap (const k) (_link_clicked a)
553-- | Place an element into the DOM and wrap it with Reflex event handlers. Note: undefined behavior may result if the element is placed multiple times, removed from the DOM after being placed, or in other situations. Don't use this unless you understand the internals of MonadWidget.
554unsafePlaceElement :: MonadWidget t m => HTMLElement -> m (El t)
555unsafePlaceElement e = do
556 p <- askParent
557 _ <- liftIO $ nodeAppendChild p $ Just e
558 wrapElement e