Add source logging to read forms.

- Introduce new SourceLoggingPushbackReader type to reader types.
- All IMeta read by a SourceLoggingPushbackReader have a :source key in their metadata.
- The :source key is the character string which was read to produce the IMeta.
- Tests to verify the :source keys for various kinds of values, e.g. IMetas, nested IMetas, native Java types, IMetas with Meta present.

Also-by: Bronsa <brobronsa@gmail.com>

Signed-off-by: Bronsa <brobronsa@gmail.com>

src/main/clojure/clojure/tools/reader.clj

@@ -154,7 +154,8 @@
         (if (identical? delim (char ch))
           (persistent! a)
           (if-let [macrofn (macros ch)]
-            (let [mret (macrofn rdr ch)]
+            (let [mret (log-source-unread rdr
+                         (macrofn rdr ch))]
               (recur (if-not (identical? mret rdr) (conj! a mret) a)))
             (let [o (read (doto rdr (unread ch)) true nil recursive?)]
               (recur (if-not (identical? o rdr) (conj! a o) a)))))
@@ -322,22 +323,23 @@
 
 (defn- read-meta
   [rdr _]
-  (let [[line column] (when (indexing-reader? rdr)
-                        [(get-line-number rdr) (int (dec (get-column-number rdr)))])
-        m (desugar-meta (read rdr true nil true))]
-    (when-not (map? m)
-      (reader-error rdr "Metadata must be Symbol, Keyword, String or Map"))
-    (let [o (read rdr true nil true)]
-      (if (instance? IMeta o)
-        (let [m (if (and line
-                         (seq? o))
-                  (assoc m :line line
+  (log-source rdr
+    (let [[line column] (when (indexing-reader? rdr)
+                          [(get-line-number rdr) (int (dec (get-column-number rdr)))])
+          m (desugar-meta (read rdr true nil true))]
+      (when-not (map? m)
+        (reader-error rdr "Metadata must be Symbol, Keyword, String or Map"))
+      (let [o (read rdr true nil true)]
+        (if (instance? IMeta o)
+          (let [m (if (and line
+                           (seq? o))
+                    (assoc m :line line
                            :column column)
-                  m)]
-          (if (instance? IObj o)
-            (with-meta o (merge (meta o) m))
-            (reset-meta! o m)))
-        (reader-error rdr "Metadata can only be applied to IMetas")))))
+                    m)]
+            (if (instance? IObj o)
+              (with-meta o (merge (meta o) m))
+              (reset-meta! o m)))
+          (reader-error rdr "Metadata can only be applied to IMetas"))))))
 
 (defn- read-set
   [rdr _]
@@ -719,19 +721,20 @@
      (when (= :unknown *read-eval*)
        (reader-error "Reading disallowed - *read-eval* bound to :unknown"))
      (try
-       (let [ch (read-char reader)]
-         (cond
-          (whitespace? ch) (read reader eof-error? sentinel recursive?)
-          (nil? ch) (if eof-error? (reader-error reader "EOF") sentinel)
-          (number-literal? reader ch) (read-number reader ch)
-          (comment-prefix? ch) (read (read-comment reader ch) eof-error? sentinel recursive?)
-          :else (let [f (macros ch)]
-                  (if f
-                    (let [res (f reader ch)]
-                      (if (identical? res reader)
-                        (read reader eof-error? sentinel recursive?)
-                        res))
-                    (read-symbol reader ch)))))
+       (log-source reader
+                   (let [ch (read-char reader)]
+                     (cond
+                      (whitespace? ch) (read reader eof-error? sentinel recursive?)
+                      (nil? ch) (if eof-error? (reader-error reader "EOF") sentinel)
+                      (number-literal? reader ch) (read-number reader ch)
+                      (comment-prefix? ch) (read (read-comment reader ch) eof-error? sentinel recursive?)
+                      :else (let [f (macros ch)]
+                              (if f
+                                (let [res (f reader ch)]
+                                  (if (identical? res reader)
+                                    (read reader eof-error? sentinel recursive?)
+                                    res))
+                                (read-symbol reader ch))))))
        (catch Exception e
          (if (ex-info? e)
            (throw e)

src/main/clojure/clojure/tools/reader/reader_types.clj

@@ -11,7 +11,7 @@
   clojure.tools.reader.reader-types
   (:refer-clojure :exclude [char read-line])
   (:use clojure.tools.reader.impl.utils)
-  (:import clojure.lang.LineNumberingPushbackReader
+  (:import (clojure.lang LineNumberingPushbackReader Var)
            (java.io InputStream BufferedReader)))
 
 (defmacro ^:private update! [what f]
@@ -164,6 +164,84 @@
                         (fn [rdr] 0))
    :get-file-name (constantly nil)})
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Source Logging support
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defn merge-meta
+  "Returns an object of the same type and value as `obj`, with its
+metadata merged over `m`."
+  [obj m]
+  (let [orig-meta (meta obj)]
+    (with-meta obj (merge m (dissoc orig-meta :source)))))
+
+(defn- peek-source-log
+  "Returns a string containing the contents of the top most source
+logging frame."
+  [source-log-frames]
+  (let [current-frame @source-log-frames]
+    (.substring ^StringBuilder (:buffer current-frame) (:offset current-frame))))
+
+(defn- log-source-char
+  "Logs `char` to all currently active source logging frames."
+  [source-log-frames char]
+  (when-let [^StringBuilder buffer (:buffer @source-log-frames)]
+    (.append buffer char)))
+
+(defn- drop-last-logged-char
+  "Removes the last logged character from all currently active source
+logging frames. Called when pushing a character back."
+  [source-log-frames]
+  (when-let [^StringBuilder buffer (:buffer @source-log-frames)]
+    (.deleteCharAt buffer (dec (.length buffer)))))
+
+(deftype SourceLoggingPushbackReader
+    [rdr ^:unsynchronized-mutable line ^:unsynchronized-mutable column
+     ^:unsynchronized-mutable line-start? ^:unsynchronized-mutable prev
+     ^:unsynchronized-mutable prev-column file-name source-log-frames]
+  Reader
+  (read-char [reader]
+    (when-let [ch (read-char rdr)]
+      (let [ch (normalize-newline rdr ch)]
+        (set! prev line-start?)
+        (set! line-start? (newline? ch))
+        (when line-start?
+          (set! prev-column column)
+          (set! column 0)
+          (update! line inc))
+        (update! column inc)
+        (log-source-char source-log-frames ch)
+        ch)))
+
+  (peek-char [reader]
+    (peek-char rdr))
+
+  IPushbackReader
+  (unread [reader ch]
+    (if line-start?
+      (do (update! line dec)
+          (set! column prev-column))
+      (update! column dec))
+    (set! line-start? prev)
+    (when ch
+      (drop-last-logged-char source-log-frames))
+    (unread rdr ch))
+
+  IndexingReader
+  (get-line-number [reader] (int (inc line)))
+  (get-column-number [reader] (int column))
+  (get-file-name [reader] file-name))
+
+(defn log-source*
+  [reader f unread?]
+  (let [frame (.source_log_frames ^SourceLoggingPushbackReader reader)
+        ^StringBuilder buffer (:buffer @frame)
+        new-frame (assoc-in @frame [:offset] (+ (.length buffer) (if unread? -1 0)))]
+    (with-bindings {frame new-frame}
+      (let [ret (f)]
+        (if (instance? clojure.lang.IMeta ret)
+          (merge-meta ret {:source (peek-source-log frame)})
+          ret)))))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Public API
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -213,6 +291,26 @@
      (IndexingPushbackReader.
       (if (string? s-or-rdr) (string-push-back-reader s-or-rdr buf-len) s-or-rdr) 0 1 true nil 0 file-name)))
 
+(defn source-logging-push-back-reader
+  "Creates an IndexingPushbackReader from a given string or Reader"
+  ([s-or-rdr]
+     (source-logging-push-back-reader s-or-rdr 1))
+  ([s-or-rdr buf-len]
+     (source-logging-push-back-reader s-or-rdr buf-len nil))
+  ([s-or-rdr buf-len file-name]
+     (SourceLoggingPushbackReader.
+      (if (string? s-or-rdr) (string-push-back-reader s-or-rdr buf-len) s-or-rdr)
+      0
+      1
+      true
+      nil
+      0
+      file-name
+      (.. Var
+          (create {:buffer (StringBuilder.)
+                   :offset 0})
+          setDynamic))))
+
 (defn read-line
   "Reads a line from the reader or from *in* if no reader is specified"
   ([] (read-line *in*))
@@ -237,3 +335,25 @@
                              :column (get-column-number rdr)}
                             (when-let [file-name (get-file-name rdr)]
                               {:file file-name})))))))
+
+(defn source-logging-reader?
+  [rdr]
+  (instance? SourceLoggingPushbackReader rdr))
+
+(defmacro log-source
+  "If reader implements SourceLoggingReader, execute body in a source
+  logging context. Otherwise, execute body, returning the result."
+  [reader & body]
+  `(if (and (source-logging-reader? ~reader)
+            (not (whitespace? (peek-char ~reader))))
+     (log-source* ~reader (^{:once true} fn* [] ~@body) false)
+     (do ~@body)))
+
+(defmacro log-source-unread
+  "If reader implements SourceLoggingReader, execute body in a source
+  logging context. Otherwise, execute body, returning the result."
+  [reader & body]
+  `(if (and (source-logging-reader? ~reader)
+            (not (whitespace? (peek-char ~reader))))
+     (log-source* ~reader (^{:once true} fn* [] ~@body) true)
+     (do ~@body)))

src/test/clojure/clojure/tools/metadata_test.clj

@@ -64,3 +64,54 @@
                            (tree-seq coll? identity second-form))]
       (doseq [[expected actual] comparisons]
         (is (= [expected (meta expected)] [actual (meta actual)]))))))
+
+(def expected-haiku-ns-with-source
+  (with-meta  '(^{:line 1 :column 2 :end-line 1 :end-column 4 :source "ns"} ns
+                ^{:line 1 :column 5 :end-line 1 :end-column 31 :source "clojure.tools.reader.haiku"} clojure.tools.reader.haiku)
+    {:line 1 :column 1 :end-line 1 :end-column 32 :source "(ns clojure.tools.reader.haiku)"}))
+
+(def expected-haiku-defn-with-source
+  (with-meta (list
+              '^{:line 3 :column 2 :end-line 3 :end-column 6 :source "defn"} defn
+              '^{:line 3 :column 7 :end-line 3 :end-column 12 :source "haiku"} haiku
+              "It will read the form\n    but will the form metadata be\n    or never become?"
+              (with-meta ['^{:line 7 :column 6 :end-line 7 :end-column 16 :source "first-five"} first-five
+                          '^{:line 7 :column 17 :end-line 7 :end-column 29 :source "middle-seven"} middle-seven
+                          '^{:line 7 :column 30 :end-line 7 :end-column 39 :source "last-five"} last-five]
+                {:line 7 :column 5 :end-line 7 :end-column 40 :source "[first-five middle-seven last-five]"})
+              (with-meta (list '^{:line 8 :column 6 :end-line 8, :end-column 7 :source "-"} -
+                               (with-meta (list '^{:line 8 :column 9 :end-line 8 :end-column 14 :source "apply"} apply
+                                                '^{:line 8 :column 15 :end-line 8 :end-column 16 :source "+"} +
+                                                ^{:last 'last-five :line 9 :column 34 :end-line 9 :end-column 41 :source "^{:last last-five} [1 2 3]"}
+                                                [1 2 3])
+                                 {:line 8 :column 8 :end-line 9 :end-column 42 :source "(apply +
+              ^{:last last-five} [1 2 3])"})
+                               '^{:line 10 :column 8 :end-line 10 :end-column 18 :source "first-five"} first-five
+                               '^{:line 10 :column 19 :end-line 10 :end-column 31 :source "middle-seven"} middle-seven)
+                {:line 8 :column 5 :end-line 10 :end-column 32 :source "(- (apply +
+              ^{:last last-five} [1 2 3])
+       first-five middle-seven)"}))
+    {:line 3 :column 1 :end-line 10 :end-column 33 :source "(defn haiku
+    \"It will read the form
+    but will the form metadata be
+    or never become?\"
+    [first-five middle-seven last-five]
+    (- (apply +
+              ^{:last last-five} [1 2 3])
+       first-five middle-seven))"}))
+
+(deftest read-metadata-with-source
+  (let [reader (-> (test-reader)
+                   (LineNumberingPushbackReader.)
+                   (reader-types/source-logging-push-back-reader 1 "haiku.clj"))
+        first-form (read reader)
+        second-form (read reader)]
+    (is (= {:line 1 :column 1 :end-line 1 :end-column 32 :source "(ns clojure.tools.reader.haiku)"} (meta first-form)))
+    (let [comparisons (map vector (tree-seq coll? identity expected-haiku-ns-with-source)
+                           (tree-seq coll? identity first-form))]
+      (doseq [[expected actual] comparisons]
+        (is (= [expected (meta expected)] [actual (meta actual)]))))
+    (let [comparisons (map vector (tree-seq coll? identity expected-haiku-defn-with-source)
+                           (tree-seq coll? identity second-form))]
+      (doseq [[expected actual] comparisons]
+        (is (= [expected (meta expected)] [actual (meta actual)]))))))