git.iko.soy/reflex-dom
on 776e2fa help sign in
reflex-dom/src/Reflex/Dom/Widget/Basic.hs
483 lines 23 kB history raw
1{-# LANGUAGE ConstraintKinds #-}
2{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE GADTs #-}
6{-# LANGUAGE LambdaCase #-}
7{-# LANGUAGE MultiParamTypeClasses #-}
8{-# LANGUAGE OverloadedStrings #-}
9{-# LANGUAGE RankNTypes #-}
10{-# LANGUAGE RecursiveDo #-}
11{-# LANGUAGE ScopedTypeVariables #-}
12{-# LANGUAGE TypeFamilies #-}
13module Reflex.Dom.Widget.Basic
14 ( partitionMapBySetLT
15 , listHoldWithKey
16 , ChildResult (..)
18 -- * Displaying Values
19 , text
20 , dynText
21 , display
22 , button
23 , dyn
24 , widgetHold
26 -- * Working with Maps
27 , diffMapNoEq
28 , diffMap
29 , applyMap
30 , mapPartitionEithers
31 , applyMapKeysSet
33 -- * Widgets on Collections
34 , listWithKey
35 , listWithKey'
36 , listWithKeyShallowDiff
37 , listViewWithKey
38 , selectViewListWithKey
39 , selectViewListWithKey_
41 -- * Creating DOM Elements
42 , el
43 , elAttr
44 , elClass
45 , elDynAttr
46 , elDynClass
48 -- ** With Element Results
49 , el'
50 , elAttr'
51 , elClass'
52 , elDynAttr'
53 , elDynClass'
54 , elDynAttrNS'
55 , dynamicAttributesToModifyAttributes
57 -- * List Utils
58 , list
59 , simpleList
61 -- * Specific DOM Elements
62 , Link (..)
63 , linkClass
64 , link
65 , divClass
66 , dtdd
67 , blank
69 -- * Workflows
70 , Workflow (..)
71 , workflow
72 , workflowView
73 , mapWorkflow
74 , mapWorkflowCheap
76 -- * Tables and Lists
77 , tableDynAttr
78 , tabDisplay
80 , HasAttributes (..)
81 ) where
83import Reflex.Class
84import Reflex.Dom.Builder.Class
85import Reflex.Dom.Class
86import Reflex.Dom.Internal.Foreign ()
87import Reflex.Dynamic
88import Reflex.PostBuild.Class
90import Control.Arrow
91import Control.Lens hiding (children, element)
92import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_, sequence, sequence_)
93import Data.Align
94import Data.Default
95import Data.Either
96import Data.Foldable
97import Data.Functor.Misc
98import Data.Map (Map)
99import qualified Data.Map as Map
100import Data.Maybe
101import Data.Set (Set)
102import qualified Data.Set as Set
103import Data.Text (Text)
104import qualified Data.Text as T
105import Data.These
106import Data.Traversable
107import Prelude hiding (mapM, mapM_, sequence, sequence_)
109widgetHoldInternal :: forall t m a b. DomBuilder t m => m a -> Event t (m b) -> m (a, Event t b)
110widgetHoldInternal = runWithReplace
112-- | Breaks the given Map into pieces based on the given Set. Each piece will contain only keys that are less than the key of the piece, and greater than or equal to the key of the piece with the next-smaller key. There will be one additional piece containing all keys from the original Map that are larger or equal to the largest key in the Set.
113-- Either k () is used instead of Maybe k so that the resulting map of pieces is sorted so that the additional piece has the largest key.
114-- No empty pieces will be included in the output.
116--TODO: This can probably be done more efficiently by dividing and conquering, re-using the structure of the Set instead of going through the Set linearally
117partitionMapBySetLT :: forall k v. Ord k => Set k -> Map k v -> Map (Either k ()) (Map k v)
118partitionMapBySetLT s m0 = Map.fromDistinctAscList $ go (Set.toAscList s) m0
119 where go :: [k] -> Map k v -> [(Either k (), Map k v)]
120 go [] m = if Map.null m
121 then []
122 else [(Right (), m)]
123 go (h:t) m = let (lt, eq, gt) = Map.splitLookup h m
124 geq = maybe id (Map.insert h) eq gt
125 in if Map.null lt
126 then go t geq
127 else (Left h, lt) : go t geq
129newtype ChildResult t k a = ChildResult { unChildResult :: (a, Event t (Map k (Maybe (ChildResult t k a)))) }
131listHoldWithKey :: forall t m k v a. (Ord k, DomBuilder t m, MonadHold t m) => Map k v -> Event t (Map k (Maybe v)) -> (k -> v -> m a) -> m (Dynamic t (Map k a))
132listHoldWithKey m0 m' f = do
133 let dm0 = mapWithFunctorToDMap $ Map.mapWithKey f m0
134 dm' = fmap (PatchDMap . mapWithFunctorToDMap . Map.mapWithKey (\k v -> ComposeMaybe $ fmap (f k) v)) m'
135 (a0, a') <- sequenceDMapWithAdjust dm0 dm'
136 fmap dmapToMap . incrementalToDynamic <$> holdIncremental a0 a' --TODO: Move the dmapToMap to the righthand side so it doesn't get fully redone every time
138text :: DomBuilder t m => Text -> m ()
139text t = void $ textNode $ def & textNodeConfig_initialContents .~ t
141dynText :: forall t m. (PostBuild t m, DomBuilder t m) => Dynamic t Text -> m ()
142dynText t = do
143 postBuild <- getPostBuild
144 void $ textNode $ (def :: TextNodeConfig t) & textNodeConfig_setContents .~ leftmost
145 [ updated t
146 , tag (current t) postBuild
147 ]
149display :: (PostBuild t m, DomBuilder t m, Show a) => Dynamic t a -> m ()
150display = dynText . fmap (T.pack . show)
152button :: DomBuilder t m => Text -> m (Event t ())
153button t = do
154 (e, _) <- element "button" def $ text t
155 return $ domEvent Click e
157--TODO: Should this be renamed to 'widgetView' for consistency with 'widgetHold'?
158-- | Given a Dynamic of widget-creating actions, create a widget that is recreated whenever the Dynamic updates.
159-- The returned Event of widget results occurs when the Dynamic does.
160-- Note: Often, the type 'a' is an Event, in which case the return value is an Event-of-Events that would typically be flattened (via 'switchPromptly').
161dyn :: (DomBuilder t m, PostBuild t m) => Dynamic t (m a) -> m (Event t a)
162dyn child = do
163 postBuild <- getPostBuild
164 let newChild = leftmost [updated child, tagCheap (current child) postBuild]
165 snd <$> widgetHoldInternal (return ()) newChild
167-- | Given an initial widget and an Event of widget-creating actions, create a widget that is recreated whenever the Event fires.
168-- The returned Dynamic of widget results occurs when the Event does.
169-- Note: Often, the type 'a' is an Event, in which case the return value is a Dynamic-of-Events that would typically be flattened.
170widgetHold :: (DomBuilder t m, MonadHold t m) => m a -> Event t (m a) -> m (Dynamic t a)
171widgetHold child0 newChild = do
172 (result0, newResult) <- widgetHoldInternal child0 newChild
173 holdDyn result0 newResult
175diffMapNoEq :: (Ord k) => Map k v -> Map k v -> Map k (Maybe v)
176diffMapNoEq olds news = flip Map.mapMaybe (align olds news) $ \case
177 This _ -> Just Nothing
178 These _ new -> Just $ Just new
179 That new -> Just $ Just new
181diffMap :: (Ord k, Eq v) => Map k v -> Map k v -> Map k (Maybe v)
182diffMap olds news = flip Map.mapMaybe (align olds news) $ \case
183 This _ -> Just Nothing
184 These old new
185 | old == new -> Nothing
186 | otherwise -> Just $ Just new
187 That new -> Just $ Just new
189applyMap :: Ord k => Map k (Maybe v) -> Map k v -> Map k v
190applyMap patch old = insertions `Map.union` (old `Map.difference` deletions)
191 where (deletions, insertions) = mapPartitionEithers $ maybeToEither <$> patch
192 maybeToEither = \case
193 Nothing -> Left ()
194 Just r -> Right r
196mapPartitionEithers :: Map k (Either a b) -> (Map k a, Map k b)
197mapPartitionEithers m = (fromLeft <$> ls, fromRight <$> rs)
198 where (ls, rs) = Map.partition isLeft m
199 fromLeft (Left l) = l
200 fromLeft _ = error "mapPartitionEithers: fromLeft received a Right value; this should be impossible"
201 fromRight (Right r) = r
202 fromRight _ = error "mapPartitionEithers: fromRight received a Left value; this should be impossible"
204-- | Apply a map patch to a set
205-- > applyMapKeysSet patch (Map.keysSet m) == Map.keysSet (applyMap patch m)
206applyMapKeysSet :: Ord k => Map k (Maybe v) -> Set k -> Set k
207applyMapKeysSet patch old = Map.keysSet insertions `Set.union` (old `Set.difference` Map.keysSet deletions)
208 where (insertions, deletions) = Map.partition isJust patch
210--TODO: Something better than Dynamic t (Map k v) - we want something where the Events carry diffs, not the whole value
211listWithKey :: forall t k v m a. (Ord k, DomBuilder t m, PostBuild t m, MonadFix m, MonadHold t m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m a) -> m (Dynamic t (Map k a))
212listWithKey vals mkChild = do
213 postBuild <- getPostBuild
214 let childValChangedSelector = fanMap $ updated vals
215 -- We keep track of changes to children values in the mkChild function we pass to listHoldWithKey
216 -- The other changes we need to keep track of are child insertions and deletions. diffOnlyKeyChanges
217 -- keeps track of insertions and deletions but ignores value changes, since they're already accounted for.
218 diffOnlyKeyChanges olds news = flip Map.mapMaybe (align olds news) $ \case
219 This _ -> Just Nothing
220 These _ _ -> Nothing
221 That new -> Just $ Just new
222 rec sentVals :: Dynamic t (Map k v) <- foldDyn applyMap Map.empty changeVals
223 let changeVals :: Event t (Map k (Maybe v))
224 changeVals = attachWith diffOnlyKeyChanges (current sentVals) $ leftmost
225 [ updated vals
226 , tag (current vals) postBuild --TODO: This should probably be added to the attachWith, not to the updated; if we were using diffMap instead of diffMapNoEq, I think it might not work
227 ]
228 listHoldWithKey Map.empty changeVals $ \k v ->
229 mkChild k =<< holdDyn v (select childValChangedSelector $ Const2 k)
231{-# DEPRECATED listWithKey' "listWithKey' has been renamed to listWithKeyShallowDiff; also, its behavior has changed to fix a bug where children were always rebuilt (never updated)" #-}
232listWithKey' :: (Ord k, DomBuilder t m, MonadFix m, MonadHold t m) => Map k v -> Event t (Map k (Maybe v)) -> (k -> v -> Event t v -> m a) -> m (Dynamic t (Map k a))
233listWithKey' = listWithKeyShallowDiff
235-- | Display the given map of items (in key order) using the builder function provided, and update it with the given event. 'Nothing' update entries will delete the corresponding children, and 'Just' entries will create them if they do not exist or send an update event to them if they do.
236listWithKeyShallowDiff :: (Ord k, DomBuilder t m, MonadFix m, MonadHold t m) => Map k v -> Event t (Map k (Maybe v)) -> (k -> v -> Event t v -> m a) -> m (Dynamic t (Map k a))
237listWithKeyShallowDiff initialVals valsChanged mkChild = do
238 let childValChangedSelector = fanMap $ fmap (Map.mapMaybe id) valsChanged
239 sentVals <- foldDyn applyMap Map.empty $ fmap (fmap void) valsChanged
240 let relevantPatch patch _ = case patch of
241 Nothing -> Just Nothing -- Even if we let a Nothing through when the element doesn't already exist, this doesn't cause a problem because it is ignored
242 Just _ -> Nothing -- We don't want to let spurious re-creations of items through
243 listHoldWithKey initialVals (attachWith (flip (Map.differenceWith relevantPatch)) (current sentVals) valsChanged) $ \k v ->
244 mkChild k v $ select childValChangedSelector $ Const2 k
246--TODO: Something better than Dynamic t (Map k v) - we want something where the Events carry diffs, not the whole value
247-- | Create a dynamically-changing set of Event-valued widgets.
248-- This is like listWithKey, specialized for widgets returning (Event t a). listWithKey would return 'Dynamic t (Map k (Event t a))' in this scenario, but listViewWithKey flattens this to 'Event t (Map k a)' via 'switch'.
249listViewWithKey :: (Ord k, DomBuilder t m, PostBuild t m, MonadHold t m, MonadFix m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m (Event t a)) -> m (Event t (Map k a))
250listViewWithKey vals mkChild = switch . fmap mergeMap <$> listViewWithKey' vals mkChild
252listViewWithKey' :: (Ord k, DomBuilder t m, PostBuild t m, MonadHold t m, MonadFix m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m a) -> m (Behavior t (Map k a))
253listViewWithKey' vals mkChild = current <$> listWithKey vals mkChild
255-- | Create a dynamically-changing set of widgets, one of which is selected at any time.
256selectViewListWithKey :: forall t m k v a. (DomBuilder t m, Ord k, PostBuild t m, MonadHold t m, MonadFix m)
257 => Dynamic t k -- ^ Current selection key
258 -> Dynamic t (Map k v) -- ^ Dynamic key/value map
259 -> (k -> Dynamic t v -> Dynamic t Bool -> m (Event t a)) -- ^ Function to create a widget for a given key from Dynamic value and Dynamic Bool indicating if this widget is currently selected
260 -> m (Event t (k, a)) -- ^ Event that fires when any child's return Event fires. Contains key of an arbitrary firing widget.
261selectViewListWithKey selection vals mkChild = do
262 let selectionDemux = demux selection -- For good performance, this value must be shared across all children
263 selectChild <- listWithKey vals $ \k v -> do
264 let selected = demuxed selectionDemux k
265 selectSelf <- mkChild k v selected
266 return $ fmap ((,) k) selectSelf
267 return $ switchPromptlyDyn $ leftmost . Map.elems <$> selectChild
269selectViewListWithKey_ :: forall t m k v a. (DomBuilder t m, Ord k, PostBuild t m, MonadHold t m, MonadFix m)
270 => Dynamic t k -- ^ Current selection key
271 -> Dynamic t (Map k v) -- ^ Dynamic key/value map
272 -> (k -> Dynamic t v -> Dynamic t Bool -> m (Event t a)) -- ^ Function to create a widget for a given key from Dynamic value and Dynamic Bool indicating if this widget is currently selected
273 -> m (Event t k) -- ^ Event that fires when any child's return Event fires. Contains key of an arbitrary firing widget.
274selectViewListWithKey_ selection vals mkChild = fmap fst <$> selectViewListWithKey selection vals mkChild
276-- | Create a DOM element
277-- > el "div" (text "Hello World")
278-- <div>Hello World</div>
279{-# INLINABLE el #-}
280el :: forall t m a. DomBuilder t m => Text -> m a -> m a
281el elementTag child = snd <$> el' elementTag child
283-- | Create a DOM element with attributes
284-- > elAttr "a" ("href" =: "http://google.com") (text "Google!")
285-- <a href="http://google.com">Google!</a>
286{-# INLINABLE elAttr #-}
287elAttr :: forall t m a. DomBuilder t m => Text -> Map Text Text -> m a -> m a
288elAttr elementTag attrs child = snd <$> elAttr' elementTag attrs child
290-- | Create a DOM element with classes
291-- > elClass "div" "row" (return ())
292-- <div class="row"></div>
293{-# INLINABLE elClass #-}
294elClass :: forall t m a. DomBuilder t m => Text -> Text -> m a -> m a
295elClass elementTag c child = snd <$> elClass' elementTag c child
297-- | Create a DOM element with Dynamic Attributes
298-- > elClass "div" (constDyn ("class" =: "row")) (return ())
299-- <div class="row"></div>
300{-# INLINABLE elDynAttr #-}
301elDynAttr :: forall t m a. (DomBuilder t m, PostBuild t m) => Text -> Dynamic t (Map Text Text) -> m a -> m a
302elDynAttr elementTag attrs child = snd <$> elDynAttr' elementTag attrs child
304-- | Create a DOM element with a Dynamic Class
305-- > elDynClass "div" (constDyn "row") (return ())
306-- <div class="row"></div>
307{-# INLINABLE elDynClass #-}
308elDynClass :: forall t m a. (DomBuilder t m, PostBuild t m) => Text -> Dynamic t Text -> m a -> m a
309elDynClass elementTag c child = snd <$> elDynClass' elementTag c child
311-- | Create a DOM element and return the element
312-- > do (e, _) <- el' "div" (text "Click")
313-- > return $ domEvent Click e
314{-# INLINABLE el' #-}
315el' :: forall t m a. DomBuilder t m => Text -> m a -> m (Element EventResult (DomBuilderSpace m) t, a)
316el' elementTag = element elementTag def
318-- | Create a DOM element with attributes and return the element
319{-# INLINABLE elAttr' #-}
320elAttr' :: forall t m a. DomBuilder t m => Text -> Map Text Text -> m a -> m (Element EventResult (DomBuilderSpace m) t, a)
321elAttr' elementTag attrs = element elementTag $ def
322 & initialAttributes .~ Map.mapKeys (AttributeName Nothing) attrs
324-- | Create a DOM element with a class and return the element
325{-# INLINABLE elClass' #-}
326elClass' :: forall t m a. DomBuilder t m => Text -> Text -> m a -> m (Element EventResult (DomBuilderSpace m) t, a)
327elClass' elementTag c = elAttr' elementTag ("class" =: c)
329-- | Create a DOM element with Dynamic Attributes and return the element
330{-# INLINABLE elDynAttr' #-}
331elDynAttr' :: forall t m a. (DomBuilder t m, PostBuild t m) => Text -> Dynamic t (Map Text Text) -> m a -> m (Element EventResult (DomBuilderSpace m) t, a)
332elDynAttr' = elDynAttrNS' Nothing
334-- | Create a DOM element with a Dynamic class and return the element
335{-# INLINABLE elDynClass' #-}
336elDynClass' :: forall t m a. (DomBuilder t m, PostBuild t m) => Text -> Dynamic t Text -> m a -> m (Element EventResult (DomBuilderSpace m) t, a)
337elDynClass' elementTag c = elDynAttr' elementTag (fmap ("class" =:) c)
339{-# INLINABLE elDynAttrNS' #-}
340elDynAttrNS' :: forall t m a. (DomBuilder t m, PostBuild t m) => Maybe Text -> Text -> Dynamic t (Map Text Text) -> m a -> m (Element EventResult (DomBuilderSpace m) t, a)
341elDynAttrNS' mns elementTag attrs child = do
342 modifyAttrs <- dynamicAttributesToModifyAttributes attrs
343 let cfg = def
344 & elementConfig_namespace .~ mns
345 & modifyAttributes .~ fmap mapKeysToAttributeName modifyAttrs
346 element elementTag cfg child
348dynamicAttributesToModifyAttributes :: (Ord k, PostBuild t m) => Dynamic t (Map k Text) -> m (Event t (Map k (Maybe Text)))
349dynamicAttributesToModifyAttributes = dynamicAttributesToModifyAttributesWithInitial mempty
351dynamicAttributesToModifyAttributesWithInitial :: (Ord k, PostBuild t m) => Map k Text -> Dynamic t (Map k Text) -> m (Event t (Map k (Maybe Text)))
352dynamicAttributesToModifyAttributesWithInitial attrs0 d = do
353 postBuild <- getPostBuild
354 let modificationsNeeded = flip pushAlways (align postBuild $ updated d) $ \case
355 This () -> do
356 new <- sample $ current d
357 return $ diffMap attrs0 new
358 These () new -> return $ diffMap attrs0 new
359 That new -> do
360 old <- sample $ current d
361 return $ diffMap old new
362 return modificationsNeeded
364--------------------------------------------------------------------------------
365-- Copied and pasted from Reflex.Widget.Class
366--------------------------------------------------------------------------------
368-- | Create a dynamically-changing set of widgets from a Dynamic key/value map.
369-- Unlike the 'withKey' variants, the child widgets are insensitive to which key they're associated with.
370list :: (Ord k, DomBuilder t m, MonadHold t m, PostBuild t m, MonadFix m) => Dynamic t (Map k v) -> (Dynamic t v -> m a) -> m (Dynamic t (Map k a))
371list dm mkChild = listWithKey dm (\_ dv -> mkChild dv)
373-- | Create a dynamically-changing set of widgets from a Dynamic list.
374simpleList :: (DomBuilder t m, MonadHold t m, PostBuild t m, MonadFix m) => Dynamic t [v] -> (Dynamic t v -> m a) -> m (Dynamic t [a])
375simpleList xs mkChild = fmap (fmap (map snd . Map.toList)) $ flip list mkChild $ fmap (Map.fromList . zip [(1::Int)..]) xs
377{-
378schedulePostBuild x = performEvent_ . (x <$) =<< getPostBuild
380elDynHtml' :: DomBuilder t m => Text -> Dynamic t Text -> m (El t)
381elDynHtml' elementTag html = do
382 e <- buildEmptyElement elementTag (Map.empty :: Map Text Text)
383 schedulePostBuild $ setInnerHTML e . Just =<< sample (current html)
384 performEvent_ $ fmap (setInnerHTML e . Just) $ updated html
385 wrapElement defaultDomEventHandler e
387elDynHtmlAttr' :: DomBuilder t m => Text -> Map Text Text -> Dynamic t Text -> m (El t)
388elDynHtmlAttr' elementTag attrs html = do
389 e <- buildEmptyElement elementTag attrs
390 schedulePostBuild $ setInnerHTML e . Just =<< sample (current html)
391 performEvent_ $ fmap (setInnerHTML e . Just) $ updated html
392 wrapElement defaultDomEventHandler e
393-}
395data Link t
396 = Link { _link_clicked :: Event t ()
397 }
399linkClass :: DomBuilder t m => Text -> Text -> m (Link t)
400linkClass s c = do
401 (l,_) <- elAttr' "a" ("class" =: c) $ text s
402 return $ Link $ domEvent Click l
404link :: DomBuilder t m => Text -> m (Link t)
405link s = linkClass s ""
407divClass :: forall t m a. DomBuilder t m => Text -> m a -> m a
408divClass = elClass "div"
410dtdd :: forall t m a. DomBuilder t m => Text -> m a -> m a
411dtdd h w = do
412 el "dt" $ text h
413 el "dd" w
415blank :: forall m. Monad m => m ()
416blank = return ()
418newtype Workflow t m a = Workflow { unWorkflow :: m (a, Event t (Workflow t m a)) }
420workflow :: forall t m a. (DomBuilder t m, MonadFix m, MonadHold t m) => Workflow t m a -> m (Dynamic t a)
421workflow w0 = do
422 rec eResult <- widgetHold (unWorkflow w0) $ fmap unWorkflow $ switch $ snd <$> current eResult
423 return $ fmap fst eResult
425workflowView :: forall t m a. (DomBuilder t m, MonadFix m, MonadHold t m, PostBuild t m) => Workflow t m a -> m (Event t a)
426workflowView w0 = do
427 rec eResult <- dyn . fmap unWorkflow =<< holdDyn w0 eReplace
428 eReplace <- fmap switch $ hold never $ fmap snd eResult
429 return $ fmap fst eResult
431mapWorkflow :: (DomBuilder t m) => (a -> b) -> Workflow t m a -> Workflow t m b
432mapWorkflow f (Workflow x) = Workflow (fmap (f *** fmap (mapWorkflow f)) x)
434mapWorkflowCheap :: (DomBuilder t m) => (a -> b) -> Workflow t m a -> Workflow t m b
435mapWorkflowCheap f (Workflow x) = Workflow (fmap (f *** fmapCheap (mapWorkflowCheap f)) x)
437-- | A widget to display a table with static columns and dynamic rows.
438tableDynAttr :: forall t m r k v. (Ord k, DomBuilder t m, MonadHold t m, PostBuild t m, MonadFix m)
439 => Text -- ^ Class applied to <table> element
440 -> [(Text, k -> Dynamic t r -> m v)] -- ^ Columns of (header, row key -> row value -> child widget)
441 -> Dynamic t (Map k r) -- ^ Map from row key to row value
442 -> (k -> m (Dynamic t (Map Text Text))) -- ^ Function to compute <tr> element attributes from row key
443 -> m (Dynamic t (Map k (Element EventResult (DomBuilderSpace m) t, [v]))) -- ^ Map from row key to (El, list of widget return values)
444tableDynAttr klass cols dRows rowAttrs = elAttr "div" (Map.singleton "style" "zoom: 1; overflow: auto; background: white;") $ do
445 elAttr "table" (Map.singleton "class" klass) $ do
446 el "thead" $ el "tr" $ do
447 mapM_ (\(h, _) -> el "th" $ text h) cols
448 el "tbody" $ do
449 listWithKey dRows (\k r -> do
450 dAttrs <- rowAttrs k
451 elDynAttr' "tr" dAttrs $ mapM (\x -> el "td" $ snd x k r) cols)
453-- | A widget to construct a tabbed view that shows only one of its child widgets at a time.
454-- Creates a header bar containing a <ul> with one <li> per child; clicking a <li> displays
455-- the corresponding child and hides all others.
456tabDisplay :: forall t m k. (MonadFix m, DomBuilder t m, MonadHold t m, PostBuild t m, Ord k)
457 => Text -- ^ Class applied to <ul> element
458 -> Text -- ^ Class applied to currently active <li> element
459 -> Map k (Text, m ()) -- ^ Map from (arbitrary) key to (tab label, child widget)
460 -> m ()
461tabDisplay ulClass activeClass tabItems = do
462 let t0 = listToMaybe $ Map.keys tabItems
463 rec currentTab :: Demux t (Maybe k) <- elAttr "ul" ("class" =: ulClass) $ do
464 tabClicksList :: [Event t k] <- Map.elems <$> imapM (\k (s,_) -> headerBarLink s k $ demuxed currentTab (Just k)) tabItems
465 let eTabClicks :: Event t k = leftmost tabClicksList
466 fmap demux $ holdDyn t0 $ fmap Just eTabClicks
467 el "div" $ do
468 iforM_ tabItems $ \k (_, w) -> do
469 let isSelected = demuxed currentTab $ Just k
470 attrs = ffor isSelected $ \s -> if s then Map.empty else Map.singleton "style" "display:none;"
471 elDynAttr "div" attrs w
472 return ()
473 where
474 headerBarLink :: Text -> k -> Dynamic t Bool -> m (Event t k)
475 headerBarLink x k isSelected = do
476 let attrs = fmap (\b -> if b then Map.singleton "class" activeClass else Map.empty) isSelected
477 elDynAttr "li" attrs $ do
478 a <- link x
479 return $ fmap (const k) (_link_clicked a)
481class HasAttributes a where
482 type Attrs a :: *
483 attributes :: Lens' a (Attrs a)