Skip to content

Commit

Permalink
Support for class (like the html class attribute) selectors.
Browse files Browse the repository at this point in the history
  • Loading branch information
@daveray
daveray committed Jun 8, 2011
1 parent faad04d commit a66fed8
Show file tree
Hide file tree
Showing 3 changed files with 82 additions and 59 deletions.
2 changes: 2 additions & 0 deletions src/seesaw/core.clj
View file
Original file line number Diff line number Diff line change
Expand Up @@ -615,6 +615,7 @@
; Default options
(def ^{:private true} default-options {
:id selector/id-of!
:class selector/class-of!
:listen #(apply sse/listen %1 %2)
:opaque? #(.setOpaque %1 (boolean (ensure-sync-when-atom %1 :opaque? %2)))
:enabled? #(.setEnabled %1 (boolean (ensure-sync-when-atom %1 :enabled? %2)))
Expand Down Expand Up @@ -1748,6 +1749,7 @@

(def ^{:private true} frame-options {
:id selector/id-of!
:class selector/class-of!
:title #(.setTitle %1 (str %2))
:resizable? #(.setResizable %1 (boolean %2))
:content #(.setContentPane %1 (to-widget %2 true))
Expand Down
118 changes: 60 additions & 58 deletions src/seesaw/selector.clj
View file
Original file line number Diff line number Diff line change
Expand Up @@ -16,6 +16,7 @@
(:require [clojure.zip :as z]))

(def ^{:private true} id-property ::seesaw-widget-id)
(def ^{:private true} class-property ::seesaw-widget-class)

(defn id-of
[w]
Expand All @@ -28,6 +29,13 @@
; TODO should we enforce unique ids?
(ss-meta/put-meta! w id-property id-key)))

(defn class-of! [w classes]
(ss-meta/put-meta! w class-property
(set (map name (if (coll? classes) classes [classes])))))

(defn class-of [w]
(ss-meta/get-meta w class-property))

(defn- mapknit
([f coll]
(mapknit f coll nil))
Expand Down Expand Up @@ -132,9 +140,9 @@
(pred #(when-let [v (attr-values % attr)] (every? v values))))

(defn- has-class
"Selector predicate, :.foo.bar is as short-hand for (has-class \"foo\" \"bar\")."
"Selector predicate, :.foo.bar. Looks for widgets with (:class #{:foo :bar})"
[& classes]
(apply attr-has :class classes))
(pred #(when-let [v (class-of %)] (every? v classes))))

;; selector syntax
(defn- intersection [preds]
Expand Down Expand Up @@ -339,7 +347,7 @@
(apply zip-select-fragments* locs selector)))

;; other predicates
(defn attr?
(defn- attr?
"Selector predicate, tests if the specified attributes are present."
[& kws]
(pred #(every? (-> % :attrs keys set) kws)))
Expand All @@ -355,7 +363,8 @@
(pred #(when-let [attrs (:attrs %)]
(every?+ single-attr-pred (map attrs ks) vs))))))

(def ^{:doc "Selector predicate, tests if the specified attributes have the specified values."}
(def ^{:private true
:doc "Selector predicate, tests if the specified attributes have the specified values."}
attr=
(multi-attr-pred =))

Expand All @@ -368,15 +377,18 @@
(defn- contains-substring? [^String s ^String substring]
(and s (<= 0 (.indexOf s substring))))

(def ^{:doc "Selector predicate, tests if the specified attributes start with the specified values. See CSS ^= ."}
(def ^{:private true
:doc "Selector predicate, tests if the specified attributes start with the specified values. See CSS ^= ."}
attr-starts
(multi-attr-pred starts-with?))

(def ^{:doc "Selector predicate, tests if the specified attributes end with the specified values. See CSS $= ."}
(def ^{:private true
:doc "Selector predicate, tests if the specified attributes end with the specified values. See CSS $= ."}
attr-ends
(multi-attr-pred ends-with?))

(def ^{:doc "Selector predicate, tests if the specified attributes contain the specified values. See CSS *= ."}
(def ^{:private true
:doc "Selector predicate, tests if the specified attributes contain the specified values. See CSS *= ."}
attr-contains
(multi-attr-pred contains-substring?))

Expand All @@ -385,11 +397,12 @@
(.startsWith s segment)
(= \- (.charAt s (count segment)))))

(def ^{:doc "Selector predicate, tests if the specified attributes start with the specified values. See CSS |= ."}
(def ^{:private true
:doc "Selector predicate, tests if the specified attributes start with the specified values. See CSS |= ."}
attr|=
(multi-attr-pred is-first-segment?))

(def root
(def ^{:private true} root
(zip-pred #(-> % z/up nil?)))

(defn- nth?
Expand All @@ -402,12 +415,12 @@
an (- an+b b)]
(and (zero? (rem an a)) (<= 0 (quot an a))))))

(defn nth-child
(defn- nth-child
"Selector step, tests if the node has an+b-1 siblings on its left. See CSS :nth-child."
([b] (nth-child 0 b))
([a b] (zip-pred (nth? z/lefts a b))))

(defn nth-last-child
(defn- nth-last-child
"Selector step, tests if the node has an+b-1 siblings on its right. See CSS :nth-last-child."
([b] (nth-last-child 0 b))
([a b] (zip-pred (nth? z/rights a b))))
Expand All @@ -418,85 +431,83 @@
pred #(= (:tag %) tag)]
(filter pred (f loc)))))

(defn nth-of-type
(defn- nth-of-type
"Selector step, tests if the node has an+b-1 siblings of the same type (tag name) on its left. See CSS :nth-of-type."
([b] (nth-of-type 0 b))
([a b] (zip-pred (nth? (filter-of-type z/lefts) a b))))

(defn nth-last-of-type
(defn- nth-last-of-type
"Selector step, tests if the node has an+b-1 siblings of the same type (tag name) on its right. See CSS :nth-last-of-type."
([b] (nth-last-of-type 0 b))
([a b] (zip-pred (nth? (filter-of-type z/rights) a b))))

(def first-child (nth-child 1))
(def ^{:private true} first-child (nth-child 1))

(def last-child (nth-last-child 1))
(def ^{:private true} last-child (nth-last-child 1))

(def first-of-type (nth-of-type 1))
(def ^{:private true} first-of-type (nth-of-type 1))

(def last-of-type (nth-last-of-type 1))
(def ^{:private true} last-of-type (nth-last-of-type 1))

(def only-child (intersection [first-child last-child]))
(def ^{:private true} only-child (intersection [first-child last-child]))

(def only-of-type (intersection [first-of-type last-of-type]))
(def ^{:private true} only-of-type (intersection [first-of-type last-of-type]))

(def void (pred #(empty? (remove empty? (:content %)))))
(def ^{:private true} void (pred #(empty? (remove empty? (:content %)))))

(def odd (nth-child 2 1))
(def ^{:private true} odd (nth-child 2 1))

(def even (nth-child 2 0))
(def ^{:private true} even (nth-child 2 0))

(defn- select? [node-or-nodes selector]
(-> node-or-nodes as-nodes (select selector) seq boolean))

(defn has
(defn- has
"Selector predicate, matches elements which contain at least one element that
matches the specified selector. See jQuery's :has"
[selector]
(pred #(select? (:content %) selector)))

(defn but-node
(defn- but-node
"Selector predicate, matches nodes which are rejected by the specified selector-step. See CSS :not"
[selector-step]
(complement (compile-step selector-step)))

(defn but
(defn- but
"Selector predicate, matches elements which are rejected by the specified selector-step. See CSS :not"
[selector-step]
(intersection [any (but-node selector-step)]))

(defn left [selector-step]
(defn- left [selector-step]
(let [selector [:> selector-step]]
;#(when-let [sibling (first (filter xml/tag? (reverse (z/lefts %))))]
#(when-let [sibling (first (filter (constantly true) (reverse (z/lefts %))))]
(select? sibling selector))))

(defn lefts [selector-step]
(defn- lefts [selector-step]
(let [selector [:> selector-step]]
;#(select? (filter xml/tag? (z/lefts %)) selector)))
#(select? (filter (constantly true) (z/lefts %)) selector)))

(defn right [selector-step]
(defn- right [selector-step]
(let [selector [:> selector-step]]
;#(when-let [sibling (first (filter xml/tag? (z/rights %)))]
#(when-let [sibling (first (filter (constantly true) (z/rights %)))]
(select? sibling selector))))

(defn rights [selector-step]
(defn- rights [selector-step]
(let [selector [:> selector-step]]
;#(select? (filter xml/tag? (z/rights %)) selector)))
#(select? (filter (constantly true) (z/rights %)) selector)))

(def any-node (constantly true))

(def this-node [:> any-node])
(def ^{:private true} any-node (constantly true))

(def text-node #(string? (z/node %)))
(def ^{:private true} this-node [:> any-node])

(def comment-node (constantly false)) ;#(xml/comment? (z/node %)))
(def ^{:private true} text-node #(string? (z/node %)))

;; screen-scraping utils
(defn text
(defn- text
"Returns the text value of a node."
{:tag String}
[node]
Expand All @@ -505,32 +516,23 @@
;(xml/tag? node) (apply str (map text (:content node)))
:else ""))

(defn texts
(defn- texts
"Returns the text value of a nodes collection."
{:tag String}
[nodes]
(map text nodes))

(defmacro let-select
"For each node or fragment, performs a subselect and bind it to a local,
then evaluates body.
bindings is a vector of binding forms and selectors."
[nodes-or-fragments bindings & body]
(let [node-or-fragment (gensym "node-or-fragment__")
bindings
(map (fn [f x] (f x))
(cycle [identity (fn [spec] `(select ~node-or-fragment ~spec))])
bindings)]
`(map (fn [~node-or-fragment]
(let [~@bindings]
~@body)) ~nodes-or-fragments)))

;; repl-utils
;(defn sniptest* [nodes f]
;(apply str (emit* (flatmap f nodes))))

;(defmacro sniptest
;"A handy macro for experimenting at the repl"
;[source-string & forms]
;`(sniptest* (html-snippet ~source-string) (transformation ~@forms)))
;(defmacro let-select
;"For each node or fragment, performs a subselect and bind it to a local,
;then evaluates body.
;bindings is a vector of binding forms and selectors."
;[nodes-or-fragments bindings & body]
;(let [node-or-fragment (gensym "node-or-fragment__")
;bindings
;(map (fn [f x] (f x))
;(cycle [identity (fn [spec] `(select ~node-or-fragment ~spec))])
;bindings)]
;`(map (fn [~node-or-fragment]
;(let [~@bindings]
;~@body)) ~nodes-or-fragments)))

21 changes: 20 additions & 1 deletion test/seesaw/test/core.clj
View file
Original file line number Diff line number Diff line change
Expand Up @@ -9,6 +9,7 @@
; You must not remove this notice, or any other, from this software.

(ns seesaw.test.core
(:require [seesaw.selector :as selector])
(:use seesaw.core
seesaw.font
seesaw.graphics
Expand Down Expand Up @@ -73,6 +74,15 @@
(try
(do (config! (label :id :foo) :id :bar) false)
(catch IllegalStateException e true))))

(testing "the :class option"
(it "does nothing when omitted"
(expect (nil? (-> (JPanel.) apply-default-opts selector/class-of))))
(it "sets the class of the widget"
(expect (= #{"foo"} (selector/class-of (flow-panel :class :foo)))))
(it "sets the classes of a widget"
(expect (= #{"foo" "bar"} (selector/class-of (flow-panel :class #{:foo :bar}))))))

(testing "the :preferred-size option"
(it "set the component's preferred size using to-dimension"
(let [p (apply-default-opts (JPanel.) {:preferred-size [10 :by 20]})]
Expand Down Expand Up @@ -966,7 +976,7 @@
(expect (= [d] (select f [:<javax.swing.JLabel!>])))
(expect (= nil (seq (select f ["<javax.swing.AbstractButton!>"]))))))

(it "should find a widget by class name"
(it "should find a widget by Java class name"
(let [c (proxy [JLabel] [])
d (label)
b (toggle)
Expand All @@ -975,6 +985,15 @@
(expect (= [d] (select f [:JLabel])))
(expect (= nil (seq (select f ["JRadioButton"]))))))

(it "should find a widget by class name"
(let [c (proxy [JLabel] [])
d (label :class :foo)
b (toggle :class #{:foo :bar})
p (flow-panel :items [c d b])
f (frame :title "select by class" :content p)]
(expect (= [d b] (select f [:.foo])))
(expect (= [b] (seq (select f [".bar"]))))))

(it "should find all descendants of a widget"
(let [c (proxy [JLabel] [])
d (label)
Expand Down

0 comments on commit a66fed8

Please sign in to comment.