git.iko.soy/reflex-dom
on bb6dcea help sign in
reflex-dom/src/Reflex/Dom/Widget/Basic.hs
502 lines 23 kB history raw
1{-# LANGUAGE ScopedTypeVariables, LambdaCase, ConstraintKinds, TypeFamilies, FlexibleContexts, MultiParamTypeClasses, FlexibleInstances, RecursiveDo #-}
3module Reflex.Dom.Widget.Basic where
5import Reflex.Dom.Class
7import Reflex
8import Reflex.Host.Class
9import Data.Functor.Misc
10import Data.Map (Map)
11import qualified Data.Map as Map
12import Data.Set (Set)
13import qualified Data.Set as Set
14import Data.Dependent.Sum (DSum (..))
15import Control.Monad.Trans
16import Control.Monad.Reader
17import Control.Monad.Ref
18import GHCJS.DOM.Node
19import GHCJS.DOM.UIEvent
20import GHCJS.DOM.EventM (event, Signal)
21import GHCJS.DOM.Document
22import GHCJS.DOM.Element
23import GHCJS.DOM.HTMLElement
24import GHCJS.DOM.Types hiding (Widget (..), unWidget, Event)
25import GHCJS.DOM.NamedNodeMap
26import Control.Lens
27import Data.Monoid
28import Data.These
29import Data.Align
31import Data.Maybe
33type AttributeMap = Map String String
35data El t
36 = El { _el_element :: HTMLElement
37 , _el_clicked :: Event t ()
38 , _el_keypress :: Event t Int
39 , _el_scrolled :: Event t Int
40 }
42class Attributes m a where
43 addAttributes :: IsElement e => a -> e -> m ()
45instance MonadIO m => Attributes m AttributeMap where
46 addAttributes curAttrs e = liftIO $ imapM_ (elementSetAttribute e) curAttrs
48instance MonadWidget t m => Attributes m (Dynamic t AttributeMap) where
49 addAttributes attrs e = do
50 schedulePostBuild $ do
51 curAttrs <- sample $ current attrs
52 liftIO $ imapM_ (elementSetAttribute e) curAttrs
53 addVoidAction $ flip fmap (updated attrs) $ \newAttrs -> liftIO $ do
54 oldAttrs <- maybe (return Set.empty) namedNodeMapGetNames =<< elementGetAttributes e
55 forM_ (Set.toList $ oldAttrs `Set.difference` Map.keysSet newAttrs) $ elementRemoveAttribute e
56 imapM_ (elementSetAttribute e) newAttrs --TODO: avoid re-setting unchanged attributes; possibly do the compare using Align in haskell
58buildEmptyElement :: (MonadWidget t m, Attributes m attrs) => String -> attrs -> m HTMLElement
59buildEmptyElement elementTag attrs = do
60 doc <- askDocument
61 p <- askParent
62 Just e <- liftIO $ documentCreateElement doc elementTag
63 addAttributes attrs e
64 _ <- liftIO $ nodeAppendChild p $ Just e
65 return $ castToHTMLElement e
67-- 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
68buildElement :: (MonadWidget t m, Attributes m attrs) => String -> attrs -> m a -> m (HTMLElement, a)
69buildElement elementTag attrs child = do
70 e <- buildEmptyElement elementTag attrs
71 result <- subWidget (toNode e) child
72 return (e, result)
74namedNodeMapGetNames :: IsNamedNodeMap self => self -> IO (Set String)
75namedNodeMapGetNames self = do
76 l <- namedNodeMapGetLength self
77 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
78 liftM Set.fromList $ forM locations $ \i -> do
79 Just n <- namedNodeMapItem self i
80 nodeGetNodeName n
82text :: MonadWidget t m => String -> m ()
83text = void . text'
85--TODO: Wrap the result
86text' :: MonadWidget t m => String -> m Text
87text' s = do
88 doc <- askDocument
89 p <- askParent
90 Just n <- liftIO $ documentCreateTextNode doc s
91 _ <- liftIO $ nodeAppendChild p $ Just n
92 return n
94dynText :: MonadWidget t m => Dynamic t String -> m ()
95dynText s = do
96 n <- text' ""
97 schedulePostBuild $ do
98 curS <- sample $ current s
99 liftIO $ nodeSetNodeValue n curS
100 addVoidAction $ fmap (liftIO . nodeSetNodeValue n) $ updated s
102--TODO: Should this be renamed to 'widgetView' for consistency with 'widgetHold'?
103dyn :: MonadWidget t m => Dynamic t (m a) -> m (Event t a)
104dyn child = do
105 startPlaceholder <- text' ""
106 endPlaceholder <- text' ""
107 (newChildBuilt, newChildBuiltTriggerRef) <- newEventWithTriggerRef
108 let e = fmap snd newChildBuilt --TODO: Get rid of this hack
109 childVoidAction <- hold never e
110 performEvent_ $ fmap (const $ return ()) e --TODO: Get rid of this hack
111 addVoidAction $ switch childVoidAction
112 doc <- askDocument
113 runWidget <- getRunWidget
114 let build c = do
115 Just df <- liftIO $ documentCreateDocumentFragment doc
116 result <- runWidget df c
117 runFrameWithTriggerRef newChildBuiltTriggerRef result
118 Just p <- liftIO $ nodeGetParentNode endPlaceholder
119 liftIO $ nodeInsertBefore p (Just df) (Just endPlaceholder)
120 return ()
121 schedulePostBuild $ do
122 c <- sample $ current child
123 build c
124 addVoidAction $ ffor (updated child) $ \newChild -> do
125 liftIO $ deleteBetweenExclusive startPlaceholder endPlaceholder
126 build newChild
127 return $ fmap fst newChildBuilt
129widgetHold :: MonadWidget t m => m a -> Event t (m a) -> m (Dynamic t a)
130widgetHold child0 newChild = do
131 startPlaceholder <- text' ""
132 result0 <- child0
133 endPlaceholder <- text' ""
134 (newChildBuilt, newChildBuiltTriggerRef) <- newEventWithTriggerRef
135 childVoidAction <- hold never $ fmap snd newChildBuilt
136 addVoidAction $ switch childVoidAction
137 doc <- askDocument
138 runWidget <- getRunWidget
139 let build c = do
140 Just df <- liftIO $ documentCreateDocumentFragment doc
141 result <- runWidget df c
142 runFrameWithTriggerRef newChildBuiltTriggerRef result
143 Just p <- liftIO $ nodeGetParentNode endPlaceholder
144 liftIO $ nodeInsertBefore p (Just df) (Just endPlaceholder)
145 return ()
146 addVoidAction $ ffor newChild $ \c -> do
147 liftIO $ deleteBetweenExclusive startPlaceholder endPlaceholder
148 build c
149 holdDyn result0 $ fmap fst newChildBuilt
151--TODO: Something better than Dynamic t (Map k v) - we want something where the Events carry diffs, not the whole value
152listWithKey :: (Ord k, MonadWidget t m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m a) -> m (Dynamic t (Map k a))
153listWithKey vals mkChild = do
154 doc <- askDocument
155 startPlaceholder <- text' ""
156 endPlaceholder <- text' ""
157 (newChildren, newChildrenTriggerRef) <- newEventWithTriggerRef
158 performEvent_ $ fmap (const $ return ()) newChildren --TODO: Get rid of this hack
159 children <- hold Map.empty $ traceEventWith (\x -> "newChildren: " <> show (Map.size x)) newChildren
160 addVoidAction $ switch $ fmap (mergeWith (>>) . map snd . Map.elems) children
161 runWidget <- getRunWidget
162 let buildChild df k v = runWidget df $ do
163 childStart <- text' ""
164 result <- mkChild k =<< holdDyn v (fmapMaybe (Map.lookup k) (updated vals))
165 childEnd <- text' ""
166 return (result, (childStart, childEnd))
167 schedulePostBuild $ do
168 Just df <- liftIO $ documentCreateDocumentFragment doc
169 curVals <- sample $ current vals
170 initialState <- iforM curVals $ buildChild df
171 runFrameWithTriggerRef newChildrenTriggerRef initialState --TODO: Do all these in a single runFrame
172 Just p <- liftIO $ nodeGetParentNode endPlaceholder
173 liftIO $ nodeInsertBefore p (Just df) (Just endPlaceholder)
174 return ()
175 addVoidAction $ flip fmap (updated vals) $ \newVals -> do
176 curState <- sample children
177 --TODO: Should we remove the parent from the DOM first to avoid reflows?
178 newState <- liftM (Map.mapMaybe id) $ iforM (align curState newVals) $ \k -> \case
179 This ((_, (start, end)), _) -> do
180 liftIO $ putStrLn "Deleting item"
181 liftIO $ deleteBetweenInclusive start end
182 return Nothing
183 That v -> do
184 liftIO $ putStrLn "Creating item"
185 Just df <- liftIO $ documentCreateDocumentFragment doc
186 s <- buildChild df k v
187 let placeholder = case Map.lookupGT k curState of
188 Nothing -> endPlaceholder
189 Just (_, ((_, (start, _)), _)) -> start
190 Just p <- liftIO $ nodeGetParentNode placeholder
191 liftIO $ nodeInsertBefore p (Just df) (Just placeholder)
192 return $ Just s
193 These state _ -> do
194 liftIO $ putStrLn "Leaving item unchanged"
195 return $ Just state
196 liftIO $ putStrLn "Triggering newChildren"
197 liftIO $ putStrLn . ("newChildrenTriggerRef is Just? " <>) . show . isJust =<< readRef newChildrenTriggerRef
198 runFrameWithTriggerRef newChildrenTriggerRef newState
199 liftIO $ putStrLn "Triggering newChildren done"
200 holdDyn Map.empty $ fmap (fmap (fst . fst)) newChildren
202listWithKey' :: 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))
203listWithKey' initialVals valsChanged mkChild = do
204 doc <- askDocument
205 startPlaceholder <- text' ""
206 endPlaceholder <- text' ""
207 (newChildren, newChildrenTriggerRef) <- newEventWithTriggerRef
208-- performEvent_ $ fmap (const $ return ()) newChildren --TODO: Get rid of this hack
209 runWidget <- getRunWidget
210 let childValChangedSelector :: EventSelector t (Const2 k v)
211 childValChangedSelector = fanMap $ fmap (Map.mapMaybe id) valsChanged
212 buildChild :: DocumentFragment -> k -> v -> WidgetHost m ((a, (Text, Text)), Event t (WidgetHost m ()))
213 buildChild df k v = runWidget df $ wrapChild k v
214 wrapChild k v = do
215 childStart <- text' ""
216 result <- mkChild k v $ select childValChangedSelector $ Const2 k
217 childEnd <- text' ""
218 return (result, (childStart, childEnd))
219 Just df <- liftIO $ documentCreateDocumentFragment doc
220 initialState <- iforM initialVals $ \k v -> subWidgetWithVoidActions (toNode df) $ 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
221 children <- holdDyn initialState $ traceEventWith (\x -> "newChildren: " <> show (Map.size x)) newChildren
222 addVoidAction $ switch $ fmap (mergeWith (>>) . map snd . Map.elems) $ current children
223 Just p <- liftIO $ nodeGetParentNode endPlaceholder
224 liftIO $ nodeInsertBefore p (Just df) (Just endPlaceholder)
225 addVoidAction $ flip fmap valsChanged $ \newVals -> do
226 curState <- sample $ current children
227 --TODO: Should we remove the parent from the DOM first to avoid reflows?
228 newState <- liftM (Map.mapMaybe id) $ iforM (align curState newVals) $ \k -> \case
229 These ((_, (start, end)), _) Nothing -> do -- Deleting child
230 liftIO $ deleteBetweenInclusive start end
231 return Nothing
232 These ((_, (start, end)), _) (Just v) -> do -- Replacing existing child
233 liftIO $ deleteBetweenExclusive start end
234 Just df <- liftIO $ documentCreateDocumentFragment doc
235 s <- buildChild df k v
236 Just p <- liftIO $ nodeGetParentNode end
237 liftIO $ nodeInsertBefore p (Just df) (Just end)
238 return $ Just s
239 That Nothing -> return Nothing -- Deleting non-existent child
240 That (Just v) -> do -- Creating new child
241 Just df <- liftIO $ documentCreateDocumentFragment doc
242 s <- buildChild df k v
243 let placeholder = case Map.lookupGT k curState of
244 Nothing -> endPlaceholder
245 Just (_, ((_, (start, _)), _)) -> start
246 Just p <- liftIO $ nodeGetParentNode placeholder
247 liftIO $ nodeInsertBefore p (Just df) (Just placeholder)
248 return $ Just s
249 This state -> do -- No change
250 return $ Just state
251 liftIO $ putStrLn "Triggering newChildren"
252 liftIO $ putStrLn . ("newChildrenTriggerRef is Just? " <>) . show . isJust =<< readRef newChildrenTriggerRef
253 runFrameWithTriggerRef newChildrenTriggerRef newState
254 liftIO $ putStrLn "Triggering newChildren done"
255 mapDyn (fmap (fst . fst)) children
257--TODO: Something better than Dynamic t (Map k v) - we want something where the Events carry diffs, not the whole value
258listViewWithKey :: (Ord k, MonadWidget t m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m (Event t a)) -> m (Event t (Map k a))
259listViewWithKey vals mkChild = do
260 doc <- askDocument
261 startPlaceholder <- text' ""
262 endPlaceholder <- text' ""
263 (newChildren, newChildrenTriggerRef) <- newEventWithTriggerRef
264 performEvent_ $ fmap (const $ return ()) newChildren --TODO: Get rid of this hack
265 children <- hold Map.empty $ traceEventWith (\x -> "newChildren: " <> show (Map.size x)) newChildren
266 addVoidAction $ switch $ fmap (mergeWith (>>) . map snd . Map.elems) children
267 runWidget <- getRunWidget
268 let buildChild df k v = runWidget df $ do
269 childStart <- text' ""
270 result <- mkChild k =<< holdDyn v (fmapMaybe (Map.lookup k) (updated vals))
271 childEnd <- text' ""
272 return (result, (childStart, childEnd))
273 schedulePostBuild $ do
274 Just df <- liftIO $ documentCreateDocumentFragment doc
275 curVals <- sample $ current vals
276 initialState <- iforM curVals $ buildChild df
277 runFrameWithTriggerRef newChildrenTriggerRef initialState --TODO: Do all these in a single runFrame
278 Just p <- liftIO $ nodeGetParentNode endPlaceholder
279 liftIO $ nodeInsertBefore p (Just df) (Just endPlaceholder)
280 return ()
281 addVoidAction $ flip fmap (updated vals) $ \newVals -> do
282 curState <- sample children
283 --TODO: Should we remove the parent from the DOM first to avoid reflows?
284 newState <- liftM (Map.mapMaybe id) $ iforM (align curState newVals) $ \k -> \case
285 This ((_, (start, end)), _) -> do
286 liftIO $ putStrLn "Deleting item"
287 liftIO $ deleteBetweenInclusive start end
288 return Nothing
289 That v -> do
290 liftIO $ putStrLn "Creating item"
291 Just df <- liftIO $ documentCreateDocumentFragment doc
292 s <- buildChild df k v
293 let placeholder = case Map.lookupGT k curState of
294 Nothing -> endPlaceholder
295 Just (_, ((_, (start, _)), _)) -> start
296 Just p <- liftIO $ nodeGetParentNode placeholder
297 liftIO $ nodeInsertBefore p (Just df) (Just placeholder)
298 return $ Just s
299 These state _ -> do
300 liftIO $ putStrLn "Leaving item unchanged"
301 return $ Just state
302 liftIO $ putStrLn "Triggering newChildren"
303 liftIO $ putStrLn . ("newChildrenTriggerRef is Just? " <>) . show . isJust =<< readRef newChildrenTriggerRef
304 runFrameWithTriggerRef newChildrenTriggerRef newState
305 liftIO $ putStrLn "Triggering newChildren done"
306 return $ switch $ fmap (mergeMap . fmap (fst . fst)) children
308--TODO: Deduplicate the various list*WithKey* implementations
310selectViewListWithKey_ :: 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)
311selectViewListWithKey_ selection vals mkChild = do
312 let selectionDemux = demux selection -- For good performance, this value must be shared across all children
313 selectChild <- listWithKey vals $ \k v -> do
314 selected <- getDemuxed selectionDemux k
315 selectSelf <- mkChild k v selected
316 return $ fmap (const k) selectSelf
317 liftM switchPromptlyDyn $ mapDyn (leftmost . Map.elems) selectChild
319--------------------------------------------------------------------------------
320-- Basic DOM manipulation helpers
321--------------------------------------------------------------------------------
323-- | s and e must both be children of the same node and s must precede e
324deleteBetweenExclusive s e = do
325 Just currentParent <- nodeGetParentNode e -- May be different than it was at initial construction, e.g., because the parent may have dumped us in from a DocumentFragment
326 let go = do
327 Just x <- nodeGetPreviousSibling e -- This can't be Nothing because we should hit 's' first
328 when (unNode (toNode s) /= unNode (toNode x)) $ do
329 nodeRemoveChild currentParent $ Just x
330 go
331 go
333-- | s and e must both be children of the same node and s must precede e
334deleteBetweenInclusive s e = do
335 Just currentParent <- nodeGetParentNode e -- May be different than it was at initial construction, e.g., because the parent may have dumped us in from a DocumentFragment
336 let go = do
337 Just x <- nodeGetPreviousSibling e -- This can't be Nothing because we should hit 's' first
338 nodeRemoveChild currentParent $ Just x
339 when (unNode (toNode s) /= unNode (toNode x)) go
340 go
341 nodeRemoveChild currentParent $ Just e
343--------------------------------------------------------------------------------
344-- Adapters
345--------------------------------------------------------------------------------
347--TODO: Get rid of extra version of this function
348wrapDomEvent element elementOnevent getValue = do
349 postGui <- askPostGui
350 runWithActions <- askRunWithActions
351 e <- newEventWithTrigger $ \et -> do
352 unsubscribe <- {-# SCC "a" #-} liftIO $ {-# SCC "b" #-} elementOnevent element $ {-# SCC "c" #-} do
353 v <- {-# SCC "d" #-} getValue
354 liftIO $ postGui $ runWithActions [et :=> v]
355 return $ liftIO $ do
356 {-# SCC "e" #-} unsubscribe
357 return $! {-# SCC "f" #-} e
359wrapElement :: (Functor (Event t), MonadIO m, MonadSample t m, MonadReflexCreateTrigger t m, Reflex t, HasPostGui t h m) => HTMLElement -> m (El t)
360wrapElement e = do
361 clicked <- wrapDomEvent e elementOnclick (return ())
362 keypress <- wrapDomEvent e elementOnkeypress $ liftIO . uiEventGetKeyCode =<< event
363 scrolled <- wrapDomEvent e elementOnscroll $ liftIO $ elementGetScrollTop e
364 return $ El e clicked keypress scrolled
366elDynAttr' :: forall t m a. MonadWidget t m => String -> Dynamic t (Map String String) -> m a -> m (El t, a)
367elDynAttr' elementTag attrs child = do
368 (e, result) <- buildElement elementTag attrs child
369 e' <- wrapElement e
370 return (e', result)
372{-# INLINABLE elAttr #-}
373elAttr :: forall t m a. MonadWidget t m => String -> Map String String -> m a -> m a
374elAttr elementTag attrs child = do
375 (_, result) <- buildElement elementTag attrs child
376 return result
378{-# INLINABLE el' #-}
379el' :: forall t m a. MonadWidget t m => String -> m a -> m (El t, a)
380el' tag child = elAttr' tag (Map.empty :: AttributeMap) child
382{-# INLINABLE elAttr' #-}
383elAttr' :: forall t m a. MonadWidget t m => String -> Map String String -> m a -> m (El t, a)
384elAttr' elementTag attrs child = do
385 (e, result) <- buildElement elementTag attrs child
386 e' <- wrapElement e
387 return (e', result)
389{-# INLINABLE elDynAttr #-}
390elDynAttr :: forall t m a. MonadWidget t m => String -> Dynamic t (Map String String) -> m a -> m a
391elDynAttr elementTag attrs child = do
392 (_, result) <- buildElement elementTag attrs child
393 return result
395{-# INLINABLE el #-}
396el :: forall t m a. MonadWidget t m => String -> m a -> m a
397el tag child = elAttr tag Map.empty child
399elClass :: forall t m a. MonadWidget t m => String -> String -> m a -> m a
400elClass tag c child = elAttr tag ("class" =: c) child
402--------------------------------------------------------------------------------
403-- Copied and pasted from Reflex.Widget.Class
404--------------------------------------------------------------------------------
406list dm mkChild = listWithKey dm (\_ dv -> mkChild dv)
408elDynHtml' :: MonadWidget t m => String -> Dynamic t String -> m (El t)
409elDynHtml' elementTag html = do
410 e <- buildEmptyElement elementTag (Map.empty :: Map String String)
411 schedulePostBuild $ liftIO . htmlElementSetInnerHTML e =<< sample (current html)
412 addVoidAction $ fmap (liftIO . htmlElementSetInnerHTML e) $ updated html
413 wrapElement e
415{-
417--TODO: Update dynamically
418{-# INLINABLE dynHtml #-}
419dynHtml :: MonadWidget t m => Dynamic t String -> m ()
420dynHtml ds = do
421 let mkSelf h = do
422 doc <- askDocument
423 Just e <- liftIO $ liftM (fmap castToHTMLElement) $ documentCreateElement doc "div"
424 liftIO $ htmlElementSetInnerHTML e h
425 return e
426 eCreated <- performEvent . fmap mkSelf . tagDyn ds =<< getEInit
427 putEChildren $ fmap ((:[]) . toNode) eCreated
429-}
431data Link t
432 = Link { _link_clicked :: Event t ()
433 }
435linkClass :: MonadWidget t m => String -> String -> m (Link t)
436linkClass s c = do
437 (l,_) <- elAttr' "a" ("class" =: c) $ text s
438 return $ Link $ _el_clicked l
440link :: MonadWidget t m => String -> m (Link t)
441link s = linkClass s ""
443newtype Workflow t m a = Workflow { unWorkflow :: m (a, Event t (Workflow t m a)) }
445workflowView :: forall t m a. MonadWidget t m => Workflow t m a -> m (Event t a)
446workflowView w0 = do
447 rec eResult <- dyn =<< mapDyn unWorkflow =<< holdDyn w0 eReplace
448 eReplace <- liftM switch $ hold never $ fmap snd eResult
449 eResult `seq` eReplace `seq` return ()
450 return $ fmap fst eResult
452divClass :: forall t m a. MonadWidget t m => String -> m a -> m a
453divClass = elClass "div"
455dtdd :: forall t m a. MonadWidget t m => String -> m a -> m a
456dtdd h w = do
457 el "dt" $ text h
458 el "dd" $ w
460blank :: forall t m. MonadWidget t m => m ()
461blank = return ()
463tableDynAttr :: 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])))
464tableDynAttr klass cols dRows rowAttrs = elAttr "div" (Map.singleton "style" "zoom: 1; overflow: auto; background: white;") $ do
465 elAttr "table" (Map.singleton "class" klass) $ do
466 el "thead" $ el "tr" $ do
467 mapM (\(h, _) -> el "th" $ text h) cols
468 el "tbody" $ do
469 listWithKey dRows (\k r -> do
470 dAttrs <- rowAttrs k
471 elDynAttr' "tr" dAttrs $ mapM (\x -> el "td" $ snd x k r) cols)
473--TODO preselect a tab on open
474tabDisplay :: forall t m k. (MonadFix m, MonadWidget t m, Show k, Ord k) => String -> String -> Map k (String, m ()) -> m ()
475tabDisplay ulClass activeClass tabItems = do
476 rec dCurrentTab <- holdDyn Nothing (updated dTabClicks)
477 dTabClicks :: Dynamic t (Maybe k) <- elAttr "ul" (Map.singleton "class" ulClass) $ do
478 tabClicksList :: [Event t k] <- (liftM Map.elems) $ imapM (\k (s,_) -> headerBarLink s k =<< mapDyn (== (Just k)) dCurrentTab) tabItems
479 let eTabClicks :: Event t k = leftmost tabClicksList
480 holdDyn Nothing $ fmap Just eTabClicks :: m (Dynamic t (Maybe k))
481 divClass "" $ do
482 let dTabs :: Dynamic t (Map k (String, m ())) = constDyn tabItems
483 listWithKey dTabs (\k dTab -> do
484 dAttrs <- mapDyn (\sel -> do
485 let t1 = listToMaybe $ Map.keys tabItems
486 if sel == Just k || (sel == Nothing && t1 == Just k) then Map.empty else Map.singleton "style" "display:none;") dCurrentTab
487 elDynAttr "div" dAttrs $ dyn =<< mapDyn snd dTab)
488 return ()
489 where
490 headerBarLink :: (MonadWidget t m, Ord k) => String -> k -> Dynamic t Bool -> m (Event t k)
491 headerBarLink x k dBool = do
492 dAttributes <- mapDyn (\b -> if b then Map.singleton "class" activeClass else Map.empty) dBool
493 elDynAttr "li" dAttributes $ do
494 a <- link x
495 return $ fmap (const k) (_link_clicked a)
497-- | 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.
498unsafePlaceElement :: MonadWidget t m => HTMLElement -> m (El t)
499unsafePlaceElement e = do
500 p <- askParent
501 liftIO $ nodeAppendChild p $ Just e
502 wrapElement e