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