git.iko.soy/reflex-dom
on a1aedeb help sign in
reflex-dom/src/Reflex/Dom/Widget/Basic.hs
421 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 where
15import Reflex.Dom.Builder.Class
16import Reflex.Dom.Class
17import Reflex.Dom.Internal.Foreign ()
18import Reflex.Dom.PostBuild.Class
20import Control.Arrow
21import Control.Lens hiding (children, element)
22import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_, sequence, sequence_)
23import Data.Align
24import Data.Default
25import Data.Either
26import Data.Foldable
27import Data.Functor.Misc
28import Data.Map (Map)
29import qualified Data.Map as Map
30import Data.Maybe
31import Data.Semigroup
32import Data.Set (Set)
33import qualified Data.Set as Set
34import Data.Text (Text)
35import qualified Data.Text as T
36import Data.These
37import Data.Traversable
38import Prelude hiding (mapM, mapM_, sequence, sequence_)
39import Reflex
41widgetHoldInternal :: DomBuilder t m => m a -> Event t (m b) -> m (a, Event t b)
42widgetHoldInternal child0 child' = do
43 childResult0 <- deletable (void child') child0
44 childResult' <- placeholder $ def & placeholderConfig_insertAbove .~ fmap (deletable (void child')) child'
45 return (childResult0, _placeholder_insertedAbove childResult')
47-- | 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.
48-- 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.
49-- No empty pieces will be included in the output.
51--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
52partitionMapBySetLT :: forall k v. Ord k => Set k -> Map k v -> Map (Either k ()) (Map k v)
53partitionMapBySetLT s m0 = Map.fromDistinctAscList $ go (Set.toAscList s) m0
54 where go :: [k] -> Map k v -> [(Either k (), Map k v)]
55 go [] m = if Map.null m
56 then []
57 else [(Right (), m)]
58 go (h:t) m = let (lt, eq, gt) = Map.splitLookup h m
59 geq = maybe id (Map.insert h) eq gt
60 in if Map.null lt
61 then go t geq
62 else (Left h, lt) : go t geq
64newtype ChildResult t k a = ChildResult { unChildResult :: (a, Event t (Map k (Maybe (ChildResult t k a)))) }
66listHoldWithKey :: forall t m k v a. (Ord k, DomBuilder t m, MonadHold t m, MonadFix m) => Map k v -> Event t (Map k (Maybe v)) -> (k -> v -> m a) -> m (Dynamic t (Map k a))
67listHoldWithKey initialChildren modifyChildren buildChild = do
68 let deleteChildSelector = fanMap $ fmap void modifyChildren
69 liveChildren :: Dynamic t (Set k) <- foldDyn applyMapKeysSet (Map.keysSet initialChildren) modifyChildren
70 let placeChildSelector = fanMap $ attachWith partitionMapBySetLT (current liveChildren) $ fmap (Map.mapMaybe id) modifyChildren
71 buildAugmentedChild :: k -> v -> m (ChildResult t k a)
72 buildAugmentedChild k v = do
73 let delete = select deleteChildSelector $ Const2 k
74 myCfg = def
75 & insertAbove .~ fmap (imapM buildAugmentedChild) (select placeChildSelector $ Const2 $ Left k)
76 & deleteSelf .~ delete
77 ph <- placeholder myCfg
78 result <- deletable delete $ buildChild k v
79 return $ ChildResult (result, (fmap Just <$> _placeholder_insertedAbove ph) <> (Map.singleton k Nothing <$ _placeholder_deletedSelf ph)) --Note: we could also use the "deleted" output on deletable, if it had one; we're using this so that everything changes all at once, instead of deletions being prompt and insertions being delayed
80 rec initialAugmentedResults <- iforM initialChildren buildAugmentedChild
81 augmentedResults <- foldDyn applyMap initialAugmentedResults $ newInsertedBelow <> newInsertedAbove
82 let newInsertedAbove = switch $ mconcat . reverse . fmap (snd . unChildResult) . Map.elems <$> current augmentedResults
83 belowAll <- placeholder $ def & placeholderConfig_insertAbove .~ fmap (imapM buildAugmentedChild) (select placeChildSelector $ Const2 $ Right ())
84 let newInsertedBelow = fmap Just <$> _placeholder_insertedAbove belowAll
85 return $ fmap (fmap (fst . unChildResult)) augmentedResults
87text :: DomBuilder t m => Text -> m ()
88text t = void $ textNode $ def & textNodeConfig_initialContents .~ t
90dynText :: forall t m. (PostBuild t m, DomBuilder t m) => Dynamic t Text -> m ()
91dynText t = do
92 postBuild <- getPostBuild
93 void $ textNode $ (def :: TextNodeConfig t) & textNodeConfig_setContents .~ leftmost
94 [ updated t
95 , tag (current t) postBuild
96 ]
98display :: (PostBuild t m, DomBuilder t m, Show a) => Dynamic t a -> m ()
99display = dynText . fmap (T.pack . show)
101button :: DomBuilder t m => Text -> m (Event t ())
102button t = do
103 (e, _) <- element "button" def $ text t
104 return $ domEvent Click e
106--TODO: Should this be renamed to 'widgetView' for consistency with 'widgetHold'?
107-- | Given a Dynamic of widget-creating actions, create a widget that is recreated whenever the Dynamic updates.
108-- The returned Event of widget results occurs when the Dynamic does.
109-- 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').
110dyn :: (DomBuilder t m, PostBuild t m) => Dynamic t (m a) -> m (Event t a)
111dyn child = do
112 postBuild <- getPostBuild
113 let newChild = leftmost [updated child, tag (current child) postBuild]
114 snd <$> widgetHoldInternal (return ()) newChild
116-- | Given an initial widget and an Event of widget-creating actions, create a widget that is recreated whenever the Event fires.
117-- The returned Dynamic of widget results occurs when the Event does.
118-- Note: Often, the type 'a' is an Event, in which case the return value is a Dynamic-of-Events that would typically be flattened.
119widgetHold :: (DomBuilder t m, MonadHold t m) => m a -> Event t (m a) -> m (Dynamic t a)
120widgetHold child0 newChild = do
121 (result0, newResult) <- widgetHoldInternal child0 newChild
122 holdDyn result0 newResult
124diffMapNoEq :: (Ord k) => Map k v -> Map k v -> Map k (Maybe v)
125diffMapNoEq olds news = flip Map.mapMaybe (align olds news) $ \case
126 This _ -> Just Nothing
127 These _ new -> Just $ Just new
128 That new -> Just $ Just new
130diffMap :: (Ord k, Eq v) => Map k v -> Map k v -> Map k (Maybe v)
131diffMap olds news = flip Map.mapMaybe (align olds news) $ \case
132 This _ -> Just Nothing
133 These old new
134 | old == new -> Nothing
135 | otherwise -> Just $ Just new
136 That new -> Just $ Just new
138applyMap :: Ord k => Map k (Maybe v) -> Map k v -> Map k v
139applyMap patch old = insertions `Map.union` (old `Map.difference` deletions)
140 where (deletions, insertions) = mapPartitionEithers $ maybeToEither <$> patch
141 maybeToEither = \case
142 Nothing -> Left ()
143 Just r -> Right r
145mapPartitionEithers :: Map k (Either a b) -> (Map k a, Map k b)
146mapPartitionEithers m = (fromLeft <$> ls, fromRight <$> rs)
147 where (ls, rs) = Map.partition isLeft m
148 fromLeft (Left l) = l
149 fromLeft _ = error "mapPartitionEithers: fromLeft received a Right value; this should be impossible"
150 fromRight (Right r) = r
151 fromRight _ = error "mapPartitionEithers: fromRight received a Left value; this should be impossible"
153-- | Apply a map patch to a set
154-- > applyMapKeysSet patch (Map.keysSet m) == Map.keysSet (applyMap patch m)
155applyMapKeysSet :: Ord k => Map k (Maybe v) -> Set k -> Set k
156applyMapKeysSet patch old = Map.keysSet insertions `Set.union` (old `Set.difference` Map.keysSet deletions)
157 where (insertions, deletions) = Map.partition isJust patch
159--TODO: Something better than Dynamic t (Map k v) - we want something where the Events carry diffs, not the whole value
160listWithKey :: 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))
161listWithKey vals mkChild = do
162 postBuild <- getPostBuild
163 rec sentVals :: Dynamic t (Map k v) <- foldDyn applyMap Map.empty changeVals
164 let changeVals :: Event t (Map k (Maybe v))
165 changeVals = attachWith diffMapNoEq (current sentVals) $ leftmost
166 [ updated vals
167 , 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
168 ]
169 listWithKeyShallowDiff Map.empty changeVals $ \k v0 dv -> do
170 mkChild k =<< holdDyn v0 dv
172{-# DEPRECATED listWithKey' "listWithKey' has been renamed to listWithKeyShallowDiff; also, its behavior has changed to fix a bug where children were always rebuilt (never updated)" #-}
173listWithKey' :: (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))
174listWithKey' = listWithKeyShallowDiff
176-- | 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.
177listWithKeyShallowDiff :: (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))
178listWithKeyShallowDiff initialVals valsChanged mkChild = do
179 let childValChangedSelector = fanMap $ fmap (Map.mapMaybe id) valsChanged
180 sentVals <- foldDyn applyMap Map.empty $ fmap (fmap void) valsChanged
181 let relevantPatch patch _ = case patch of
182 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
183 Just _ -> Nothing -- We don't want to let spurious re-creations of items through
184 listHoldWithKey initialVals (attachWith (flip (Map.differenceWith relevantPatch)) (current sentVals) valsChanged) $ \k v ->
185 mkChild k v $ Reflex.select childValChangedSelector $ Const2 k
187--TODO: Something better than Dynamic t (Map k v) - we want something where the Events carry diffs, not the whole value
188-- | Create a dynamically-changing set of Event-valued widgets.
189-- 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'.
190listViewWithKey :: (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))
191listViewWithKey vals mkChild = switch . fmap mergeMap <$> listViewWithKey' vals mkChild
193listViewWithKey' :: (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))
194listViewWithKey' vals mkChild = current <$> listWithKey vals mkChild
196-- | Create a dynamically-changing set of widgets, one of which is selected at any time.
197selectViewListWithKey :: forall t m k v a. (DomBuilder t m, Ord k, PostBuild t m, MonadHold t m, MonadFix m)
198 => Dynamic t k -- ^ Current selection key
199 -> Dynamic t (Map k v) -- ^ Dynamic key/value map
200 -> (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
201 -> m (Event t (k, a)) -- ^ Event that fires when any child's return Event fires. Contains key of an arbitrary firing widget.
202selectViewListWithKey selection vals mkChild = do
203 let selectionDemux = demux selection -- For good performance, this value must be shared across all children
204 selectChild <- listWithKey vals $ \k v -> do
205 let selected = demuxed selectionDemux k
206 selectSelf <- mkChild k v selected
207 return $ fmap ((,) k) selectSelf
208 return $ switchPromptlyDyn $ leftmost . Map.elems <$> selectChild
210selectViewListWithKey_ :: forall t m k v a. (DomBuilder t m, Ord k, PostBuild t m, MonadHold t m, MonadFix m)
211 => Dynamic t k -- ^ Current selection key
212 -> Dynamic t (Map k v) -- ^ Dynamic key/value map
213 -> (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
214 -> m (Event t k) -- ^ Event that fires when any child's return Event fires. Contains key of an arbitrary firing widget.
215selectViewListWithKey_ selection vals mkChild = fmap fst <$> selectViewListWithKey selection vals mkChild
217{-
218{-# INLINABLE elWith #-}
219elWith :: (DomBuilder t m, Attributes m attrs) => Text -> ElConfig attrs -> m a -> m a
220elWith elementTag cfg child = do
221 (_, result) <- buildElementNS (cfg ^. namespace) elementTag (cfg ^. attributes) child
222 return result
224{-# INLINABLE elWith' #-}
225elWith' :: (DomBuilder t m, Attributes m attrs) => Text -> ElConfig attrs -> m a -> m (El t, a)
226elWith' elementTag cfg child = do
227 (e, result) <- buildElementNS (cfg ^. namespace) elementTag (cfg ^. attributes) child
228 e' <- wrapElement defaultDomEventHandler e
229 return (e', result)
231{-# INLINABLE emptyElWith #-}
232emptyElWith :: (DomBuilder t m, Attributes m attrs) => Text -> ElConfig attrs -> m ()
233emptyElWith elementTag cfg = do
234 _ <- buildEmptyElementNS (cfg ^. namespace) elementTag (cfg ^. attributes)
235 return ()
237{-# INLINABLE emptyElWith' #-}
238emptyElWith' :: (DomBuilder t m, Attributes m attrs) => Text -> ElConfig attrs -> m (El t)
239emptyElWith' elementTag cfg = do
240 wrapElement defaultDomEventHandler =<< buildEmptyElementNS (cfg ^. namespace) elementTag (cfg ^. attributes)
241-}
243{-# INLINABLE el #-}
244el :: forall t m a. DomBuilder t m => Text -> m a -> m a
245el elementTag child = snd <$> el' elementTag child
247{-# INLINABLE elAttr #-}
248elAttr :: forall t m a. DomBuilder t m => Text -> Map Text Text -> m a -> m a
249elAttr elementTag attrs child = snd <$> elAttr' elementTag attrs child
251{-# INLINABLE elClass #-}
252elClass :: forall t m a. DomBuilder t m => Text -> Text -> m a -> m a
253elClass elementTag c child = snd <$> elClass' elementTag c child
255{-# INLINABLE elDynAttr #-}
256elDynAttr :: forall t m a. (DomBuilder t m, PostBuild t m) => Text -> Dynamic t (Map Text Text) -> m a -> m a
257elDynAttr elementTag attrs child = snd <$> elDynAttr' elementTag attrs child
259{-# INLINABLE elDynClass #-}
260elDynClass :: forall t m a. (DomBuilder t m, PostBuild t m) => Text -> Dynamic t Text -> m a -> m a
261elDynClass elementTag c child = snd <$> elDynClass' elementTag c child
263{-# INLINABLE el' #-}
264el' :: forall t m a. DomBuilder t m => Text -> m a -> m (Element EventResult (DomBuilderSpace m) t, a)
265el' elementTag = element elementTag def
267{-# INLINABLE elAttr' #-}
268elAttr' :: forall t m a. DomBuilder t m => Text -> Map Text Text -> m a -> m (Element EventResult (DomBuilderSpace m) t, a)
269elAttr' elementTag attrs = element elementTag $ def
270 & initialAttributes .~ Map.mapKeys (\k -> (Nothing, k)) attrs
272{-# INLINABLE elClass' #-}
273elClass' :: forall t m a. DomBuilder t m => Text -> Text -> m a -> m (Element EventResult (DomBuilderSpace m) t, a)
274elClass' elementTag c = elAttr' elementTag ("class" =: c)
276{-# INLINABLE elDynAttr' #-}
277elDynAttr' :: 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)
278elDynAttr' = elDynAttrNS' Nothing
280{-# INLINABLE elDynClass' #-}
281elDynClass' :: forall t m a. (DomBuilder t m, PostBuild t m) => Text -> Dynamic t Text -> m a -> m (Element EventResult (DomBuilderSpace m) t, a)
282elDynClass' elementTag c = elDynAttr' elementTag (fmap ("class" =:) c)
284{-# INLINABLE elDynAttrNS' #-}
285elDynAttrNS' :: 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)
286elDynAttrNS' mns elementTag attrs child = do
287 modifyAttrs <- dynamicAttributesToModifyAttributes attrs
288 let cfg = def
289 & elementConfig_namespace .~ mns
290 & modifyAttributes .~ modifyAttrs
291 element elementTag cfg child
293dynamicAttributesToModifyAttributes :: PostBuild t m => Dynamic t (Map Text Text) -> m (Event t (Map AttributeName (Maybe Text)))
294dynamicAttributesToModifyAttributes d = do
295 postBuild <- getPostBuild
296 let modificationsNeeded = flip pushAlways (align postBuild $ updated d) $ \case
297 This () -> fmap (fmap Just) $ sample $ current d
298 These () new -> return $ fmap Just new
299 That new -> do
300 old <- sample $ current d
301 return $ diffMap old new
302 return $ Map.fromList . fmap (\(k, v) -> ((Nothing, k), v)) . Map.toList <$> modificationsNeeded
304--------------------------------------------------------------------------------
305-- Copied and pasted from Reflex.Widget.Class
306--------------------------------------------------------------------------------
308-- | Create a dynamically-changing set of widgets from a Dynamic key/value map.
309-- Unlike the 'withKey' variants, the child widgets are insensitive to which key they're associated with.
310list :: (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))
311list dm mkChild = listWithKey dm (\_ dv -> mkChild dv)
313-- | Create a dynamically-changing set of widgets from a Dynamic list.
314simpleList :: (DomBuilder t m, MonadHold t m, PostBuild t m, MonadFix m) => Dynamic t [v] -> (Dynamic t v -> m a) -> m (Dynamic t [a])
315simpleList xs mkChild = fmap (fmap (map snd . Map.toList)) $ flip list mkChild $ fmap (Map.fromList . zip [(1::Int)..]) xs
317{-
318schedulePostBuild x = performEvent_ . (x <$) =<< getPostBuild
320elDynHtml' :: DomBuilder t m => Text -> Dynamic t Text -> m (El t)
321elDynHtml' elementTag html = do
322 e <- buildEmptyElement elementTag (Map.empty :: Map Text Text)
323 schedulePostBuild $ setInnerHTML e . Just =<< sample (current html)
324 performEvent_ $ fmap (setInnerHTML e . Just) $ updated html
325 wrapElement defaultDomEventHandler e
327elDynHtmlAttr' :: DomBuilder t m => Text -> Map Text Text -> Dynamic t Text -> m (El t)
328elDynHtmlAttr' elementTag attrs html = do
329 e <- buildEmptyElement elementTag attrs
330 schedulePostBuild $ setInnerHTML e . Just =<< sample (current html)
331 performEvent_ $ fmap (setInnerHTML e . Just) $ updated html
332 wrapElement defaultDomEventHandler e
333-}
335data Link t
336 = Link { _link_clicked :: Event t ()
337 }
339linkClass :: DomBuilder t m => Text -> Text -> m (Link t)
340linkClass s c = do
341 (l,_) <- elAttr' "a" ("class" =: c) $ text s
342 return $ Link $ domEvent Click l
344link :: DomBuilder t m => Text -> m (Link t)
345link s = linkClass s ""
347newtype Workflow t m a = Workflow { unWorkflow :: m (a, Event t (Workflow t m a)) }
349workflow :: forall t m a. (DomBuilder t m, MonadFix m, MonadHold t m) => Workflow t m a -> m (Dynamic t a)
350workflow w0 = do
351 rec eResult <- widgetHold (unWorkflow w0) $ fmap unWorkflow $ switch $ snd <$> current eResult
352 return $ fmap fst eResult
354workflowView :: forall t m a. (DomBuilder t m, MonadFix m, MonadHold t m, PostBuild t m) => Workflow t m a -> m (Event t a)
355workflowView w0 = do
356 rec eResult <- dyn . fmap unWorkflow =<< holdDyn w0 eReplace
357 eReplace <- fmap switch $ hold never $ fmap snd eResult
358 return $ fmap fst eResult
360mapWorkflow :: (DomBuilder t m) => (a -> b) -> Workflow t m a -> Workflow t m b
361mapWorkflow f (Workflow x) = Workflow (fmap (f *** fmap (mapWorkflow f)) x)
363divClass :: forall t m a. DomBuilder t m => Text -> m a -> m a
364divClass = elClass "div"
366dtdd :: forall t m a. DomBuilder t m => Text -> m a -> m a
367dtdd h w = do
368 el "dt" $ text h
369 el "dd" w
371blank :: forall m. Monad m => m ()
372blank = return ()
374-- | A widget to display a table with static columns and dynamic rows.
375tableDynAttr :: forall t m r k v. (Ord k, DomBuilder t m, MonadHold t m, PostBuild t m, MonadFix m)
376 => Text -- ^ Class applied to <table> element
377 -> [(Text, k -> Dynamic t r -> m v)] -- ^ Columns of (header, row key -> row value -> child widget)
378 -> Dynamic t (Map k r) -- ^ Map from row key to row value
379 -> (k -> m (Dynamic t (Map Text Text))) -- ^ Function to compute <tr> element attributes from row key
380 -> m (Dynamic t (Map k (Element EventResult (DomBuilderSpace m) t, [v]))) -- ^ Map from row key to (El, list of widget return values)
381tableDynAttr klass cols dRows rowAttrs = elAttr "div" (Map.singleton "style" "zoom: 1; overflow: auto; background: white;") $ do
382 elAttr "table" (Map.singleton "class" klass) $ do
383 el "thead" $ el "tr" $ do
384 mapM_ (\(h, _) -> el "th" $ text h) cols
385 el "tbody" $ do
386 listWithKey dRows (\k r -> do
387 dAttrs <- rowAttrs k
388 elDynAttr' "tr" dAttrs $ mapM (\x -> el "td" $ snd x k r) cols)
390--TODO preselect a tab on open
391-- | A widget to construct a tabbed view that shows only one of its child widgets at a time.
392-- Creates a header bar containing a <ul> with one <li> per child; clicking a <li> displays
393-- the corresponding child and hides all others.
394tabDisplay :: forall t m k. (MonadFix m, DomBuilder t m, MonadHold t m, PostBuild t m, Ord k)
395 => Text -- ^ Class applied to <ul> element
396 -> Text -- ^ Class applied to currently active <li> element
397 -> Map k (Text, m ()) -- ^ Map from (arbitrary) key to (tab label, child widget)
398 -> m ()
399tabDisplay ulClass activeClass tabItems = do
400 let t0 = listToMaybe $ Map.keys tabItems
401 rec currentTab :: Demux t (Maybe k) <- elAttr "ul" ("class" =: ulClass) $ do
402 tabClicksList :: [Event t k] <- Map.elems <$> imapM (\k (s,_) -> headerBarLink s k $ demuxed currentTab (Just k)) tabItems
403 let eTabClicks :: Event t k = leftmost tabClicksList
404 fmap demux $ holdDyn t0 $ fmap Just eTabClicks
405 el "div" $ do
406 iforM_ tabItems $ \k (_, w) -> do
407 let isSelected = demuxed currentTab $ Just k
408 attrs = ffor isSelected $ \s -> if s then Map.empty else Map.singleton "style" "display:none;"
409 elDynAttr "div" attrs w
410 return ()
411 where
412 headerBarLink :: Text -> k -> Dynamic t Bool -> m (Event t k)
413 headerBarLink x k isSelected = do
414 let attrs = fmap (\b -> if b then Map.singleton "class" activeClass else Map.empty) isSelected
415 elDynAttr "li" attrs $ do
416 a <- link x
417 return $ fmap (const k) (_link_clicked a)
419class HasAttributes a where
420 type Attrs a :: *
421 attributes :: Lens' a (Attrs a)