foo.clj

(deftype Lens [get set])

(defn lupdate [^Lens lens v s]
  ((.-set lens) v s))

(defn view [^Lens lens s]
  ((.-get lens) s))

(defn lalter [lens fun & args]
  (fn [s]
    (lupdate lens (apply fun (view lens s) args) s)))

(defn lcompose [a b]
  (Lens. (fn [s]
           (view b (view a s)))
         (fn [v s]
           (let [x (view a s)
                 x (update b v s)]
             (update a x s)))))

(defmacro flense [type]
  (let [^Class t (resolve type)
        fields (for [^java.lang.reflect.Method method (.getDeclaredMethods t)
                     :when (= (.getName method) "getBasis")
                     field (.invoke method type (object-array 0))]
                 field)]
    `(do
       ~@(for [field fields
               :let [data (gensym 'data)
                     node (with-meta (gensym 'node) {:tag type})]]
           `(def ~(symbol (str "L" field))
              (Lens. (fn [~node] (. ~node ~field))
                     (fn [~data ~node]
                       (new ~type
                            ~@(for [f fields]
                                (if (= f field)
                                  data
                                  `(. ~node ~f)))))))))))

(flense Node)

(defprotocol Traversal
  (tpush [traversal lens])
  (tpop [traversal])
  (here [traversal])
  (talter [traversal fun])
  (root? [traversal]))

(defrecord ATraversal [stack current]
  Traversal
  (tpush [traversal lens]
    (->ATraversal (conj stack [lens current])
                  (view lens current)))
  (tpop [traversal]
    (let [[l v] (clojure.core/peek stack)]
      (lupdate l current v)))
  (here [traversal]
    current)
  (talter [traversal fun]
    (->ATraversal stack (fun current)))
  (root? [traversal]
    (empty? stack)))

(defn unwind [traversal]
  (if (root? traversal)
    traversal
    (recur (tpop traversal))))

(defn seek-to [root k]
  (loop [t (->ATraversal () root)]
    (let [kk (view Lkey (here t))]
      (cond
       (= k kk) t
       (> k kk) (recur (tpush t Lhigh))
       (< k kk) (recur (tpush t Llow))))))

(defn search'' [root k]
  (view Lvalue (here (seek-to root k))))

(defn update'' [root k v]
  (assert root)
  (-> (seek-to root k)
      (tpush Lvalue)
      (talter (constantly v))
      (unwind)
      (here)))