git.iko.soy/reflex-dom
on ff66767 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
75 -- * Tables and Lists
76 , tableDynAttr
77 , tabDisplay
79 , HasAttributes (..)
80 ) where
82import Reflex.Class as Reflex
83import Reflex.Dom.Builder.Class
84import Reflex.Dom.Class
85import Reflex.Dom.Internal.Foreign ()
86import Reflex.Dynamic
87import Reflex.PostBuild.Class
89import Control.Arrow
90import Control.Lens hiding (children, element)
91import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_, sequence, sequence_)
92import Data.Align
93import Data.Default
94import Data.Either
95import Data.Foldable
96import Data.Functor.Misc
97import Data.Map (Map)
98import qualified Data.Map as Map
99import Data.Maybe
100import Data.Semigroup
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 :: DomBuilder t m => m a -> Event t (m b) -> m (a, Event t b)
110widgetHoldInternal child0 child' = do
111 childResult0 <- deletable (void child') child0
112 childResult' <- placeholder $ def & placeholderConfig_insertAbove .~ fmap (deletable (void child')) child'
113 return (childResult0, _placeholder_insertedAbove childResult')
115-- | 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.
116-- 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.
117-- No empty pieces will be included in the output.
119--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
120partitionMapBySetLT :: forall k v. Ord k => Set k -> Map k v -> Map (Either k ()) (Map k v)
121partitionMapBySetLT s m0 = Map.fromDistinctAscList $ go (Set.toAscList s) m0
122 where go :: [k] -> Map k v -> [(Either k (), Map k v)]
123 go [] m = if Map.null m
124 then []
125 else [(Right (), m)]
126 go (h:t) m = let (lt, eq, gt) = Map.splitLookup h m
127 geq = maybe id (Map.insert h) eq gt
128 in if Map.null lt
129 then go t geq
130 else (Left h, lt) : go t geq
132newtype ChildResult t k a = ChildResult { unChildResult :: (a, Event t (Map k (Maybe (ChildResult t k a)))) }
134listHoldWithKey :: 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))
135listHoldWithKey initialChildren modifyChildren buildChild = do
136 let deleteChildSelector = fanMap $ fmap void modifyChildren
137 liveChildren :: Dynamic t (Set k) <- foldDyn applyMapKeysSet (Map.keysSet initialChildren) modifyChildren
138 let placeChildSelector = fanMap $ attachWith partitionMapBySetLT (current liveChildren) $ fmap (Map.mapMaybe id) modifyChildren
139 buildAugmentedChild :: k -> v -> m (ChildResult t k a)
140 buildAugmentedChild k v = do
141 let delete = select deleteChildSelector $ Const2 k
142 myCfg = def
143 & insertAbove .~ fmap (imapM buildAugmentedChild) (select placeChildSelector $ Const2 $ Left k)
144 & deleteSelf .~ delete
145 ph <- placeholder myCfg
146 result <- deletable delete $ buildChild k v
147 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
148 rec initialAugmentedResults <- iforM initialChildren buildAugmentedChild
149 augmentedResults <- foldDyn applyMap initialAugmentedResults $ newInsertedBelow <> newInsertedAbove
150 let newInsertedAbove = switch $ mconcat . reverse . fmap (snd . unChildResult) . Map.elems <$> current augmentedResults
151 belowAll <- placeholder $ def & placeholderConfig_insertAbove .~ fmap (imapM buildAugmentedChild) (select placeChildSelector $ Const2 $ Right ())
152 let newInsertedBelow = fmap Just <$> _placeholder_insertedAbove belowAll
153 return $ fmap (fmap (fst . unChildResult)) augmentedResults
155text :: DomBuilder t m => Text -> m ()
156text t = void $ textNode $ def & textNodeConfig_initialContents .~ t
158dynText :: forall t m. (PostBuild t m, DomBuilder t m) => Dynamic t Text -> m ()
159dynText t = do
160 postBuild <- getPostBuild
161 void $ textNode $ (def :: TextNodeConfig t) & textNodeConfig_setContents .~ leftmost
162 [ updated t
163 , tag (current t) postBuild
164 ]
166display :: (PostBuild t m, DomBuilder t m, Show a) => Dynamic t a -> m ()
167display = dynText . fmap (T.pack . show)
169button :: DomBuilder t m => Text -> m (Event t ())
170button t = do
171 (e, _) <- element "button" def $ text t
172 return $ domEvent Click e
174--TODO: Should this be renamed to 'widgetView' for consistency with 'widgetHold'?
175-- | Given a Dynamic of widget-creating actions, create a widget that is recreated whenever the Dynamic updates.
176-- The returned Event of widget results occurs when the Dynamic does.
177-- 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').
178dyn :: (DomBuilder t m, PostBuild t m) => Dynamic t (m a) -> m (Event t a)
179dyn child = do
180 postBuild <- getPostBuild
181 let newChild = leftmost [updated child, tag (current child) postBuild]
182 snd <$> widgetHoldInternal (return ()) newChild
184-- | Given an initial widget and an Event of widget-creating actions, create a widget that is recreated whenever the Event fires.
185-- The returned Dynamic of widget results occurs when the Event does.
186-- Note: Often, the type 'a' is an Event, in which case the return value is a Dynamic-of-Events that would typically be flattened.
187widgetHold :: (DomBuilder t m, MonadHold t m) => m a -> Event t (m a) -> m (Dynamic t a)
188widgetHold child0 newChild = do
189 (result0, newResult) <- widgetHoldInternal child0 newChild
190 holdDyn result0 newResult
192diffMapNoEq :: (Ord k) => Map k v -> Map k v -> Map k (Maybe v)
193diffMapNoEq olds news = flip Map.mapMaybe (align olds news) $ \case
194 This _ -> Just Nothing
195 These _ new -> Just $ Just new
196 That new -> Just $ Just new
198diffMap :: (Ord k, Eq v) => Map k v -> Map k v -> Map k (Maybe v)
199diffMap olds news = flip Map.mapMaybe (align olds news) $ \case
200 This _ -> Just Nothing
201 These old new
202 | old == new -> Nothing
203 | otherwise -> Just $ Just new
204 That new -> Just $ Just new
206applyMap :: Ord k => Map k (Maybe v) -> Map k v -> Map k v
207applyMap patch old = insertions `Map.union` (old `Map.difference` deletions)
208 where (deletions, insertions) = mapPartitionEithers $ maybeToEither <$> patch
209 maybeToEither = \case
210 Nothing -> Left ()
211 Just r -> Right r
213mapPartitionEithers :: Map k (Either a b) -> (Map k a, Map k b)
214mapPartitionEithers m = (fromLeft <$> ls, fromRight <$> rs)
215 where (ls, rs) = Map.partition isLeft m
216 fromLeft (Left l) = l
217 fromLeft _ = error "mapPartitionEithers: fromLeft received a Right value; this should be impossible"
218 fromRight (Right r) = r
219 fromRight _ = error "mapPartitionEithers: fromRight received a Left value; this should be impossible"
221-- | Apply a map patch to a set
222-- > applyMapKeysSet patch (Map.keysSet m) == Map.keysSet (applyMap patch m)
223applyMapKeysSet :: Ord k => Map k (Maybe v) -> Set k -> Set k
224applyMapKeysSet patch old = Map.keysSet insertions `Set.union` (old `Set.difference` Map.keysSet deletions)
225 where (insertions, deletions) = Map.partition isJust patch
227--TODO: Something better than Dynamic t (Map k v) - we want something where the Events carry diffs, not the whole value
228listWithKey :: 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))
229listWithKey vals mkChild = do
230 postBuild <- getPostBuild
231 rec sentVals :: Dynamic t (Map k v) <- foldDyn applyMap Map.empty changeVals
232 let changeVals :: Event t (Map k (Maybe v))
233 changeVals = attachWith diffMapNoEq (current sentVals) $ leftmost
234 [ updated vals
235 , 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
236 ]
237 listWithKeyShallowDiff Map.empty changeVals $ \k v0 dv -> do
238 mkChild k =<< holdDyn v0 dv
240{-# DEPRECATED listWithKey' "listWithKey' has been renamed to listWithKeyShallowDiff; also, its behavior has changed to fix a bug where children were always rebuilt (never updated)" #-}
241listWithKey' :: (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))
242listWithKey' = listWithKeyShallowDiff
244-- | 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.
245listWithKeyShallowDiff :: (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))
246listWithKeyShallowDiff initialVals valsChanged mkChild = do
247 let childValChangedSelector = fanMap $ fmap (Map.mapMaybe id) valsChanged
248 sentVals <- foldDyn applyMap Map.empty $ fmap (fmap void) valsChanged
249 let relevantPatch patch _ = case patch of
250 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
251 Just _ -> Nothing -- We don't want to let spurious re-creations of items through
252 listHoldWithKey initialVals (attachWith (flip (Map.differenceWith relevantPatch)) (current sentVals) valsChanged) $ \k v ->
253 mkChild k v $ Reflex.select childValChangedSelector $ Const2 k
255--TODO: Something better than Dynamic t (Map k v) - we want something where the Events carry diffs, not the whole value
256-- | Create a dynamically-changing set of Event-valued widgets.
257-- 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'.
258listViewWithKey :: (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))
259listViewWithKey vals mkChild = switch . fmap mergeMap <$> listViewWithKey' vals mkChild
261listViewWithKey' :: (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))
262listViewWithKey' vals mkChild = current <$> listWithKey vals mkChild
264-- | Create a dynamically-changing set of widgets, one of which is selected at any time.
265selectViewListWithKey :: forall t m k v a. (DomBuilder t m, Ord k, PostBuild t m, MonadHold t m, MonadFix m)
266 => Dynamic t k -- ^ Current selection key
267 -> Dynamic t (Map k v) -- ^ Dynamic key/value map
268 -> (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
269 -> m (Event t (k, a)) -- ^ Event that fires when any child's return Event fires. Contains key of an arbitrary firing widget.
270selectViewListWithKey selection vals mkChild = do
271 let selectionDemux = demux selection -- For good performance, this value must be shared across all children
272 selectChild <- listWithKey vals $ \k v -> do
273 let selected = demuxed selectionDemux k
274 selectSelf <- mkChild k v selected
275 return $ fmap ((,) k) selectSelf
276 return $ switchPromptlyDyn $ leftmost . Map.elems <$> selectChild
278selectViewListWithKey_ :: forall t m k v a. (DomBuilder t m, Ord k, PostBuild t m, MonadHold t m, MonadFix m)
279 => Dynamic t k -- ^ Current selection key
280 -> Dynamic t (Map k v) -- ^ Dynamic key/value map
281 -> (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
282 -> m (Event t k) -- ^ Event that fires when any child's return Event fires. Contains key of an arbitrary firing widget.
283selectViewListWithKey_ selection vals mkChild = fmap fst <$> selectViewListWithKey selection vals mkChild
285-- | Create a DOM element
286-- > el "div" (text "Hello World")
287-- <div>Hello World</div>
288{-# INLINABLE el #-}
289el :: forall t m a. DomBuilder t m => Text -> m a -> m a
290el elementTag child = snd <$> el' elementTag child
292-- | Create a DOM element with attributes
293-- > elAttr "a" ("href" =: "http://google.com") (text "Google!")
294-- <a href="http://google.com">Google!</a>
295{-# INLINABLE elAttr #-}
296elAttr :: forall t m a. DomBuilder t m => Text -> Map Text Text -> m a -> m a
297elAttr elementTag attrs child = snd <$> elAttr' elementTag attrs child
299-- | Create a DOM element with classes
300-- > elClass "div" "row" (return ())
301-- <div class="row"></div>
302{-# INLINABLE elClass #-}
303elClass :: forall t m a. DomBuilder t m => Text -> Text -> m a -> m a
304elClass elementTag c child = snd <$> elClass' elementTag c child
306-- | Create a DOM element with Dynamic Attributes
307-- > elClass "div" (constDyn ("class" =: "row")) (return ())
308-- <div class="row"></div>
309{-# INLINABLE elDynAttr #-}
310elDynAttr :: forall t m a. (DomBuilder t m, PostBuild t m) => Text -> Dynamic t (Map Text Text) -> m a -> m a
311elDynAttr elementTag attrs child = snd <$> elDynAttr' elementTag attrs child
313-- | Create a DOM element with a Dynamic Class
314-- > elDynClass "div" (constDyn "row") (return ())
315-- <div class="row"></div>
316{-# INLINABLE elDynClass #-}
317elDynClass :: forall t m a. (DomBuilder t m, PostBuild t m) => Text -> Dynamic t Text -> m a -> m a
318elDynClass elementTag c child = snd <$> elDynClass' elementTag c child
320-- | Create a DOM element and return the element
321-- > do (e, _) <- el' "div" (text "Click")
322-- > return $ domEvent Click e
323{-# INLINABLE el' #-}
324el' :: forall t m a. DomBuilder t m => Text -> m a -> m (Element EventResult (DomBuilderSpace m) t, a)
325el' elementTag = element elementTag def
327-- | Create a DOM element with attributes and return the element
328{-# INLINABLE elAttr' #-}
329elAttr' :: forall t m a. DomBuilder t m => Text -> Map Text Text -> m a -> m (Element EventResult (DomBuilderSpace m) t, a)
330elAttr' elementTag attrs = element elementTag $ def
331 & initialAttributes .~ Map.mapKeys (AttributeName Nothing) attrs
333-- | Create a DOM element with a class and return the element
334{-# INLINABLE elClass' #-}
335elClass' :: forall t m a. DomBuilder t m => Text -> Text -> m a -> m (Element EventResult (DomBuilderSpace m) t, a)
336elClass' elementTag c = elAttr' elementTag ("class" =: c)
338-- | Create a DOM element with Dynamic Attributes and return the element
339{-# INLINABLE elDynAttr' #-}
340elDynAttr' :: 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)
341elDynAttr' = elDynAttrNS' Nothing
343-- | Create a DOM element with a Dynamic class and return the element
344{-# INLINABLE elDynClass' #-}
345elDynClass' :: forall t m a. (DomBuilder t m, PostBuild t m) => Text -> Dynamic t Text -> m a -> m (Element EventResult (DomBuilderSpace m) t, a)
346elDynClass' elementTag c = elDynAttr' elementTag (fmap ("class" =:) c)
348{-# INLINABLE elDynAttrNS' #-}
349elDynAttrNS' :: 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)
350elDynAttrNS' mns elementTag attrs child = do
351 modifyAttrs <- dynamicAttributesToModifyAttributes attrs
352 let cfg = def
353 & elementConfig_namespace .~ mns
354 & modifyAttributes .~ fmap mapKeysToAttributeName modifyAttrs
355 element elementTag cfg child
357dynamicAttributesToModifyAttributes :: (Ord k, PostBuild t m) => Dynamic t (Map k Text) -> m (Event t (Map k (Maybe Text)))
358dynamicAttributesToModifyAttributes = dynamicAttributesToModifyAttributesWithInitial mempty
360dynamicAttributesToModifyAttributesWithInitial :: (Ord k, PostBuild t m) => Map k Text -> Dynamic t (Map k Text) -> m (Event t (Map k (Maybe Text)))
361dynamicAttributesToModifyAttributesWithInitial attrs0 d = do
362 postBuild <- getPostBuild
363 let modificationsNeeded = flip pushAlways (align postBuild $ updated d) $ \case
364 This () -> do
365 new <- sample $ current d
366 return $ diffMap attrs0 new
367 These () new -> return $ diffMap attrs0 new
368 That new -> do
369 old <- sample $ current d
370 return $ diffMap old new
371 return modificationsNeeded
373--------------------------------------------------------------------------------
374-- Copied and pasted from Reflex.Widget.Class
375--------------------------------------------------------------------------------
377-- | Create a dynamically-changing set of widgets from a Dynamic key/value map.
378-- Unlike the 'withKey' variants, the child widgets are insensitive to which key they're associated with.
379list :: (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))
380list dm mkChild = listWithKey dm (\_ dv -> mkChild dv)
382-- | Create a dynamically-changing set of widgets from a Dynamic list.
383simpleList :: (DomBuilder t m, MonadHold t m, PostBuild t m, MonadFix m) => Dynamic t [v] -> (Dynamic t v -> m a) -> m (Dynamic t [a])
384simpleList xs mkChild = fmap (fmap (map snd . Map.toList)) $ flip list mkChild $ fmap (Map.fromList . zip [(1::Int)..]) xs
386{-
387schedulePostBuild x = performEvent_ . (x <$) =<< getPostBuild
389elDynHtml' :: DomBuilder t m => Text -> Dynamic t Text -> m (El t)
390elDynHtml' elementTag html = do
391 e <- buildEmptyElement elementTag (Map.empty :: Map Text Text)
392 schedulePostBuild $ setInnerHTML e . Just =<< sample (current html)
393 performEvent_ $ fmap (setInnerHTML e . Just) $ updated html
394 wrapElement defaultDomEventHandler e
396elDynHtmlAttr' :: DomBuilder t m => Text -> Map Text Text -> Dynamic t Text -> m (El t)
397elDynHtmlAttr' elementTag attrs html = do
398 e <- buildEmptyElement elementTag attrs
399 schedulePostBuild $ setInnerHTML e . Just =<< sample (current html)
400 performEvent_ $ fmap (setInnerHTML e . Just) $ updated html
401 wrapElement defaultDomEventHandler e
402-}
404data Link t
405 = Link { _link_clicked :: Event t ()
406 }
408linkClass :: DomBuilder t m => Text -> Text -> m (Link t)
409linkClass s c = do
410 (l,_) <- elAttr' "a" ("class" =: c) $ text s
411 return $ Link $ domEvent Click l
413link :: DomBuilder t m => Text -> m (Link t)
414link s = linkClass s ""
416divClass :: forall t m a. DomBuilder t m => Text -> m a -> m a
417divClass = elClass "div"
419dtdd :: forall t m a. DomBuilder t m => Text -> m a -> m a
420dtdd h w = do
421 el "dt" $ text h
422 el "dd" w
424blank :: forall m. Monad m => m ()
425blank = return ()
427newtype Workflow t m a = Workflow { unWorkflow :: m (a, Event t (Workflow t m a)) }
429workflow :: forall t m a. (DomBuilder t m, MonadFix m, MonadHold t m) => Workflow t m a -> m (Dynamic t a)
430workflow w0 = do
431 rec eResult <- widgetHold (unWorkflow w0) $ fmap unWorkflow $ switch $ snd <$> current eResult
432 return $ fmap fst eResult
434workflowView :: forall t m a. (DomBuilder t m, MonadFix m, MonadHold t m, PostBuild t m) => Workflow t m a -> m (Event t a)
435workflowView w0 = do
436 rec eResult <- dyn . fmap unWorkflow =<< holdDyn w0 eReplace
437 eReplace <- fmap switch $ hold never $ fmap snd eResult
438 return $ fmap fst eResult
440mapWorkflow :: (DomBuilder t m) => (a -> b) -> Workflow t m a -> Workflow t m b
441mapWorkflow f (Workflow x) = Workflow (fmap (f *** fmap (mapWorkflow 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)