git.iko.soy/reflex-dom
on 1e930c2 help sign in
reflex-dom/src/Reflex/Dom/Widget/Basic.hs
489 lines 24 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.PerformEvent.Class
89import Reflex.PostBuild.Class
91import Control.Arrow
92import Control.Lens hiding (children, element)
93import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_, sequence, sequence_)
94import Data.Align
95import Data.Default
96import Data.Either
97import Data.Foldable
98import Data.Functor.Misc
99import Data.Map (Map)
100import qualified Data.Map as Map
101import Data.Maybe
102import Data.Set (Set)
103import qualified Data.Set as Set
104import Data.Text (Text)
105import qualified Data.Text as T
106import Data.These
107import Data.Traversable
108import Prelude hiding (mapM, mapM_, sequence, sequence_)
110widgetHoldInternal :: forall t m a b. DomBuilder t m => m a -> Event t (m b) -> m (a, Event t b)
111widgetHoldInternal = runWithReplace
113-- | 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.
114-- 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.
115-- No empty pieces will be included in the output.
117--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
118partitionMapBySetLT :: forall k v. Ord k => Set k -> Map k v -> Map (Either k ()) (Map k v)
119partitionMapBySetLT s m0 = Map.fromDistinctAscList $ go (Set.toAscList s) m0
120 where go :: [k] -> Map k v -> [(Either k (), Map k v)]
121 go [] m = if Map.null m
122 then []
123 else [(Right (), m)]
124 go (h:t) m = let (lt, eq, gt) = Map.splitLookup h m
125 geq = maybe id (Map.insert h) eq gt
126 in if Map.null lt
127 then go t geq
128 else (Left h, lt) : go t geq
130newtype ChildResult t k a = ChildResult { unChildResult :: (a, Event t (Map k (Maybe (ChildResult t k a)))) }
132listHoldWithKey :: 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))
133listHoldWithKey m0 m' f = do
134 let dm0 = mapWithFunctorToDMap $ Map.mapWithKey f m0
135 dm' = fmap (PatchDMap . mapWithFunctorToDMap . Map.mapWithKey (\k v -> ComposeMaybe $ fmap (f k) v)) m'
136 (a0, a') <- sequenceDMapWithAdjust dm0 dm'
137 fmap dmapToMap . incrementalToDynamic <$> holdIncremental a0 a' --TODO: Move the dmapToMap to the righthand side so it doesn't get fully redone every time
139text :: DomBuilder t m => Text -> m ()
140text t = void $ textNode $ def & textNodeConfig_initialContents .~ t
142dynText :: forall t m. (PostBuild t m, DomBuilder t m) => Dynamic t Text -> m ()
143dynText t = do
144 postBuild <- getPostBuild
145 void $ textNode $ (def :: TextNodeConfig t) & textNodeConfig_setContents .~ leftmost
146 [ updated t
147 , tag (current t) postBuild
148 ]
149 notReadyUntil postBuild
151display :: (PostBuild t m, DomBuilder t m, Show a) => Dynamic t a -> m ()
152display = dynText . fmap (T.pack . show)
154button :: DomBuilder t m => Text -> m (Event t ())
155button t = do
156 (e, _) <- element "button" def $ text t
157 return $ domEvent Click e
159--TODO: Should this be renamed to 'widgetView' for consistency with 'widgetHold'?
160-- | Given a Dynamic of widget-creating actions, create a widget that is recreated whenever the Dynamic updates.
161-- The returned Event of widget results occurs when the Dynamic does.
162-- 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').
163dyn :: (DomBuilder t m, PostBuild t m) => Dynamic t (m a) -> m (Event t a)
164dyn child = do
165 postBuild <- getPostBuild
166 let newChild = leftmost [updated child, tagCheap (current child) postBuild]
167 result <- snd <$> widgetHoldInternal notReady newChild
168 return result
170-- | Given an initial widget and an Event of widget-creating actions, create a widget that is recreated whenever the Event fires.
171-- The returned Dynamic of widget results occurs when the Event does.
172-- Note: Often, the type 'a' is an Event, in which case the return value is a Dynamic-of-Events that would typically be flattened.
173widgetHold :: (DomBuilder t m, MonadHold t m) => m a -> Event t (m a) -> m (Dynamic t a)
174widgetHold child0 newChild = do
175 (result0, newResult) <- widgetHoldInternal child0 newChild
176 holdDyn result0 newResult
178diffMapNoEq :: (Ord k) => Map k v -> Map k v -> Map k (Maybe v)
179diffMapNoEq olds news = flip Map.mapMaybe (align olds news) $ \case
180 This _ -> Just Nothing
181 These _ new -> Just $ Just new
182 That new -> Just $ Just new
184diffMap :: (Ord k, Eq v) => Map k v -> Map k v -> Map k (Maybe v)
185diffMap olds news = flip Map.mapMaybe (align olds news) $ \case
186 This _ -> Just Nothing
187 These old new
188 | old == new -> Nothing
189 | otherwise -> Just $ Just new
190 That new -> Just $ Just new
192applyMap :: Ord k => Map k (Maybe v) -> Map k v -> Map k v
193applyMap patch old = insertions `Map.union` (old `Map.difference` deletions)
194 where (deletions, insertions) = mapPartitionEithers $ maybeToEither <$> patch
195 maybeToEither = \case
196 Nothing -> Left ()
197 Just r -> Right r
199mapPartitionEithers :: Map k (Either a b) -> (Map k a, Map k b)
200mapPartitionEithers m = (fromLeft <$> ls, fromRight <$> rs)
201 where (ls, rs) = Map.partition isLeft m
202 fromLeft (Left l) = l
203 fromLeft _ = error "mapPartitionEithers: fromLeft received a Right value; this should be impossible"
204 fromRight (Right r) = r
205 fromRight _ = error "mapPartitionEithers: fromRight received a Left value; this should be impossible"
207-- | Apply a map patch to a set
208-- > applyMapKeysSet patch (Map.keysSet m) == Map.keysSet (applyMap patch m)
209applyMapKeysSet :: Ord k => Map k (Maybe v) -> Set k -> Set k
210applyMapKeysSet patch old = Map.keysSet insertions `Set.union` (old `Set.difference` Map.keysSet deletions)
211 where (insertions, deletions) = Map.partition isJust patch
213--TODO: Something better than Dynamic t (Map k v) - we want something where the Events carry diffs, not the whole value
214listWithKey :: 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))
215listWithKey vals mkChild = do
216 postBuild <- getPostBuild
217 let childValChangedSelector = fanMap $ updated vals
218 -- We keep track of changes to children values in the mkChild function we pass to listHoldWithKey
219 -- The other changes we need to keep track of are child insertions and deletions. diffOnlyKeyChanges
220 -- keeps track of insertions and deletions but ignores value changes, since they're already accounted for.
221 diffOnlyKeyChanges olds news = flip Map.mapMaybe (align olds news) $ \case
222 This _ -> Just Nothing
223 These _ _ -> Nothing
224 That new -> Just $ Just new
225 rec sentVals :: Dynamic t (Map k v) <- foldDyn applyMap Map.empty changeVals
226 let changeVals :: Event t (Map k (Maybe v))
227 changeVals = attachWith diffOnlyKeyChanges (current sentVals) $ leftmost
228 [ updated vals
229 , 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
230 ]
231 listHoldWithKey Map.empty changeVals $ \k v ->
232 mkChild k =<< holdDyn v (select childValChangedSelector $ Const2 k)
234{-# DEPRECATED listWithKey' "listWithKey' has been renamed to listWithKeyShallowDiff; also, its behavior has changed to fix a bug where children were always rebuilt (never updated)" #-}
235listWithKey' :: (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))
236listWithKey' = listWithKeyShallowDiff
238-- | 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.
239listWithKeyShallowDiff :: (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))
240listWithKeyShallowDiff initialVals valsChanged mkChild = do
241 let childValChangedSelector = fanMap $ fmap (Map.mapMaybe id) valsChanged
242 sentVals <- foldDyn applyMap Map.empty $ fmap (fmap void) valsChanged
243 let relevantPatch patch _ = case patch of
244 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
245 Just _ -> Nothing -- We don't want to let spurious re-creations of items through
246 listHoldWithKey initialVals (attachWith (flip (Map.differenceWith relevantPatch)) (current sentVals) valsChanged) $ \k v ->
247 mkChild k v $ select childValChangedSelector $ Const2 k
249--TODO: Something better than Dynamic t (Map k v) - we want something where the Events carry diffs, not the whole value
250-- | Create a dynamically-changing set of Event-valued widgets.
251-- 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'.
252listViewWithKey :: (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))
253listViewWithKey vals mkChild = switch . fmap mergeMap <$> listViewWithKey' vals mkChild
255listViewWithKey' :: (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))
256listViewWithKey' vals mkChild = current <$> listWithKey vals mkChild
258-- | Create a dynamically-changing set of widgets, one of which is selected at any time.
259selectViewListWithKey :: forall t m k v a. (DomBuilder t m, Ord k, PostBuild t m, MonadHold t m, MonadFix m)
260 => Dynamic t k -- ^ Current selection key
261 -> Dynamic t (Map k v) -- ^ Dynamic key/value map
262 -> (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
263 -> m (Event t (k, a)) -- ^ Event that fires when any child's return Event fires. Contains key of an arbitrary firing widget.
264selectViewListWithKey selection vals mkChild = do
265 let selectionDemux = demux selection -- For good performance, this value must be shared across all children
266 selectChild <- listWithKey vals $ \k v -> do
267 let selected = demuxed selectionDemux k
268 selectSelf <- mkChild k v selected
269 return $ fmap ((,) k) selectSelf
270 return $ switchPromptlyDyn $ leftmost . Map.elems <$> selectChild
272selectViewListWithKey_ :: forall t m k v a. (DomBuilder t m, Ord k, PostBuild t m, MonadHold t m, MonadFix m)
273 => Dynamic t k -- ^ Current selection key
274 -> Dynamic t (Map k v) -- ^ Dynamic key/value map
275 -> (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
276 -> m (Event t k) -- ^ Event that fires when any child's return Event fires. Contains key of an arbitrary firing widget.
277selectViewListWithKey_ selection vals mkChild = fmap fst <$> selectViewListWithKey selection vals mkChild
279-- | Create a DOM element
280-- > el "div" (text "Hello World")
281-- <div>Hello World</div>
282{-# INLINABLE el #-}
283el :: forall t m a. DomBuilder t m => Text -> m a -> m a
284el elementTag child = snd <$> el' elementTag child
286-- | Create a DOM element with attributes
287-- > elAttr "a" ("href" =: "http://google.com") (text "Google!")
288-- <a href="http://google.com">Google!</a>
289{-# INLINABLE elAttr #-}
290elAttr :: forall t m a. DomBuilder t m => Text -> Map Text Text -> m a -> m a
291elAttr elementTag attrs child = snd <$> elAttr' elementTag attrs child
293-- | Create a DOM element with classes
294-- > elClass "div" "row" (return ())
295-- <div class="row"></div>
296{-# INLINABLE elClass #-}
297elClass :: forall t m a. DomBuilder t m => Text -> Text -> m a -> m a
298elClass elementTag c child = snd <$> elClass' elementTag c child
300-- | Create a DOM element with Dynamic Attributes
301-- > elClass "div" (constDyn ("class" =: "row")) (return ())
302-- <div class="row"></div>
303{-# INLINABLE elDynAttr #-}
304elDynAttr :: forall t m a. (DomBuilder t m, PostBuild t m) => Text -> Dynamic t (Map Text Text) -> m a -> m a
305elDynAttr elementTag attrs child = snd <$> elDynAttr' elementTag attrs child
307-- | Create a DOM element with a Dynamic Class
308-- > elDynClass "div" (constDyn "row") (return ())
309-- <div class="row"></div>
310{-# INLINABLE elDynClass #-}
311elDynClass :: forall t m a. (DomBuilder t m, PostBuild t m) => Text -> Dynamic t Text -> m a -> m a
312elDynClass elementTag c child = snd <$> elDynClass' elementTag c child
314-- | Create a DOM element and return the element
315-- > do (e, _) <- el' "div" (text "Click")
316-- > return $ domEvent Click e
317{-# INLINABLE el' #-}
318el' :: forall t m a. DomBuilder t m => Text -> m a -> m (Element EventResult (DomBuilderSpace m) t, a)
319el' elementTag = element elementTag def
321-- | Create a DOM element with attributes and return the element
322{-# INLINABLE elAttr' #-}
323elAttr' :: forall t m a. DomBuilder t m => Text -> Map Text Text -> m a -> m (Element EventResult (DomBuilderSpace m) t, a)
324elAttr' elementTag attrs = element elementTag $ def
325 & initialAttributes .~ Map.mapKeys (AttributeName Nothing) attrs
327-- | Create a DOM element with a class and return the element
328{-# INLINABLE elClass' #-}
329elClass' :: forall t m a. DomBuilder t m => Text -> Text -> m a -> m (Element EventResult (DomBuilderSpace m) t, a)
330elClass' elementTag c = elAttr' elementTag ("class" =: c)
332-- | Create a DOM element with Dynamic Attributes and return the element
333{-# INLINABLE elDynAttr' #-}
334elDynAttr' :: 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)
335elDynAttr' = elDynAttrNS' Nothing
337-- | Create a DOM element with a Dynamic class and return the element
338{-# INLINABLE elDynClass' #-}
339elDynClass' :: forall t m a. (DomBuilder t m, PostBuild t m) => Text -> Dynamic t Text -> m a -> m (Element EventResult (DomBuilderSpace m) t, a)
340elDynClass' elementTag c = elDynAttr' elementTag (fmap ("class" =:) c)
342{-# INLINABLE elDynAttrNS' #-}
343elDynAttrNS' :: 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)
344elDynAttrNS' mns elementTag attrs child = do
345 modifyAttrs <- dynamicAttributesToModifyAttributes attrs
346 let cfg = def
347 & elementConfig_namespace .~ mns
348 & modifyAttributes .~ fmapCheap mapKeysToAttributeName modifyAttrs
349 result <- element elementTag cfg child
350 postBuild <- getPostBuild
351 notReadyUntil postBuild
352 return result
354dynamicAttributesToModifyAttributes :: (Ord k, PostBuild t m) => Dynamic t (Map k Text) -> m (Event t (Map k (Maybe Text)))
355dynamicAttributesToModifyAttributes = dynamicAttributesToModifyAttributesWithInitial mempty
357dynamicAttributesToModifyAttributesWithInitial :: (Ord k, PostBuild t m) => Map k Text -> Dynamic t (Map k Text) -> m (Event t (Map k (Maybe Text)))
358dynamicAttributesToModifyAttributesWithInitial attrs0 d = do
359 postBuild <- getPostBuild
360 let modificationsNeeded = flip pushAlways (align postBuild $ updated d) $ \case
361 This () -> do
362 new <- sample $ current d
363 return $ diffMap attrs0 new
364 These () new -> return $ diffMap attrs0 new
365 That new -> do
366 old <- sample $ current d
367 return $ diffMap old new
368 return modificationsNeeded
370--------------------------------------------------------------------------------
371-- Copied and pasted from Reflex.Widget.Class
372--------------------------------------------------------------------------------
374-- | Create a dynamically-changing set of widgets from a Dynamic key/value map.
375-- Unlike the 'withKey' variants, the child widgets are insensitive to which key they're associated with.
376list :: (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))
377list dm mkChild = listWithKey dm (\_ dv -> mkChild dv)
379-- | Create a dynamically-changing set of widgets from a Dynamic list.
380simpleList :: (DomBuilder t m, MonadHold t m, PostBuild t m, MonadFix m) => Dynamic t [v] -> (Dynamic t v -> m a) -> m (Dynamic t [a])
381simpleList xs mkChild = fmap (fmap (map snd . Map.toList)) $ flip list mkChild $ fmap (Map.fromList . zip [(1::Int)..]) xs
383{-
384schedulePostBuild x = performEvent_ . (x <$) =<< getPostBuild
386elDynHtml' :: DomBuilder t m => Text -> Dynamic t Text -> m (El t)
387elDynHtml' elementTag html = do
388 e <- buildEmptyElement elementTag (Map.empty :: Map Text Text)
389 schedulePostBuild $ setInnerHTML e . Just =<< sample (current html)
390 performEvent_ $ fmap (setInnerHTML e . Just) $ updated html
391 wrapElement defaultDomEventHandler e
393elDynHtmlAttr' :: DomBuilder t m => Text -> Map Text Text -> Dynamic t Text -> m (El t)
394elDynHtmlAttr' elementTag attrs html = do
395 e <- buildEmptyElement elementTag attrs
396 schedulePostBuild $ setInnerHTML e . Just =<< sample (current html)
397 performEvent_ $ fmap (setInnerHTML e . Just) $ updated html
398 wrapElement defaultDomEventHandler e
399-}
401data Link t
402 = Link { _link_clicked :: Event t ()
403 }
405linkClass :: DomBuilder t m => Text -> Text -> m (Link t)
406linkClass s c = do
407 (l,_) <- elAttr' "a" ("class" =: c) $ text s
408 return $ Link $ domEvent Click l
410link :: DomBuilder t m => Text -> m (Link t)
411link s = linkClass s ""
413divClass :: forall t m a. DomBuilder t m => Text -> m a -> m a
414divClass = elClass "div"
416dtdd :: forall t m a. DomBuilder t m => Text -> m a -> m a
417dtdd h w = do
418 el "dt" $ text h
419 el "dd" w
421blank :: forall m. Monad m => m ()
422blank = return ()
424newtype Workflow t m a = Workflow { unWorkflow :: m (a, Event t (Workflow t m a)) }
426workflow :: forall t m a. (DomBuilder t m, MonadFix m, MonadHold t m) => Workflow t m a -> m (Dynamic t a)
427workflow w0 = do
428 rec eResult <- widgetHold (unWorkflow w0) $ fmap unWorkflow $ switch $ snd <$> current eResult
429 return $ fmap fst eResult
431workflowView :: forall t m a. (DomBuilder t m, MonadFix m, MonadHold t m, PostBuild t m) => Workflow t m a -> m (Event t a)
432workflowView w0 = do
433 rec eResult <- dyn . fmap unWorkflow =<< holdDyn w0 eReplace
434 eReplace <- fmap switch $ hold never $ fmap snd eResult
435 return $ fmap fst eResult
437mapWorkflow :: (DomBuilder t m) => (a -> b) -> Workflow t m a -> Workflow t m b
438mapWorkflow f (Workflow x) = Workflow (fmap (f *** fmap (mapWorkflow f)) x)
440mapWorkflowCheap :: (DomBuilder t m) => (a -> b) -> Workflow t m a -> Workflow t m b
441mapWorkflowCheap f (Workflow x) = Workflow (fmap (f *** fmapCheap (mapWorkflowCheap f)) x)
443-- | A widget to display a table with static columns and dynamic rows.
444tableDynAttr :: forall t m r k v. (Ord k, DomBuilder t m, MonadHold t m, PostBuild t m, MonadFix m)
445 => Text -- ^ Class applied to <table> element
446 -> [(Text, k -> Dynamic t r -> m v)] -- ^ Columns of (header, row key -> row value -> child widget)
447 -> Dynamic t (Map k r) -- ^ Map from row key to row value
448 -> (k -> m (Dynamic t (Map Text Text))) -- ^ Function to compute <tr> element attributes from row key
449 -> m (Dynamic t (Map k (Element EventResult (DomBuilderSpace m) t, [v]))) -- ^ Map from row key to (El, list of widget return values)
450tableDynAttr klass cols dRows rowAttrs = elAttr "div" (Map.singleton "style" "zoom: 1; overflow: auto; background: white;") $ do
451 elAttr "table" (Map.singleton "class" klass) $ do
452 el "thead" $ el "tr" $ do
453 mapM_ (\(h, _) -> el "th" $ text h) cols
454 el "tbody" $ do
455 listWithKey dRows (\k r -> do
456 dAttrs <- rowAttrs k
457 elDynAttr' "tr" dAttrs $ mapM (\x -> el "td" $ snd x k r) cols)
459-- | A widget to construct a tabbed view that shows only one of its child widgets at a time.
460-- Creates a header bar containing a <ul> with one <li> per child; clicking a <li> displays
461-- the corresponding child and hides all others.
462tabDisplay :: forall t m k. (MonadFix m, DomBuilder t m, MonadHold t m, PostBuild t m, Ord k)
463 => Text -- ^ Class applied to <ul> element
464 -> Text -- ^ Class applied to currently active <li> element
465 -> Map k (Text, m ()) -- ^ Map from (arbitrary) key to (tab label, child widget)
466 -> m ()
467tabDisplay ulClass activeClass tabItems = do
468 let t0 = listToMaybe $ Map.keys tabItems
469 rec currentTab :: Demux t (Maybe k) <- elAttr "ul" ("class" =: ulClass) $ do
470 tabClicksList :: [Event t k] <- Map.elems <$> imapM (\k (s,_) -> headerBarLink s k $ demuxed currentTab (Just k)) tabItems
471 let eTabClicks :: Event t k = leftmost tabClicksList
472 fmap demux $ holdDyn t0 $ fmap Just eTabClicks
473 el "div" $ do
474 iforM_ tabItems $ \k (_, w) -> do
475 let isSelected = demuxed currentTab $ Just k
476 attrs = ffor isSelected $ \s -> if s then Map.empty else Map.singleton "style" "display:none;"
477 elDynAttr "div" attrs w
478 return ()
479 where
480 headerBarLink :: Text -> k -> Dynamic t Bool -> m (Event t k)
481 headerBarLink x k isSelected = do
482 let attrs = fmap (\b -> if b then Map.singleton "class" activeClass else Map.empty) isSelected
483 elDynAttr "li" attrs $ do
484 a <- link x
485 return $ fmap (const k) (_link_clicked a)
487class HasAttributes a where
488 type Attrs a :: *
489 attributes :: Lens' a (Attrs a)