src/Reflex/Dom/Widget/Basic.hs · reflex-dom

git.iko.soy/reflex-dom

on ffbe01f help sign in

reflex-dom/src/Reflex/Dom/Widget/Basic.hs

476 lines 23 kB history raw

1{-# LANGUAGE ConstraintKinds #-}

2{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE FlexibleContexts #-}

4{-# LANGUAGE FlexibleInstances #-}

5{-# LANGUAGE GADTs #-}

6{-# LANGUAGE LambdaCase #-}

7{-# LANGUAGE MultiParamTypeClasses #-}

8{-# LANGUAGE OverloadedStrings #-}

9{-# LANGUAGE RankNTypes #-}

10{-# LANGUAGE RecursiveDo #-}

11{-# LANGUAGE ScopedTypeVariables #-}

12{-# LANGUAGE TypeFamilies #-}

13module Reflex.Dom.Widget.Basic

14 ( partitionMapBySetLT

15 , listHoldWithKey

16 , ChildResult (..)

18 -- * Displaying Values

19 , text

20 , dynText

21 , display

22 , button

23 , dyn

24 , widgetHold

26 -- * Working with Maps

27 , diffMapNoEq

28 , diffMap

29 , applyMap

30 , mapPartitionEithers

31 , applyMapKeysSet

33 -- * Widgets on Collections

34 , listWithKey

35 , listWithKey'

36 , listWithKeyShallowDiff

37 , listViewWithKey

38 , selectViewListWithKey

39 , selectViewListWithKey_

41 -- * Creating DOM Elements

42 , el

43 , elAttr

44 , elClass

45 , elDynAttr

46 , elDynClass

48 -- ** With Element Results

49 , el'

50 , elAttr'

51 , elClass'

52 , elDynAttr'

53 , elDynClass'

54 , elDynAttrNS'

55 , dynamicAttributesToModifyAttributes

57 -- * List Utils

58 , list

59 , simpleList

61 -- * Specific DOM Elements

62 , Link (..)

63 , linkClass

64 , link

65 , divClass

66 , dtdd

67 , blank

69 -- * Workflows

70 , Workflow (..)

71 , workflow

72 , workflowView

73 , mapWorkflow

74 , mapWorkflowCheap

76 -- * Tables and Lists

77 , tableDynAttr

78 , tabDisplay

80 , HasAttributes (..)

81 ) where

83import Reflex.Class

84import Reflex.Dom.Builder.Class

85import Reflex.Dom.Class

86import Reflex.Dom.Internal.Foreign ()

87import Reflex.Dynamic

88import Reflex.PostBuild.Class

90import Control.Arrow

91import Control.Lens hiding (children, element)

92import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_, sequence, sequence_)

93import Data.Align

94import Data.Default

95import Data.Either

96import Data.Foldable

97import Data.Functor.Misc

98import Data.Map (Map)

99import qualified Data.Map as Map

100import Data.Maybe

101import Data.Set (Set)

102import qualified Data.Set as Set

103import Data.Text (Text)

104import qualified Data.Text as T

105import Data.These

106import Data.Traversable

107import Prelude hiding (mapM, mapM_, sequence, sequence_)

108

109widgetHoldInternal :: forall t m a b. DomBuilder t m => m a -> Event t (m b) -> m (a, Event t b)

110widgetHoldInternal = runWithReplace

111

112-- | Breaks the given Map into pieces based on the given Set. Each piece will contain only keys that are less than the key of the piece, and greater than or equal to the key of the piece with the next-smaller key. There will be one additional piece containing all keys from the original Map that are larger or equal to the largest key in the Set.

113-- Either k () is used instead of Maybe k so that the resulting map of pieces is sorted so that the additional piece has the largest key.

114-- No empty pieces will be included in the output.

115

116--TODO: This can probably be done more efficiently by dividing and conquering, re-using the structure of the Set instead of going through the Set linearally

117partitionMapBySetLT :: forall k v. Ord k => Set k -> Map k v -> Map (Either k ()) (Map k v)

118partitionMapBySetLT s m0 = Map.fromDistinctAscList $ go (Set.toAscList s) m0

119 where go :: [k] -> Map k v -> [(Either k (), Map k v)]

120 go [] m = if Map.null m

121 then []

122 else [(Right (), m)]

123 go (h:t) m = let (lt, eq, gt) = Map.splitLookup h m

124 geq = maybe id (Map.insert h) eq gt

125 in if Map.null lt

126 then go t geq

127 else (Left h, lt) : go t geq

128

129newtype ChildResult t k a = ChildResult { unChildResult :: (a, Event t (Map k (Maybe (ChildResult t k a)))) }

130

131listHoldWithKey :: forall t m k v a. (Ord k, DomBuilder t m, MonadHold t m) => Map k v -> Event t (Map k (Maybe v)) -> (k -> v -> m a) -> m (Dynamic t (Map k a))

132listHoldWithKey m0 m' f = do

133 let dm0 = mapWithFunctorToDMap $ Map.mapWithKey f m0

134 dm' = fmap (PatchDMap . mapWithFunctorToDMap . Map.mapWithKey (\k v -> ComposeMaybe $ fmap (f k) v)) m'

135 (a0, a') <- sequenceDMapWithAdjust dm0 dm'

136 fmap dmapToMap . incrementalToDynamic <$> holdIncremental a0 a' --TODO: Move the dmapToMap to the righthand side so it doesn't get fully redone every time

137

138text :: DomBuilder t m => Text -> m ()

139text t = void $ textNode $ def & textNodeConfig_initialContents .~ t

140

141dynText :: forall t m. (PostBuild t m, DomBuilder t m) => Dynamic t Text -> m ()

142dynText t = do

143 postBuild <- getPostBuild

144 void $ textNode $ (def :: TextNodeConfig t) & textNodeConfig_setContents .~ leftmost

145 [ updated t

146 , tag (current t) postBuild

147 ]

148

149display :: (PostBuild t m, DomBuilder t m, Show a) => Dynamic t a -> m ()

150display = dynText . fmap (T.pack . show)

151

152button :: DomBuilder t m => Text -> m (Event t ())

153button t = do

154 (e, _) <- element "button" def $ text t

155 return $ domEvent Click e

156

157--TODO: Should this be renamed to 'widgetView' for consistency with 'widgetHold'?

158-- | Given a Dynamic of widget-creating actions, create a widget that is recreated whenever the Dynamic updates.

159-- The returned Event of widget results occurs when the Dynamic does.

160-- Note: Often, the type 'a' is an Event, in which case the return value is an Event-of-Events that would typically be flattened (via 'switchPromptly').

161dyn :: (DomBuilder t m, PostBuild t m) => Dynamic t (m a) -> m (Event t a)

162dyn child = do

163 postBuild <- getPostBuild

164 let newChild = leftmost [updated child, tagCheap (current child) postBuild]

165 snd <$> widgetHoldInternal (return ()) newChild

166

167-- | Given an initial widget and an Event of widget-creating actions, create a widget that is recreated whenever the Event fires.

168-- The returned Dynamic of widget results occurs when the Event does.

169-- Note: Often, the type 'a' is an Event, in which case the return value is a Dynamic-of-Events that would typically be flattened.

170widgetHold :: (DomBuilder t m, MonadHold t m) => m a -> Event t (m a) -> m (Dynamic t a)

171widgetHold child0 newChild = do

172 (result0, newResult) <- widgetHoldInternal child0 newChild

173 holdDyn result0 newResult

174

175diffMapNoEq :: (Ord k) => Map k v -> Map k v -> Map k (Maybe v)

176diffMapNoEq olds news = flip Map.mapMaybe (align olds news) $ \case

177 This _ -> Just Nothing

178 These _ new -> Just $ Just new

179 That new -> Just $ Just new

180

181diffMap :: (Ord k, Eq v) => Map k v -> Map k v -> Map k (Maybe v)

182diffMap olds news = flip Map.mapMaybe (align olds news) $ \case

183 This _ -> Just Nothing

184 These old new

185 | old == new -> Nothing

186 | otherwise -> Just $ Just new

187 That new -> Just $ Just new

188

189applyMap :: Ord k => Map k (Maybe v) -> Map k v -> Map k v

190applyMap patch old = insertions `Map.union` (old `Map.difference` deletions)

191 where (deletions, insertions) = mapPartitionEithers $ maybeToEither <$> patch

192 maybeToEither = \case

193 Nothing -> Left ()

194 Just r -> Right r

195

196mapPartitionEithers :: Map k (Either a b) -> (Map k a, Map k b)

197mapPartitionEithers m = (fromLeft <$> ls, fromRight <$> rs)

198 where (ls, rs) = Map.partition isLeft m

199 fromLeft (Left l) = l

200 fromLeft _ = error "mapPartitionEithers: fromLeft received a Right value; this should be impossible"

201 fromRight (Right r) = r

202 fromRight _ = error "mapPartitionEithers: fromRight received a Left value; this should be impossible"

203

204-- | Apply a map patch to a set

205-- > applyMapKeysSet patch (Map.keysSet m) == Map.keysSet (applyMap patch m)

206applyMapKeysSet :: Ord k => Map k (Maybe v) -> Set k -> Set k

207applyMapKeysSet patch old = Map.keysSet insertions `Set.union` (old `Set.difference` Map.keysSet deletions)

208 where (insertions, deletions) = Map.partition isJust patch

209

210--TODO: Something better than Dynamic t (Map k v) - we want something where the Events carry diffs, not the whole value

211listWithKey :: forall t k v m a. (Ord k, DomBuilder t m, PostBuild t m, MonadFix m, MonadHold t m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m a) -> m (Dynamic t (Map k a))

212listWithKey vals mkChild = do

213 postBuild <- getPostBuild

214 let childValChangedSelector = fanMap $ updated vals

215 rec sentVals :: Dynamic t (Map k v) <- foldDyn applyMap Map.empty changeVals

216 let changeVals :: Event t (Map k (Maybe v))

217 changeVals = attachWith diffMapNoEq (current sentVals) $ leftmost

218 [ updated vals

219 , 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

220 ]

221 listHoldWithKey Map.empty changeVals $ \k v ->

222 mkChild k =<< holdDyn v (select childValChangedSelector $ Const2 k)

223

224{-# DEPRECATED listWithKey' "listWithKey' has been renamed to listWithKeyShallowDiff; also, its behavior has changed to fix a bug where children were always rebuilt (never updated)" #-}

225listWithKey' :: (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))

226listWithKey' = listWithKeyShallowDiff

227

228-- | 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.

229listWithKeyShallowDiff :: (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))

230listWithKeyShallowDiff initialVals valsChanged mkChild = do

231 let childValChangedSelector = fanMap $ fmap (Map.mapMaybe id) valsChanged

232 sentVals <- foldDyn applyMap Map.empty $ fmap (fmap void) valsChanged

233 let relevantPatch patch _ = case patch of

234 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

235 Just _ -> Nothing -- We don't want to let spurious re-creations of items through

236 listHoldWithKey initialVals (attachWith (flip (Map.differenceWith relevantPatch)) (current sentVals) valsChanged) $ \k v ->

237 mkChild k v $ select childValChangedSelector $ Const2 k

238

239--TODO: Something better than Dynamic t (Map k v) - we want something where the Events carry diffs, not the whole value

240-- | Create a dynamically-changing set of Event-valued widgets.

241-- 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'.

242listViewWithKey :: (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))

243listViewWithKey vals mkChild = switch . fmap mergeMap <$> listViewWithKey' vals mkChild

244

245listViewWithKey' :: (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))

246listViewWithKey' vals mkChild = current <$> listWithKey vals mkChild

247

248-- | Create a dynamically-changing set of widgets, one of which is selected at any time.

249selectViewListWithKey :: forall t m k v a. (DomBuilder t m, Ord k, PostBuild t m, MonadHold t m, MonadFix m)

250 => Dynamic t k -- ^ Current selection key

251 -> Dynamic t (Map k v) -- ^ Dynamic key/value map

252 -> (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

253 -> m (Event t (k, a)) -- ^ Event that fires when any child's return Event fires. Contains key of an arbitrary firing widget.

254selectViewListWithKey selection vals mkChild = do

255 let selectionDemux = demux selection -- For good performance, this value must be shared across all children

256 selectChild <- listWithKey vals $ \k v -> do

257 let selected = demuxed selectionDemux k

258 selectSelf <- mkChild k v selected

259 return $ fmap ((,) k) selectSelf

260 return $ switchPromptlyDyn $ leftmost . Map.elems <$> selectChild

261

262selectViewListWithKey_ :: forall t m k v a. (DomBuilder t m, Ord k, PostBuild t m, MonadHold t m, MonadFix m)

263 => Dynamic t k -- ^ Current selection key

264 -> Dynamic t (Map k v) -- ^ Dynamic key/value map

265 -> (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

266 -> m (Event t k) -- ^ Event that fires when any child's return Event fires. Contains key of an arbitrary firing widget.

267selectViewListWithKey_ selection vals mkChild = fmap fst <$> selectViewListWithKey selection vals mkChild

268

269-- | Create a DOM element

270-- > el "div" (text "Hello World")

271-- <div>Hello World</div>

272{-# INLINABLE el #-}

273el :: forall t m a. DomBuilder t m => Text -> m a -> m a

274el elementTag child = snd <$> el' elementTag child

275

276-- | Create a DOM element with attributes

277-- > elAttr "a" ("href" =: "http://google.com") (text "Google!")

278-- <a href="http://google.com">Google!</a>

279{-# INLINABLE elAttr #-}

280elAttr :: forall t m a. DomBuilder t m => Text -> Map Text Text -> m a -> m a

281elAttr elementTag attrs child = snd <$> elAttr' elementTag attrs child

282

283-- | Create a DOM element with classes

284-- > elClass "div" "row" (return ())

285-- <div class="row"></div>

286{-# INLINABLE elClass #-}

287elClass :: forall t m a. DomBuilder t m => Text -> Text -> m a -> m a

288elClass elementTag c child = snd <$> elClass' elementTag c child

289

290-- | Create a DOM element with Dynamic Attributes

291-- > elClass "div" (constDyn ("class" =: "row")) (return ())

292-- <div class="row"></div>

293{-# INLINABLE elDynAttr #-}

294elDynAttr :: forall t m a. (DomBuilder t m, PostBuild t m) => Text -> Dynamic t (Map Text Text) -> m a -> m a

295elDynAttr elementTag attrs child = snd <$> elDynAttr' elementTag attrs child

296

297-- | Create a DOM element with a Dynamic Class

298-- > elDynClass "div" (constDyn "row") (return ())

299-- <div class="row"></div>

300{-# INLINABLE elDynClass #-}

301elDynClass :: forall t m a. (DomBuilder t m, PostBuild t m) => Text -> Dynamic t Text -> m a -> m a

302elDynClass elementTag c child = snd <$> elDynClass' elementTag c child

303

304-- | Create a DOM element and return the element

305-- > do (e, _) <- el' "div" (text "Click")

306-- > return $ domEvent Click e

307{-# INLINABLE el' #-}

308el' :: forall t m a. DomBuilder t m => Text -> m a -> m (Element EventResult (DomBuilderSpace m) t, a)

309el' elementTag = element elementTag def

310

311-- | Create a DOM element with attributes and return the element

312{-# INLINABLE elAttr' #-}

313elAttr' :: forall t m a. DomBuilder t m => Text -> Map Text Text -> m a -> m (Element EventResult (DomBuilderSpace m) t, a)

314elAttr' elementTag attrs = element elementTag $ def

315 & initialAttributes .~ Map.mapKeys (AttributeName Nothing) attrs

316

317-- | Create a DOM element with a class and return the element

318{-# INLINABLE elClass' #-}

319elClass' :: forall t m a. DomBuilder t m => Text -> Text -> m a -> m (Element EventResult (DomBuilderSpace m) t, a)

320elClass' elementTag c = elAttr' elementTag ("class" =: c)

321

322-- | Create a DOM element with Dynamic Attributes and return the element

323{-# INLINABLE elDynAttr' #-}

324elDynAttr' :: 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)

325elDynAttr' = elDynAttrNS' Nothing

326

327-- | Create a DOM element with a Dynamic class and return the element

328{-# INLINABLE elDynClass' #-}

329elDynClass' :: forall t m a. (DomBuilder t m, PostBuild t m) => Text -> Dynamic t Text -> m a -> m (Element EventResult (DomBuilderSpace m) t, a)

330elDynClass' elementTag c = elDynAttr' elementTag (fmap ("class" =:) c)

331

332{-# INLINABLE elDynAttrNS' #-}

333elDynAttrNS' :: 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)

334elDynAttrNS' mns elementTag attrs child = do

335 modifyAttrs <- dynamicAttributesToModifyAttributes attrs

336 let cfg = def

337 & elementConfig_namespace .~ mns

338 & modifyAttributes .~ fmap mapKeysToAttributeName modifyAttrs

339 element elementTag cfg child

340

341dynamicAttributesToModifyAttributes :: (Ord k, PostBuild t m) => Dynamic t (Map k Text) -> m (Event t (Map k (Maybe Text)))

342dynamicAttributesToModifyAttributes = dynamicAttributesToModifyAttributesWithInitial mempty

343

344dynamicAttributesToModifyAttributesWithInitial :: (Ord k, PostBuild t m) => Map k Text -> Dynamic t (Map k Text) -> m (Event t (Map k (Maybe Text)))

345dynamicAttributesToModifyAttributesWithInitial attrs0 d = do

346 postBuild <- getPostBuild

347 let modificationsNeeded = flip pushAlways (align postBuild $ updated d) $ \case

348 This () -> do

349 new <- sample $ current d

350 return $ diffMap attrs0 new

351 These () new -> return $ diffMap attrs0 new

352 That new -> do

353 old <- sample $ current d

354 return $ diffMap old new

355 return modificationsNeeded

356

357--------------------------------------------------------------------------------

358-- Copied and pasted from Reflex.Widget.Class

359--------------------------------------------------------------------------------

360

361-- | Create a dynamically-changing set of widgets from a Dynamic key/value map.

362-- Unlike the 'withKey' variants, the child widgets are insensitive to which key they're associated with.

363list :: (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))

364list dm mkChild = listWithKey dm (\_ dv -> mkChild dv)

365

366-- | Create a dynamically-changing set of widgets from a Dynamic list.

367simpleList :: (DomBuilder t m, MonadHold t m, PostBuild t m, MonadFix m) => Dynamic t [v] -> (Dynamic t v -> m a) -> m (Dynamic t [a])

368simpleList xs mkChild = fmap (fmap (map snd . Map.toList)) $ flip list mkChild $ fmap (Map.fromList . zip [(1::Int)..]) xs

369

370{-

371schedulePostBuild x = performEvent_ . (x <$) =<< getPostBuild

372

373elDynHtml' :: DomBuilder t m => Text -> Dynamic t Text -> m (El t)

374elDynHtml' elementTag html = do

375 e <- buildEmptyElement elementTag (Map.empty :: Map Text Text)

376 schedulePostBuild $ setInnerHTML e . Just =<< sample (current html)

377 performEvent_ $ fmap (setInnerHTML e . Just) $ updated html

378 wrapElement defaultDomEventHandler e

379

380elDynHtmlAttr' :: DomBuilder t m => Text -> Map Text Text -> Dynamic t Text -> m (El t)

381elDynHtmlAttr' elementTag attrs html = do

382 e <- buildEmptyElement elementTag attrs

383 schedulePostBuild $ setInnerHTML e . Just =<< sample (current html)

384 performEvent_ $ fmap (setInnerHTML e . Just) $ updated html

385 wrapElement defaultDomEventHandler e

386-}

387

388data Link t

389 = Link { _link_clicked :: Event t ()

390 }

391

392linkClass :: DomBuilder t m => Text -> Text -> m (Link t)

393linkClass s c = do

394 (l,_) <- elAttr' "a" ("class" =: c) $ text s

395 return $ Link $ domEvent Click l

396

397link :: DomBuilder t m => Text -> m (Link t)

398link s = linkClass s ""

399

400divClass :: forall t m a. DomBuilder t m => Text -> m a -> m a

401divClass = elClass "div"

402

403dtdd :: forall t m a. DomBuilder t m => Text -> m a -> m a

404dtdd h w = do

405 el "dt" $ text h

406 el "dd" w

407

408blank :: forall m. Monad m => m ()

409blank = return ()

410

411newtype Workflow t m a = Workflow { unWorkflow :: m (a, Event t (Workflow t m a)) }

412

413workflow :: forall t m a. (DomBuilder t m, MonadFix m, MonadHold t m) => Workflow t m a -> m (Dynamic t a)

414workflow w0 = do

415 rec eResult <- widgetHold (unWorkflow w0) $ fmap unWorkflow $ switch $ snd <$> current eResult

416 return $ fmap fst eResult

417

418workflowView :: forall t m a. (DomBuilder t m, MonadFix m, MonadHold t m, PostBuild t m) => Workflow t m a -> m (Event t a)

419workflowView w0 = do

420 rec eResult <- dyn . fmap unWorkflow =<< holdDyn w0 eReplace

421 eReplace <- fmap switch $ hold never $ fmap snd eResult

422 return $ fmap fst eResult

423

424mapWorkflow :: (DomBuilder t m) => (a -> b) -> Workflow t m a -> Workflow t m b

425mapWorkflow f (Workflow x) = Workflow (fmap (f *** fmap (mapWorkflow f)) x)

426

427mapWorkflowCheap :: (DomBuilder t m) => (a -> b) -> Workflow t m a -> Workflow t m b

428mapWorkflowCheap f (Workflow x) = Workflow (fmap (f *** fmapCheap (mapWorkflowCheap f)) x)

429

430-- | A widget to display a table with static columns and dynamic rows.

431tableDynAttr :: forall t m r k v. (Ord k, DomBuilder t m, MonadHold t m, PostBuild t m, MonadFix m)

432 => Text -- ^ Class applied to <table> element

433 -> [(Text, k -> Dynamic t r -> m v)] -- ^ Columns of (header, row key -> row value -> child widget)

434 -> Dynamic t (Map k r) -- ^ Map from row key to row value

435 -> (k -> m (Dynamic t (Map Text Text))) -- ^ Function to compute <tr> element attributes from row key

436 -> m (Dynamic t (Map k (Element EventResult (DomBuilderSpace m) t, [v]))) -- ^ Map from row key to (El, list of widget return values)

437tableDynAttr klass cols dRows rowAttrs = elAttr "div" (Map.singleton "style" "zoom: 1; overflow: auto; background: white;") $ do

438 elAttr "table" (Map.singleton "class" klass) $ do

439 el "thead" $ el "tr" $ do

440 mapM_ (\(h, _) -> el "th" $ text h) cols

441 el "tbody" $ do

442 listWithKey dRows (\k r -> do

443 dAttrs <- rowAttrs k

444 elDynAttr' "tr" dAttrs $ mapM (\x -> el "td" $ snd x k r) cols)

445

446-- | A widget to construct a tabbed view that shows only one of its child widgets at a time.

447-- Creates a header bar containing a <ul> with one <li> per child; clicking a <li> displays

448-- the corresponding child and hides all others.

449tabDisplay :: forall t m k. (MonadFix m, DomBuilder t m, MonadHold t m, PostBuild t m, Ord k)

450 => Text -- ^ Class applied to <ul> element

451 -> Text -- ^ Class applied to currently active <li> element

452 -> Map k (Text, m ()) -- ^ Map from (arbitrary) key to (tab label, child widget)

453 -> m ()

454tabDisplay ulClass activeClass tabItems = do

455 let t0 = listToMaybe $ Map.keys tabItems

456 rec currentTab :: Demux t (Maybe k) <- elAttr "ul" ("class" =: ulClass) $ do

457 tabClicksList :: [Event t k] <- Map.elems <$> imapM (\k (s,_) -> headerBarLink s k $ demuxed currentTab (Just k)) tabItems

458 let eTabClicks :: Event t k = leftmost tabClicksList

459 fmap demux $ holdDyn t0 $ fmap Just eTabClicks

460 el "div" $ do

461 iforM_ tabItems $ \k (_, w) -> do

462 let isSelected = demuxed currentTab $ Just k

463 attrs = ffor isSelected $ \s -> if s then Map.empty else Map.singleton "style" "display:none;"

464 elDynAttr "div" attrs w

465 return ()

466 where

467 headerBarLink :: Text -> k -> Dynamic t Bool -> m (Event t k)

468 headerBarLink x k isSelected = do

469 let attrs = fmap (\b -> if b then Map.singleton "class" activeClass else Map.empty) isSelected

470 elDynAttr "li" attrs $ do

471 a <- link x

472 return $ fmap (const k) (_link_clicked a)

473

474class HasAttributes a where

475 type Attrs a :: *

476 attributes :: Lens' a (Attrs a)