Skip to content


Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

779 lines (653 sloc) 26.71 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]
[ :as ns]
(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]
(let [value (first (eval-region string))]
;; If the result is a seq, consume it here instead of getting evaluated
;; from pr-str to allow side-effects to go to the repl.
(if (instance? clojure.lang.LazySeq value)
(doall value)
(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]+)\)")
(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 destroy-ns
(doseq [sym (keys (ns-refers ns))]
(ns-unmap ns sym))
(doseq [a (keys (ns-aliases ns))]
(ns-unalias ns a))
(doseq [a (keys (ns-publics ns))]
(ns-unmap ns a)))
(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
ns-form (ns/read-file-ns-decl ( file-name))
ns (second ns-form)]
(when ns
(destroy-ns ns))
(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)))
(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 (clojure.lang.Compiler$CompilerException.
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)
(catch RuntimeException e (if (instance? ClassNotFoundException (.getCause e))
(throw e)))))
(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.