From a9b1cf4ed718518d61794657b933d6d7378c5ebe Mon Sep 17 00:00:00 2001 From: Brandon Olivier Date: Wed, 11 Feb 2026 05:21:15 -0600 Subject: [PATCH 1/2] Add tests for more roles --- src/main/rapid_test/html.clj | 221 ++++++++++++++++++++++++++--- test/main/rapid_test/html_test.clj | 204 +++++++++++++++++++++++++- 2 files changed, 404 insertions(+), 21 deletions(-) diff --git a/src/main/rapid_test/html.clj b/src/main/rapid_test/html.clj index d699c5a..b390072 100644 --- a/src/main/rapid_test/html.clj +++ b/src/main/rapid_test/html.clj @@ -20,18 +20,14 @@ class-sb (StringBuilder.) _ (.append class-sb (or (:class base-props) "")) tag-str (name (first hiccup)) - props (transient base-props)] - - - (loop [tag-props-seq (rest (map #(apply str %) - (partition-by #{\. \#} tag-str)))] + (partition-by #{\. \#} tag-str)))] (when-not (empty? tag-props-seq) (let [[marker-char value & rst] tag-props-seq] (case marker-char "#" (do (reset! id - (keyword value)) + (keyword value)) (recur rst)) "." (do (.append class-sb (format " %s" @@ -90,22 +86,139 @@ (= parent-el :menu))) false))) +(def ^:private simple-role->tags + {:heading #{:h1 :h2 :h3 :h4 :h5 :h6} + :img #{:img} + :table #{:table} + :row #{:tr} + :cell #{:td} + :columnheader #{:th} + :separator #{:hr} + :article #{:article} + :figure #{:figure} + :navigation #{:nav} + :main #{:main} + :complementary #{:aside} + :form #{:form} + :region #{:section} + :dialog #{:dialog} + :meter #{:meter} + :progressbar #{:progress} + :option #{:option} + :search #{:search}}) + +(defn- input-type? + "True if hiccup is an with type in type-set. nil in type-set matches inputs with no type." + [hiccup type-set] + (and (= :input (get-base-tag hiccup)) + (let [raw-type (get-attribute hiccup :type) + input-type (when raw-type + (name raw-type))] + (contains? type-set input-type)))) + +(defn- explicit-role? + "True if hiccup has an explicit role attribute matching the given role keyword." + [hiccup role] + (let [r (get-attribute hiccup :role)] + (and r (= (name role) (name r))))) + +(defn- inside-sectioning-content? + "True if the zipper location is inside an article, aside, main, nav, or section element." + [hzip] + (let [sectioning-tags #{:article :aside :main :nav :section}] + (loop [loc (zip/up hzip)] + (if (nil? loc) + false + (let [node (zip/node loc)] + (if (and (vector? node) + (contains? sectioning-tags + (get-base-tag node))) + true + (recur (zip/up loc)))))))) + +(m/defmethod role-match? :button + [_ hzip] + (let [hiccup (zip/node hzip)] + (or (= :button (get-base-tag hiccup)) + (input-type? hiccup #{"button" "submit" "reset"}) + (explicit-role? hiccup :button)))) + +(m/defmethod role-match? :textbox + [_ hzip] + (let [hiccup (zip/node hzip)] + (or (= :textarea (get-base-tag hiccup)) + (input-type? hiccup #{"text" nil}) + (explicit-role? hiccup :textbox)))) + +(m/defmethod role-match? :checkbox + [_ hzip] + (let [hiccup (zip/node hzip)] + (or (input-type? hiccup #{"checkbox"}) (explicit-role? hiccup :checkbox)))) + +(m/defmethod role-match? :radio + [_ hzip] + (let [hiccup (zip/node hzip)] + (or (input-type? hiccup #{"radio"}) (explicit-role? hiccup :radio)))) + +(m/defmethod role-match? :searchbox + [_ hzip] + (let [hiccup (zip/node hzip)] + (or (input-type? hiccup #{"search"}) (explicit-role? hiccup :searchbox)))) + +(m/defmethod role-match? :slider + [_ hzip] + (let [hiccup (zip/node hzip)] + (or (input-type? hiccup #{"range"}) (explicit-role? hiccup :slider)))) + +(m/defmethod role-match? :spinbutton + [_ hzip] + (let [hiccup (zip/node hzip)] + (or (input-type? hiccup #{"number"}) (explicit-role? hiccup :spinbutton)))) + +(m/defmethod role-match? :link + [_ hzip] + (let [hiccup (zip/node hzip)] + (or (and (= :a (get-base-tag hiccup)) (some? (get-attribute hiccup :href))) + (explicit-role? hiccup :link)))) + +(m/defmethod role-match? :banner + [_ hzip] + (let [hiccup (zip/node hzip)] + (or (and (= :header (get-base-tag hiccup)) + (not (inside-sectioning-content? hzip))) + (explicit-role? hiccup :banner)))) + +(m/defmethod role-match? :contentinfo + [_ hzip] + (let [hiccup (zip/node hzip)] + (or (and (= :footer (get-base-tag hiccup)) + (not (inside-sectioning-content? hzip))) + (explicit-role? hiccup :contentinfo)))) + +(m/defmethod role-match? :rowheader + [_ hzip] + (let [hiccup (zip/node hzip)] + (or (and (= :th (get-base-tag hiccup)) + (= "row" + (some-> (get-attribute hiccup :scope) + name))) + (explicit-role? hiccup :rowheader)))) + +(m/defmethod role-match? :combobox + [_ hzip] + (let [hiccup (zip/node hzip)] + (or (and (= :select (get-base-tag hiccup)) + (not (get-attribute hiccup :multiple)) + (let [size (get-attribute hiccup :size)] + (or (nil? size) (<= (long size) 1)))) + (explicit-role? hiccup :combobox)))) + (m/defmethod role-match? :default [role hzip] - (let [hiccup (zip/node hzip)] - (throw (ex-info (format "`role-match?` not implemented for role `%s`" role) - {:role role - :hiccup hiccup})))) - -(defn get-by-role [role hiccup] - (loop [hzip (hiccup-zipper hiccup)] - (if (zip/end? hzip) - nil - (if (and (not (string? (zip/node hzip))) - (role-match? role - hzip)) - (zip/node hzip) - (recur (zip/next hzip)))))) + (let [hiccup (zip/node hzip) + tag (get-base-tag hiccup)] + (or (contains? (get simple-role->tags role) tag) + (explicit-role? hiccup role)))) (defn get-text "Get the (nested) text of a hiccup node." @@ -121,6 +234,74 @@ (recur sb (zip/next hzip)))))) +(defn- get-accessible-name [hiccup] + (or (get-attribute hiccup :aria-label) (get-text hiccup))) + +(def ^:private heading-tag->level + {:h1 1 + :h2 2 + :h3 3 + :h4 4 + :h5 5 + :h6 6}) + +(defn- get-heading-level [hiccup] + (or (some-> (get-attribute hiccup :aria-level) + str + parse-long) + (get heading-tag->level (get-base-tag hiccup)))) + +(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))) + true) + (if level + (= level (get-heading-level hiccup)) + true)))) + +(defn get-by-role + ([role hiccup] + (get-by-role role hiccup {})) + ([role hiccup opts] + (loop [hzip (hiccup-zipper hiccup)] + (if (zip/end? hzip) + nil + (let [node (zip/node hzip)] + (if (and (not (string? node)) + (role-match? role + hzip) + (matches-options? node + opts)) + node + (recur (zip/next hzip)))))))) + +(defn get-all-by-role + ([role hiccup] + (get-all-by-role role hiccup {})) + ([role hiccup opts] + (loop [hzip (hiccup-zipper hiccup) + results []] + (if (zip/end? hzip) + results + (let [node (zip/node hzip)] + (if (and (not (string? node)) + (role-match? role + hzip) + (matches-options? node + opts)) + (recur (zip/next hzip) + (conj results + node)) + (recur (zip/next hzip) + results))))))) + (comment (def hiccup [:input.inpt#my-id]) diff --git a/test/main/rapid_test/html_test.clj b/test/main/rapid_test/html_test.clj index 65b7584..6d9d961 100644 --- a/test/main/rapid_test/html_test.clj +++ b/test/main/rapid_test/html_test.clj @@ -50,7 +50,209 @@ (is (= [:li "Incorrect email or password."] (sut/get-by-role :listitem [:ul#errors.error-messages {:hx-swap-oob true} - '([:li "Incorrect email or password."])]))))) + '([:li "Incorrect email or password."])])))) + (testing "simple role mappings" + (testing "heading" + (is (= [:h1 "Title"] (sut/get-by-role :heading [:div [:h1 "Title"]]))) + (is (= [:h3 "Sub"] (sut/get-by-role :heading [:div [:h3 "Sub"]])))) + (testing "img" + (is (= [:img {:src "a.png" + :alt "pic"}] + (sut/get-by-role :img + [:div + [:img {:src "a.png" + :alt "pic"}]])))) + (testing "table / row / cell / columnheader" + (let [html [:table [:tr [:th "Name"] [:td "Alice"]]]] + (is (= html (sut/get-by-role :table [:div html]))) + (is (= [:tr [:th "Name"] [:td "Alice"]] + (sut/get-by-role :row [:div html]))) + (is (= [:td "Alice"] (sut/get-by-role :cell [:div html]))) + (is (= [:th "Name"] (sut/get-by-role :columnheader [:div html]))))) + (testing "separator" + (is (= [:hr] (sut/get-by-role :separator [:div [:hr]])))) + (testing "article" + (is (= [:article "Post"] + (sut/get-by-role :article [:div [:article "Post"]])))) + (testing "figure" + (is (= [:figure [:img {:src "x"}]] + (sut/get-by-role :figure + [:div [:figure [:img {:src "x"}]]])))) + (testing "navigation" + (is (= [:nav + [:a {:href "/"} + "Home"]] + (sut/get-by-role :navigation + [:div + [:nav + [:a {:href "/"} + "Home"]]])))) + (testing "main" + (is (= [:main "Content"] + (sut/get-by-role :main [:div [:main "Content"]])))) + (testing "complementary" + (is (= [:aside "Sidebar"] + (sut/get-by-role :complementary [:div [:aside "Sidebar"]])))) + (testing "dialog" + (is (= [:dialog "Modal"] + (sut/get-by-role :dialog [:div [:dialog "Modal"]])))) + (testing "form" + (is (= [:form [:input]] (sut/get-by-role :form [:div [:form [:input]]])))) + (testing "region" + (is (= [:section "Area"] + (sut/get-by-role :region [:div [:section "Area"]])))) + (testing "meter" + (is (= [:meter {:value 5}] + (sut/get-by-role :meter + [:div [:meter {:value 5}]])))) + (testing "progressbar" + (is (= [:progress {:value 50}] + (sut/get-by-role :progressbar + [:div [:progress {:value 50}]])))) + (testing "option" + (is (= [:option "A"] + (sut/get-by-role :option [:select [:option "A"] [:option "B"]])))) + (testing "search" + (is (= [:search [:input]] + (sut/get-by-role :search [:div [:search [:input]]]))))) + (testing "input-type dispatch" + (testing "button" + (is (some? (sut/get-by-role :button [:div [:button "Click"]]))) + (is (some? (sut/get-by-role :button + [:div [:input {:type "submit"}]]))) + (is (some? (sut/get-by-role :button + [:div [:input {:type "reset"}]]))) + (is (some? (sut/get-by-role :button + [:div [:input {:type "button"}]])))) + (testing "textbox" + (is (some? (sut/get-by-role :textbox [:div [:textarea]]))) + (is (some? (sut/get-by-role :textbox + [:div [:input {:type "text"}]]))) + (is (some? (sut/get-by-role :textbox [:div [:input]]))) + (is (nil? (sut/get-by-role :textbox + [:div [:input {:type "email"}]])))) + (testing "checkbox" + (is (some? (sut/get-by-role :checkbox + [:div [:input {:type "checkbox"}]])))) + (testing "radio" + (is (some? (sut/get-by-role :radio + [:div [:input {:type "radio"}]])))) + (testing "searchbox" + (is (some? (sut/get-by-role :searchbox + [:div [:input {:type "search"}]])))) + (testing "slider" + (is (some? (sut/get-by-role :slider + [:div [:input {:type "range"}]])))) + (testing "spinbutton" + (is (some? (sut/get-by-role :spinbutton + [:div [:input {:type "number"}]]))))) + (testing "conditional roles" + (testing "link" + (is (some? (sut/get-by-role :link + [:div + [:a {:href "/page"} + "Link"]]))) + (is (nil? (sut/get-by-role :link [:div [:a "No href"]])))) + (testing "banner" + (is (some? (sut/get-by-role :banner [:div [:header "Site Header"]]))) + (is (nil? (sut/get-by-role :banner + [:div + [:article [:header "Article Header"]]])))) + (testing "contentinfo" + (is (some? (sut/get-by-role :contentinfo [:div [:footer "Site Footer"]]))) + (is (nil? (sut/get-by-role :contentinfo + [:div [:nav [:footer "Nav Footer"]]])))) + (testing "rowheader" + (is (some? (sut/get-by-role :rowheader + [:table + [:tr + [:th {:scope "row"} + "Name"]]]))) + (is (nil? (sut/get-by-role :rowheader [:table [:tr [:th "Name"]]])))) + (testing "combobox" + (is (some? (sut/get-by-role :combobox [:div [:select [:option "A"]]]))) + (is (nil? (sut/get-by-role :combobox + [:div + [:select {:multiple true} + [:option "A"]]]))))) + (testing "explicit role attribute fallback" + (is (some? (sut/get-by-role :alert + [:div + [:div {:role "alert"} + "Error!"]]))) + (is (some? (sut/get-by-role :status + [:div + [:div {:role "status"} + "OK"]]))) + (is (some? (sut/get-by-role :switch + [:div + [:span {:role "switch"} + "Toggle"]]))) + (is (nil? (sut/get-by-role :alert [:div [:span "No role here"]])))) + (testing "2-arity backward compatibility" + (is (= [:h1 "Title"] (sut/get-by-role :heading [:div [:h1 "Title"]])))) + (testing "returns nil for no match" + (is (nil? (sut/get-by-role :button [:div [:span "Not a button"]]))))) + +(deftest get-by-role-options-test + (testing "name option - exact string match" + (is (= [:button "Save"] + (sut/get-by-role :button + [:div [:button "Cancel"] [:button "Save"]] + {:name "Save"})))) + (testing "name option - aria-label takes precedence" + (is (= [:button {:aria-label "Close dialog"} + "X"] + (sut/get-by-role :button + [:div + [:button {:aria-label "Close dialog"} + "X"]] + {:name "Close dialog"})))) + (testing "name option - regex" + (is (= [:button "Save changes"] + (sut/get-by-role :button + [:div [:button "Cancel"] [:button "Save changes"]] + {:name #"Save"})))) + (testing "level option - tag-derived" + (is (= [:h2 "Subtitle"] + (sut/get-by-role :heading + [:div [:h1 "Title"] [:h2 "Subtitle"]] + {:level 2})))) + (testing "level option - aria-level" + (is (= [:div {:role "heading" + :aria-level 3} + "Custom"] + (sut/get-by-role :heading + [:div + [:h1 "Title"] + [:div {:role "heading" + :aria-level 3} + "Custom"]] + {:level 3})))) + (testing "name and level combined" + (is (= [:h2 "Features"] + (sut/get-by-role + :heading + [:div [:h2 "About"] [:h2 "Features"] [:h3 "Details"]] + {:name "Features" + :level 2}))))) + +(deftest get-all-by-role-test + (testing "returns all matches" + (is (= [[:li "A"] [:li "B"] [:li "C"]] + (sut/get-all-by-role :listitem + [:ul [:li "A"] [:li "B"] [:li "C"]])))) + (testing "returns empty vector when no matches" + (is (= [] (sut/get-all-by-role :button [:div [:span "No buttons"]])))) + (testing "with options" + (is (= [[:h2 "One"] [:h2 "Two"]] + (sut/get-all-by-role + :heading + [:div [:h1 "Title"] [:h2 "One"] [:h2 "Two"] [:h3 "Three"]] + {:level 2})))) + (testing "2-arity" + (is (= [[:h1 "A"] [:h2 "B"]] + (sut/get-all-by-role :heading [:div [:h1 "A"] [:h2 "B"]]))))) (deftest get-text-test (is (= "" (sut/get-text nil))) From 944f85598276b60d43d04b9b1466e7d4607a178e Mon Sep 17 00:00:00 2001 From: Brandon Olivier Date: Wed, 11 Feb 2026 06:00:12 -0600 Subject: [PATCH 2/2] Reorg functions for html testing --- src/main/rapid_test/html.clj | 319 +---------------------- src/main/rapid_test/html/role.clj | 200 ++++++++++++++ src/main/rapid_test/html/utils.clj | 118 +++++++++ test/main/rapid_test/html/utils_test.clj | 50 ++++ test/main/rapid_test/html_test.clj | 63 ++--- 5 files changed, 388 insertions(+), 362 deletions(-) create mode 100644 src/main/rapid_test/html/role.clj create mode 100644 src/main/rapid_test/html/utils.clj create mode 100644 test/main/rapid_test/html/utils_test.clj diff --git a/src/main/rapid_test/html.clj b/src/main/rapid_test/html.clj index b390072..a5cb554 100644 --- a/src/main/rapid_test/html.clj +++ b/src/main/rapid_test/html.clj @@ -1,319 +1,8 @@ (ns rapid-test.html "HTML testing utils inspired by Testing Library (https://testing-library.com/)" - (:require [clojure.string :as str] - [clojure.zip :as zip] - [methodical.core :as m] - [rapid-test.hiccup-zipper :refer [hiccup-zipper]])) + (:require [potemkin :refer [import-vars]] + [rapid-test.html.role])) -(defn has-props? - "Return whether the hiccup has an explicit props map." - [hiccup] - (map? (second hiccup))) +;; Re-exports functions from other files -(defn get-props - "Get the props for a hiccup element" - [hiccup] - (let [base-props (if (has-props? hiccup) - (second hiccup) - {}) - id (atom nil) - class-sb (StringBuilder.) - _ (.append class-sb (or (:class base-props) "")) - tag-str (name (first hiccup)) - props (transient base-props)] - (loop [tag-props-seq (rest (map #(apply str %) - (partition-by #{\. \#} tag-str)))] - (when-not (empty? tag-props-seq) - (let [[marker-char value & rst] tag-props-seq] - (case marker-char - "#" (do (reset! id - (keyword value)) - (recur rst)) - "." (do (.append class-sb - (format " %s" - value)) - (recur rst)))))) - (let [class (str/trim (.toString class-sb))] - (when-not (empty? class) - (assoc! props - :class - class))) - (when (and @id - (not (:id base-props))) - (assoc! props - :id - @id)) - (persistent! props))) - -(defn get-attribute - "Get `attribute` from `hiccup`. Works when attribute is from a compound tag." - [hiccup attr] - (let [props (get-props hiccup)] - (get props attr))) - -(defn get-base-tag - "Convert a compound tag into a simple tag. - - :div#my-id.my-class => :div" - [hiccup] - (let [tag (first hiccup)] - (->> tag - name - (take-while #(and (not= \# %) (not= \. %))) - (apply str) - keyword))) - -(m/defmulti role-match? - "Return a node from a hiccup tree that has the html role `role`. - - Note: Takes a hiccup zipper and not plain hiccup" - (fn [role _] role)) - -(m/defmethod role-match? :list - [_ hzip] - (let [hiccup (zip/node hzip)] - (or (contains? #{:menu :ol :ul} (get-base-tag hiccup)) - (= :list (get-attribute hiccup :role))))) - -(m/defmethod role-match? :listitem - [_ hzip] - (let [tag (get-base-tag (zip/node hzip))] - (if (= :li tag) - (let [parent-el (when-let [parent (zip/up hzip)] - (get-base-tag (zip/node parent)))] - (or (= parent-el :ol) - (= parent-el :ul) - (= parent-el :menu))) - false))) - -(def ^:private simple-role->tags - {:heading #{:h1 :h2 :h3 :h4 :h5 :h6} - :img #{:img} - :table #{:table} - :row #{:tr} - :cell #{:td} - :columnheader #{:th} - :separator #{:hr} - :article #{:article} - :figure #{:figure} - :navigation #{:nav} - :main #{:main} - :complementary #{:aside} - :form #{:form} - :region #{:section} - :dialog #{:dialog} - :meter #{:meter} - :progressbar #{:progress} - :option #{:option} - :search #{:search}}) - -(defn- input-type? - "True if hiccup is an with type in type-set. nil in type-set matches inputs with no type." - [hiccup type-set] - (and (= :input (get-base-tag hiccup)) - (let [raw-type (get-attribute hiccup :type) - input-type (when raw-type - (name raw-type))] - (contains? type-set input-type)))) - -(defn- explicit-role? - "True if hiccup has an explicit role attribute matching the given role keyword." - [hiccup role] - (let [r (get-attribute hiccup :role)] - (and r (= (name role) (name r))))) - -(defn- inside-sectioning-content? - "True if the zipper location is inside an article, aside, main, nav, or section element." - [hzip] - (let [sectioning-tags #{:article :aside :main :nav :section}] - (loop [loc (zip/up hzip)] - (if (nil? loc) - false - (let [node (zip/node loc)] - (if (and (vector? node) - (contains? sectioning-tags - (get-base-tag node))) - true - (recur (zip/up loc)))))))) - -(m/defmethod role-match? :button - [_ hzip] - (let [hiccup (zip/node hzip)] - (or (= :button (get-base-tag hiccup)) - (input-type? hiccup #{"button" "submit" "reset"}) - (explicit-role? hiccup :button)))) - -(m/defmethod role-match? :textbox - [_ hzip] - (let [hiccup (zip/node hzip)] - (or (= :textarea (get-base-tag hiccup)) - (input-type? hiccup #{"text" nil}) - (explicit-role? hiccup :textbox)))) - -(m/defmethod role-match? :checkbox - [_ hzip] - (let [hiccup (zip/node hzip)] - (or (input-type? hiccup #{"checkbox"}) (explicit-role? hiccup :checkbox)))) - -(m/defmethod role-match? :radio - [_ hzip] - (let [hiccup (zip/node hzip)] - (or (input-type? hiccup #{"radio"}) (explicit-role? hiccup :radio)))) - -(m/defmethod role-match? :searchbox - [_ hzip] - (let [hiccup (zip/node hzip)] - (or (input-type? hiccup #{"search"}) (explicit-role? hiccup :searchbox)))) - -(m/defmethod role-match? :slider - [_ hzip] - (let [hiccup (zip/node hzip)] - (or (input-type? hiccup #{"range"}) (explicit-role? hiccup :slider)))) - -(m/defmethod role-match? :spinbutton - [_ hzip] - (let [hiccup (zip/node hzip)] - (or (input-type? hiccup #{"number"}) (explicit-role? hiccup :spinbutton)))) - -(m/defmethod role-match? :link - [_ hzip] - (let [hiccup (zip/node hzip)] - (or (and (= :a (get-base-tag hiccup)) (some? (get-attribute hiccup :href))) - (explicit-role? hiccup :link)))) - -(m/defmethod role-match? :banner - [_ hzip] - (let [hiccup (zip/node hzip)] - (or (and (= :header (get-base-tag hiccup)) - (not (inside-sectioning-content? hzip))) - (explicit-role? hiccup :banner)))) - -(m/defmethod role-match? :contentinfo - [_ hzip] - (let [hiccup (zip/node hzip)] - (or (and (= :footer (get-base-tag hiccup)) - (not (inside-sectioning-content? hzip))) - (explicit-role? hiccup :contentinfo)))) - -(m/defmethod role-match? :rowheader - [_ hzip] - (let [hiccup (zip/node hzip)] - (or (and (= :th (get-base-tag hiccup)) - (= "row" - (some-> (get-attribute hiccup :scope) - name))) - (explicit-role? hiccup :rowheader)))) - -(m/defmethod role-match? :combobox - [_ hzip] - (let [hiccup (zip/node hzip)] - (or (and (= :select (get-base-tag hiccup)) - (not (get-attribute hiccup :multiple)) - (let [size (get-attribute hiccup :size)] - (or (nil? size) (<= (long size) 1)))) - (explicit-role? hiccup :combobox)))) - -(m/defmethod role-match? :default - [role hzip] - (let [hiccup (zip/node hzip) - tag (get-base-tag hiccup)] - (or (contains? (get simple-role->tags role) tag) - (explicit-role? hiccup role)))) - -(defn get-text - "Get the (nested) text of a hiccup node." - ([hiccup] - (.toString (get-text (StringBuilder.) (hiccup-zipper hiccup)))) - ([sb hzip] - (if (zip/end? hzip) - sb - (let [node (zip/node hzip)] - (when (string? node) - (.append sb - node)) - (recur sb - (zip/next hzip)))))) - -(defn- get-accessible-name [hiccup] - (or (get-attribute hiccup :aria-label) (get-text hiccup))) - -(def ^:private heading-tag->level - {:h1 1 - :h2 2 - :h3 3 - :h4 4 - :h5 5 - :h6 6}) - -(defn- get-heading-level [hiccup] - (or (some-> (get-attribute hiccup :aria-level) - str - parse-long) - (get heading-tag->level (get-base-tag hiccup)))) - -(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))) - true) - (if level - (= level (get-heading-level hiccup)) - true)))) - -(defn get-by-role - ([role hiccup] - (get-by-role role hiccup {})) - ([role hiccup opts] - (loop [hzip (hiccup-zipper hiccup)] - (if (zip/end? hzip) - nil - (let [node (zip/node hzip)] - (if (and (not (string? node)) - (role-match? role - hzip) - (matches-options? node - opts)) - node - (recur (zip/next hzip)))))))) - -(defn get-all-by-role - ([role hiccup] - (get-all-by-role role hiccup {})) - ([role hiccup opts] - (loop [hzip (hiccup-zipper hiccup) - results []] - (if (zip/end? hzip) - results - (let [node (zip/node hzip)] - (if (and (not (string? node)) - (role-match? role - hzip) - (matches-options? node - opts)) - (recur (zip/next hzip) - (conj results - node)) - (recur (zip/next hzip) - results))))))) - -(comment - (def hiccup - [:input.inpt#my-id]) - (def attr - :id) - (def role - :list) - (def hiccup - [:p - "The " - [:a {:href "#"} - [:code "Rapid Test"]] - " library helps you test UI components."]) - (def hiccup - [:div [:span "errors: "] [:ul#error-list [:li "Something went wrong!"]]])) +(import-vars [rapid-test.html.role get-by-role get-all-by-role]) diff --git a/src/main/rapid_test/html/role.clj b/src/main/rapid_test/html/role.clj new file mode 100644 index 0000000..805335a --- /dev/null +++ b/src/main/rapid_test/html/role.clj @@ -0,0 +1,200 @@ +(ns rapid-test.html.role + (:require [clojure.zip :as zip] + [methodical.core :as m] + [rapid-test.hiccup-zipper :refer [hiccup-zipper]] + [rapid-test.html.utils :as util])) + +(m/defmulti role-match? + "Return a node from a hiccup tree that has the html role `role`. + + Note: Takes a hiccup zipper and not plain hiccup" + (fn [role _] role)) + +(m/defmethod role-match? :list + [_ hzip] + (let [hiccup (zip/node hzip)] + (or (contains? #{:menu :ol :ul} (util/get-base-tag hiccup)) + (= :list (util/get-attribute hiccup :role))))) + +(m/defmethod role-match? :listitem + [_ hzip] + (let [tag (util/get-base-tag (zip/node hzip))] + (if (= :li tag) + (let [parent-el (when-let [parent (zip/up hzip)] + (util/get-base-tag (zip/node parent)))] + (or (= parent-el :ol) + (= parent-el :ul) + (= parent-el :menu))) + false))) + +(def ^:private simple-role->tags + {:heading #{:h1 :h2 :h3 :h4 :h5 :h6} + :img #{:img} + :table #{:table} + :row #{:tr} + :cell #{:td} + :columnheader #{:th} + :separator #{:hr} + :article #{:article} + :figure #{:figure} + :navigation #{:nav} + :main #{:main} + :complementary #{:aside} + :form #{:form} + :region #{:section} + :dialog #{:dialog} + :meter #{:meter} + :progressbar #{:progress} + :option #{:option} + :search #{:search}}) + +(defn- input-type? + "True if hiccup is an with type in type-set. nil in type-set matches inputs with no type." + [hiccup type-set] + (and (= :input (util/get-base-tag hiccup)) + (let [raw-type (util/get-attribute hiccup :type) + input-type (when raw-type + (name raw-type))] + (contains? type-set input-type)))) + +(defn- explicit-role? + "True if hiccup has an explicit role attribute matching the given role keyword." + [hiccup role] + (let [r (util/get-attribute hiccup :role)] + (and r (= (name role) (name r))))) + +(m/defmethod role-match? :button + [_ hzip] + (let [hiccup (zip/node hzip)] + (or (= :button (util/get-base-tag hiccup)) + (input-type? hiccup #{"button" "submit" "reset"}) + (explicit-role? hiccup :button)))) + +(m/defmethod role-match? :textbox + [_ hzip] + (let [hiccup (zip/node hzip)] + (or (= :textarea (util/get-base-tag hiccup)) + (input-type? hiccup #{"text" nil}) + (explicit-role? hiccup :textbox)))) + +(m/defmethod role-match? :checkbox + [_ hzip] + (let [hiccup (zip/node hzip)] + (or (input-type? hiccup #{"checkbox"}) (explicit-role? hiccup :checkbox)))) + +(m/defmethod role-match? :radio + [_ hzip] + (let [hiccup (zip/node hzip)] + (or (input-type? hiccup #{"radio"}) (explicit-role? hiccup :radio)))) + +(m/defmethod role-match? :searchbox + [_ hzip] + (let [hiccup (zip/node hzip)] + (or (input-type? hiccup #{"search"}) (explicit-role? hiccup :searchbox)))) + +(m/defmethod role-match? :slider + [_ hzip] + (let [hiccup (zip/node hzip)] + (or (input-type? hiccup #{"range"}) (explicit-role? hiccup :slider)))) + +(m/defmethod role-match? :spinbutton + [_ hzip] + (let [hiccup (zip/node hzip)] + (or (input-type? hiccup #{"number"}) (explicit-role? hiccup :spinbutton)))) + +(m/defmethod role-match? :link + [_ hzip] + (let [hiccup (zip/node hzip)] + (or (and (= :a (util/get-base-tag hiccup)) + (some? (util/get-attribute hiccup :href))) + (explicit-role? hiccup :link)))) + +(m/defmethod role-match? :banner + [_ hzip] + (let [hiccup (zip/node hzip)] + (or (and (= :header (util/get-base-tag hiccup)) + (not (util/inside-sectioning-content? hzip))) + (explicit-role? hiccup :banner)))) + +(m/defmethod role-match? :contentinfo + [_ hzip] + (let [hiccup (zip/node hzip)] + (or (and (= :footer (util/get-base-tag hiccup)) + (not (util/inside-sectioning-content? hzip))) + (explicit-role? hiccup :contentinfo)))) + +(m/defmethod role-match? :rowheader + [_ hzip] + (let [hiccup (zip/node hzip)] + (or (and (= :th (util/get-base-tag hiccup)) + (= "row" + (some-> (util/get-attribute hiccup :scope) + name))) + (explicit-role? hiccup :rowheader)))) + +(m/defmethod role-match? :combobox + [_ hzip] + (let [hiccup (zip/node hzip)] + (or (and (= :select (util/get-base-tag hiccup)) + (not (util/get-attribute hiccup :multiple)) + (let [size (util/get-attribute hiccup :size)] + (or (nil? size) (<= (long (cond-> size (string? size) parse-long)) 1)))) + (explicit-role? hiccup :combobox)))) + +(m/defmethod role-match? :default + [role hzip] + (let [hiccup (zip/node hzip) + tag (util/get-base-tag hiccup)] + (or (contains? (get simple-role->tags role) tag) + (explicit-role? hiccup role)))) + +(defn get-by-role + ([role hiccup] + (get-by-role role hiccup {})) + ([role hiccup opts] + (loop [hzip (hiccup-zipper hiccup)] + (if (zip/end? hzip) + nil + (let [node (zip/node hzip)] + (if (and (not (string? node)) + (role-match? role + hzip) + (util/matches-options? node + opts)) + node + (recur (zip/next hzip)))))))) + +(defn get-all-by-role + ([role hiccup] + (get-all-by-role role hiccup {})) + ([role hiccup opts] + (loop [hzip (hiccup-zipper hiccup) + results []] + (if (zip/end? hzip) + results + (let [node (zip/node hzip)] + (if (and (not (string? node)) + (role-match? role + hzip) + (util/matches-options? node + opts)) + (recur (zip/next hzip) + (conj results + node)) + (recur (zip/next hzip) + results))))))) +(comment + (def hiccup + [:input.inpt#my-id]) + (def attr + :id) + (def role + :list) + (def hiccup + [:p + "The " + [:a {:href "#"} + [:code "Rapid Test"]] + " library helps you test UI components."]) + (def hiccup + [:div [:span "errors: "] [:ul#error-list [:li "Something went wrong!"]]])) diff --git a/src/main/rapid_test/html/utils.clj b/src/main/rapid_test/html/utils.clj new file mode 100644 index 0000000..d8a4c06 --- /dev/null +++ b/src/main/rapid_test/html/utils.clj @@ -0,0 +1,118 @@ +(ns rapid-test.html.utils + (:require [clojure.string :as str] + [clojure.zip :as zip] + [rapid-test.hiccup-zipper :refer [hiccup-zipper]] + [tram.utils :refer [omit-by]])) + +(defn has-props? + "Return whether the hiccup has an explicit props map." + [hiccup] + (map? (second hiccup))) + +(defn get-props + "Get the props for a hiccup element" + [hiccup] + (let [base-props (if (has-props? hiccup) + (second hiccup) + {}) + tag-str (name (first hiccup)) + marker? #{\# \.} + props (loop [props (update base-props :class vector) + chars (drop-while (complement marker?) tag-str)] + (if (empty? chars) + props + (let [marker (first chars) + [value rst] (split-with (complement marker?) + (rest chars)) + value (apply str + value)] + (recur (case marker + \# (update props + :id + #(or (:id %) + (keyword value))) + \. (update props + :class + conj + value)) + rst))))] + (omit-by #(or (nil? %) (= "" %)) + (update props :class #(str/join " " (remove nil? %)))))) + +(defn get-attribute + "Get `attribute` from `hiccup`. Works when attribute is from a compound tag." + [hiccup attr] + (let [props (get-props hiccup)] + (get props attr))) + +(defn get-base-tag + "Convert a compound tag into a simple tag. + + :div#my-id.my-class => :div" + [hiccup] + (let [tag (first hiccup)] + (->> tag + name + (take-while #(and (not= \# %) (not= \. %))) + (apply str) + keyword))) + +(defn inside-sectioning-content? + "True if the zipper location is inside an article, aside, main, nav, or section element." + [hzip] + (let [sectioning-tags #{:article :aside :main :nav :section}] + (loop [loc (zip/up hzip)] + (if (nil? loc) + false + (let [node (zip/node loc)] + (if (and (vector? node) + (contains? sectioning-tags + (get-base-tag node))) + true + (recur (zip/up loc)))))))) + +(defn get-text + "Get the (nested) text of a hiccup node." + ([hiccup] + (.toString (get-text (StringBuilder.) (hiccup-zipper hiccup)))) + ([sb hzip] + (if (zip/end? hzip) + sb + (let [node (zip/node hzip)] + (when (string? node) + (.append sb + node)) + (recur sb + (zip/next hzip)))))) + +(defn get-accessible-name [hiccup] + (or (get-attribute hiccup :aria-label) (get-text hiccup))) + +(def ^:private heading-tag->level + {:h1 1 + :h2 2 + :h3 3 + :h4 4 + :h5 5 + :h6 6}) + +(defn get-heading-level [hiccup] + (or (some-> (get-attribute hiccup :aria-level) + str + parse-long) + (get heading-tag->level (get-base-tag hiccup)))) + +(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))) + true) + (if level + (= level (get-heading-level hiccup)) + true)))) diff --git a/test/main/rapid_test/html/utils_test.clj b/test/main/rapid_test/html/utils_test.clj new file mode 100644 index 0000000..777bbfc --- /dev/null +++ b/test/main/rapid_test/html/utils_test.clj @@ -0,0 +1,50 @@ +(ns rapid-test.html.utils-test + (:require [clojure.test :refer [deftest is testing]] + [rapid-test.html.utils :as sut])) + +(deftest get-base-tag-test + (is (= :div (sut/get-base-tag [:div.class]))) + (is (= :div (sut/get-base-tag [:div#my-id.class]))) + (is (= :div (sut/get-base-tag [:div#my-id])))) + +(deftest get-props-test + (is (= {:id :my-id} (sut/get-props [:input#my-id]))) + (is (= {:id :my-id + :name :email} + (sut/get-props [:input#my-id {:name :email}]))) + (is (= {:id :my-id + :name :email + :class "my-class"} + (sut/get-props [:input#my-id.my-class {:name :email}]))) + (is (= {:id :my-id + :name :email + :class "my-class my-other-class"} + (sut/get-props [:input#my-id.my-class.my-other-class {:name :email}]))) + (is (= {:class "my-other-class my-class"} + (sut/get-props [:input.my-class {:class "my-other-class"}]))) + (is (= {:name :email + :class "my-other-class"} + (sut/get-props [:input.my-other-class {:name :email}]))) + (is (= {:name :email + :class "my-class"} + (sut/get-props [:input.my-class {:name :email}]))) + (is (= {:class "my-class"} (sut/get-props [:input.my-class])))) + +(deftest get-attribute-test + (is (= :email + (sut/get-attribute [:input {:name :email}] + :name))) + (is (= :my-id (sut/get-attribute [:input#my-id] :id))) + (is (= "my-class" (sut/get-attribute [:input.my-class] :class)))) + +(deftest get-text-test + (is (= "" (sut/get-text nil))) + (testing "simple case for single node" + (is (= "hello world" (sut/get-text [:span "hello world"])))) + (testing "Nested case" + (is (= "The Rapid Test library helps you test UI components." + (sut/get-text [:p + "The " + [:a {:href "#"} + [:code "Rapid Test"]] + " library helps you test UI components."]))))) diff --git a/test/main/rapid_test/html_test.clj b/test/main/rapid_test/html_test.clj index 6d9d961..3ec60ae 100644 --- a/test/main/rapid_test/html_test.clj +++ b/test/main/rapid_test/html_test.clj @@ -2,41 +2,6 @@ (:require [clojure.test :refer [deftest is testing]] [rapid-test.html :as sut])) -(deftest get-base-tag-test - (is (= :div (sut/get-base-tag [:div.class]))) - (is (= :div (sut/get-base-tag [:div#my-id.class]))) - (is (= :div (sut/get-base-tag [:div#my-id])))) - -(deftest get-props-test - (is (= {:id :my-id} (sut/get-props [:input#my-id]))) - (is (= {:id :my-id - :name :email} - (sut/get-props [:input#my-id {:name :email}]))) - (is (= {:id :my-id - :name :email - :class "my-class"} - (sut/get-props [:input#my-id.my-class {:name :email}]))) - (is (= {:id :my-id - :name :email - :class "my-class my-other-class"} - (sut/get-props [:input#my-id.my-class.my-other-class {:name :email}]))) - (is (= {:class "my-other-class my-class"} - (sut/get-props [:input.my-class {:class "my-other-class"}]))) - (is (= {:name :email - :class "my-other-class"} - (sut/get-props [:inputmy-class.my-other-class {:name :email}]))) - (is (= {:name :email - :class "my-class"} - (sut/get-props [:input.my-class {:name :email}]))) - (is (= {:class "my-class"} (sut/get-props [:input.my-class])))) - -(deftest get-attribute-test - (is (= :email - (sut/get-attribute [:input {:name :email}] - :name))) - (is (= :my-id (sut/get-attribute [:input#my-id] :id))) - (is (= "my-class" (sut/get-attribute [:input.my-class] :class)))) - (deftest get-by-role-test (testing "list role" (is (= [:ul#error-list [:li "Something went wrong!"]] @@ -171,6 +136,22 @@ (is (nil? (sut/get-by-role :rowheader [:table [:tr [:th "Name"]]])))) (testing "combobox" (is (some? (sut/get-by-role :combobox [:div [:select [:option "A"]]]))) + (is (some? (sut/get-by-role :combobox + [:div + [:select {:size 0} + [:option "A"]]]))) + (is (some? (sut/get-by-role :combobox + [:div + [:select {:size "1"} + [:option "A"]]]))) + (is (nil? (sut/get-by-role :combobox + [:div + [:select {:size 3} + [:option "A"]]]))) + (is (nil? (sut/get-by-role :combobox + [:div + [:select {:size "4"} + [:option "A"]]]))) (is (nil? (sut/get-by-role :combobox [:div [:select {:multiple true} @@ -253,15 +234,3 @@ (testing "2-arity" (is (= [[:h1 "A"] [:h2 "B"]] (sut/get-all-by-role :heading [:div [:h1 "A"] [:h2 "B"]]))))) - -(deftest get-text-test - (is (= "" (sut/get-text nil))) - (testing "simple case for single node" - (is (= "hello world" (sut/get-text [:span "hello world"])))) - (testing "Nested case" - (is (= "The Rapid Test library helps you test UI components." - (sut/get-text [:p - "The " - [:a {:href "#"} - [:code "Rapid Test"]] - " library helps you test UI components."])))))