Skip to content


Subversion checkout URL

You can clone with
Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

762 lines (636 sloc) 26.183 kB
(ns swank.commands.basic
(:refer-clojure :exclude [load-file print-doc])
(:use (swank util commands core)
(swank.util.concurrent thread)
(swank.util string clojure)
(swank.clj-contrib pprint macroexpand))
(:require (swank.util [sys :as sys])
[swank.core.debugger-backends :as dbe]
(java.util.jar JarFile)
( File StringReader
FileInputStream LineNumberReader
InputStreamReader Reader PushbackReader)
(clojure.lang LineNumberingPushbackReader Symbol)))
;;;; Connection
(defslimefn connection-info []
`(:pid ~(sys/get-pid)
:style :spawn
:lisp-implementation (:type "Clojure"
:name "clojure"
:version ~(clojure-version))
:package (:name ~(name (ns-name *ns*))
:prompt ~(name (ns-name *ns*)))
:version ~(deref protocol-version)))
(defslimefn quit-lisp []
(and @exit-on-quit?
(System/exit 0)))
(defslimefn toggle-debug-on-swank-error []
(alter-var-root #'swank.core/debug-swank-clojure not))
;;;; Evaluation
(defn- eval-region
"Evaluate string, return the results of the last form as a list and
a secondary value the last form."
(eval-region string "NO_SOURCE_FILE" 1))
([string file line]
(with-open [rdr (proxy [LineNumberingPushbackReader]
((StringReader. string))
(getLineNumber [] line))]
(binding [*file* file]
(loop [form (read rdr false rdr), value nil, last-form nil]
(if (= form rdr)
[value last-form]
(recur (read rdr false rdr)
(dbe/swank-eval form)
(defn- compile-region
"Compile region."
([string file line]
(with-open [rdr1 (proxy [LineNumberingPushbackReader]
((StringReader. string)))
rdr (proxy [LineNumberingPushbackReader] (rdr1)
(getLineNumber [] (+ line (.getLineNumber rdr1) -1)))]
(clojure.lang.Compiler/load rdr file (.getName (File. #^String file))))))
(defslimefn interactive-eval-region [string]
(pr-str (first (eval-region string)))))
(defslimefn interactive-eval [string]
(pr-str (first (eval-region string)))))
(defslimefn listener-eval [form]
(let [[value last-form] (eval-region form)]
(when (and last-form (not (one-of? last-form '*1 '*2 '*3 '*e)))
(set! *3 *2)
(set! *2 *1)
(set! *1 value))
(send-repl-results-to-emacs value)))))
(defslimefn eval-and-grab-output [string]
(let [retval (promise)]
(list (with-out-str
(deliver retval (pr-str (first (eval-region string)))))
(defslimefn pprint-eval [string]
(pretty-pr-code (first (eval-region string)))))
;;;; Macro expansion
(defn- apply-macro-expander [expander string]
(pretty-pr-code (expander (read-string string))))
(defslimefn swank-macroexpand-1 [string]
(apply-macro-expander macroexpand-1 string))
(defslimefn swank-macroexpand [string]
(apply-macro-expander macroexpand string))
;; not implemented yet, needs walker
(defslimefn swank-macroexpand-all [string]
(apply-macro-expander macroexpand-all string))
;;;; Compiler / Execution
(def compiler-exception-location-re #"Exception:.*\(([^:]+):([0-9]+)(:[0-9]+)?\)")
(defn- guess-compiler-exception-location [#^Throwable t]
(when (instance? clojure.lang.Compiler$CompilerException t)
(let [[match file line] (re-find compiler-exception-location-re (str t))]
(when (and file line)
`(:location (:file ~file) (:line ~(Integer/parseInt line)) nil)))))
;; TODO: Make more and better guesses
(defn- exception-location [#^Throwable t]
(or (guess-compiler-exception-location t)
'(:error "No error location available")))
;; plist of message, severity, location, references, short-message
(defn- exception-to-message [#^Throwable t]
`(:message ~(.toString t)
:severity :error
:location ~(exception-location t)
:references nil
:short-message ~(.toString t)))
(defn- compile-file-for-emacs*
"Compiles a file for emacs. Because clojure doesn't compile, this is
simple an alias for load file w/ timing and messages. This function
is to reply with the following:
(:swank-compilation-unit notes results durations)"
(let [start (System/nanoTime)]
(let [ret (clojure.core/load-file file-name)
delta (- (System/nanoTime) start)]
`(:compilation-result nil ~(pr-str ret) ~(/ delta 1000000000.0)))
(catch Throwable t
(let [delta (- (System/nanoTime) start)
causes (exception-causes t)
num (count causes)]
(.printStackTrace t) ;; prints to *inferior-lisp*
~(map exception-to-message causes) ;; notes
nil ;; results
~(/ delta 1000000000.0) ;; durations
(defslimefn compile-file-for-emacs
([file-name load? & compile-options]
(when load?
(compile-file-for-emacs* file-name))))
(defslimefn load-file [file-name]
(let [libs-ref @(resolve 'clojure.core/*loaded-libs*)
libs @libs-ref]
(dosync (ref-set libs-ref #{}))
(pr-str (clojure.core/load-file file-name))
(dosync (alter libs-ref into libs))))))
(defn- line-at-position [file position]
(with-open [f ( (
#^String file))]
(.skip f position)
(.getLineNumber f))
(catch Exception e 1)))
(defmacro compiler-exception [directory line ex]
`(eval (if (>= (:minor *clojure-version*) 5)
~directory ~line 0 ~ex)
~directory ~line ~ex))))
(defslimefn compile-string-for-emacs [string buffer position directory debug]
(let [start (System/nanoTime)
line (line-at-position directory position)
ret (with-emacs-package
(when-not (= (name (ns-name *ns*)) *current-package*)
(throw (compiler-exception
directory line
(Exception. (str "No such namespace: "
(compile-region string directory line))
delta (- (System/nanoTime) start)]
`(:compilation-result nil ~(pr-str ret) ~(/ delta 1000000000.0))))
;;;; Describe
(defn- maybe-resolve-sym
"Returns a Var or nil"
(ns-resolve (maybe-ns *current-package*) (symbol symbol-name))
(catch ClassNotFoundException e nil)))
(defn- maybe-resolve-ns
"Returns a Namespace or nil"
(let [sym (symbol sym-name)]
(or ((ns-aliases (maybe-ns *current-package*)) sym)
(find-ns sym))))
(defn- print-doc* [m]
(println "-------------------------")
(println (str (when-let [ns (:ns m)] (str (ns-name ns) "/")) (:name m)))
(:forms m) (doseq [f (:forms m)]
(print " ")
(prn f))
(:arglists m) (prn (:arglists m)))
(if (:special-form m)
(println "Special Form")
(println " " (:doc m))
(if (contains? m :url)
(when (:url m)
(println (str "\n Please see" (:url m))))
(println (str "\n Please see"
(:name m)))))
(when (:macro m)
(println "Macro"))
(println " " (:doc m)))))
(def print-doc (let [print-doc (resolve 'clojure.core/print-doc)]
(if (or (nil? print-doc) (-> print-doc meta :private))
(comp print-doc* meta)
(defn- describe-to-string [var]
(print-doc var)))
(defn- describe-symbol* [symbol-name]
(if-let [v (maybe-resolve-sym symbol-name)]
(if-not (class? v)
(describe-to-string v)))))
(defslimefn describe-symbol [symbol-name]
(describe-symbol* symbol-name))
(defslimefn describe-function [symbol-name]
(describe-symbol* symbol-name))
;; Only one namespace... so no kinds
(defslimefn describe-definition-for-emacs [name kind]
(describe-symbol* name))
;; Only one namespace... so only describe symbol
(defslimefn documentation-symbol
([symbol-name default] (documentation-symbol symbol-name))
([symbol-name] (describe-symbol* symbol-name)))
;;;; Documentation
(defn- briefly-describe-symbol-for-emacs [var]
(let [lines (fn [s] (.split #^String s (System/getProperty "line.separator")))
[_ symbol-name arglists d1 d2 & __] (lines (describe-to-string var))
macro? (= d1 "Macro")]
(list :designator symbol-name
macro? :macro
(:arglists (meta var)) :function
:else :variable)
(apply str (concat arglists (if macro? d2 d1))))))
(defn- make-apropos-matcher [pattern case-sensitive?]
(let [pattern (java.util.regex.Pattern/quote pattern)
pat (re-pattern (if case-sensitive?
(format "(?i:%s)" pattern)))]
(fn [var] (re-find pat (pr-str var)))))
(defn- apropos-symbols [string external-only? case-sensitive? package]
(let [packages (or (when package [package]) (all-ns))
matcher (make-apropos-matcher string case-sensitive?)
lister (if external-only? ns-publics ns-interns)]
(filter matcher
(apply concat (map (comp (partial map second) lister)
(defn- present-symbol-before
"Comparator such that x belongs before y in a printed summary of symbols.
Sorted alphabetically by namespace name and then symbol name, except
that symbols accessible in the current namespace go first."
[x y]
(let [accessible?
(fn [var] (= (maybe-resolve-sym (:name (meta var)))
ax (accessible? x) ay (accessible? y)]
(and ax ay) (compare (:name (meta x)) (:name (meta y)))
ax -1
ay 1
:else (let [nx (str (:ns (meta x))) ny (str (:ns (meta y)))]
(if (= nx ny)
(compare (:name (meta x)) (:name (meta y)))
(compare nx ny))))))
(defslimefn apropos-list-for-emacs
(apropos-list-for-emacs name nil))
([name external-only?]
(apropos-list-for-emacs name external-only? nil))
([name external-only? case-sensitive?]
(apropos-list-for-emacs name external-only? case-sensitive? nil))
([name external-only? case-sensitive? package]
(let [package (when package
(maybe-ns package))]
(map briefly-describe-symbol-for-emacs
(sort present-symbol-before
(apropos-symbols name external-only? case-sensitive?
;;;; Operator messages
(defslimefn operator-arglist [name package]
(let [f (read-string name)]
(keyword? f) "([map])"
(symbol? f) (let [var (ns-resolve (maybe-ns package) f)]
(if-let [args (and var (:arglists (meta var)))]
(pr-str args)
:else nil))
(catch Throwable t nil)))
;;;; Package Commands
(defslimefn list-all-package-names
([] (map (comp str ns-name) (all-ns)))
([nicknames?] (list-all-package-names)))
(defslimefn set-package [name]
(let [ns (maybe-ns name)]
(in-ns (ns-name ns))
(list (str (ns-name ns))
(str (ns-name ns)))))
;;;; Tracing
(defonce traced-fn-map {})
(def #^{:dynamic true} *trace-level* 0)
(defn- indent [num]
(dotimes [x (+ 1 num)]
(print " ")))
(defn- trace-fn-call [fn-sym f args]
(indent *trace-level*)
(println (str *trace-level* ":")
(apply str (take 240 (pr-str (when fn-sym (cons fn-sym args)) ))))
(let [result (binding [*trace-level* (+ *trace-level* 1)] (apply f args))]
(indent *trace-level*)
(println (str *trace-level* ": "
fn-sym " returned "
(apply str (take 240 (pr-str result)))))
(defslimefn swank-toggle-trace [#^String fname]
(when-let [f-var (maybe-resolve-sym fname)
(if-let [f# (get traced-fn-map f-var)]
(alter-var-root #'traced-fn-map dissoc f-var)
(alter-var-root f-var (constantly f#))
(str " untraced."))
(let [f# @f-var]
(alter-var-root #'traced-fn-map assoc f-var f#)
(alter-var-root f-var
(fn [& args]
(trace-fn-call (symbol fname) f# args))))
(str " traced.")))))
(defslimefn untrace-all []
(doseq [f-var (keys traced-fn-map)]
(let [fname (str (:ns (meta f-var)) "/" (:name (meta f-var)))]
(swank-toggle-trace fname))))
;;; Profiling
;; stubs
(defslimefn toggle-profile-fdefinition
"`toggle-profile-fdefinition` is *not* implemented")
(defslimefn unprofile-all
[] "`unprofile-all` is *not* implemented")
(defslimefn profile-report
[] "`profile-report` is *not* implemented")
(defslimefn profile-reset
[] "`profile-reset` is *not* implemented")
(defslimefn profiled-functions
[] "`profiled-functions` is *not* implemented")
(defslimefn profile-package
[package callers? methods?] "`profiled-package` is *not* implemented")
(defslimefn profile-by-substring
[substring & [package]] "`profiled-by` is *not* implemented")
;;;; Source Locations
"Sets the default directory (java's user.dir). Note, however, that
this will not change the search path of load-file. ")
(defslimefn set-default-directory
([directory & ignore]
(System/setProperty "user.dir" directory)
(defslimefn default-directory
([] (System/getProperty "user.dir")))
;;;; meta dot find
(defn- clean-windows-path [#^String path]
;; Decode file URI encoding and remove an opening slash from
;; /c:/program%20files/... in jar file URLs and file resources.
(or (and (.startsWith (System/getProperty "") "Windows")
(second (re-matches #"^/([a-zA-Z]:/.*)$" path)))
(defn- slime-zip-resource [#^ resource]
(let [jar-connection #^ (.openConnection resource)
jar-file (.getPath (.toURI (.getJarFileURL jar-connection)))]
(list :zip (clean-windows-path jar-file) (.getEntryName jar-connection))))
(defn- slime-file-resource [#^ resource]
(list :file (clean-windows-path (.getFile resource))))
(defn- slime-find-resource [#^String file]
(if-let [resource (.getResource (clojure.lang.RT/baseLoader) file)]
(if (= (.getProtocol resource) "jar")
(slime-zip-resource resource)
(slime-file-resource resource))))
(defn- slime-find-file [#^String file]
(if file
(if (.isAbsolute (File. file))
(list :file file)
(slime-find-resource file))))
(defn- namespace-to-path [ns]
(let [#^String ns-str (name (ns-name ns))
last-dot-index (.lastIndexOf ns-str ".")]
(if (pos? last-dot-index)
(-> (.substring ns-str 0 last-dot-index)
(.replace \- \_)
(.replace \. \/)))))
(defn- classname-to-path [class-name]
(symbol (.replace #^String class-name \_ \-))))
(defn- location-in-file [path line]
`(:location ~path (:line ~line) nil))
(defn- location-label [name type]
(if type
(str "(" type " " name ")")
(str name)))
(defn- location [name type path line]
`((~(location-label name type)
~(if path
(location-in-file path line)
(list :error (format "%s - definition not found." name))))))
(defn- location-not-found [name type]
(location name type nil nil))
(defn source-location-for-frame [#^StackTraceElement frame]
(let [line (.getLineNumber frame)
filename (if (.. frame getFileName (endsWith ".java"))
(.. frame getClassName (replace \. \/)
(substring 0 (.lastIndexOf (.getClassName frame) "."))
(concat (str File/separator (.getFileName frame))))
(let [ns-path (classname-to-path
((re-find #"(.*?)\$"
(.getClassName frame)) 1))]
(if ns-path
(str ns-path File/separator (.getFileName frame))
(.getFileName frame))))
path (slime-find-file filename)]
(if path
(location-in-file path line)
(list :error (format "%s - source not found." filename)))))
(defn- namespace-to-filename [ns]
(str (-> (str ns)
(.replaceAll "\\." File/separator)
(.replace \- \_ ))
(defn- source-location-for-meta [meta xref-type-name]
(location (:name meta)
(slime-find-file (:file meta))
(:line meta)))
(defn- find-ns-definition [sym-name]
(if-let [ns (maybe-resolve-ns sym-name)]
(when-let [path (slime-find-file (namespace-to-filename ns))]
(location ns nil path 1))))
(defn- find-var-definition [sym-name]
;; TODO this doesn't work if sym-name refers to a protocol function
(if-let [meta (meta (maybe-resolve-sym sym-name))]
(source-location-for-meta meta "defn")))
(defslimefn find-definitions-for-emacs [name]
(let [sym-name (read-string name)]
(or (find-var-definition sym-name)
(find-ns-definition sym-name)
(location name nil nil nil))))
;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; xref who-calls support (was in xref.clj)
(defn- get-jar-entry-as-stream [^String jarpath ^String entry-name]
(let [jarfile (JarFile. jarpath)]
(.getInputStream jarfile (.getEntry jarfile entry-name))))
(defn- get-resource-stream [filepath]
(if-let [location (slime-find-file filepath)]
(case (first location)
:zip (apply get-jar-entry-as-stream (rest location))
:file ( ^String (second location)))))
(defn- get-source-from-var
"Returns a string of the source code for the given symbol, if it can
find it. This requires that the symbol resolve to a Var defined in
a namespace for which the .clj is in the classpath. Returns nil if
it can't find the source.
Example: (get-source-from-var 'filter)"
(when-let [filepath (:file (meta v))]
(when-let [strm (get-resource-stream filepath)]
(with-open [rdr (LineNumberReader. (InputStreamReader. strm))]
(dotimes [_ (dec (:line (meta v)))] (.readLine rdr))
(let [text (StringBuilder.)
pbr (proxy [PushbackReader] [rdr]
(read [] (let [#^Reader this this
i (proxy-super read)]
(.append text (char i))
(read (PushbackReader. pbr))
(str text))))))
(defn- recursive-contains? [coll obj]
"True if coll contains obj. Obj can't be a seq"
(not (empty? (filter #(= obj %) (flatten coll)))))
(defn- does-var-call-fn [var fn]
"Checks if a var calls a function named 'fn"
(if-let [source (get-source-from-var var)]
(let [node (read-string source)]
(if (recursive-contains? node fn)
(defn- does-ns-refer-to-var? [ns var]
(ns-resolve ns var))
(defn- all-vars-who-call [sym]
(filter identity
(map #(does-var-call-fn % sym)
(map vals
(map ns-interns
(filter #(does-ns-refer-to-var? % sym)
(defn who-calls [name]
(letfn [(xref-lisp [sym-var] ; see find-definitions-for-emacs
(when-let [meta (meta sym-var)]
(source-location-for-meta meta nil)))]
(let [callers (all-vars-who-call name) ]
(map first (map xref-lisp callers)))))
(defn- get-line-no-from-defmethod
;; TODO this is very simplistic at the moment and relies on a
;; brittle regex
[multifn-name dispatch-val ns]
(let [filepath (namespace-to-filename ns)
re (re-pattern (str "defmethod *" multifn-name " *" dispatch-val))]
(when-let [strm (get-resource-stream filepath)]
(with-open [rdr (LineNumberReader. (InputStreamReader. strm))]
(loop []
(if-let [ln (.readLine rdr)]
(if (re-find re ln)
(location (str multifn-name " " dispatch-val)
(slime-find-file filepath)
(.getLineNumber rdr))
#_(loop [results []]
(if-let [ln (.readLine rdr)]
(if (re-find re ln)
(recur (conj results
(location multifn-name "defmulti"
(slime-find-file filepath)
(.getLineNumber rdr))))
(recur results))
(defn- all-ns-who-defmulti [multifn]
(for [[dispatch-val m] (methods multifn)]
(let [ns-nm (-> m str (clojure.string/split #"\$") first)
ns-nm-v2 (clojure.string/replace ns-nm "_" "-")]
[dispatch-val (some (fn [ns]
(let [nm (-> ns ns-name str)]
(if (or (= ns-nm nm)
(= ns-nm-v2 nm)) ns)))
(defn who-specializes-multifn [multifn-var]
(let [multifn-name (:name (meta multifn-var))]
(map first (filter seq
(for [[dispatch-val ns] (all-ns-who-defmulti @multifn-var)]
(filter identity (get-line-no-from-defmethod
multifn-name dispatch-val ns)))))))
(defn who-specializes [class]
;; this appears to be broken
;; TODO make it work for multimethod
;; (map ns-name (all-ns))
(letfn [(xref-lisp [sym] ; see find-definitions-for-emacs
(if-let [meta (meta sym)]
(source-location-for-meta meta "method")
(location-not-found (name sym) "method")))]
(let [methods (try (. #^java.lang.Class class getMethods)
(catch java.lang.IllegalArgumentException e nil)
(catch java.lang.NullPointerException e nil))]
(map xref-lisp methods))))
(defslimefn xref [type name]
(let [sexp (maybe-resolve-sym name)]
(condp = type
:specializes (who-specializes-multifn sexp) ;; (who-specializes sexp)
:calls (who-calls (symbol name))
:callers nil
;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defslimefn throw-to-toplevel []
(throw debug-quit-exception))
(defn invoke-restart [restart]
((nth restart 2)))
(defslimefn invoke-nth-restart-for-emacs [level n]
((invoke-restart (*sldb-restarts* (nth (keys *sldb-restarts*) n))))
(catch IndexOutOfBoundsException e (throw debug-invalid-restart-exception))))
(defslimefn throw-to-toplevel []
(if-let [restart (*sldb-restarts* :quit)]
(invoke-restart restart)))
(defslimefn sldb-continue []
(if-let [restart (*sldb-restarts* :continue)]
(invoke-restart restart)))
(defslimefn sldb-abort []
(if-let [restart (*sldb-restarts* :abort)]
(invoke-restart restart)))
(defslimefn backtrace [start end]
(dbe/build-backtrace start end))
(defslimefn buffer-first-change [file-name] nil)
(defn locals-for-emacs [m]
(sort-by second
(map #(list :name (name (first %)) :id 0
:value (pr-str (second %))) m)))
(defslimefn frame-catch-tags-for-emacs [n] nil)
(defslimefn frame-locals-for-emacs [n]
(if (and (zero? n) (seq *current-env*))
(locals-for-emacs *current-env*)))
(defslimefn frame-locals-and-catch-tags [n]
(list (frame-locals-for-emacs n)
(frame-catch-tags-for-emacs n)))
(defslimefn debugger-info-for-emacs [start end]
(build-debugger-info-for-emacs start end))
(defslimefn eval-string-in-frame [expr n]
(dbe/eval-string-in-frame expr n))
(defslimefn eval-last-frame [expr]
(dbe/eval-last-frame expr))
(defslimefn frame-source-location [n]
(source-location-for-frame (dbe/get-stack-trace n)))
;; Older versions of slime use this instead of the above.
(defslimefn frame-source-location-for-emacs [n]
(source-location-for-frame (dbe/get-stack-trace n)))
(defslimefn create-repl [target] '("user" "user"))
;;; Threads
(def #^{:private true} thread-list (atom []))
(defn- get-root-group [#^java.lang.ThreadGroup tg]
(if-let [parent (.getParent tg)]
(recur parent)
(defn get-thread-list []
(let [#^ThreadGroup rg (get-root-group (.getThreadGroup (Thread/currentThread)))
#^"[Ljava.lang.Thread;" arr (make-array Thread (.activeCount rg))]
(.enumerate rg arr true) ;needs type hint
(seq arr)))
(defn- extract-info [#^Thread t]
(map str [(.getId t) (.getName t) (.getPriority t) (.getState t)]))
(defslimefn list-threads
"Return a list (LABELS (ID NAME STATUS ATTRS ...) ...).
LABELS is a list of attribute names and the remaining lists are the
corresponding attribute values per thread."
(reset! thread-list (get-thread-list))
(let [labels '(id name priority state)]
(cons labels (map extract-info @thread-list))))
;;; TODO: Find a better way, as Thread.stop is deprecated
(defslimefn kill-nth-thread [index]
(when index
(when-let [#^Thread thread (nth @thread-list index nil)]
(println "Thread: " thread)
(.stop thread))))
(defslimefn quit-thread-browser []
(reset! thread-list []))
Jump to Line
Something went wrong with that request. Please try again.