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

git.iko.soy/reflex-dom

on efaaa52 help sign in

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

472 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

75 -- * Tables and Lists

76 , tableDynAttr

77 , tabDisplay

79 , HasAttributes (..)

80 ) where

82import Reflex.Class

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.Set (Set)

101import qualified Data.Set as Set

102import Data.Text (Text)

103import qualified Data.Text as T

104import Data.These

105import Data.Traversable

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

107

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

109widgetHoldInternal = runWithReplace

110

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

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

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

114

115--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

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

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

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

119 go [] m = if Map.null m

120 then []

121 else [(Right (), m)]

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

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

124 in if Map.null lt

125 then go t geq

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

127

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

129

130listHoldWithKey :: 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))

131listHoldWithKey m0 m' f = do

132 let dm0 = mapWithFunctorToDMap $ Map.mapWithKey f m0

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

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

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

136

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

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

139

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

141dynText t = do

142 postBuild <- getPostBuild

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

144 [ updated t

145 , tag (current t) postBuild

146 ]

147

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

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

150

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

152button t = do

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

154 return $ domEvent Click e

155

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

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

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

159-- 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').

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

161dyn child = do

162 postBuild <- getPostBuild

163 let newChild = leftmost [updated child, tag (current child) postBuild]

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

165

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

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

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

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

170widgetHold child0 newChild = do

171 (result0, newResult) <- widgetHoldInternal child0 newChild

172 holdDyn result0 newResult

173

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

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

176 This _ -> Just Nothing

177 These _ new -> Just $ Just new

178 That new -> Just $ Just new

179

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

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

182 This _ -> Just Nothing

183 These old new

184 | old == new -> Nothing

185 | otherwise -> Just $ Just new

186 That new -> Just $ Just new

187

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

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

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

191 maybeToEither = \case

192 Nothing -> Left ()

193 Just r -> Right r

194

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

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

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

198 fromLeft (Left l) = l

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

200 fromRight (Right r) = r

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

202

203-- | Apply a map patch to a set

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

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

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

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

208

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

210listWithKey :: 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))

211listWithKey vals mkChild = do

212 postBuild <- getPostBuild

213 let childValChangedSelector = fanMap $ updated vals

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

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

216 changeVals = attachWith diffMapNoEq (current sentVals) $ leftmost

217 [ updated vals

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

219 ]

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

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

222

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

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

225listWithKey' = listWithKeyShallowDiff

226

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

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

229listWithKeyShallowDiff initialVals valsChanged mkChild = do

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

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

232 let relevantPatch patch _ = case patch of

233 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

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

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

236 mkChild k v $ select childValChangedSelector $ Const2 k

237

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

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

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

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

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

243

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

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

246

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

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

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

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

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

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

253selectViewListWithKey selection vals mkChild = do

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

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

256 let selected = demuxed selectionDemux k

257 selectSelf <- mkChild k v selected

258 return $ fmap ((,) k) selectSelf

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

260

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

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

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

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

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

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

267

268-- | Create a DOM element

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

270-- <div>Hello World</div>

271{-# INLINABLE el #-}

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

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

274

275-- | Create a DOM element with attributes

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

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

278{-# INLINABLE elAttr #-}

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

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

281

282-- | Create a DOM element with classes

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

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

285{-# INLINABLE elClass #-}

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

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

288

289-- | Create a DOM element with Dynamic Attributes

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

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

292{-# INLINABLE elDynAttr #-}

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

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

295

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

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

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

299{-# INLINABLE elDynClass #-}

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

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

302

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

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

305-- > return $ domEvent Click e

306{-# INLINABLE el' #-}

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

308el' elementTag = element elementTag def

309

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

311{-# INLINABLE elAttr' #-}

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

313elAttr' elementTag attrs = element elementTag $ def

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

315

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

317{-# INLINABLE elClass' #-}

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

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

320

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

322{-# INLINABLE elDynAttr' #-}

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

324elDynAttr' = elDynAttrNS' Nothing

325

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

327{-# INLINABLE elDynClass' #-}

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

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

330

331{-# INLINABLE elDynAttrNS' #-}

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

333elDynAttrNS' mns elementTag attrs child = do

334 modifyAttrs <- dynamicAttributesToModifyAttributes attrs

335 let cfg = def

336 & elementConfig_namespace .~ mns

337 & modifyAttributes .~ fmap mapKeysToAttributeName modifyAttrs

338 element elementTag cfg child

339

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

341dynamicAttributesToModifyAttributes = dynamicAttributesToModifyAttributesWithInitial mempty

342

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

344dynamicAttributesToModifyAttributesWithInitial attrs0 d = do

345 postBuild <- getPostBuild

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

347 This () -> do

348 new <- sample $ current d

349 return $ diffMap attrs0 new

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

351 That new -> do

352 old <- sample $ current d

353 return $ diffMap old new

354 return modificationsNeeded

355

356--------------------------------------------------------------------------------

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

358--------------------------------------------------------------------------------

359

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

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

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

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

364

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

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

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

368

369{-

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

371

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

373elDynHtml' elementTag html = do

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

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

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

377 wrapElement defaultDomEventHandler e

378

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

380elDynHtmlAttr' elementTag attrs html = do

381 e <- buildEmptyElement elementTag attrs

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

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

384 wrapElement defaultDomEventHandler e

385-}

386

387data Link t

388 = Link { _link_clicked :: Event t ()

389 }

390

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

392linkClass s c = do

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

394 return $ Link $ domEvent Click l

395

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

397link s = linkClass s ""

398

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

400divClass = elClass "div"

401

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

403dtdd h w = do

404 el "dt" $ text h

405 el "dd" w

406

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

408blank = return ()

409

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

411

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

413workflow w0 = do

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

415 return $ fmap fst eResult

416

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

418workflowView w0 = do

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

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

421 return $ fmap fst eResult

422

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

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

425

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

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

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

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

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

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

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

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

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

435 el "thead" $ el "tr" $ do

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

437 el "tbody" $ do

438 listWithKey dRows (\k r -> do

439 dAttrs <- rowAttrs k

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

441

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

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

444-- the corresponding child and hides all others.

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

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

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

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

449 -> m ()

450tabDisplay ulClass activeClass tabItems = do

451 let t0 = listToMaybe $ Map.keys tabItems

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

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

454 let eTabClicks :: Event t k = leftmost tabClicksList

455 fmap demux $ holdDyn t0 $ fmap Just eTabClicks

456 el "div" $ do

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

458 let isSelected = demuxed currentTab $ Just k

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

460 elDynAttr "div" attrs w

461 return ()

462 where

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

464 headerBarLink x k isSelected = do

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

466 elDynAttr "li" attrs $ do

467 a <- link x

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

469

470class HasAttributes a where

471 type Attrs a :: *

472 attributes :: Lens' a (Attrs a)