defbean

core.clj

(ns pharoh.core
  (:import #_(org.drools.compiler DrlParser)
           #_(org.drools.spi Consequence)
           (java.beans PropertyChangeSupport)))

(definterface IBean
  (init [])
  (addPropertyChangeListener [pcl])
  (removePropertyChangeListener [pcl]))

(defn camel-case [sym]
  (let [[f & r] (.split (name sym) "-")]
    (->> r
         (mapcat (fn [[f & r]]
                   (cons (Character/toUpperCase f) r)))
         (concat (seq f))
         (apply str))))

(defmacro defbean [bean-name fields & details]
  (let [prop (gensym 'prop)
        ifacename (symbol (str "I" bean-name))]
    (doseq [f fields]
      (prn f (meta f)))
    `(do
       (definterface ~ifacename
         ~@(for [field fields]
             `(~(with-meta (symbol (camel-case (str "get-" field)))
                  (meta field)) []))
         ~@(for [field fields
                 :when (:volatile-mutable (meta field))]
             `(~(with-meta (symbol (camel-case (str "set-" field)))
                  {:tag 'void})
               [~(with-meta (gensym 'a)
                   (meta field))])))

       (deftype ~bean-name ~(vec (concat fields
                                         [(with-meta prop
                                            {:volatile-mutable true})]))
         ~@details
         ~ifacename
         ~@(for [field fields]
             `(~(symbol (camel-case (str "get-" field)))
               [~(gensym 'this)] ~(vary-meta field dissoc :tag)))
         ~@(for [field fields
                 :when (:volatile-mutable (meta field))
                 :let [arg-name (gensym 'a)]]
             `(~(symbol (camel-case (str "set-" field)))
               [~(gensym 'this) ~arg-name]
                 (let [old-value# ~(vary-meta field dissoc :tag)]
                   (set! ~(vary-meta field dissoc :tag) ~arg-name)
                   (.firePropertyChange ~prop ~(name field) old-value#
                                        ~arg-name))))
         IBean
         (init [p#]
           (when-not ~prop
             (set! ~prop (PropertyChangeSupport. p#))))
         (addPropertyChangeListener [p# pcl#]
           (.add ~prop pcl#))
         (removePropertyChangeListener [p# pcl#]
           (.remove ~prop pcl#)))

       (defn ~(with-meta (symbol (.toLowerCase (name bean-name)))
                {:tag ifacename
                 ::backing-class bean-name})
         [& {:keys ~(vec (for [f fields] (vary-meta f dissoc :tag)))}]
         (doto (new ~bean-name ~@fields nil)
           .init)))))

(defbean Person [^String ^:volatile-mutable name
                 ^long ^:volatile-mutable age]
  Object
  (toString [p]
    (str {:name name :age age}))
  (equals [p o]
    (and (instance? IPerson o)
         (= (.getName p) (.getName o))
         (= (.getAge p) (.getAge o))))
  (hashCode [p]
    (int (mod (+ (.hashCode name)
                 (.hashCode age))
              Integer/MAX_VALUE))))

(def a-person (person :name "Some Guy" :age 1))