diff options
Diffstat (limited to 'vim/bundle/slimv/swank-clojure/swank/commands/basic.clj')
| -rw-r--r-- | vim/bundle/slimv/swank-clojure/swank/commands/basic.clj | 601 |
1 files changed, 601 insertions, 0 deletions
diff --git a/vim/bundle/slimv/swank-clojure/swank/commands/basic.clj b/vim/bundle/slimv/swank-clojure/swank/commands/basic.clj new file mode 100644 index 0000000..a397280 --- /dev/null +++ b/vim/bundle/slimv/swank-clojure/swank/commands/basic.clj @@ -0,0 +1,601 @@ +(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.commands [xref :as xref])) + (:import (java.io StringReader File) + (java.util.zip ZipFile) + (clojure.lang LineNumberingPushbackReader))) + +;;;; 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 [] + (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." + ([string] + (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) + (eval (with-env-locals form)) + 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. file)))))) + + +(defslimefn interactive-eval-region [string] + (with-emacs-package + (pr-str (first (eval-region string))))) + +(defslimefn interactive-eval [string] + (with-emacs-package + (pr-str (first (eval-region string))))) + +(defslimefn listener-eval [form] + (with-emacs-package + (with-package-tracking + (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] + (with-emacs-package + (let [retval (promise)] + (list (with-out-str + (deliver retval (pr-str (first (eval-region string))))) + @retval)))) + +(defslimefn pprint-eval [string] + (with-emacs-package + (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- 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)" + ([file-name] + (let [start (System/nanoTime)] + (try + (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* + `(:compilation-result + ~(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] + (try + (dosync (ref-set libs-ref #{})) + (pr-str (clojure.core/load-file file-name)) + (finally + (dosync (alter libs-ref into libs)))))) + +(defn- line-at-position [file position] + (try + (with-open [f (java.io.LineNumberReader. (java.io.FileReader. 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: " + *current-package*))))) + (compile-region string directory line)) + delta (- (System/nanoTime) start)] + `(:compilation-result nil ~(pr-str ret) ~(/ delta 1000000000.0)))) + +;;;; Describe + +(defn- maybe-resolve-sym [symbol-name] + (try + (ns-resolve (maybe-ns *current-package*) (symbol symbol-name)) + (catch ClassNotFoundException e nil))) + +(defn- maybe-resolve-ns [sym-name] + (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))) + (cond + (:forms m) (doseq [f (:forms m)] + (print " ") + (prn f)) + (:arglists m) (prn (:arglists m))) + (if (:special-form m) + (do + (println "Special Form") + (println " " (:doc m)) + (if (contains? m :url) + (when (:url m) + (println (str "\n Please see http://clojure.org/" (:url m)))) + (println (str "\n Please see http://clojure.org/special_forms#" + (:name m))))) + (do + (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) + print-doc))) + +(defn- describe-to-string [var] + (with-out-str + (print-doc var))) + +(defn- describe-symbol* [symbol-name] + (with-emacs-package + (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 + (cond + 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? + pattern + (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) + packages))))) + +(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))) + var)) + ax (accessible? x) ay (accessible? y)] + (cond + (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 + ([name] + (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? + package)))))) + +;;;; Operator messages +(defslimefn operator-arglist [name package] + (try + (let [f (read-string name)] + (cond + (keyword? f) "([map])" + (symbol? f) (let [var (ns-resolve (maybe-ns package) f)] + (if-let [args (and var (:arglists (meta var)))] + (pr-str args) + nil)) + :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 [sym f args] + (let [fname (symbol (str (.name (.ns sym)) "/" (.sym sym)))] + (indent *trace-level*) + (println (str *trace-level* ":") + (apply str (take 240 (pr-str (when fname (cons fname args)) )))) + (let [result (binding [*trace-level* (+ *trace-level* 1)] (apply f args))] + (indent *trace-level*) + (println (str *trace-level* ": " fname " returned " (apply str (take 240 (pr-str result))))) + result))) + +(defslimefn swank-toggle-trace [fname] + (when-let [sym (maybe-resolve-sym fname)] + (if-let [f# (get traced-fn-map sym)] + (do + (alter-var-root #'traced-fn-map dissoc sym) + (alter-var-root sym (constantly f#)) + (str " untraced.")) + (let [f# @sym] + (alter-var-root #'traced-fn-map assoc sym f#) + (alter-var-root sym + (constantly + (fn [& args] + (trace-fn-call sym f# args)))) + (str " traced."))))) + +(defslimefn untrace-all [] + (doseq [sym (keys traced-fn-map)] + (swank-toggle-trace (.sym sym)))) + +;;;; Source Locations +(comment + "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) + directory)) + + +;;;; 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 "os.name") "Windows") + (second (re-matches #"^/([a-zA-Z]:/.*)$" path))) + path)) + +(defn- slime-zip-resource [#^java.net.URL resource] + (let [jar-connection #^java.net.JarURLConnection (.openConnection resource) + jar-file (.getPath (.toURI (.getJarFileURL jar-connection)))] + (list :zip (clean-windows-path jar-file) (.getEntryName jar-connection)))) + +(defn- slime-file-resource [#^java.net.URL 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 (.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] + (namespace-to-path + (symbol (.replace 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)] + (location-in-file path line))) + +(defn- namespace-to-filename [ns] + (str (-> (str ns) + (.replaceAll "\\." File/separator) + (.replace \- \_ )) + ".clj")) + +(defn- source-location-for-meta [meta xref-type-name] + (location (:name meta) + xref-type-name + (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] + (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)))) + +(defn who-specializes [class] + (letfn [(xref-lisp [sym] ; see find-definitions-for-emacs + (if-let [meta (meta sym)] + (source-location-for-meta meta "method") + (location-not-found (.getName sym) "method")))] + (let [methods (try (. class getMethods) + (catch java.lang.IllegalArgumentException e nil) + (catch java.lang.NullPointerException e nil))] + (map xref-lisp methods)))) + +(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 (xref/all-vars-who-call name) ] + (map first (map xref-lisp callers))))) + +(defslimefn xref [type name] + (let [sexp (maybe-resolve-sym name)] + (condp = type + :specializes (who-specializes sexp) + :calls (who-calls (symbol name)) + :callers nil + :not-implemented))) + +(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))))) + +(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] + (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] + (if (and (zero? n) *current-env*) + (with-bindings *current-env* + (eval expr)))) + +(defslimefn frame-source-location [n] + (source-location-for-frame + (nth (.getStackTrace *current-exception*) n))) + +;; Older versions of slime use this instead of the above. +(defslimefn frame-source-location-for-emacs [n] + (source-location-for-frame + (nth (.getStackTrace *current-exception*) 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) + tg)) + +(defn- get-thread-list [] + (let [rg (get-root-group (.getThreadGroup (Thread/currentThread))) + arr (make-array Thread (.activeCount rg))] + (.enumerate rg arr true) + (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 (nth @thread-list index nil)] + (println "Thread: " thread) + (.stop thread)))) + +(defslimefn quit-thread-browser [] + (reset! thread-list [])) |