mirror of
https://github.com/amix/vimrc
synced 2025-07-10 03:25:00 +08:00
Add support for Scheme and Racket language.
This commit is contained in:
Kurtis Moxley
608
sources_non_forked/slimv/swank-clojure/swank/commands/basic.clj
Normal file
608
sources_non_forked/slimv/swank-clojure/swank/commands/basic.clj
Normal file
@ -0,0 +1,608 @@
|
||||
(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]+)(:[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)))
|
||||
|
||||
(defmacro compiler-exception [directory line ex]
|
||||
`(eval (if (>= (:minor *clojure-version*) 5)
|
||||
'(clojure.lang.Compiler$CompilerException.
|
||||
~directory ~line 0 ~ex)
|
||||
'(clojure.lang.Compiler$CompilerException.
|
||||
~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: "
|
||||
*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 []))
|
||||
@ -0,0 +1,103 @@
|
||||
(ns swank.commands.completion
|
||||
(:use (swank util core commands)
|
||||
(swank.util string clojure java class-browse)))
|
||||
|
||||
(defn potential-ns
|
||||
"Returns a list of potential namespace completions for a given
|
||||
namespace"
|
||||
([] (potential-ns *ns*))
|
||||
([ns]
|
||||
(for [ns-sym (concat (keys (ns-aliases (ns-name ns)))
|
||||
(map ns-name (all-ns)))]
|
||||
(name ns-sym))))
|
||||
|
||||
(defn potential-var-public
|
||||
"Returns a list of potential public var name completions for a
|
||||
given namespace"
|
||||
([] (potential-var-public *ns*))
|
||||
([ns]
|
||||
(for [var-sym (keys (ns-publics ns))]
|
||||
(name var-sym))))
|
||||
|
||||
(defn potential-var
|
||||
"Returns a list of all potential var name completions for a given
|
||||
namespace"
|
||||
([] (potential-var *ns*))
|
||||
([ns]
|
||||
(for [[key v] (ns-map ns)
|
||||
:when (var? v)]
|
||||
(name key))))
|
||||
|
||||
(defn potential-classes
|
||||
"Returns a list of potential class name completions for a given
|
||||
namespace"
|
||||
([] (potential-classes *ns*))
|
||||
([ns]
|
||||
(for [class-sym (keys (ns-imports ns))]
|
||||
(name class-sym))))
|
||||
|
||||
(defn potential-dot
|
||||
"Returns a list of potential dot method name completions for a given
|
||||
namespace"
|
||||
([] (potential-dot *ns*))
|
||||
([ns]
|
||||
(map #(str "." %) (set (map member-name (mapcat instance-methods (vals (ns-imports ns))))))))
|
||||
|
||||
(defn potential-static
|
||||
"Returns a list of potential static members for a given namespace"
|
||||
([#^Class class]
|
||||
(concat (map member-name (static-methods class))
|
||||
(map member-name (static-fields class)))))
|
||||
|
||||
|
||||
(defn potential-classes-on-path
|
||||
"Returns a list of Java class and Clojure package names found on the current
|
||||
classpath. To minimize noise, list is nil unless a '.' is present in the search
|
||||
string, and nested classes are only shown if a '$' is present."
|
||||
([symbol-string]
|
||||
(when (.contains symbol-string ".")
|
||||
(if (.contains symbol-string "$")
|
||||
@nested-classes
|
||||
@top-level-classes))))
|
||||
|
||||
(defn resolve-class
|
||||
"Attempts to resolve a symbol into a java Class. Returns nil on
|
||||
failure."
|
||||
([sym]
|
||||
(try
|
||||
(let [res (resolve sym)]
|
||||
(when (class? res)
|
||||
res))
|
||||
(catch Throwable t
|
||||
nil))))
|
||||
|
||||
|
||||
(defn- maybe-alias [sym ns]
|
||||
(or (resolve-ns sym (maybe-ns ns))
|
||||
(maybe-ns ns)))
|
||||
|
||||
(defn potential-completions [symbol-ns ns]
|
||||
(if symbol-ns
|
||||
(map #(str symbol-ns "/" %)
|
||||
(if-let [class (resolve-class symbol-ns)]
|
||||
(potential-static class)
|
||||
(potential-var-public (maybe-alias symbol-ns ns))))
|
||||
(concat (potential-var ns)
|
||||
(when-not symbol-ns
|
||||
(potential-ns))
|
||||
(potential-classes ns)
|
||||
(potential-dot ns))))
|
||||
|
||||
|
||||
(defslimefn simple-completions [symbol-string package]
|
||||
(try
|
||||
(let [[sym-ns sym-name] (symbol-name-parts symbol-string)
|
||||
potential (concat (potential-completions (when sym-ns (symbol sym-ns)) (ns-name (maybe-ns package)))
|
||||
(potential-classes-on-path symbol-string))
|
||||
matches (seq (sort (filter #(.startsWith #^String % symbol-string) potential)))]
|
||||
(list matches
|
||||
(if matches
|
||||
(reduce largest-common-prefix matches)
|
||||
symbol-string)))
|
||||
(catch java.lang.Throwable t
|
||||
(list nil symbol-string))))
|
||||
@ -0,0 +1,9 @@
|
||||
(ns swank.commands.contrib
|
||||
(:use (swank util core commands)))
|
||||
|
||||
(defslimefn swank-require [keys]
|
||||
(binding [*ns* (find-ns 'swank.commands.contrib)]
|
||||
(doseq [k (if (seq? keys) keys (list keys))]
|
||||
(try
|
||||
(require (symbol (str "swank.commands.contrib." (name k))))
|
||||
(catch java.io.FileNotFoundException fne nil)))))
|
||||
@ -0,0 +1,123 @@
|
||||
(ns swank.commands.contrib.swank-arglists
|
||||
(:use (swank util core commands)))
|
||||
|
||||
((slime-fn 'swank-require) :swank-c-p-c)
|
||||
|
||||
;;; pos starts at 1 bc 0 is function name
|
||||
(defn position-in-arglist? [arglist pos]
|
||||
(or (some #(= '& %) arglist)
|
||||
(<= pos (count arglist))))
|
||||
|
||||
;; (position-in-arglist? '[x y] 2)
|
||||
;; => true
|
||||
|
||||
(defn highlight-position [arglist pos]
|
||||
(if (zero? pos)
|
||||
arglist
|
||||
;; i.e. not rest args
|
||||
(let [num-normal-args (count (take-while #(not= % '&) arglist))]
|
||||
(if (<= pos num-normal-args)
|
||||
(into [] (concat (take (dec pos) arglist)
|
||||
'(===>)
|
||||
(list (nth arglist (dec pos)))
|
||||
'(<===)
|
||||
(drop pos arglist)))
|
||||
(let [rest-arg? (some #(= % '&) arglist)]
|
||||
(if rest-arg?
|
||||
(into [] (concat (take-while #(not= % '&) arglist)
|
||||
'(===>)
|
||||
'(&)
|
||||
(list (last arglist))
|
||||
'(<===)))))))))
|
||||
|
||||
;; (highlight-position '[x y] 0)
|
||||
;; => [===> x <=== y]
|
||||
|
||||
(defn highlight-arglists [arglists pos]
|
||||
(let [arglists (read-string arglists)]
|
||||
(loop [checked []
|
||||
current (first arglists)
|
||||
remaining (rest arglists)]
|
||||
(if (position-in-arglist? current pos)
|
||||
(apply list (concat checked
|
||||
[(highlight-position current pos)]
|
||||
remaining))
|
||||
(when (seq remaining)
|
||||
(recur (conj checked current)
|
||||
(first remaining)
|
||||
(rest remaining)))))))
|
||||
|
||||
;; (highlight-arglists "([x] [x & more])" 1)
|
||||
;; => ([===> x <===] [x & more])
|
||||
|
||||
;;(defmacro dbg[x] `(let [x# ~x] (println '~x "->" x#) x#))
|
||||
|
||||
(defn defnk-arglists? [arglists]
|
||||
(and (not (nil? arglists ))
|
||||
(not (vector? (first (read-string arglists))))))
|
||||
|
||||
(defn fix-defnk-arglists [arglists]
|
||||
(str (list (into [] (read-string arglists)))))
|
||||
|
||||
(defn arglists-for-fname-lookup [fname]
|
||||
((slime-fn 'operator-arglist) fname *current-package*))
|
||||
|
||||
(defn arglists-for-fname [fname]
|
||||
(let [arglists (arglists-for-fname-lookup fname)]
|
||||
;; defnk's arglists format is (a b) instead of ([a b])
|
||||
(if (defnk-arglists? arglists)
|
||||
(fix-defnk-arglists arglists)
|
||||
arglists)))
|
||||
|
||||
(defn message-format [cmd arglists pos]
|
||||
(str (when cmd (str cmd ": "))
|
||||
(when arglists
|
||||
(if pos
|
||||
(highlight-arglists arglists pos)
|
||||
arglists))))
|
||||
|
||||
(defn handle-apply [raw-specs pos]
|
||||
(let [fname (second (first raw-specs))]
|
||||
(message-format fname (arglists-for-fname fname) (dec pos))))
|
||||
|
||||
(defslimefn arglist-for-echo-area [raw-specs & options]
|
||||
(let [{:keys [arg-indices
|
||||
print-right-margin
|
||||
print-lines]} (apply hash-map options)]
|
||||
(if-not (and raw-specs
|
||||
(seq? raw-specs)
|
||||
(seq? (first raw-specs)))
|
||||
nil ;; problem?
|
||||
(let [pos (first (second options))
|
||||
top-level? (= 1 (count raw-specs))
|
||||
parent-pos (when-not top-level?
|
||||
(second (second options)))
|
||||
fname (ffirst raw-specs)
|
||||
parent-fname (when-not top-level?
|
||||
(first (second raw-specs)))
|
||||
arglists (arglists-for-fname fname)
|
||||
inside-binding? (and (not top-level?)
|
||||
(#{"let" "binding" "doseq" "for" "loop"}
|
||||
parent-fname)
|
||||
(= 1 parent-pos))]
|
||||
;; (dbg raw-specs)
|
||||
;; (dbg options)
|
||||
(cond
|
||||
;; display arglists for function being applied unless on top of apply
|
||||
(and (= fname "apply") (not= pos 0)) (handle-apply raw-specs pos)
|
||||
;; highlight binding inside binding forms unless >1 level deep
|
||||
inside-binding? (message-format parent-fname
|
||||
(arglists-for-fname parent-fname)
|
||||
1)
|
||||
:else (message-format fname arglists pos))))))
|
||||
|
||||
(defslimefn variable-desc-for-echo-area [variable-name]
|
||||
(with-emacs-package
|
||||
(or
|
||||
(try
|
||||
(when-let [sym (read-string variable-name)]
|
||||
(when-let [var (resolve sym)]
|
||||
(when (.isBound #^clojure.lang.Var var)
|
||||
(str variable-name " => " (var-get var)))))
|
||||
(catch Exception e nil))
|
||||
"")))
|
||||
@ -0,0 +1,21 @@
|
||||
(ns swank.commands.contrib.swank-c-p-c
|
||||
(:use (swank util core commands)
|
||||
(swank.commands completion)
|
||||
(swank.util string clojure)
|
||||
(swank.commands.contrib.swank-c-p-c internal)))
|
||||
|
||||
(defslimefn completions [symbol-string package]
|
||||
(try
|
||||
(let [[sym-ns sym-name] (symbol-name-parts symbol-string)
|
||||
potential (concat
|
||||
(potential-completions
|
||||
(when sym-ns (symbol sym-ns))
|
||||
(ns-name (maybe-ns package)))
|
||||
(potential-classes-on-path symbol-string))
|
||||
matches (seq (sort (filter #(split-compound-prefix-match? symbol-string %) potential)))]
|
||||
(list matches
|
||||
(if matches
|
||||
(reduce largest-common-prefix matches)
|
||||
symbol-string)))
|
||||
(catch java.lang.Throwable t
|
||||
(list nil symbol-string))))
|
||||
@ -0,0 +1,59 @@
|
||||
(ns swank.commands.contrib.swank-c-p-c.internal
|
||||
(:use (swank util core commands)
|
||||
(swank.commands completion)
|
||||
(swank.util string clojure)))
|
||||
|
||||
(defn compound-prefix-match?
|
||||
"Takes a `prefix' and a `target' string and returns whether `prefix'
|
||||
is a compound-prefix of `target'.
|
||||
|
||||
Viewing each of `prefix' and `target' as a series of substrings
|
||||
split by `split', if each substring of `prefix' is a prefix of the
|
||||
corresponding substring in `target' then we call `prefix' a
|
||||
compound-prefix of `target'."
|
||||
([split #^String prefix #^String target]
|
||||
(let [prefixes (split prefix)
|
||||
targets (split target)]
|
||||
(when (<= (count prefixes) (count targets))
|
||||
(every? true? (map #(.startsWith #^String %1 %2) targets prefixes))))))
|
||||
|
||||
(defn unacronym
|
||||
"Interposes delimiter between each character of string."
|
||||
([delimiter #^String string]
|
||||
(apply str (interpose delimiter string)))
|
||||
{:tag String})
|
||||
|
||||
(defn delimited-compound-prefix-match?
|
||||
"Uses a delimiter as the `split' for a compound prefix match check.
|
||||
See also: `compound-prefix-match?'"
|
||||
([delimiter prefix target]
|
||||
(compound-prefix-match? #(.split #^String % (str "[" (java.util.regex.Pattern/quote delimiter) "]") -1)
|
||||
prefix
|
||||
target)))
|
||||
|
||||
|
||||
(defn delimited-compound-prefix-match-acronym?
|
||||
([delimiter prefix target]
|
||||
(or (delimited-compound-prefix-match? delimiter prefix target)
|
||||
(delimited-compound-prefix-match? delimiter (unacronym (first delimiter) prefix) target))))
|
||||
|
||||
(defn camel-compound-prefix-match?
|
||||
"Uses camel case as a delimiter for a compound prefix match check.
|
||||
|
||||
See also: `compound-prefix-match?'"
|
||||
([#^String prefix #^String target]
|
||||
(compound-prefix-match? #(re-seq #"(?:^.|[A-Z])[^A-Z]*" %)
|
||||
prefix
|
||||
target)))
|
||||
|
||||
(defn split-compound-prefix-match? [#^String symbol-string #^String potential]
|
||||
(if (.startsWith symbol-string ".")
|
||||
(and (.startsWith potential ".")
|
||||
(camel-compound-prefix-match? symbol-string potential))
|
||||
(let [[sym-ns sym-name] (symbol-name-parts symbol-string)
|
||||
[pot-ns pot-name] (symbol-name-parts potential)]
|
||||
(and (or (= sym-ns pot-ns)
|
||||
(and sym-ns pot-ns
|
||||
(delimited-compound-prefix-match-acronym? "." sym-ns pot-ns)))
|
||||
(or (delimited-compound-prefix-match-acronym? "-." sym-name pot-name)
|
||||
(camel-compound-prefix-match? sym-name pot-name))))))
|
||||
@ -0,0 +1,428 @@
|
||||
;;; swank_fuzzy.clj --- fuzzy symbol completion, Clojure implementation.
|
||||
|
||||
;; Original CL implementation authors (from swank-fuzzy.lisp) below,
|
||||
;; Authors: Brian Downing <bdowning@lavos.net>
|
||||
;; Tobias C. Rittweiler <tcr@freebits.de>
|
||||
;; and others
|
||||
|
||||
;; This progam is based on the swank-fuzzy.lisp.
|
||||
;; Thanks the CL implementation authors for that useful software.
|
||||
|
||||
(ns swank.commands.contrib.swank-fuzzy
|
||||
(:use (swank util core commands))
|
||||
(:use (swank.util clojure)))
|
||||
|
||||
(def #^{:dynamic true} *fuzzy-recursion-soft-limit* 30)
|
||||
(defn- compute-most-completions [short full]
|
||||
(let [collect-chunk (fn [[pcur [[pa va] ys]] [pb vb]]
|
||||
(let [xs (if (= (dec pb) pcur)
|
||||
[[pa (str va vb)]]
|
||||
[[pb vb] [pa va]])]
|
||||
[pb (if ys (conj xs ys) xs)]))
|
||||
step (fn step [short full pos chunk seed limit?]
|
||||
(cond
|
||||
(and (empty? full) (not (empty? short)))
|
||||
nil
|
||||
(or (empty? short) limit?)
|
||||
(if chunk
|
||||
(conj seed
|
||||
(second (reduce collect-chunk
|
||||
[(ffirst chunk) [(first chunk)]]
|
||||
(rest chunk))))
|
||||
seed)
|
||||
(= (first short) (first full))
|
||||
(let [seed2
|
||||
(step short (rest full) (inc pos) chunk seed
|
||||
(< *fuzzy-recursion-soft-limit* (count seed)))]
|
||||
(recur (rest short) (rest full) (inc pos)
|
||||
(conj chunk [pos (str (first short))])
|
||||
(if (and seed2 (not (empty? seed2)))
|
||||
seed2
|
||||
seed)
|
||||
false))
|
||||
:else
|
||||
(recur short (rest full) (inc pos) chunk seed false)))]
|
||||
(map reverse (step short full 0 [] () false))))
|
||||
|
||||
(def fuzzy-completion-symbol-prefixes "*+-%&?<")
|
||||
(def fuzzy-completion-word-separators "-/.")
|
||||
(def fuzzy-completion-symbol-suffixes "*+->?!")
|
||||
(defn- score-completion [completion short full]
|
||||
(let [find1
|
||||
(fn [c s]
|
||||
(re-find (re-pattern (java.util.regex.Pattern/quote (str c))) s))
|
||||
at-beginning? zero?
|
||||
after-prefix?
|
||||
(fn [pos]
|
||||
(and (= pos 1)
|
||||
(find1 (nth full 0) fuzzy-completion-symbol-prefixes)))
|
||||
word-separator?
|
||||
(fn [pos]
|
||||
(find1 (nth full pos) fuzzy-completion-word-separators))
|
||||
after-word-separator?
|
||||
(fn [pos]
|
||||
(find1 (nth full (dec pos)) fuzzy-completion-word-separators))
|
||||
at-end?
|
||||
(fn [pos]
|
||||
(= pos (dec (count full))))
|
||||
before-suffix?
|
||||
(fn [pos]
|
||||
(and (= pos (- (count full) 2))
|
||||
(find1 (nth full (dec (count full)))
|
||||
fuzzy-completion-symbol-suffixes)))]
|
||||
(letfn [(score-or-percentage-of-previous
|
||||
[base-score pos chunk-pos]
|
||||
(if (zero? chunk-pos)
|
||||
base-score
|
||||
(max base-score
|
||||
(+ (* (score-char (dec pos) (dec chunk-pos)) 0.85)
|
||||
(Math/pow 1.2 chunk-pos)))))
|
||||
(score-char
|
||||
[pos chunk-pos]
|
||||
(score-or-percentage-of-previous
|
||||
(cond (at-beginning? pos) 10
|
||||
(after-prefix? pos) 10
|
||||
(word-separator? pos) 1
|
||||
(after-word-separator? pos) 8
|
||||
(at-end? pos) 6
|
||||
(before-suffix? pos) 6
|
||||
:else 1)
|
||||
pos chunk-pos))
|
||||
(score-chunk
|
||||
[chunk]
|
||||
(let [chunk-len (count (second chunk))]
|
||||
(apply +
|
||||
(map score-char
|
||||
(take chunk-len (iterate inc (first chunk)))
|
||||
(reverse (take chunk-len
|
||||
(iterate dec (dec chunk-len))))))))]
|
||||
(let [chunk-scores (map score-chunk completion)
|
||||
length-score (/ 10.0 (inc (- (count full) (count short))))]
|
||||
[(+ (apply + chunk-scores) length-score)
|
||||
(list (map list chunk-scores completion) length-score)]))))
|
||||
|
||||
(defn- compute-highest-scoring-completion [short full]
|
||||
(let [scored-results
|
||||
(map (fn [result]
|
||||
[(first (score-completion result short full))
|
||||
result])
|
||||
(compute-most-completions short full))
|
||||
winner (first (sort (fn [[av _] [bv _]] (> av bv))
|
||||
scored-results))]
|
||||
[(second winner) (first winner)]))
|
||||
|
||||
(defn- call-with-timeout [time-limit-in-msec proc]
|
||||
"Create a thunk that returns true if given time-limit-in-msec has been
|
||||
elapsed and calls proc with the thunk as an argument. Returns a 3 elements
|
||||
vec: A proc result, given time-limit-in-msec has been elapsed or not,
|
||||
elapsed time in millisecond."
|
||||
(let [timed-out (atom false)
|
||||
start! (fn []
|
||||
(future (do
|
||||
(Thread/sleep time-limit-in-msec)
|
||||
(swap! timed-out (constantly true)))))
|
||||
timed-out? (fn [] @timed-out)
|
||||
started-at (System/nanoTime)]
|
||||
(start!)
|
||||
[(proc timed-out?)
|
||||
@timed-out
|
||||
(/ (double (- (System/nanoTime) started-at)) 1000000.0)]))
|
||||
|
||||
(defmacro with-timeout
|
||||
"Create a thunk that returns true if given time-limit-in-msec has been
|
||||
elapsed and bind it to timed-out?. Then execute body."
|
||||
#^{:private true}
|
||||
[[timed-out? time-limit-in-msec] & body]
|
||||
`(call-with-timeout ~time-limit-in-msec (fn [~timed-out?] ~@body)))
|
||||
|
||||
(defstruct fuzzy-matching
|
||||
:var :ns :symbol :ns-name :score :ns-chunks :var-chunks)
|
||||
|
||||
(defn- fuzzy-extract-matching-info [matching string]
|
||||
(let [[user-ns-name _] (symbol-name-parts string)]
|
||||
(cond
|
||||
(:var matching)
|
||||
[(str (:symbol matching))
|
||||
(cond (nil? user-ns-name) nil
|
||||
:else (:ns-name matching))]
|
||||
:else
|
||||
[""
|
||||
(str (:symbol matching))])))
|
||||
|
||||
(defn- fuzzy-find-matching-vars
|
||||
[string ns var-filter external-only?]
|
||||
(let [compute (partial compute-highest-scoring-completion string)
|
||||
ns-maps (cond
|
||||
external-only? ns-publics
|
||||
(= ns *ns*) ns-map
|
||||
:else ns-interns)]
|
||||
(map (fn [[match-result score var sym]]
|
||||
(if (var? var)
|
||||
(struct fuzzy-matching
|
||||
var nil (or (:name (meta var))
|
||||
(symbol (pr-str var)))
|
||||
nil
|
||||
score nil match-result)
|
||||
(struct fuzzy-matching
|
||||
nil nil sym
|
||||
nil
|
||||
score nil match-result)))
|
||||
(filter (fn [[match-result & _]]
|
||||
(or (= string "")
|
||||
(not-empty match-result)))
|
||||
(map (fn [[k v]]
|
||||
(if (= string "")
|
||||
(conj [nil 0.0] v k)
|
||||
(conj (compute (.toLowerCase (str k))) v k)))
|
||||
(filter var-filter (seq (ns-maps ns))))))))
|
||||
(defn- fuzzy-find-matching-nss
|
||||
[string]
|
||||
(let [compute (partial compute-highest-scoring-completion string)]
|
||||
(map (fn [[match-result score ns ns-sym]]
|
||||
(struct fuzzy-matching nil ns ns-sym (str ns-sym)
|
||||
score match-result nil))
|
||||
(filter (fn [[match-result & _]] (not-empty match-result))
|
||||
(map (fn [[ns-sym ns]]
|
||||
(conj (compute (str ns-sym)) ns ns-sym))
|
||||
(concat
|
||||
(map (fn [ns] [(symbol (str ns)) ns]) (all-ns))
|
||||
(ns-aliases *ns*)))))))
|
||||
|
||||
(defn- fuzzy-generate-matchings
|
||||
[string default-ns timed-out?]
|
||||
(let [take* (partial take-while (fn [_] (not (timed-out?))))
|
||||
[parsed-ns-name parsed-symbol-name] (symbol-name-parts string)
|
||||
find-vars
|
||||
(fn find-vars
|
||||
([designator ns]
|
||||
(find-vars designator ns identity))
|
||||
([designator ns var-filter]
|
||||
(find-vars designator ns var-filter nil))
|
||||
([designator ns var-filter external-only?]
|
||||
(take* (fuzzy-find-matching-vars designator
|
||||
ns
|
||||
var-filter
|
||||
external-only?))))
|
||||
find-nss (comp take* fuzzy-find-matching-nss)
|
||||
make-duplicate-var-filter
|
||||
(fn [fuzzy-ns-matchings]
|
||||
(let [nss (set (map :ns-name fuzzy-ns-matchings))]
|
||||
(comp not nss str :ns meta second)))
|
||||
matching-greater
|
||||
(fn [a b]
|
||||
(cond
|
||||
(> (:score a) (:score b)) -1
|
||||
(< (:score a) (:score b)) 1
|
||||
:else (compare (:symbol a) (:symbol b))))
|
||||
fix-up
|
||||
(fn [matchings parent-package-matching]
|
||||
(map (fn [m]
|
||||
(assoc m
|
||||
:ns-name (:ns-name parent-package-matching)
|
||||
:ns-chunks (:ns-chunks parent-package-matching)
|
||||
:score (if (= parsed-ns-name "")
|
||||
(/ (:score parent-package-matching) 100)
|
||||
(+ (:score parent-package-matching)
|
||||
(:score m)))))
|
||||
matchings))]
|
||||
(sort matching-greater
|
||||
(cond
|
||||
(nil? parsed-ns-name)
|
||||
(concat
|
||||
(find-vars parsed-symbol-name (maybe-ns default-ns))
|
||||
(find-nss parsed-symbol-name))
|
||||
;; (apply concat
|
||||
;; (let [ns *ns*]
|
||||
;; (pcalls #(binding [*ns* ns]
|
||||
;; (find-vars parsed-symbol-name
|
||||
;; (maybe-ns default-ns)))
|
||||
;; #(binding [*ns* ns]
|
||||
;; (find-nss parsed-symbol-name)))))
|
||||
(= "" parsed-ns-name)
|
||||
(find-vars parsed-symbol-name (maybe-ns default-ns))
|
||||
:else
|
||||
(let [found-nss (find-nss parsed-ns-name)
|
||||
find-vars1 (fn [ns-matching]
|
||||
(fix-up
|
||||
(find-vars parsed-symbol-name
|
||||
(:ns ns-matching)
|
||||
(make-duplicate-var-filter
|
||||
(filter (partial = ns-matching)
|
||||
found-nss))
|
||||
true)
|
||||
ns-matching))]
|
||||
(concat
|
||||
(apply concat
|
||||
(map find-vars1 (sort matching-greater found-nss)))
|
||||
found-nss))))))
|
||||
|
||||
(defn- fuzzy-format-matching [string matching]
|
||||
(let [[symbol package] (fuzzy-extract-matching-info matching string)
|
||||
result (str package (when package "/") symbol)]
|
||||
[result (.indexOf #^String result #^String symbol)]))
|
||||
|
||||
(defn- classify-matching [m]
|
||||
(let [make-var-meta (fn [m]
|
||||
(fn [key]
|
||||
(when-let [var (:var m)]
|
||||
(when-let [var-meta (meta var)]
|
||||
(get var-meta key)))))
|
||||
vm (make-var-meta m)]
|
||||
(set
|
||||
(filter
|
||||
identity
|
||||
[(when-not (or (vm :macro) (vm :arglists))
|
||||
:boundp)
|
||||
(when (vm :arglists) :fboundp)
|
||||
;; (:typespec)
|
||||
;; (:class)
|
||||
(when (vm :macro) :macro)
|
||||
(when (special-symbol? (:symbol m)) :special-operator)
|
||||
(when (:ns-name m) :package)
|
||||
(when (= clojure.lang.MultiFn (vm :tag))
|
||||
:generic-function)]))))
|
||||
(defn- classification->string [flags]
|
||||
(format (apply str (replicate 8 "%s"))
|
||||
(if (or (:boundp flags)
|
||||
(:constant flags)) "b" "-")
|
||||
(if (:fboundp flags) "f" "-")
|
||||
(if (:generic-function flags) "g" "-")
|
||||
(if (:class flags) "c" "-")
|
||||
(if (:typespec flags) "t" "-")
|
||||
(if (:macro flags) "m" "-")
|
||||
(if (:special-operator flags) "s" "-")
|
||||
(if (:package flags) "p" "-")))
|
||||
|
||||
(defn- fuzzy-convert-matching-for-emacs [string matching]
|
||||
(let [[name added-length] (fuzzy-format-matching string matching)]
|
||||
[name
|
||||
(format "%.2f" (:score matching))
|
||||
(concat (:ns-chunks matching)
|
||||
(map (fn [[offset string]] [(+ added-length offset) string])
|
||||
(:var-chunks matching)))
|
||||
(classification->string (classify-matching matching))
|
||||
]))
|
||||
|
||||
(defn- fuzzy-completion-set
|
||||
[string default-ns limit time-limit-in-msec]
|
||||
(let [[matchings interrupted? _]
|
||||
(with-timeout [timed-out? time-limit-in-msec]
|
||||
(vec (fuzzy-generate-matchings string default-ns timed-out?)))
|
||||
subvec1 (if (and limit
|
||||
(> limit 0)
|
||||
(< limit (count matchings)))
|
||||
(fn [v] (subvec v 0 limit))
|
||||
identity)]
|
||||
[(subvec1 (vec (map (partial fuzzy-convert-matching-for-emacs string)
|
||||
matchings)))
|
||||
interrupted?]))
|
||||
|
||||
(defslimefn fuzzy-completions
|
||||
[string default-package-name
|
||||
_limit limit _time-limit-in-msec time-limit-in-msec]
|
||||
(let [[xs x] (fuzzy-completion-set string default-package-name
|
||||
limit time-limit-in-msec)]
|
||||
(list
|
||||
(map (fn [[symbol score chunks class]]
|
||||
(list symbol score (map (partial apply list) chunks) class))
|
||||
xs)
|
||||
(when x 't))))
|
||||
|
||||
(defslimefn fuzzy-completion-selected [_ _] nil)
|
||||
|
||||
(comment
|
||||
(do
|
||||
(use '[clojure.test])
|
||||
|
||||
(is (= '(([0 "m"] [9 "v"] [15 "b"]))
|
||||
(compute-most-completions "mvb" "multiple-value-bind")))
|
||||
(is (= '(([0 "zz"]) ([0 "z"] [2 "z"]) ([1 "zz"]))
|
||||
(compute-most-completions "zz" "zzz")))
|
||||
(is (= 103
|
||||
(binding [*fuzzy-recursion-soft-limit* 2]
|
||||
(count
|
||||
(compute-most-completions "ZZZZZZ" "ZZZZZZZZZZZZZZZZZZZZZZZ")))))
|
||||
|
||||
(are [x p s] (= x (score-completion [[p s]] s "*multiple-value+"))
|
||||
'[10.625 (((10 [0 "*"])) 0.625)] 0 "*" ;; at-beginning
|
||||
'[10.625 (((10 [1 "m"])) 0.625)] 1 "m" ;; after-prefix
|
||||
'[1.625 (((1 [9 "-"])) 0.625)] 9 "-" ;; word-sep
|
||||
'[8.625 (((8 [10 "v"])) 0.625)] 10 "v" ;; after-word-sep
|
||||
'[6.625 (((6 [15 "+"])) 0.625)] 15 "+" ;; at-end
|
||||
'[6.625 (((6 [14 "e"])) 0.625)] 14 "e" ;; before-suffix
|
||||
'[1.625 (((1 [2 "u"])) 0.625)] 2 "u" ;; other
|
||||
)
|
||||
(is (= (+ 10 ;; m's score
|
||||
(+ (* 10 0.85) (Math/pow 1.2 1))) ;; u's score
|
||||
(let [[_ x]
|
||||
(score-completion [[1 "mu"]] "mu" "*multiple-value+")]
|
||||
((comp first ffirst) x)))
|
||||
"`m''s score + `u''s score (percentage of previous which is 'm''s)")
|
||||
|
||||
(is (= '[([0 "zz"]) 24.7]
|
||||
(compute-highest-scoring-completion "zz" "zzz")))
|
||||
|
||||
(are [to? ret to proc] (= [ret to?]
|
||||
(let [[x y _] (call-with-timeout to proc)]
|
||||
[x y]))
|
||||
false "r" 10 (fn [_] "r")
|
||||
true nil 1 (fn [_] (Thread/sleep 10) nil))
|
||||
|
||||
(are [symbol package input] (= [symbol package]
|
||||
(fuzzy-extract-matching-info
|
||||
(struct fuzzy-matching
|
||||
true nil
|
||||
"symbol" "ns-name"
|
||||
nil nil nil)
|
||||
input))
|
||||
"symbol" "ns-name" "p/*"
|
||||
"symbol" nil "*")
|
||||
(is (= ["" "ns-name"]
|
||||
(fuzzy-extract-matching-info
|
||||
(struct fuzzy-matching
|
||||
nil nil
|
||||
"ns-name" ""
|
||||
nil nil nil)
|
||||
"")))
|
||||
|
||||
(defmacro try! #^{:private true}
|
||||
[& body]
|
||||
`(do
|
||||
~@(map (fn [x] `(try ~x (catch Throwable ~'_ nil)))
|
||||
body)))
|
||||
|
||||
(try
|
||||
(def testing-testing0 't)
|
||||
(def #^{:private true} testing-testing1 't)
|
||||
(are [x external-only?] (= x
|
||||
(vec
|
||||
(sort
|
||||
(map (comp str :symbol)
|
||||
(fuzzy-find-matching-vars
|
||||
"testing" *ns*
|
||||
(fn [[k v]]
|
||||
(and (= ((comp :ns meta) v) *ns*)
|
||||
(re-find #"^testing-"
|
||||
(str k))))
|
||||
external-only?)))))
|
||||
["testing-testing0" "testing-testing1"] nil
|
||||
["testing-testing0"] true)
|
||||
(finally
|
||||
(try!
|
||||
(ns-unmap *ns* 'testing-testing0)
|
||||
(ns-unmap *ns* 'testing-testing1))))
|
||||
|
||||
(try
|
||||
(create-ns 'testing-testing0)
|
||||
(create-ns 'testing-testing1)
|
||||
(is (= '["testing-testing0" "testing-testing1"]
|
||||
(vec
|
||||
(sort
|
||||
(map (comp str :symbol)
|
||||
(fuzzy-find-matching-nss "testing-"))))))
|
||||
(finally
|
||||
(try!
|
||||
(remove-ns 'testing-testing0)
|
||||
(remove-ns 'testing-testing1))))
|
||||
)
|
||||
)
|
||||
100
sources_non_forked/slimv/swank-clojure/swank/commands/indent.clj
Normal file
100
sources_non_forked/slimv/swank-clojure/swank/commands/indent.clj
Normal file
@ -0,0 +1,100 @@
|
||||
(ns swank.commands.indent
|
||||
(:use (swank util core)
|
||||
(swank.core hooks connection)
|
||||
(swank.util hooks)))
|
||||
|
||||
(defn- need-full-indentation-update?
|
||||
"Return true if the indentation cache should be updated for all
|
||||
namespaces.
|
||||
|
||||
This is a heuristic so as to avoid scanning all symbols from all
|
||||
namespaces. Instead, we only check whether the set of namespaces in
|
||||
the cache match the set of currently defined namespaces."
|
||||
([connection]
|
||||
(not= (hash (all-ns))
|
||||
(hash @(connection :indent-cache-pkg)))))
|
||||
|
||||
(defn- find-args-body-position
|
||||
"Given an arglist, return the number of arguments before
|
||||
[... & body]
|
||||
If no & body is found, nil will be returned"
|
||||
([args]
|
||||
(when (coll? args)
|
||||
(when-let [amp-position (position '#{&} args)]
|
||||
(when-let [body-position (position '#{body clauses} args)]
|
||||
(when (= (inc amp-position) body-position)
|
||||
amp-position))))))
|
||||
|
||||
(defn- find-arglists-body-position
|
||||
"Find the smallest body position from an arglist"
|
||||
([arglists]
|
||||
(let [positions (remove nil? (map find-args-body-position arglists))]
|
||||
(when-not (empty? positions)
|
||||
(apply min positions)))))
|
||||
|
||||
(defn- find-var-body-position
|
||||
"Returns a var's :indent override or the smallest body position of a
|
||||
var's arglists"
|
||||
([var]
|
||||
(let [var-meta (meta var)]
|
||||
(or (:indent var-meta)
|
||||
(find-arglists-body-position (:arglists var-meta))))))
|
||||
|
||||
(defn- var-indent-representation
|
||||
"Returns the slime indentation representation (name . position) for
|
||||
a given var. If there is no indentation representation, nil is
|
||||
returned."
|
||||
([var]
|
||||
(when-let [body-position (find-var-body-position var)]
|
||||
(when (or (= body-position 'defun)
|
||||
(not (neg? body-position)))
|
||||
(list (name (:name (meta var)))
|
||||
'.
|
||||
body-position)))))
|
||||
|
||||
(defn- get-cache-update-for-var
|
||||
"Checks whether a given var needs to be updated in a cache. If it
|
||||
needs updating, return [var-name var-indentation-representation].
|
||||
Otherwise return nil"
|
||||
([find-in-cache var]
|
||||
(when-let [indent (var-indent-representation var)]
|
||||
(let [name (:name (meta var))]
|
||||
(when-not (= (find-in-cache name) indent)
|
||||
[name indent])))))
|
||||
|
||||
(defn- get-cache-updates-in-namespace
|
||||
"Finds all cache updates needed within a namespace"
|
||||
([find-in-cache ns]
|
||||
(remove nil? (map (partial get-cache-update-for-var find-in-cache) (vals (ns-interns ns))))))
|
||||
|
||||
(defn- update-indentation-delta
|
||||
"Update the cache and return the changes in a (symbol '. indent) list.
|
||||
If FORCE is true then check all symbols, otherwise only check
|
||||
symbols belonging to the buffer package"
|
||||
([cache-ref load-all-ns?]
|
||||
(let [find-in-cache @cache-ref]
|
||||
(let [namespaces (if load-all-ns? (all-ns) [(maybe-ns *current-package*)])
|
||||
updates (mapcat (partial get-cache-updates-in-namespace find-in-cache) namespaces)]
|
||||
(when (seq updates)
|
||||
(dosync (alter cache-ref into updates))
|
||||
(map second updates))))))
|
||||
|
||||
(defn- perform-indentation-update
|
||||
"Update the indentation cache in connection and update emacs.
|
||||
If force is true, then start again without considering the old cache."
|
||||
([conn force]
|
||||
(let [cache (conn :indent-cache)]
|
||||
(let [delta (update-indentation-delta cache force)]
|
||||
(dosync
|
||||
(ref-set (conn :indent-cache-pkg) (hash (all-ns)))
|
||||
(when (seq delta)
|
||||
(send-to-emacs `(:indentation-update ~delta))))))))
|
||||
|
||||
(defn- sync-indentation-to-emacs
|
||||
"Send any indentation updates to Emacs via emacs-connection"
|
||||
([]
|
||||
(perform-indentation-update
|
||||
*current-connection*
|
||||
(need-full-indentation-update? *current-connection*))))
|
||||
|
||||
(add-hook pre-reply-hook #'sync-indentation-to-emacs)
|
||||
@ -0,0 +1,323 @@
|
||||
(ns swank.commands.inspector
|
||||
(:use (swank util core commands)
|
||||
(swank.core connection)))
|
||||
|
||||
;;;; Inspector for basic clojure data structures
|
||||
|
||||
;; This a mess, I'll clean up this code after I figure out exactly
|
||||
;; what I need for debugging support.
|
||||
|
||||
(def inspectee (ref nil))
|
||||
(def inspectee-content (ref nil))
|
||||
(def inspectee-parts (ref nil))
|
||||
(def inspectee-actions (ref nil))
|
||||
(def inspector-stack (ref nil))
|
||||
(def inspector-history (ref nil))
|
||||
|
||||
(defn reset-inspector []
|
||||
(dosync
|
||||
(ref-set inspectee nil)
|
||||
(ref-set inspectee-content nil)
|
||||
(ref-set inspectee-parts [])
|
||||
(ref-set inspectee-actions [])
|
||||
(ref-set inspector-stack nil)
|
||||
(ref-set inspector-history [])))
|
||||
|
||||
(defn inspectee-title [obj]
|
||||
(cond
|
||||
(instance? clojure.lang.LazySeq obj) (str "clojure.lang.LazySeq@...")
|
||||
:else (str obj)))
|
||||
|
||||
(defn print-part-to-string [value]
|
||||
(let [s (inspectee-title value)
|
||||
pos (position #{value} @inspector-history)]
|
||||
(if pos
|
||||
(str "#" pos "=" s)
|
||||
s)))
|
||||
|
||||
(defn assign-index [o dest]
|
||||
(dosync
|
||||
(let [index (count @dest)]
|
||||
(alter dest conj o)
|
||||
index)))
|
||||
|
||||
(defn value-part [obj s]
|
||||
(list :value (or s (print-part-to-string obj))
|
||||
(assign-index obj inspectee-parts)))
|
||||
|
||||
(defn action-part [label lambda refresh?]
|
||||
(list :action label
|
||||
(assign-index (list lambda refresh?)
|
||||
inspectee-actions)))
|
||||
|
||||
(defn label-value-line
|
||||
([label value] (label-value-line label value true))
|
||||
([label value newline?]
|
||||
(list* (str label) ": " (list :value value)
|
||||
(if newline? '((:newline)) nil))))
|
||||
|
||||
(defmacro label-value-line* [& label-values]
|
||||
`(concat ~@(map (fn [[label value]]
|
||||
`(label-value-line ~label ~value))
|
||||
label-values)))
|
||||
|
||||
;; Inspection
|
||||
|
||||
;; This is the simple version that only knows about clojure stuff.
|
||||
;; Many of these will probably be redefined by swank-clojure-debug
|
||||
(defmulti emacs-inspect
|
||||
(fn known-types [obj]
|
||||
(cond
|
||||
(map? obj) :map
|
||||
(vector? obj) :vector
|
||||
(var? obj) :var
|
||||
(string? obj) :string
|
||||
(seq? obj) :seq
|
||||
(instance? Class obj) :class
|
||||
(instance? clojure.lang.Namespace obj) :namespace
|
||||
(instance? clojure.lang.ARef obj) :aref
|
||||
(.isArray (class obj)) :array)))
|
||||
|
||||
(defn inspect-meta-information [obj]
|
||||
(when (> (count (meta obj)) 0)
|
||||
(concat
|
||||
'("Meta Information: " (:newline))
|
||||
(mapcat (fn [[key val]]
|
||||
`(" " (:value ~key) " = " (:value ~val) (:newline)))
|
||||
(meta obj)))))
|
||||
|
||||
(defmethod emacs-inspect :map [obj]
|
||||
(concat
|
||||
(label-value-line*
|
||||
("Class" (class obj))
|
||||
("Count" (count obj)))
|
||||
'("Contents: " (:newline))
|
||||
(inspect-meta-information obj)
|
||||
(mapcat (fn [[key val]]
|
||||
`(" " (:value ~key) " = " (:value ~val)
|
||||
(:newline)))
|
||||
obj)))
|
||||
|
||||
(defmethod emacs-inspect :vector [obj]
|
||||
(concat
|
||||
(label-value-line*
|
||||
("Class" (class obj))
|
||||
("Count" (count obj)))
|
||||
'("Contents: " (:newline))
|
||||
(inspect-meta-information obj)
|
||||
(mapcat (fn [i val]
|
||||
`(~(str " " i ". ") (:value ~val) (:newline)))
|
||||
(iterate inc 0)
|
||||
obj)))
|
||||
|
||||
(defmethod emacs-inspect :array [obj]
|
||||
(concat
|
||||
(label-value-line*
|
||||
("Class" (class obj))
|
||||
("Count" (alength obj))
|
||||
("Component Type" (.getComponentType (class obj))))
|
||||
'("Contents: " (:newline))
|
||||
(mapcat (fn [i val]
|
||||
`(~(str " " i ". ") (:value ~val) (:newline)))
|
||||
(iterate inc 0)
|
||||
obj)))
|
||||
|
||||
(defmethod emacs-inspect :var [#^clojure.lang.Var obj]
|
||||
(concat
|
||||
(label-value-line*
|
||||
("Class" (class obj)))
|
||||
(inspect-meta-information obj)
|
||||
(when (.isBound obj)
|
||||
`("Value: " (:value ~(var-get obj))))))
|
||||
|
||||
(defmethod emacs-inspect :string [obj]
|
||||
(concat
|
||||
(label-value-line*
|
||||
("Class" (class obj)))
|
||||
(inspect-meta-information obj)
|
||||
(list (str "Value: " (pr-str obj)))))
|
||||
|
||||
(defmethod emacs-inspect :seq [obj]
|
||||
(concat
|
||||
(label-value-line*
|
||||
("Class" (class obj)))
|
||||
'("Contents: " (:newline))
|
||||
(inspect-meta-information obj)
|
||||
(mapcat (fn [i val]
|
||||
`(~(str " " i ". ") (:value ~val) (:newline)))
|
||||
(iterate inc 0)
|
||||
obj)))
|
||||
|
||||
(defmethod emacs-inspect :default [obj]
|
||||
(let [fields (. (class obj) getDeclaredFields)
|
||||
names (map (memfn getName) fields)
|
||||
get (fn [f]
|
||||
(try (.setAccessible f true)
|
||||
(catch java.lang.SecurityException e))
|
||||
(try (.get f obj)
|
||||
(catch java.lang.IllegalAccessException e
|
||||
"Access denied.")))
|
||||
vals (map get fields)]
|
||||
(concat
|
||||
`("Type: " (:value ~(class obj)) (:newline)
|
||||
"Value: " (:value ~obj) (:newline)
|
||||
"---" (:newline)
|
||||
"Fields: " (:newline))
|
||||
(mapcat
|
||||
(fn [name val]
|
||||
`(~(str " " name ": ") (:value ~val) (:newline))) names vals))))
|
||||
|
||||
(defmethod emacs-inspect :class [#^Class obj]
|
||||
(let [meths (. obj getMethods)
|
||||
fields (. obj getFields)]
|
||||
(concat
|
||||
`("Type: " (:value ~(class obj)) (:newline)
|
||||
"---" (:newline)
|
||||
"Fields: " (:newline))
|
||||
(mapcat (fn [f]
|
||||
`(" " (:value ~f) (:newline))) fields)
|
||||
'("---" (:newline)
|
||||
"Methods: " (:newline))
|
||||
(mapcat (fn [m]
|
||||
`(" " (:value ~m) (:newline))) meths))))
|
||||
|
||||
(defmethod emacs-inspect :aref [#^clojure.lang.ARef obj]
|
||||
`("Type: " (:value ~(class obj)) (:newline)
|
||||
"Value: " (:value ~(deref obj)) (:newline)))
|
||||
|
||||
(defn ns-refers-by-ns [#^clojure.lang.Namespace ns]
|
||||
(group-by (fn [#^clojure.lang.Var v] (. v ns))
|
||||
(map val (ns-refers ns))))
|
||||
|
||||
(defmethod emacs-inspect :namespace [#^clojure.lang.Namespace obj]
|
||||
(concat
|
||||
(label-value-line*
|
||||
("Class" (class obj))
|
||||
("Count" (count (ns-map obj))))
|
||||
'("---" (:newline)
|
||||
"Refer from: " (:newline))
|
||||
(mapcat (fn [[ns refers]]
|
||||
`(" "(:value ~ns) " = " (:value ~refers) (:newline)))
|
||||
(ns-refers-by-ns obj))
|
||||
(label-value-line*
|
||||
("Imports" (ns-imports obj))
|
||||
("Interns" (ns-interns obj)))))
|
||||
|
||||
(defn inspector-content [specs]
|
||||
(letfn [(spec-seq [seq]
|
||||
(let [[f & args] seq]
|
||||
(cond
|
||||
(= f :newline) (str \newline)
|
||||
|
||||
(= f :value)
|
||||
(let [[obj & [str]] args]
|
||||
(value-part obj str))
|
||||
|
||||
(= f :action)
|
||||
(let [[label lambda & options] args
|
||||
{:keys [refresh?]} (apply hash-map options)]
|
||||
(action-part label lambda refresh?)))))
|
||||
(spec-value [val]
|
||||
(cond
|
||||
(string? val) val
|
||||
(seq? val) (spec-seq val)))]
|
||||
(map spec-value specs)))
|
||||
|
||||
;; Works for infinite sequences, but it lies about length. Luckily, emacs doesn't
|
||||
;; care.
|
||||
(defn content-range [lst start end]
|
||||
(let [amount-wanted (- end start)
|
||||
shifted (drop start lst)
|
||||
taken (take amount-wanted shifted)
|
||||
amount-taken (count taken)]
|
||||
(if (< amount-taken amount-wanted)
|
||||
(list taken (+ amount-taken start) start end)
|
||||
;; There's always more until we know there isn't
|
||||
(list taken (+ end 500) start end))))
|
||||
|
||||
(defn inspect-object [o]
|
||||
(dosync
|
||||
(ref-set inspectee o)
|
||||
(alter inspector-stack conj o)
|
||||
(when-not (filter #(identical? o %) @inspector-history)
|
||||
(alter inspector-history conj o))
|
||||
(ref-set inspectee-content (inspector-content (emacs-inspect o)))
|
||||
(list :title (inspectee-title o)
|
||||
:id (assign-index o inspectee-parts)
|
||||
:content (content-range @inspectee-content 0 500))))
|
||||
|
||||
(defslimefn init-inspector [string]
|
||||
(with-emacs-package
|
||||
(reset-inspector)
|
||||
(inspect-object (eval (read-string string)))))
|
||||
|
||||
(defn inspect-in-emacs [what]
|
||||
(letfn [(send-it []
|
||||
(with-emacs-package
|
||||
(reset-inspector)
|
||||
(send-to-emacs `(:inspect ~(inspect-object what)))))]
|
||||
(cond
|
||||
*current-connection* (send-it)
|
||||
(comment (first @connections))
|
||||
;; TODO: take a second look at this, will probably need garbage collection on connections
|
||||
(comment
|
||||
(binding [*current-connection* (first @connections)]
|
||||
(send-it))))))
|
||||
|
||||
(defslimefn inspect-frame-var [frame index]
|
||||
(if (and (zero? frame) *current-env*)
|
||||
(let [locals *current-env*
|
||||
object (locals (nth (keys locals) index))]
|
||||
(with-emacs-package
|
||||
(reset-inspector)
|
||||
(inspect-object object)))))
|
||||
|
||||
(defslimefn inspector-nth-part [index]
|
||||
(get @inspectee-parts index))
|
||||
|
||||
(defslimefn inspect-nth-part [index]
|
||||
(with-emacs-package
|
||||
(inspect-object ((slime-fn 'inspector-nth-part) index))))
|
||||
|
||||
(defslimefn inspector-range [from to]
|
||||
(content-range @inspectee-content from to))
|
||||
|
||||
(defn ref-pop [ref]
|
||||
(let [[f & r] @ref]
|
||||
(ref-set ref r)
|
||||
f))
|
||||
|
||||
(defslimefn inspector-call-nth-action [index & args]
|
||||
(let [[fn refresh?] (get @inspectee-actions index)]
|
||||
(apply fn args)
|
||||
(if refresh?
|
||||
(inspect-object (dosync (ref-pop inspector-stack)))
|
||||
nil)))
|
||||
|
||||
(defslimefn inspector-pop []
|
||||
(with-emacs-package
|
||||
(cond
|
||||
(rest @inspector-stack)
|
||||
(inspect-object
|
||||
(dosync
|
||||
(ref-pop inspector-stack)
|
||||
(ref-pop inspector-stack)))
|
||||
:else nil)))
|
||||
|
||||
(defslimefn inspector-next []
|
||||
(with-emacs-package
|
||||
(let [pos (position #{@inspectee} @inspector-history)]
|
||||
(cond
|
||||
(= (inc pos) (count @inspector-history)) nil
|
||||
:else (inspect-object (get @inspector-history (inc pos)))))))
|
||||
|
||||
(defslimefn inspector-reinspect []
|
||||
(inspect-object @inspectee))
|
||||
|
||||
(defslimefn quit-inspector []
|
||||
(reset-inspector)
|
||||
nil)
|
||||
|
||||
(defslimefn describe-inspectee []
|
||||
(with-emacs-package
|
||||
(str @inspectee)))
|
||||
@ -0,0 +1,51 @@
|
||||
(ns swank.commands.xref
|
||||
(:use clojure.walk swank.util)
|
||||
(:import (clojure.lang RT)
|
||||
(java.io LineNumberReader InputStreamReader PushbackReader)))
|
||||
|
||||
;; Yoinked and modified from clojure.contrib.repl-utils.
|
||||
;; Now takes a var instead of a sym in the current ns
|
||||
(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)"
|
||||
[v] (when-let [filepath (:file (meta v))]
|
||||
(when-let [strm (.getResourceAsStream (RT/baseLoader) filepath)]
|
||||
(with-open [rdr (LineNumberReader. (InputStreamReader. strm))]
|
||||
(dotimes [_ (dec (:line (meta v)))] (.readLine rdr))
|
||||
(let [text (StringBuilder.)
|
||||
pbr (proxy [PushbackReader] [rdr]
|
||||
(read [] (let [i (proxy-super read)]
|
||||
(.append text (char i))
|
||||
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)
|
||||
var
|
||||
false))))
|
||||
|
||||
(defn- does-ns-refer-to-var? [ns var]
|
||||
(ns-resolve ns var))
|
||||
|
||||
(defn all-vars-who-call [sym]
|
||||
(filter
|
||||
ifn?
|
||||
(filter
|
||||
#(identity %)
|
||||
(map #(does-var-call-fn % sym)
|
||||
(flatten
|
||||
(map vals
|
||||
(map ns-interns
|
||||
(filter #(does-ns-refer-to-var? % sym)
|
||||
(all-ns)))))))))
|
||||
Reference in New Issue
Block a user