1
0
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
2022-06-05 18:14:25 +08:00
parent ea73a5a99d
commit e371e16382
129 changed files with 67865 additions and 587 deletions

View 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 []))

View File

@ -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))))

View File

@ -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)))))

View File

@ -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))
"")))

View File

@ -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))))

View File

@ -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))))))

View File

@ -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))))
)
)

View 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)

View File

@ -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)))

View File

@ -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)))))))))