Reduce complexity and 'black-boxed' nature of tab panel logic

DESCRIPTION

@@ -80,7 +80,7 @@ Imports:
     mime (>= 0.3),
     jsonlite (>= 0.9.16),
     xtable,
-    htmltools (>= 0.5.0.9001),
+    htmltools (>= 0.5.1.9002),
     R6 (>= 2.0),
     sourcetools,
     later (>= 1.0.0),
@@ -92,7 +92,7 @@ Imports:
     withr,
     commonmark (>= 1.7),
     glue (>= 1.3.2),
-    bslib (>= 0.2.2.9002),
+    bslib (>= 0.2.4.9003),
     cachem,
     ellipsis,
     lifecycle (>= 0.2.0)
@@ -113,6 +113,8 @@ Suggests:
     ragg,
     showtext,
     sass
+Remotes:
+    rstudio/htmltools
 URL: https://shiny.rstudio.com/
 BugReports: https://github.com/rstudio/shiny/issues
 Collate:

R/bootstrap.R

@@ -1026,119 +1026,72 @@ buildNavItem <- function(divTag, tabsetId, index) {
   divTag$attribs$title <- NULL
   list(
     divTag = divTag,
-    liTag = tagFunction(function() {
-      navItem <- if ("3" %in% getCurrentVersion()) bs3NavItem else bs4NavItem
-      navItem(id, title, value, icon, active)
-    })
-  )
-}
-
-buildDropdown <- function(divTag, tabset) {
-  title <- divTag$title
-  value <- divTag$menuName
-  icon <- getIcon(iconClass = divTag$iconClass)
-  active <- containsSelectedTab(divTag$tabs)
-  list(
-    # list of tab content divs from the child tabset
-    divTag = tabset$content$children,
-    liTag = tagFunction(function() {
-      if ("3" %in% getCurrentVersion()) {
-        bs3NavItemDropdown(title, value, icon, active, tabset$navList)
-      } else {
-        # In BS4, dropdown nav anchors can't be wrapped in a <li> tag
-        # and also need .nav-link replaced with .dropdown-item to be
-        # styled sensibly
-        items <- tabset$navList
-        items$children <- lapply(items$children, function(x) {
-          # x should be a tagFunction() due to the else block below
-          x <- if (inherits(x, "shiny.tag.function")) x() else x
-          # Replace <li class="nav-item"><a class="nav-link"></a></li>
-          #    with <a class="dropdown-item"></a>
-          if (tagHasClass(x, "nav-item")) {
-            x <- x$children[[1]]
-            x$attribs$class <- "dropdown-item"
-          }
-          x
-        })
-        bs4NavItemDropdown(title, value, icon, active, items)
+    liTag = tagAddRenderHook(
+      liTag(id, title, value, icon),
+      function(x) {
+        if (isTRUE(getCurrentVersion() >= 4)) {
+          tagQuery(x)$
+            addClass("nav-item")$
+            find("a")$
+            addClass(c("nav-link", if (active) "active"))$
+            root()
+        } else {
+          tagAppendAttributes(x, class = if (active) "active")
+        }
       }
-    })
+    )
   )
 }
 
-
-bs3NavItemDropdown <- function(title, value, icon, active, items) {
+liTag <- function(id, title, value, icon) {
   tags$li(
-    class = "dropdown",
-    class = if (active) "active", # BS3
     tags$a(
-      href = "#",
-      class = "dropdown-toggle",
-      `data-toggle` = "dropdown",
-      `data-value` = value,
-      icon,
-      title, tags$b(class = "caret")
-    ),
-    items
+      `data-toggle` = "tab", `data-value` = value,
+      href = paste0("#", id), icon, title
+    )
   )
 }
 
-bs3NavItem <- function(id, title, value, icon, active) {
-  tags$li(
-    class = if (active) "active",
-    tags$a(
-      href = paste0("#", id),
-      `data-toggle` = "tab",
-      `data-value` = value,
-      icon,
-      title
-    )
+buildDropdown <- function(divTag, tabset) {
+
+  navList <- tagAddRenderHook(
+    tabset$navList,
+    function(x) {
+      if (isTRUE(getCurrentVersion() >= 4)) {
+        tagQuery(x)$
+          removeClass("nav-item")$
+          find(".nav-link")$
+          removeClass("nav-link")$
+          addClass("dropdown-item")$
+          root()
+      } else {
+        x
+      }
+    }
   )
-}
 
-bs4NavItemDropdown <- function(title, value, icon, active, items) {
-  tags$li(
+  active <- containsSelectedTab(divTag$tabs)
+
+  dropdown <- tags$li(
     class = "dropdown",
-    class = "nav-item",
     tags$a(
       href = "#",
       class = "dropdown-toggle",
-      class = "nav-link",
-      class = if (active) "active",
       `data-toggle` = "dropdown",
-      `data-value` = value,
-      icon,
-      title,
-      tags$b(class = "caret") # TODO: can be removed?
+      `data-value` = divTag$menuName,
+      getIcon(iconClass = divTag$iconClass),
+      divTag$title,
+      tags$b(class = "caret")
     ),
-    items
+    navList
   )
-}
 
-bs4NavItem <- function(id, title, value, icon, active) {
-  tags$li(
-    class = "nav-item",
-    tags$a(
-      class = "nav-link",
-      class = if (active) "active",
-      href = paste0("#", id),
-      `data-toggle` = "tab",
-      `data-value` = value,
-      icon,
-      title
-    )
+  list(
+    divTag = tabset$content$children,
+    liTag = dropdown
   )
 }
 
-# TODO: something like this should exist in htmltools
-tagHasClass <- function(x, class) {
-  if (!inherits(x, "shiny.tag")) return(FALSE)
-  classes <- unlist(x$attribs[names(x$attribs) %in% "class"], use.names = FALSE)
-  if (!length(classes)) return(FALSE)
-  classes <- unlist(strsplit(classes, split = "\\s+"), use.names = FALSE)
-  isTRUE(class %in% classes)
-}
-
 #' Create a text output element
 #'
 #' Render a reactive output variable as text within an application page.

srcts/src/main.ts

@@ -1242,10 +1242,8 @@ function main(): void {
     function getTargetTabs($tabset, $tabContent, target) {
       const dataValue = "[data-value='" + $escape(target) + "']";
       const $aTag = $tabset.find("a" + dataValue);
-      let $liTag = $aTag.parent("li");
-      // BS3 dropdown anchors are wrapped in <li>, but they can't be in BS4
+      let $liTag = $aTag.parent();
 
-      if ($liTag.length === 0) $liTag = $aTag;
       if ($liTag.length === 0) {
         throw (
           "There is no tabPanel (or navbarMenu) with value" +
@@ -1262,12 +1260,10 @@ function main(): void {
         const $dropdownTabset = $aTag.find("+ ul.dropdown-menu");
         const dropdownId = $dropdownTabset.attr("data-tabsetid");
 
-        let $dropdownLiTags = $dropdownTabset.find("a[data-toggle='tab']");
-        // BS3 dropdown anchors are wrapped in <li>, but they can't be in BS4
+        const $dropdownLiTags = $dropdownTabset.find("a[data-toggle='tab']");
+
+        parent("li");
 
-        if ($dropdownLiTags.parent("li").length > 0) {
-          $dropdownLiTags = $dropdownLiTags.parent("li");
-        }
         $dropdownLiTags.each(function (i, el) {
           $liTags.push($(el));
         });
@@ -1291,7 +1287,7 @@ function main(): void {
       let tabsetId = $parentTabset.attr("data-tabsetid");
 
       const $divTag = $(message.divTag.html);
-      let $liTag = $(message.liTag.html);
+      const $liTag = $(message.liTag.html);
       const $aTag = $liTag.find("> a");
 
       // Unless the item is being prepended/appended, the target tab
@@ -1302,12 +1298,6 @@ function main(): void {
       if (message.target !== null) {
         target = getTargetTabs($tabset, $tabContent, message.target);
         $targetLiTag = target.$liTag;
-        // If the target is a (BS4) .dropdown-item, then we can't insert
-        // <li class='nav-item'><a class='nav-link'>...</a></li>,
-        // instead, we need <a class='dropdown-item'>...</a>
-        if ($targetLiTag.hasClass("dropdown-item")) {
-          $liTag = $aTag.removeClass("nav-link").addClass("dropdown-item");
-        }
       }
 
       // If the item is to be placed inside a navbarMenu (dropdown),
@@ -1332,11 +1322,7 @@ function main(): void {
         const index = getTabIndex($tabset, tabsetId);
         const tabId = "tab-" + tabsetId + "-" + index;
 
-        let anchor = $liTag.find("> a");
-        // BS3 dropdown anchors are wrapped in <li>, but they can't be in BS4
-
-        if (anchor.length === 0) anchor = $liTag;
-        anchor.attr("href", "#" + tabId);
+        $liTag.find("> a").attr("href", "#" + tabId);
         $divTag.attr("id", tabId);
       }