Changes to support the object explorer

3 files changed, 40 insertions, 18 deletions

diff --git a/src/clojure/contrib/pprint/ColumnWriter.clj b/src/clojure/contrib/pprint/ColumnWriter.clj
index 381c81fe..fc6ae75c 100644
--- a/src/clojure/contrib/pprint/ColumnWriter.clj
+++ b/src/clojure/contrib/pprint/ColumnWriter.clj
@@ -20,6 +20,7 @@
    :constructors {[java.io.Writer Integer] [], 
                   [java.io.Writer] []}
    :methods [[getColumn [] Integer]
+             [getLine [] Integer]
              [getMaxColumn [] Integer]
              [setMaxColumn [Integer] Void]
              [getWriter [] java.io.Writer]]
@@ -29,7 +30,7 @@
 
 (defn- -init 
   ([writer] (-init writer *default-page-width*))
-  ([writer max-columns] [[] (ref {:max max-columns, :cur 0, :base writer})]))
+  ([writer max-columns] [[] (ref {:max max-columns, :cur 0, :line 0 :base writer})]))
 
 (defn- get-field [#^clojure.contrib.pprint.ColumnWriter this sym]
   (sym @(.state this)))
@@ -40,11 +41,15 @@
 (defn- -getColumn [this]
   (get-field this :cur))
 
+(defn- -getLine [this]
+  (get-field this :line))
+
 (defn- -getMaxColumn [this]
   (get-field this :max))
 
 (defn- -setMaxColumn [this new-max]
-  (dosync (set-field this :max new-max)))
+  (dosync (set-field this :max new-max))
+  nil)
 
 (defn- -getWriter [this]
   (get-field this :base))
@@ -62,7 +67,10 @@
 	     nl (.lastIndexOf s (int \newline))]
 	 (dosync (if (neg? nl)
 		   (set-field this :cur (+ (get-field this :cur) (count s)))
-		   (set-field this :cur (- (count s) nl 1))))
+		   (do
+                     (set-field this :cur (- (count s) nl 1))
+                     (set-field this :line (+ (get-field this :line)
+                                              (count (filter #(= % \newline) s)))))))
 	 (.write #^java.io.Writer (get-field this :base) s))
 
        Integer
@@ -70,7 +78,9 @@
 
 (defn- write-char [#^clojure.contrib.pprint.ColumnWriter this #^Integer c]
   (dosync (if (= c (int \newline))
-	    (set-field this :cur 0)
+	    (do
+              (set-field this :cur 0)
+              (set-field this :line (inc (get-field this :line))))
 	    (set-field this :cur (inc (get-field this :cur)))))
   (.write #^java.io.Writer (get-field this :base) c))
 
diff --git a/src/clojure/contrib/pprint/PrettyWriter.clj b/src/clojure/contrib/pprint/PrettyWriter.clj
index 31ad1226..61e0c9ad 100644
--- a/src/clojure/contrib/pprint/PrettyWriter.clj
+++ b/src/clojure/contrib/pprint/PrettyWriter.clj
@@ -25,7 +25,8 @@
              [newline [clojure.lang.Keyword] void]
              [indent [clojure.lang.Keyword Integer] void]
              [getMiserWidth [] Object]
-             [setMiserWidth [Object] void]]
+             [setMiserWidth [Object] void]
+             [setLogicalBlockCallback [clojure.lang.IFn] void]]
    :exposes-methods {write col-write}
    :state pwstate))
 
@@ -62,7 +63,8 @@
 (defstruct #^{:private true} logical-block
            :parent :section :start-col :indent
            :done-nl :intra-block-nl
-           :prefix :per-line-prefix :suffix)
+           :prefix :per-line-prefix :suffix
+           :logical-block-callback)
 
 (defn ancestor? [parent child]
   (loop [child (:parent child)]
@@ -117,16 +119,18 @@
 
 (defmulti write-token #(:type-tag %2))
 (defmethod write-token :start-block [#^clojure.contrib.pprint.PrettyWriter this token]
-  (let [lb (:logical-block token)]
+   (when-let [cb (getf :logical-block-callback)] (cb :start))
+   (let [lb (:logical-block token)]
     (dosync
-     (if-let [#^String prefix (:prefix lb)] 
+     (when-let [#^String prefix (:prefix lb)] 
        (.col-write this prefix))
      (let [col (.getColumn this)]
        (ref-set (:start-col lb) col)
        (ref-set (:indent lb) col)))))
 
 (defmethod write-token :end-block [#^clojure.contrib.pprint.PrettyWriter this token]
-  (if-let [#^String suffix (:suffix (:logical-block token))] 
+  (when-let [cb (getf :logical-block-callback)] (cb :end))
+  (when-let [#^String suffix (:suffix (:logical-block token))] 
     (.col-write this suffix)))
 
 (defmethod write-token :indent [#^clojure.contrib.pprint.PrettyWriter this token]
@@ -414,7 +418,7 @@
 ;;; Methods for PrettyWriter
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(defn- -startBlock 
+(defn -startBlock 
   [#^clojure.contrib.pprint.PrettyWriter this 
    #^String prefix #^String per-line-prefix #^String suffix]
   (dosync 
@@ -425,7 +429,8 @@
      (if (= (getf :mode) :writing)
        (do
          (write-white-space this)
-         (if prefix 
+          (when-let [cb (getf :logical-block-callback)] (cb :start))
+          (if prefix 
            (.col-write this prefix))
          (let [col (.getColumn this)]
            (ref-set (:start-col lb) col)
@@ -435,7 +440,7 @@
          (setf :pos newpos)
          (add-to-buffer this (make-start-block lb oldpos newpos)))))))
 
-(defn- -endBlock [#^clojure.contrib.pprint.PrettyWriter this]
+(defn -endBlock [#^clojure.contrib.pprint.PrettyWriter this]
   (dosync
    (let [lb (getf :logical-blocks)
          #^String suffix (:suffix lb)]
@@ -443,7 +448,8 @@
        (do
          (write-white-space this)
          (if suffix
-           (.col-write this suffix)))
+           (.col-write this suffix))
+         (when-let [cb (getf :logical-block-callback)] (cb :end)))
        (let [oldpos (getf :pos)
              newpos (+ oldpos (if suffix (count suffix) 0))]
          (setf :pos newpos)
@@ -475,3 +481,5 @@
 (defn- -setMiserWidth [#^clojure.contrib.pprint.PrettyWriter this new-miser-width]
   (dosync (setf :miser-width new-miser-width)))
 
+(defn- -setLogicalBlockCallback [#^clojure.contrib.pprint.PrettyWriter this f]
+  (dosync (setf :logical-block-callback f)))
diff --git a/src/clojure/contrib/pprint/pprint_base.clj b/src/clojure/contrib/pprint/pprint_base.clj
index 87816310..3c5c7375 100644
--- a/src/clojure/contrib/pprint/pprint_base.clj
+++ b/src/clojure/contrib/pprint/pprint_base.clj
@@ -125,12 +125,13 @@ pretty printing the results of macro expansions"}
   (PrettyWriter. base-writer right-margin miser-width))
 
 (defmacro #^{:private true} with-pretty-writer [base-writer & body]
-  `(let [new-writer# (not (pretty-writer? ~base-writer))]
+  `(let [base-writer# ~base-writer
+         new-writer# (not (pretty-writer? base-writer#))]
      (binding [*out* (if new-writer#
-                      (make-pretty-writer ~base-writer *print-right-margin* *print-miser-width*)
-                      ~base-writer)]
+                      (make-pretty-writer base-writer# *print-right-margin* *print-miser-width*)
+                      base-writer#)]
        ~@body
-       (if new-writer# (.flush *out*)))))
+       (.flush *out*))))
 
 (defn write-out 
   "Write an object to *out* subject to the current bindings of the printer control 
@@ -248,6 +249,9 @@ clojure.contrib.pprint.dispatch.clj."
             ;; TODO clean up choices string
             (str "Bad argument: " arg ". It must be one of " choices)))))
 
+(defn level-exceeded []
+  (and *print-level* (>= *current-level* *print-level*)))
+
 (defmacro pprint-logical-block 
   "Execute the body as a pretty printing logical block with output to *out* which 
 must be a pretty printing writer. When used from pprint or cl-format, this can be 
@@ -258,7 +262,7 @@ and :suffix."
   {:arglists '[[options* body]]}
   [& args]
   (let [[options body] (parse-lb-options #{:prefix :per-line-prefix :suffix} args)]
-    `(do (if (and *print-level* (>= *current-level* *print-level*)) 
+    `(do (if (level-exceeded) 
            (.write #^PrettyWriter *out* "#")
            (binding [*current-level* (inc *current-level*)
                      *current-length* 0]