Add label html utils

src/main/rapid_test/html.clj

@@ -1,8 +1,11 @@
 (ns rapid-test.html
   "HTML testing utils inspired by Testing Library (https://testing-library.com/)"
   (:require [potemkin :refer [import-vars]]
-            [rapid-test.html.role]))
+            [rapid-test.html.label]
+            [rapid-test.html.role]
+            [rapid-test.html.utils]))
 
 ;; Re-exports functions from other files
 
-(import-vars [rapid-test.html.role get-by-role get-all-by-role])
+(import-vars [rapid-test.html.label get-by-label get-all-by-label]
+             [rapid-test.html.role get-by-role get-all-by-role])

src/main/rapid_test/html/label.clj

@@ -0,0 +1,88 @@
+(ns rapid-test.html.label
+  (:require [clojure.zip :as zip]
+            [rapid-test.hiccup-zipper :refer [hiccup-zipper]]
+            [rapid-test.html.utils :as util]))
+
+(defn- labeled-by-for?
+  "Check if a <label for=\"X\"> exists whose text matches, and the current node's id is X."
+  [label-text hzip root]
+  (let [node    (zip/node hzip)
+        node-id (util/get-attribute node :id)]
+    (when node-id
+      (loop [lzip (hiccup-zipper root)]
+        (if (zip/end? lzip)
+          false
+          (let [lnode (zip/node lzip)]
+            (if (and (not (string? lnode))
+                     (= :label (util/get-base-tag lnode))
+                     (let [for-attr (util/get-attribute lnode :for)]
+                       (and for-attr (= (name for-attr) (name node-id))))
+                     (util/text-match? label-text (util/get-text lnode)))
+              true
+              (recur (zip/next lzip)))))))))
+
+(defn- labeled-by-wrapping?
+  "Check if the current node is inside a <label> ancestor whose text matches."
+  [label-text hzip]
+  (loop [loc (zip/up hzip)]
+    (if (nil? loc)
+      false
+      (let [node (zip/node loc)]
+        (if (and (vector? node)
+                 (= :label (util/get-base-tag node))
+                 (util/text-match? label-text (util/get-text node)))
+          true
+          (recur (zip/up loc)))))))
+
+(defn- labeled-by-aria-label?
+  "Check if the node's aria-label matches."
+  [label-text hiccup]
+  (let [aria-label (util/get-attribute hiccup :aria-label)]
+    (and aria-label (util/text-match? label-text aria-label))))
+
+(defn- labeled-by-aria-labelledby?
+  "Check if the node has aria-labelledby, resolve the referenced element, get its text, and compare."
+  [label-text hiccup root]
+  (let [labelledby (util/get-attribute hiccup :aria-labelledby)]
+    (when labelledby
+      (let [referenced (util/find-by-id labelledby root)]
+        (and referenced
+             (util/text-match? label-text (util/get-text referenced)))))))
+
+(defn- label-match?
+  "Check if a node is labeled by the given text via any of the four mechanisms."
+  [label-text hzip root]
+  (let [node (zip/node hzip)]
+    (or (labeled-by-for? label-text hzip root)
+        (labeled-by-wrapping? label-text hzip)
+        (labeled-by-aria-label? label-text node)
+        (labeled-by-aria-labelledby? label-text node root))))
+
+(defn get-by-label
+  "Return the first element labeled by `label-text`, or nil."
+  [label-text hiccup]
+  (loop [hzip (hiccup-zipper hiccup)]
+    (if (zip/end? hzip)
+      nil
+      (let [node (zip/node hzip)]
+        (if (and (not (string? node))
+                 (not= :label (util/get-base-tag node))
+                 (label-match? label-text hzip hiccup))
+          node
+          (recur (zip/next hzip)))))))
+
+(defn get-all-by-label
+  "Return a vector of all elements labeled by `label-text`."
+  [label-text hiccup]
+  (loop [hzip    (hiccup-zipper hiccup)
+         results []]
+    (if (zip/end? hzip)
+      results
+      (let [node (zip/node hzip)]
+        (if (and (not (string? node))
+                 (not= :label (util/get-base-tag node))
+                 (label-match? label-text hzip hiccup))
+          (recur (zip/next hzip)
+                 (conj results node))
+          (recur (zip/next hzip)
+                 results))))))

src/main/rapid_test/html/utils.clj

@@ -85,6 +85,26 @@
        (recur sb
               (zip/next hzip))))))
 
+(defn find-by-id
+  "Traverse the hiccup tree to find the element with a matching :id attribute."
+  [id root]
+  (loop [hzip (hiccup-zipper root)]
+    (if (zip/end? hzip)
+      nil
+      (let [node (zip/node hzip)]
+        (if (and (not (string? node))
+                 (let [node-id (get-attribute node :id)]
+                   (and node-id (= (name id) (name node-id)))))
+          node
+          (recur (zip/next hzip)))))))
+
+(defn text-match?
+  "Compare text; supports both exact string and regex pattern."
+  [pattern text]
+  (if (instance? java.util.regex.Pattern pattern)
+    (boolean (re-find pattern (or text "")))
+    (= pattern text)))
+
 (defn get-accessible-name [hiccup]
   (or (get-attribute hiccup :aria-label) (get-text hiccup)))
 
@@ -105,13 +125,7 @@
 (defn matches-options? [hiccup opts]
   (let [{:keys [name level]} opts]
     (and (if name
-           (let [accessible-name (get-accessible-name hiccup)]
-             (if (instance? java.util.regex.Pattern
-                            name)
-               (boolean (re-find name
-                                 (or accessible-name
-                                     "")))
-               (= name accessible-name)))
+           (text-match? name (get-accessible-name hiccup))
            true)
          (if level
            (= level (get-heading-level hiccup))

test/main/rapid_test/html_test.clj

@@ -234,3 +234,52 @@
   (testing "2-arity"
     (is (= [[:h1 "A"] [:h2 "B"]]
            (sut/get-all-by-role :heading [:div [:h1 "A"] [:h2 "B"]])))))
+
+(deftest get-by-label-test
+  (testing "label with for attribute"
+    (is (= [:input {:id "username"}]
+           (sut/get-by-label "Username"
+                             [:div
+                              [:label {:for "username"} "Username"]
+                              [:input {:id "username"}]]))))
+  (testing "label with keyword id"
+    (is (= [:input#my-id]
+           (sut/get-by-label "Username"
+                             [:div
+                              [:label {:for :my-id} "Username"]
+                              [:input#my-id]]))))
+  (testing "wrapping label"
+    (is (= [:input]
+           (sut/get-by-label "Username"
+                             [:div
+                              [:label "Username" [:input]]]))))
+  (testing "aria-label"
+    (is (= [:button {:aria-label "Close"} "X"]
+           (sut/get-by-label "Close"
+                             [:div
+                              [:button {:aria-label "Close"} "X"]]))))
+  (testing "aria-labelledby"
+    (is (= [:input {:aria-labelledby "name-label"}]
+           (sut/get-by-label "Full Name"
+                             [:div
+                              [:span {:id "name-label"} "Full Name"]
+                              [:input {:aria-labelledby "name-label"}]]))))
+  (testing "returns nil when no label matches"
+    (is (nil? (sut/get-by-label "Username"
+                                [:div [:input {:id "username"}]]))))
+  (testing "returns nil when label text doesn't match"
+    (is (nil? (sut/get-by-label "Password"
+                                [:div
+                                 [:label {:for "username"} "Username"]
+                                 [:input {:id "username"}]])))))
+
+(deftest get-all-by-label-test
+  (testing "returns all elements with matching label"
+    (is (= [[:input {:id "first"}] [:input {:id "second" :aria-label "Name"}]]
+           (sut/get-all-by-label "Name"
+                                 [:div
+                                  [:label {:for "first"} "Name"]
+                                  [:input {:id "first"}]
+                                  [:input {:id "second" :aria-label "Name"}]]))))
+  (testing "returns empty vector when no matches"
+    (is (= [] (sut/get-all-by-label "Username" [:div [:input]])))))