git.iko.soy/reflex-dom
on 5efef2a help sign in
reflex-dom/src/Reflex/Dom/Widget/Basic.hs
528 lines 25 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)
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
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 Just p <- liftIO $ nodeGetParentNode endPlaceholder
151 liftIO $ nodeInsertBefore p (Just df) (Just endPlaceholder)
152 return ()
153 addVoidAction $ ffor newChild $ \c -> do
154 liftIO $ deleteBetweenExclusive startPlaceholder endPlaceholder
155 build c
156 holdDyn result0 $ fmap fst newChildBuilt
158--TODO: Something better than Dynamic t (Map k v) - we want something where the Events carry diffs, not the whole value
159listWithKey :: (Ord k, MonadWidget t m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m a) -> m (Dynamic t (Map k a))
160listWithKey vals mkChild = do
161 doc <- askDocument
162 startPlaceholder <- text' ""
163 endPlaceholder <- text' ""
164 (newChildren, newChildrenTriggerRef) <- newEventWithTriggerRef
165 performEvent_ $ fmap (const $ return ()) newChildren --TODO: Get rid of this hack
166 children <- hold Map.empty $ traceEventWith (\x -> "newChildren: " <> show (Map.size x)) newChildren
167 addVoidAction $ switch $ fmap (mergeWith (>>) . map snd . Map.elems) children
168 runWidget <- getRunWidget
169 let buildChild df k v = runWidget df $ do
170 childStart <- text' ""
171 result <- mkChild k =<< holdDyn v (fmapMaybe (Map.lookup k) (updated vals))
172 childEnd <- text' ""
173 return (result, (childStart, childEnd))
174 schedulePostBuild $ do
175 Just df <- liftIO $ documentCreateDocumentFragment doc
176 curVals <- sample $ current vals
177 initialState <- iforM curVals $ \k v -> do
178 (result, postBuild, voidAction) <- buildChild df k v
179 return ((result, voidAction), postBuild)
180 runFrameWithTriggerRef newChildrenTriggerRef $ fmap fst initialState --TODO: Do all these in a single runFrame
181 sequence $ fmap snd initialState
182 Just p <- liftIO $ nodeGetParentNode endPlaceholder
183 liftIO $ nodeInsertBefore p (Just df) (Just endPlaceholder)
184 return ()
185 addVoidAction $ flip fmap (updated vals) $ \newVals -> do
186 curState <- sample children
187 --TODO: Should we remove the parent from the DOM first to avoid reflows?
188 (newState, postBuild) <- flip runStateT (return ()) $ liftM (Map.mapMaybe id) $ iforM (align curState newVals) $ \k -> \case
189 This ((_, (start, end)), _) -> do
190 liftIO $ putStrLn "Deleting item"
191 liftIO $ deleteBetweenInclusive start end
192 return Nothing
193 That v -> do
194 liftIO $ putStrLn "Creating item"
195 Just df <- liftIO $ documentCreateDocumentFragment doc
196 (childResult, childPostBuild, childVoidAction) <- lift $ buildChild df k v
197 let s = (childResult, childVoidAction)
198 modify (>>childPostBuild)
199 let placeholder = case Map.lookupGT k curState of
200 Nothing -> endPlaceholder
201 Just (_, ((_, (start, _)), _)) -> start
202 Just p <- liftIO $ nodeGetParentNode placeholder
203 liftIO $ nodeInsertBefore p (Just df) (Just placeholder)
204 return $ Just s
205 These state _ -> do
206 liftIO $ putStrLn "Leaving item unchanged"
207 return $ Just state
208 liftIO $ putStrLn "Triggering newChildren"
209 liftIO $ putStrLn . ("newChildrenTriggerRef is Just? " <>) . show . isJust =<< readRef newChildrenTriggerRef
210 runFrameWithTriggerRef newChildrenTriggerRef newState
211 postBuild
212 liftIO $ putStrLn "Triggering newChildren done"
213 holdDyn Map.empty $ fmap (fmap (fst . fst)) newChildren
215listWithKey' :: 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))
216listWithKey' initialVals valsChanged mkChild = do
217 doc <- askDocument
218 startPlaceholder <- text' ""
219 endPlaceholder <- text' ""
220 (newChildren, newChildrenTriggerRef) <- newEventWithTriggerRef
221-- performEvent_ $ fmap (const $ return ()) newChildren --TODO: Get rid of this hack
222 runWidget <- getRunWidget
223 let childValChangedSelector :: EventSelector t (Const2 k v)
224 childValChangedSelector = fanMap $ fmap (Map.mapMaybe id) valsChanged
225 buildChild df k v = runWidget df $ wrapChild k v
226 wrapChild k v = do
227 childStart <- text' ""
228 result <- mkChild k v $ select childValChangedSelector $ Const2 k
229 childEnd <- text' ""
230 return (result, (childStart, childEnd))
231 Just df <- liftIO $ documentCreateDocumentFragment doc
232 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
233 children <- holdDyn initialState $ traceEventWith (\x -> "newChildren: " <> show (Map.size x)) newChildren
234 addVoidAction $ switch $ fmap (mergeWith (>>) . map snd . Map.elems) $ current children
235 Just p <- liftIO $ nodeGetParentNode endPlaceholder
236 liftIO $ nodeInsertBefore p (Just df) (Just endPlaceholder)
237 addVoidAction $ flip fmap valsChanged $ \newVals -> do
238 curState <- sample $ current children
239 --TODO: Should we remove the parent from the DOM first to avoid reflows?
240 (newState, postBuild) <- flip runStateT (return ()) $ liftM (Map.mapMaybe id) $ iforM (align curState newVals) $ \k -> \case
241 These ((_, (start, end)), _) Nothing -> do -- Deleting child
242 liftIO $ deleteBetweenInclusive start end
243 return Nothing
244 These ((_, (start, end)), _) (Just v) -> do -- Replacing existing child
245 liftIO $ deleteBetweenExclusive start end
246 Just df <- liftIO $ documentCreateDocumentFragment doc
247 (childResult, childPostBuild, childVoidAction) <- lift $ buildChild df k v
248 let s = (childResult, childVoidAction)
249 modify (>>childPostBuild)
250 Just p <- liftIO $ nodeGetParentNode end
251 liftIO $ nodeInsertBefore p (Just df) (Just end)
252 return $ Just s
253 That Nothing -> return Nothing -- Deleting non-existent child
254 That (Just v) -> do -- Creating new child
255 Just df <- liftIO $ documentCreateDocumentFragment doc
256 (childResult, childPostBuild, childVoidAction) <- lift $ buildChild df k v
257 let s = (childResult, childVoidAction)
258 modify (>>childPostBuild)
259 let placeholder = case Map.lookupGT k curState of
260 Nothing -> endPlaceholder
261 Just (_, ((_, (start, _)), _)) -> start
262 Just p <- liftIO $ nodeGetParentNode placeholder
263 liftIO $ nodeInsertBefore p (Just df) (Just placeholder)
264 return $ Just s
265 This state -> do -- No change
266 return $ Just state
267 liftIO $ putStrLn "Triggering newChildren"
268 liftIO $ putStrLn . ("newChildrenTriggerRef is Just? " <>) . show . isJust =<< readRef newChildrenTriggerRef
269 runFrameWithTriggerRef newChildrenTriggerRef newState
270 postBuild
271 liftIO $ putStrLn "Triggering newChildren done"
272 mapDyn (fmap (fst . fst)) children
274--TODO: Something better than Dynamic t (Map k v) - we want something where the Events carry diffs, not the whole value
275listViewWithKey :: (Ord k, MonadWidget t m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m (Event t a)) -> m (Event t (Map k a))
276listViewWithKey vals mkChild = liftM (switch . fmap mergeMap) $ listViewWithKey' vals mkChild
278listViewWithKey' :: (Ord k, MonadWidget t m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m a) -> m (Behavior t (Map k a))
279listViewWithKey' vals mkChild = do
280 doc <- askDocument
281 startPlaceholder <- text' ""
282 endPlaceholder <- text' ""
283 (newChildren, newChildrenTriggerRef) <- newEventWithTriggerRef
284 performEvent_ $ fmap (const $ return ()) newChildren --TODO: Get rid of this hack
285 children <- hold Map.empty $ traceEventWith (\x -> "newChildren: " <> show (Map.size x)) newChildren
286 addVoidAction $ switch $ fmap (mergeWith (>>) . map snd . Map.elems) children
287 runWidget <- getRunWidget
288 let buildChild df k v = runWidget df $ do
289 childStart <- text' ""
290 result <- mkChild k =<< holdDyn v (fmapMaybe (Map.lookup k) (updated vals))
291 childEnd <- text' ""
292 return (result, (childStart, childEnd))
293 schedulePostBuild $ do
294 Just df <- liftIO $ documentCreateDocumentFragment doc
295 curVals <- sample $ current vals
296 initialState <- iforM curVals $ \k v -> do
297 (result, postBuild, voidAction) <- buildChild df k v
298 return ((result, voidAction), postBuild)
299 runFrameWithTriggerRef newChildrenTriggerRef $ fmap fst initialState --TODO: Do all these in a single runFrame
300 sequence $ fmap snd initialState
301 Just p <- liftIO $ nodeGetParentNode endPlaceholder
302 liftIO $ nodeInsertBefore p (Just df) (Just endPlaceholder)
303 return ()
304 addVoidAction $ flip fmap (updated vals) $ \newVals -> do
305 curState <- sample children
306 --TODO: Should we remove the parent from the DOM first to avoid reflows?
307 (newState, postBuild) <- flip runStateT (return ()) $ liftM (Map.mapMaybe id) $ iforM (align curState newVals) $ \k -> \case
308 This ((_, (start, end)), _) -> do
309 liftIO $ putStrLn "Deleting item"
310 liftIO $ deleteBetweenInclusive start end
311 return Nothing
312 That v -> do
313 liftIO $ putStrLn "Creating item"
314 Just df <- liftIO $ documentCreateDocumentFragment doc
315 (childResult, childPostBuild, childVoidAction) <- lift $ buildChild df k v
316 let s = (childResult, childVoidAction)
317 modify (>>childPostBuild)
318 let placeholder = case Map.lookupGT k curState of
319 Nothing -> endPlaceholder
320 Just (_, ((_, (start, _)), _)) -> start
321 Just p <- liftIO $ nodeGetParentNode placeholder
322 liftIO $ nodeInsertBefore p (Just df) (Just placeholder)
323 return $ Just s
324 These state _ -> do
325 liftIO $ putStrLn "Leaving item unchanged"
326 return $ Just state
327 liftIO $ putStrLn "Triggering newChildren"
328 liftIO $ putStrLn . ("newChildrenTriggerRef is Just? " <>) . show . isJust =<< readRef newChildrenTriggerRef
329 runFrameWithTriggerRef newChildrenTriggerRef newState
330 postBuild
331 liftIO $ putStrLn "Triggering newChildren done"
332 return $ fmap (fmap (fst . fst)) children
334--TODO: Deduplicate the various list*WithKey* implementations
336selectViewListWithKey_ :: 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)
337selectViewListWithKey_ selection vals mkChild = do
338 let selectionDemux = demux selection -- For good performance, this value must be shared across all children
339 selectChild <- listWithKey vals $ \k v -> do
340 selected <- getDemuxed selectionDemux k
341 selectSelf <- mkChild k v selected
342 return $ fmap (const k) selectSelf
343 liftM switchPromptlyDyn $ mapDyn (leftmost . Map.elems) selectChild
345--------------------------------------------------------------------------------
346-- Basic DOM manipulation helpers
347--------------------------------------------------------------------------------
349-- | s and e must both be children of the same node and s must precede e
350deleteBetweenExclusive s e = do
351 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
352 let go = do
353 Just x <- nodeGetPreviousSibling e -- This can't be Nothing because we should hit 's' first
354 when (unNode (toNode s) /= unNode (toNode x)) $ do
355 nodeRemoveChild currentParent $ Just x
356 go
357 go
359-- | s and e must both be children of the same node and s must precede e
360deleteBetweenInclusive s e = do
361 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
362 let go = do
363 Just x <- nodeGetPreviousSibling e -- This can't be Nothing because we should hit 's' first
364 nodeRemoveChild currentParent $ Just x
365 when (unNode (toNode s) /= unNode (toNode x)) go
366 go
367 nodeRemoveChild currentParent $ Just e
369--------------------------------------------------------------------------------
370-- Adapters
371--------------------------------------------------------------------------------
373--TODO: Get rid of extra version of this function
374wrapDomEvent 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 v <- {-# SCC "d" #-} getValue
380 liftIO $ postGui $ runWithActions [et :=> v]
381 return $ liftIO $ do
382 {-# SCC "e" #-} unsubscribe
383 return $! {-# SCC "f" #-} e
385wrapElement :: (Functor (Event t), MonadIO m, MonadSample t m, MonadReflexCreateTrigger t m, Reflex t, HasPostGui t h m) => HTMLElement -> m (El t)
386wrapElement e = do
387 clicked <- wrapDomEvent e elementOnclick (return ())
388 keypress <- wrapDomEvent e elementOnkeypress $ liftIO . uiEventGetKeyCode =<< event
389 scrolled <- wrapDomEvent e elementOnscroll $ liftIO $ elementGetScrollTop e
390 return $ El e clicked keypress scrolled
392elDynAttr' :: forall t m a. MonadWidget t m => String -> Dynamic t (Map String String) -> m a -> m (El t, a)
393elDynAttr' elementTag attrs child = do
394 (e, result) <- buildElement elementTag attrs child
395 e' <- wrapElement e
396 return (e', result)
398{-# INLINABLE elAttr #-}
399elAttr :: forall t m a. MonadWidget t m => String -> Map String String -> m a -> m a
400elAttr elementTag attrs child = do
401 (_, result) <- buildElement elementTag attrs child
402 return result
404{-# INLINABLE el' #-}
405el' :: forall t m a. MonadWidget t m => String -> m a -> m (El t, a)
406el' tag child = elAttr' tag (Map.empty :: AttributeMap) child
408{-# INLINABLE elAttr' #-}
409elAttr' :: forall t m a. MonadWidget t m => String -> Map String String -> m a -> m (El t, a)
410elAttr' elementTag attrs child = do
411 (e, result) <- buildElement elementTag attrs child
412 e' <- wrapElement e
413 return (e', result)
415{-# INLINABLE elDynAttr #-}
416elDynAttr :: forall t m a. MonadWidget t m => String -> Dynamic t (Map String String) -> m a -> m a
417elDynAttr elementTag attrs child = do
418 (_, result) <- buildElement elementTag attrs child
419 return result
421{-# INLINABLE el #-}
422el :: forall t m a. MonadWidget t m => String -> m a -> m a
423el tag child = elAttr tag Map.empty child
425elClass :: forall t m a. MonadWidget t m => String -> String -> m a -> m a
426elClass tag c child = elAttr tag ("class" =: c) child
428--------------------------------------------------------------------------------
429-- Copied and pasted from Reflex.Widget.Class
430--------------------------------------------------------------------------------
432list dm mkChild = listWithKey dm (\_ dv -> mkChild dv)
434elDynHtml' :: MonadWidget t m => String -> Dynamic t String -> m (El t)
435elDynHtml' elementTag html = do
436 e <- buildEmptyElement elementTag (Map.empty :: Map String String)
437 schedulePostBuild $ liftIO . htmlElementSetInnerHTML e =<< sample (current html)
438 addVoidAction $ fmap (liftIO . htmlElementSetInnerHTML e) $ updated html
439 wrapElement e
441{-
443--TODO: Update dynamically
444{-# INLINABLE dynHtml #-}
445dynHtml :: MonadWidget t m => Dynamic t String -> m ()
446dynHtml ds = do
447 let mkSelf h = do
448 doc <- askDocument
449 Just e <- liftIO $ liftM (fmap castToHTMLElement) $ documentCreateElement doc "div"
450 liftIO $ htmlElementSetInnerHTML e h
451 return e
452 eCreated <- performEvent . fmap mkSelf . tagDyn ds =<< getEInit
453 putEChildren $ fmap ((:[]) . toNode) eCreated
455-}
457data Link t
458 = Link { _link_clicked :: Event t ()
459 }
461linkClass :: MonadWidget t m => String -> String -> m (Link t)
462linkClass s c = do
463 (l,_) <- elAttr' "a" ("class" =: c) $ text s
464 return $ Link $ _el_clicked l
466link :: MonadWidget t m => String -> m (Link t)
467link s = linkClass s ""
469newtype Workflow t m a = Workflow { unWorkflow :: m (a, Event t (Workflow t m a)) }
471workflowView :: forall t m a. MonadWidget t m => Workflow t m a -> m (Event t a)
472workflowView w0 = do
473 rec eResult <- dyn =<< mapDyn unWorkflow =<< holdDyn w0 eReplace
474 eReplace <- liftM switch $ hold never $ fmap snd eResult
475 eResult `seq` eReplace `seq` return ()
476 return $ fmap fst eResult
478divClass :: forall t m a. MonadWidget t m => String -> m a -> m a
479divClass = elClass "div"
481dtdd :: forall t m a. MonadWidget t m => String -> m a -> m a
482dtdd h w = do
483 el "dt" $ text h
484 el "dd" $ w
486blank :: forall t m. MonadWidget t m => m ()
487blank = return ()
489tableDynAttr :: 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])))
490tableDynAttr klass cols dRows rowAttrs = elAttr "div" (Map.singleton "style" "zoom: 1; overflow: auto; background: white;") $ do
491 elAttr "table" (Map.singleton "class" klass) $ do
492 el "thead" $ el "tr" $ do
493 mapM (\(h, _) -> el "th" $ text h) cols
494 el "tbody" $ do
495 listWithKey dRows (\k r -> do
496 dAttrs <- rowAttrs k
497 elDynAttr' "tr" dAttrs $ mapM (\x -> el "td" $ snd x k r) cols)
499--TODO preselect a tab on open
500tabDisplay :: forall t m k. (MonadFix m, MonadWidget t m, Show k, Ord k) => String -> String -> Map k (String, m ()) -> m ()
501tabDisplay ulClass activeClass tabItems = do
502 rec dCurrentTab <- holdDyn Nothing (updated dTabClicks)
503 dTabClicks :: Dynamic t (Maybe k) <- elAttr "ul" (Map.singleton "class" ulClass) $ do
504 tabClicksList :: [Event t k] <- (liftM Map.elems) $ imapM (\k (s,_) -> headerBarLink s k =<< mapDyn (== (Just k)) dCurrentTab) tabItems
505 let eTabClicks :: Event t k = leftmost tabClicksList
506 holdDyn Nothing $ fmap Just eTabClicks :: m (Dynamic t (Maybe k))
507 divClass "" $ do
508 let dTabs :: Dynamic t (Map k (String, m ())) = constDyn tabItems
509 listWithKey dTabs (\k dTab -> do
510 dAttrs <- mapDyn (\sel -> do
511 let t1 = listToMaybe $ Map.keys tabItems
512 if sel == Just k || (sel == Nothing && t1 == Just k) then Map.empty else Map.singleton "style" "display:none;") dCurrentTab
513 elDynAttr "div" dAttrs $ dyn =<< mapDyn snd dTab)
514 return ()
515 where
516 headerBarLink :: (MonadWidget t m, Ord k) => String -> k -> Dynamic t Bool -> m (Event t k)
517 headerBarLink x k dBool = do
518 dAttributes <- mapDyn (\b -> if b then Map.singleton "class" activeClass else Map.empty) dBool
519 elDynAttr "li" dAttributes $ do
520 a <- link x
521 return $ fmap (const k) (_link_clicked a)
523-- | 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.
524unsafePlaceElement :: MonadWidget t m => HTMLElement -> m (El t)
525unsafePlaceElement e = do
526 p <- askParent
527 liftIO $ nodeAppendChild p $ Just e
528 wrapElement e