git.iko.soy/reflex-dom
on f992dc4 help sign in
reflex-dom/src/Reflex/Dom/Widget/Basic.hs
523 lines 24 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.State
18import Control.Monad.Ref
19import GHCJS.DOM.Node
20import GHCJS.DOM.UIEvent
21import GHCJS.DOM.EventM (event, Signal, EventM)
22import GHCJS.DOM.Document
23import GHCJS.DOM.Element
24import GHCJS.DOM.HTMLElement
25import GHCJS.DOM.Types hiding (Widget (..), unWidget, Event)
26import GHCJS.DOM.NamedNodeMap
27import Control.Lens
28import Data.Monoid
29import Data.These
30import Data.Align
32import Data.Maybe
34type AttributeMap = Map String String
36data El t
37 = El { _el_element :: HTMLElement
38 , _el_clicked :: Event t ()
39 , _el_keypress :: Event t Int
40 , _el_scrolled :: Event t Int
41 }
43class Attributes m a where
44 addAttributes :: IsElement e => a -> e -> m ()
46instance MonadIO m => Attributes m AttributeMap where
47 addAttributes curAttrs e = liftIO $ imapM_ (elementSetAttribute e) curAttrs
49instance MonadWidget t m => Attributes m (Dynamic t AttributeMap) where
50 addAttributes attrs e = do
51 schedulePostBuild $ do
52 curAttrs <- sample $ current attrs
53 liftIO $ imapM_ (elementSetAttribute e) curAttrs
54 addVoidAction $ flip fmap (updated attrs) $ \newAttrs -> liftIO $ do
55 oldAttrs <- maybe (return Set.empty) namedNodeMapGetNames =<< elementGetAttributes e
56 forM_ (Set.toList $ oldAttrs `Set.difference` Map.keysSet newAttrs) $ elementRemoveAttribute e
57 imapM_ (elementSetAttribute e) newAttrs --TODO: avoid re-setting unchanged attributes; possibly do the compare using Align in haskell
59buildEmptyElement :: (MonadWidget t m, Attributes m attrs) => String -> attrs -> m HTMLElement
60buildEmptyElement elementTag attrs = do
61 doc <- askDocument
62 p <- askParent
63 Just e <- liftIO $ documentCreateElement doc elementTag
64 addAttributes attrs e
65 _ <- liftIO $ nodeAppendChild p $ Just e
66 return $ castToHTMLElement e
68-- 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
69buildElement :: (MonadWidget t m, Attributes m attrs) => String -> attrs -> m a -> m (HTMLElement, a)
70buildElement elementTag attrs child = do
71 e <- buildEmptyElement elementTag attrs
72 result <- subWidget (toNode e) child
73 return (e, result)
75namedNodeMapGetNames :: IsNamedNodeMap self => self -> IO (Set String)
76namedNodeMapGetNames self = do
77 l <- namedNodeMapGetLength self
78 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
79 liftM Set.fromList $ forM locations $ \i -> do
80 Just n <- namedNodeMapItem self i
81 nodeGetNodeName n
83text :: MonadWidget t m => String -> m ()
84text = void . text'
86--TODO: Wrap the result
87text' :: MonadWidget t m => String -> m Text
88text' s = do
89 doc <- askDocument
90 p <- askParent
91 Just n <- liftIO $ documentCreateTextNode doc s
92 _ <- liftIO $ nodeAppendChild p $ Just n
93 return n
95dynText :: MonadWidget t m => Dynamic t String -> m ()
96dynText s = do
97 n <- text' ""
98 schedulePostBuild $ do
99 curS <- sample $ current s
100 liftIO $ nodeSetNodeValue n curS
101 addVoidAction $ fmap (liftIO . nodeSetNodeValue n) $ updated s
103display :: (MonadWidget t m, Show a) => Dynamic t a -> m ()
104display a = dynText =<< mapDyn show a
106--TODO: Should this be renamed to 'widgetView' for consistency with 'widgetHold'?
107dyn :: MonadWidget t m => Dynamic t (m a) -> m (Event t a)
108dyn child = do
109 startPlaceholder <- text' ""
110 endPlaceholder <- text' ""
111 (newChildBuilt, newChildBuiltTriggerRef) <- newEventWithTriggerRef
112 let e = fmap snd newChildBuilt --TODO: Get rid of this hack
113 childVoidAction <- hold never e
114 performEvent_ $ fmap (const $ return ()) e --TODO: Get rid of this hack
115 addVoidAction $ switch childVoidAction
116 doc <- askDocument
117 runWidget <- getRunWidget
118 let build c = do
119 Just df <- liftIO $ documentCreateDocumentFragment doc
120 (result, postBuild, voidActions) <- runWidget df c
121 runFrameWithTriggerRef newChildBuiltTriggerRef (result, voidActions)
122 postBuild
123 Just p <- liftIO $ nodeGetParentNode endPlaceholder
124 liftIO $ nodeInsertBefore p (Just df) (Just endPlaceholder)
125 return ()
126 schedulePostBuild $ do
127 c <- sample $ current child
128 build c
129 addVoidAction $ ffor (updated child) $ \newChild -> do
130 liftIO $ deleteBetweenExclusive startPlaceholder endPlaceholder
131 build newChild
132 return $ fmap fst newChildBuilt
134widgetHold :: MonadWidget t m => m a -> Event t (m a) -> m (Dynamic t a)
135widgetHold child0 newChild = do
136 startPlaceholder <- text' ""
137 result0 <- child0 -- I'm pretty sure this is wrong; the void actions should get removed when the child is swapped out
138 endPlaceholder <- text' ""
139 (newChildBuilt, newChildBuiltTriggerRef) <- newEventWithTriggerRef
140 performEvent_ $ fmap (const $ return ()) newChildBuilt --TODO: Get rid of this hack
141 childVoidAction <- hold never $ fmap snd newChildBuilt
142 addVoidAction $ switch childVoidAction --TODO: Should this be a switchPromptly?
143 doc <- askDocument
144 runWidget <- getRunWidget
145 let build c = do
146 Just df <- liftIO $ documentCreateDocumentFragment doc
147 (result, postBuild, voidActions) <- runWidget df c
148 runFrameWithTriggerRef newChildBuiltTriggerRef (result, voidActions)
149 postBuild
150 mp <- liftIO $ nodeGetParentNode endPlaceholder
151 case mp of
152 Nothing -> return () --TODO: Is this right?
153 Just p -> do
154 liftIO $ nodeInsertBefore p (Just df) (Just endPlaceholder)
155 return ()
156 return ()
157 addVoidAction $ ffor newChild $ \c -> do
158 liftIO $ deleteBetweenExclusive startPlaceholder endPlaceholder
159 build c
160 holdDyn result0 $ fmap fst newChildBuilt
162--TODO: Something better than Dynamic t (Map k v) - we want something where the Events carry diffs, not the whole value
163listWithKey :: (Ord k, MonadWidget t m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m a) -> m (Dynamic t (Map k a))
164listWithKey vals mkChild = do
165 doc <- askDocument
166 startPlaceholder <- text' ""
167 endPlaceholder <- text' ""
168 (newChildren, newChildrenTriggerRef) <- newEventWithTriggerRef
169 performEvent_ $ fmap (const $ return ()) newChildren --TODO: Get rid of this hack
170 children <- hold Map.empty newChildren
171 addVoidAction $ switch $ fmap (mergeWith (>>) . map snd . Map.elems) children
172 runWidget <- getRunWidget
173 let buildChild df k v = runWidget df $ do
174 childStart <- text' ""
175 result <- mkChild k =<< holdDyn v (fmapMaybe (Map.lookup k) (updated vals))
176 childEnd <- text' ""
177 return (result, (childStart, childEnd))
178 schedulePostBuild $ do
179 Just df <- liftIO $ documentCreateDocumentFragment doc
180 curVals <- sample $ current vals
181 initialState <- iforM curVals $ \k v -> do
182 (result, postBuild, voidAction) <- buildChild df k v
183 return ((result, voidAction), postBuild)
184 runFrameWithTriggerRef newChildrenTriggerRef $ fmap fst initialState --TODO: Do all these in a single runFrame
185 sequence $ fmap snd initialState
186 Just p <- liftIO $ nodeGetParentNode endPlaceholder
187 liftIO $ nodeInsertBefore p (Just df) (Just endPlaceholder)
188 return ()
189 addVoidAction $ flip fmap (updated vals) $ \newVals -> do
190 curState <- sample children
191 --TODO: Should we remove the parent from the DOM first to avoid reflows?
192 (newState, postBuild) <- flip runStateT (return ()) $ liftM (Map.mapMaybe id) $ iforM (align curState newVals) $ \k -> \case
193 This ((_, (start, end)), _) -> do
194 liftIO $ deleteBetweenInclusive start end
195 return Nothing
196 That v -> do
197 Just df <- liftIO $ documentCreateDocumentFragment doc
198 (childResult, childPostBuild, childVoidAction) <- lift $ buildChild df k v
199 let s = (childResult, childVoidAction)
200 modify (>>childPostBuild)
201 let placeholder = case Map.lookupGT k curState of
202 Nothing -> endPlaceholder
203 Just (_, ((_, (start, _)), _)) -> start
204 Just p <- liftIO $ nodeGetParentNode placeholder
205 liftIO $ nodeInsertBefore p (Just df) (Just placeholder)
206 return $ Just s
207 These state _ -> do
208 return $ Just state
209 runFrameWithTriggerRef newChildrenTriggerRef newState
210 postBuild
211 holdDyn Map.empty $ fmap (fmap (fst . fst)) newChildren
213listWithKey' :: 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))
214listWithKey' initialVals valsChanged mkChild = do
215 doc <- askDocument
216 startPlaceholder <- text' ""
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 df <- liftIO $ documentCreateDocumentFragment doc
230 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
231 children <- holdDyn initialState newChildren
232 addVoidAction $ switch $ fmap (mergeWith (>>) . map snd . Map.elems) $ current children
233 Just p <- liftIO $ nodeGetParentNode endPlaceholder
234 liftIO $ nodeInsertBefore p (Just df) (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 startPlaceholder <- text' ""
277 endPlaceholder <- text' ""
278 (newChildren, newChildrenTriggerRef) <- newEventWithTriggerRef
279 performEvent_ $ fmap (const $ return ()) newChildren --TODO: Get rid of this hack
280 children <- hold Map.empty newChildren
281 addVoidAction $ switch $ fmap (mergeWith (>>) . map snd . Map.elems) children
282 runWidget <- getRunWidget
283 let buildChild df k v = runWidget df $ do
284 childStart <- text' ""
285 result <- mkChild k =<< holdDyn v (fmapMaybe (Map.lookup k) (updated vals))
286 childEnd <- text' ""
287 return (result, (childStart, childEnd))
288 schedulePostBuild $ do
289 Just df <- liftIO $ documentCreateDocumentFragment doc
290 curVals <- sample $ current vals
291 initialState <- iforM curVals $ \k v -> do
292 (result, postBuild, voidAction) <- buildChild df k v
293 return ((result, voidAction), postBuild)
294 runFrameWithTriggerRef newChildrenTriggerRef $ fmap fst initialState --TODO: Do all these in a single runFrame
295 sequence $ fmap snd initialState
296 Just p <- liftIO $ nodeGetParentNode endPlaceholder
297 liftIO $ nodeInsertBefore p (Just df) (Just endPlaceholder)
298 return ()
299 addVoidAction $ flip fmap (updated vals) $ \newVals -> do
300 curState <- sample children
301 --TODO: Should we remove the parent from the DOM first to avoid reflows?
302 (newState, postBuild) <- flip runStateT (return ()) $ liftM (Map.mapMaybe id) $ iforM (align curState newVals) $ \k -> \case
303 This ((_, (start, end)), _) -> do
304 liftIO $ deleteBetweenInclusive start end
305 return Nothing
306 That v -> do
307 Just df <- liftIO $ documentCreateDocumentFragment doc
308 (childResult, childPostBuild, childVoidAction) <- lift $ buildChild df k v
309 let s = (childResult, childVoidAction)
310 modify (>>childPostBuild)
311 let placeholder = case Map.lookupGT k curState of
312 Nothing -> endPlaceholder
313 Just (_, ((_, (start, _)), _)) -> start
314 Just p <- liftIO $ nodeGetParentNode placeholder
315 liftIO $ nodeInsertBefore p (Just df) (Just placeholder)
316 return $ Just s
317 These state _ -> do
318 return $ Just state
319 runFrameWithTriggerRef newChildrenTriggerRef newState
320 postBuild
321 return $ fmap (fmap (fst . fst)) children
323--TODO: Deduplicate the various list*WithKey* implementations
325selectViewListWithKey_ :: 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)
326selectViewListWithKey_ selection vals mkChild = do
327 let selectionDemux = demux selection -- For good performance, this value must be shared across all children
328 selectChild <- listWithKey vals $ \k v -> do
329 selected <- getDemuxed selectionDemux k
330 selectSelf <- mkChild k v selected
331 return $ fmap (const k) selectSelf
332 liftM switchPromptlyDyn $ mapDyn (leftmost . Map.elems) selectChild
334--------------------------------------------------------------------------------
335-- Basic DOM manipulation helpers
336--------------------------------------------------------------------------------
338-- | s and e must both be children of the same node and s must precede e
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 (unNode (toNode s) /= unNode (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 s e = do
353 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
354 let go = do
355 Just x <- nodeGetPreviousSibling e -- This can't be Nothing because we should hit 's' first
356 nodeRemoveChild currentParent $ Just x
357 when (unNode (toNode s) /= unNode (toNode x)) go
358 go
359 nodeRemoveChild currentParent $ Just e
361--------------------------------------------------------------------------------
362-- Adapters
363--------------------------------------------------------------------------------
365wrapDomEvent :: (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)
366wrapDomEvent element elementOnevent getValue = wrapDomEventMaybe element elementOnevent $ liftM Just getValue
368wrapDomEventMaybe :: (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)
369wrapDomEventMaybe element elementOnevent getValue = do
370 postGui <- askPostGui
371 runWithActions <- askRunWithActions
372 e <- newEventWithTrigger $ \et -> do
373 unsubscribe <- {-# SCC "a" #-} liftIO $ {-# SCC "b" #-} elementOnevent element $ {-# SCC "c" #-} do
374 mv <- {-# SCC "d" #-} getValue
375 forM_ mv $ \v -> liftIO $ postGui $ runWithActions [et :=> v]
376 return $ liftIO $ do
377 {-# SCC "e" #-} unsubscribe
378 return $! {-# SCC "f" #-} e
380wrapElement :: (Functor (Event t), MonadIO m, MonadSample t m, MonadReflexCreateTrigger t m, Reflex t, HasPostGui t h m) => HTMLElement -> m (El t)
381wrapElement e = do
382 clicked <- wrapDomEvent e elementOnclick (return ())
383 keypress <- wrapDomEvent e elementOnkeypress $ liftIO . uiEventGetKeyCode =<< event
384 scrolled <- wrapDomEvent e elementOnscroll $ liftIO $ elementGetScrollTop e
385 return $ El e clicked keypress scrolled
387elDynAttr' :: forall t m a. MonadWidget t m => String -> Dynamic t (Map String String) -> m a -> m (El t, a)
388elDynAttr' elementTag attrs child = do
389 (e, result) <- buildElement elementTag attrs child
390 e' <- wrapElement e
391 return (e', result)
393{-# INLINABLE elAttr #-}
394elAttr :: forall t m a. MonadWidget t m => String -> Map String String -> m a -> m a
395elAttr elementTag attrs child = do
396 (_, result) <- buildElement elementTag attrs child
397 return result
399{-# INLINABLE el' #-}
400el' :: forall t m a. MonadWidget t m => String -> m a -> m (El t, a)
401el' tag child = elAttr' tag (Map.empty :: AttributeMap) child
403{-# INLINABLE elAttr' #-}
404elAttr' :: forall t m a. MonadWidget t m => String -> Map String String -> m a -> m (El t, a)
405elAttr' elementTag attrs child = do
406 (e, result) <- buildElement elementTag attrs child
407 e' <- wrapElement e
408 return (e', result)
410{-# INLINABLE elDynAttr #-}
411elDynAttr :: forall t m a. MonadWidget t m => String -> Dynamic t (Map String String) -> m a -> m a
412elDynAttr elementTag attrs child = do
413 (_, result) <- buildElement elementTag attrs child
414 return result
416{-# INLINABLE el #-}
417el :: forall t m a. MonadWidget t m => String -> m a -> m a
418el tag child = elAttr tag Map.empty child
420elClass :: forall t m a. MonadWidget t m => String -> String -> m a -> m a
421elClass tag c child = elAttr tag ("class" =: c) child
423--------------------------------------------------------------------------------
424-- Copied and pasted from Reflex.Widget.Class
425--------------------------------------------------------------------------------
427list dm mkChild = listWithKey dm (\_ dv -> mkChild dv)
429elDynHtml' :: MonadWidget t m => String -> Dynamic t String -> m (El t)
430elDynHtml' elementTag html = do
431 e <- buildEmptyElement elementTag (Map.empty :: Map String String)
432 schedulePostBuild $ liftIO . htmlElementSetInnerHTML e =<< sample (current html)
433 addVoidAction $ fmap (liftIO . htmlElementSetInnerHTML e) $ updated html
434 wrapElement e
436{-
438--TODO: Update dynamically
439{-# INLINABLE dynHtml #-}
440dynHtml :: MonadWidget t m => Dynamic t String -> m ()
441dynHtml ds = do
442 let mkSelf h = do
443 doc <- askDocument
444 Just e <- liftIO $ liftM (fmap castToHTMLElement) $ documentCreateElement doc "div"
445 liftIO $ htmlElementSetInnerHTML e h
446 return e
447 eCreated <- performEvent . fmap mkSelf . tagDyn ds =<< getEInit
448 putEChildren $ fmap ((:[]) . toNode) eCreated
450-}
452data Link t
453 = Link { _link_clicked :: Event t ()
454 }
456linkClass :: MonadWidget t m => String -> String -> m (Link t)
457linkClass s c = do
458 (l,_) <- elAttr' "a" ("class" =: c) $ text s
459 return $ Link $ _el_clicked l
461link :: MonadWidget t m => String -> m (Link t)
462link s = linkClass s ""
464newtype Workflow t m a = Workflow { unWorkflow :: m (a, Event t (Workflow t m a)) }
466workflowView :: forall t m a. MonadWidget t m => Workflow t m a -> m (Event t a)
467workflowView w0 = do
468 rec eResult <- dyn =<< mapDyn unWorkflow =<< holdDyn w0 eReplace
469 eReplace <- liftM switch $ hold never $ fmap snd eResult
470 eResult `seq` eReplace `seq` return ()
471 return $ fmap fst eResult
473divClass :: forall t m a. MonadWidget t m => String -> m a -> m a
474divClass = elClass "div"
476dtdd :: forall t m a. MonadWidget t m => String -> m a -> m a
477dtdd h w = do
478 el "dt" $ text h
479 el "dd" $ w
481blank :: forall t m. MonadWidget t m => m ()
482blank = return ()
484tableDynAttr :: 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])))
485tableDynAttr klass cols dRows rowAttrs = elAttr "div" (Map.singleton "style" "zoom: 1; overflow: auto; background: white;") $ do
486 elAttr "table" (Map.singleton "class" klass) $ do
487 el "thead" $ el "tr" $ do
488 mapM (\(h, _) -> el "th" $ text h) cols
489 el "tbody" $ do
490 listWithKey dRows (\k r -> do
491 dAttrs <- rowAttrs k
492 elDynAttr' "tr" dAttrs $ mapM (\x -> el "td" $ snd x k r) cols)
494--TODO preselect a tab on open
495tabDisplay :: forall t m k. (MonadFix m, MonadWidget t m, Show k, Ord k) => String -> String -> Map k (String, m ()) -> m ()
496tabDisplay ulClass activeClass tabItems = do
497 rec dCurrentTab <- holdDyn Nothing (updated dTabClicks)
498 dTabClicks :: Dynamic t (Maybe k) <- elAttr "ul" (Map.singleton "class" ulClass) $ do
499 tabClicksList :: [Event t k] <- (liftM Map.elems) $ imapM (\k (s,_) -> headerBarLink s k =<< mapDyn (== (Just k)) dCurrentTab) tabItems
500 let eTabClicks :: Event t k = leftmost tabClicksList
501 holdDyn Nothing $ fmap Just eTabClicks :: m (Dynamic t (Maybe k))
502 divClass "" $ do
503 let dTabs :: Dynamic t (Map k (String, m ())) = constDyn tabItems
504 listWithKey dTabs (\k dTab -> do
505 dAttrs <- mapDyn (\sel -> do
506 let t1 = listToMaybe $ Map.keys tabItems
507 if sel == Just k || (sel == Nothing && t1 == Just k) then Map.empty else Map.singleton "style" "display:none;") dCurrentTab
508 elDynAttr "div" dAttrs $ dyn =<< mapDyn snd dTab)
509 return ()
510 where
511 headerBarLink :: (MonadWidget t m, Ord k) => String -> k -> Dynamic t Bool -> m (Event t k)
512 headerBarLink x k dBool = do
513 dAttributes <- mapDyn (\b -> if b then Map.singleton "class" activeClass else Map.empty) dBool
514 elDynAttr "li" dAttributes $ do
515 a <- link x
516 return $ fmap (const k) (_link_clicked a)
518-- | 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.
519unsafePlaceElement :: MonadWidget t m => HTMLElement -> m (El t)
520unsafePlaceElement e = do
521 p <- askParent
522 liftIO $ nodeAppendChild p $ Just e
523 wrapElement e