diff options
Diffstat (limited to 'vim/bundle/slimv/swank-clojure/swank/commands')
10 files changed, 1818 insertions, 0 deletions
diff --git a/vim/bundle/slimv/swank-clojure/swank/commands/basic.clj b/vim/bundle/slimv/swank-clojure/swank/commands/basic.clj new file mode 100644 index 0000000..a397280 --- /dev/null +++ b/vim/bundle/slimv/swank-clojure/swank/commands/basic.clj @@ -0,0 +1,601 @@ +(ns swank.commands.basic + (:refer-clojure :exclude [load-file print-doc]) + (:use (swank util commands core) + (swank.util.concurrent thread) + (swank.util string clojure) + (swank.clj-contrib pprint macroexpand)) + (:require (swank.util [sys :as sys]) + (swank.commands [xref :as xref])) + (:import (java.io StringReader File) + (java.util.zip ZipFile) + (clojure.lang LineNumberingPushbackReader))) + +;;;; Connection + +(defslimefn connection-info [] + `(:pid ~(sys/get-pid) + :style :spawn + :lisp-implementation (:type "Clojure" + :name "clojure" + :version ~(clojure-version)) + :package (:name ~(name (ns-name *ns*)) + :prompt ~(name (ns-name *ns*))) + :version ~(deref protocol-version))) + +(defslimefn quit-lisp [] + (System/exit 0)) + +(defslimefn toggle-debug-on-swank-error [] + (alter-var-root #'swank.core/debug-swank-clojure not)) + +;;;; Evaluation + +(defn- eval-region + "Evaluate string, return the results of the last form as a list and + a secondary value the last form." + ([string] + (eval-region string "NO_SOURCE_FILE" 1)) + ([string file line] + (with-open [rdr (proxy [LineNumberingPushbackReader] + ((StringReader. string)) + (getLineNumber [] line))] + (binding [*file* file] + (loop [form (read rdr false rdr), value nil, last-form nil] + (if (= form rdr) + [value last-form] + (recur (read rdr false rdr) + (eval (with-env-locals form)) + form))))))) + +(defn- compile-region + "Compile region." + ([string file line] + (with-open [rdr1 (proxy [LineNumberingPushbackReader] + ((StringReader. string))) + rdr (proxy [LineNumberingPushbackReader] (rdr1) + (getLineNumber [] (+ line (.getLineNumber rdr1) -1)))] + (clojure.lang.Compiler/load rdr file (.getName (File. file)))))) + + +(defslimefn interactive-eval-region [string] + (with-emacs-package + (pr-str (first (eval-region string))))) + +(defslimefn interactive-eval [string] + (with-emacs-package + (pr-str (first (eval-region string))))) + +(defslimefn listener-eval [form] + (with-emacs-package + (with-package-tracking + (let [[value last-form] (eval-region form)] + (when (and last-form (not (one-of? last-form '*1 '*2 '*3 '*e))) + (set! *3 *2) + (set! *2 *1) + (set! *1 value)) + (send-repl-results-to-emacs value))))) + +(defslimefn eval-and-grab-output [string] + (with-emacs-package + (let [retval (promise)] + (list (with-out-str + (deliver retval (pr-str (first (eval-region string))))) + @retval)))) + +(defslimefn pprint-eval [string] + (with-emacs-package + (pretty-pr-code (first (eval-region string))))) + +;;;; Macro expansion + +(defn- apply-macro-expander [expander string] + (pretty-pr-code (expander (read-string string)))) + +(defslimefn swank-macroexpand-1 [string] + (apply-macro-expander macroexpand-1 string)) + +(defslimefn swank-macroexpand [string] + (apply-macro-expander macroexpand string)) + +;; not implemented yet, needs walker +(defslimefn swank-macroexpand-all [string] + (apply-macro-expander macroexpand-all string)) + +;;;; Compiler / Execution + +(def compiler-exception-location-re #"Exception:.*\(([^:]+):([0-9]+)\)") +(defn- guess-compiler-exception-location [#^Throwable t] + (when (instance? clojure.lang.Compiler$CompilerException t) + (let [[match file line] (re-find compiler-exception-location-re (str t))] + (when (and file line) + `(:location (:file ~file) (:line ~(Integer/parseInt line)) nil))))) + +;; TODO: Make more and better guesses +(defn- exception-location [#^Throwable t] + (or (guess-compiler-exception-location t) + '(:error "No error location available"))) + +;; plist of message, severity, location, references, short-message +(defn- exception-to-message [#^Throwable t] + `(:message ~(.toString t) + :severity :error + :location ~(exception-location t) + :references nil + :short-message ~(.toString t))) + +(defn- compile-file-for-emacs* + "Compiles a file for emacs. Because clojure doesn't compile, this is + simple an alias for load file w/ timing and messages. This function + is to reply with the following: + (:swank-compilation-unit notes results durations)" + ([file-name] + (let [start (System/nanoTime)] + (try + (let [ret (clojure.core/load-file file-name) + delta (- (System/nanoTime) start)] + `(:compilation-result nil ~(pr-str ret) ~(/ delta 1000000000.0))) + (catch Throwable t + (let [delta (- (System/nanoTime) start) + causes (exception-causes t) + num (count causes)] + (.printStackTrace t) ;; prints to *inferior-lisp* + `(:compilation-result + ~(map exception-to-message causes) ;; notes + nil ;; results + ~(/ delta 1000000000.0) ;; durations + ))))))) + +(defslimefn compile-file-for-emacs + ([file-name load? & compile-options] + (when load? + (compile-file-for-emacs* file-name)))) + +(defslimefn load-file [file-name] + (let [libs-ref @(resolve 'clojure.core/*loaded-libs*) + libs @libs-ref] + (try + (dosync (ref-set libs-ref #{})) + (pr-str (clojure.core/load-file file-name)) + (finally + (dosync (alter libs-ref into libs)))))) + +(defn- line-at-position [file position] + (try + (with-open [f (java.io.LineNumberReader. (java.io.FileReader. file))] + (.skip f position) + (.getLineNumber f)) + (catch Exception e 1))) + +(defslimefn compile-string-for-emacs [string buffer position directory debug] + (let [start (System/nanoTime) + line (line-at-position directory position) + ret (with-emacs-package + (when-not (= (name (ns-name *ns*)) *current-package*) + (throw (clojure.lang.Compiler$CompilerException. + directory line + (Exception. (str "No such namespace: " + *current-package*))))) + (compile-region string directory line)) + delta (- (System/nanoTime) start)] + `(:compilation-result nil ~(pr-str ret) ~(/ delta 1000000000.0)))) + +;;;; Describe + +(defn- maybe-resolve-sym [symbol-name] + (try + (ns-resolve (maybe-ns *current-package*) (symbol symbol-name)) + (catch ClassNotFoundException e nil))) + +(defn- maybe-resolve-ns [sym-name] + (let [sym (symbol sym-name)] + (or ((ns-aliases (maybe-ns *current-package*)) sym) + (find-ns sym)))) + +(defn- print-doc* [m] + (println "-------------------------") + (println (str (when-let [ns (:ns m)] (str (ns-name ns) "/")) (:name m))) + (cond + (:forms m) (doseq [f (:forms m)] + (print " ") + (prn f)) + (:arglists m) (prn (:arglists m))) + (if (:special-form m) + (do + (println "Special Form") + (println " " (:doc m)) + (if (contains? m :url) + (when (:url m) + (println (str "\n Please see http://clojure.org/" (:url m)))) + (println (str "\n Please see http://clojure.org/special_forms#" + (:name m))))) + (do + (when (:macro m) + (println "Macro")) + (println " " (:doc m))))) + +(def print-doc (let [print-doc (resolve 'clojure.core/print-doc)] + (if (or (nil? print-doc) (-> print-doc meta :private)) + (comp print-doc* meta) + print-doc))) + +(defn- describe-to-string [var] + (with-out-str + (print-doc var))) + +(defn- describe-symbol* [symbol-name] + (with-emacs-package + (if-let [v (maybe-resolve-sym symbol-name)] + (if-not (class? v) + (describe-to-string v))))) + +(defslimefn describe-symbol [symbol-name] + (describe-symbol* symbol-name)) + +(defslimefn describe-function [symbol-name] + (describe-symbol* symbol-name)) + +;; Only one namespace... so no kinds +(defslimefn describe-definition-for-emacs [name kind] + (describe-symbol* name)) + +;; Only one namespace... so only describe symbol +(defslimefn documentation-symbol + ([symbol-name default] (documentation-symbol symbol-name)) + ([symbol-name] (describe-symbol* symbol-name))) + +;;;; Documentation + +(defn- briefly-describe-symbol-for-emacs [var] + (let [lines (fn [s] (.split #^String s (System/getProperty "line.separator"))) + [_ symbol-name arglists d1 d2 & __] (lines (describe-to-string var)) + macro? (= d1 "Macro")] + (list :designator symbol-name + (cond + macro? :macro + (:arglists (meta var)) :function + :else :variable) + (apply str (concat arglists (if macro? d2 d1)))))) + +(defn- make-apropos-matcher [pattern case-sensitive?] + (let [pattern (java.util.regex.Pattern/quote pattern) + pat (re-pattern (if case-sensitive? + pattern + (format "(?i:%s)" pattern)))] + (fn [var] (re-find pat (pr-str var))))) + +(defn- apropos-symbols [string external-only? case-sensitive? package] + (let [packages (or (when package [package]) (all-ns)) + matcher (make-apropos-matcher string case-sensitive?) + lister (if external-only? ns-publics ns-interns)] + (filter matcher + (apply concat (map (comp (partial map second) lister) + packages))))) + +(defn- present-symbol-before + "Comparator such that x belongs before y in a printed summary of symbols. +Sorted alphabetically by namespace name and then symbol name, except +that symbols accessible in the current namespace go first." + [x y] + (let [accessible? + (fn [var] (= (maybe-resolve-sym (:name (meta var))) + var)) + ax (accessible? x) ay (accessible? y)] + (cond + (and ax ay) (compare (:name (meta x)) (:name (meta y))) + ax -1 + ay 1 + :else (let [nx (str (:ns (meta x))) ny (str (:ns (meta y)))] + (if (= nx ny) + (compare (:name (meta x)) (:name (meta y))) + (compare nx ny)))))) + +(defslimefn apropos-list-for-emacs + ([name] + (apropos-list-for-emacs name nil)) + ([name external-only?] + (apropos-list-for-emacs name external-only? nil)) + ([name external-only? case-sensitive?] + (apropos-list-for-emacs name external-only? case-sensitive? nil)) + ([name external-only? case-sensitive? package] + (let [package (when package + (maybe-ns package))] + (map briefly-describe-symbol-for-emacs + (sort present-symbol-before + (apropos-symbols name external-only? case-sensitive? + package)))))) + +;;;; Operator messages +(defslimefn operator-arglist [name package] + (try + (let [f (read-string name)] + (cond + (keyword? f) "([map])" + (symbol? f) (let [var (ns-resolve (maybe-ns package) f)] + (if-let [args (and var (:arglists (meta var)))] + (pr-str args) + nil)) + :else nil)) + (catch Throwable t nil))) + +;;;; Package Commands + +(defslimefn list-all-package-names + ([] (map (comp str ns-name) (all-ns))) + ([nicknames?] (list-all-package-names))) + +(defslimefn set-package [name] + (let [ns (maybe-ns name)] + (in-ns (ns-name ns)) + (list (str (ns-name ns)) + (str (ns-name ns))))) + +;;;; Tracing + +(defonce traced-fn-map {}) + +(def #^{:dynamic true} *trace-level* 0) + +(defn- indent [num] + (dotimes [x (+ 1 num)] + (print " "))) + +(defn- trace-fn-call [sym f args] + (let [fname (symbol (str (.name (.ns sym)) "/" (.sym sym)))] + (indent *trace-level*) + (println (str *trace-level* ":") + (apply str (take 240 (pr-str (when fname (cons fname args)) )))) + (let [result (binding [*trace-level* (+ *trace-level* 1)] (apply f args))] + (indent *trace-level*) + (println (str *trace-level* ": " fname " returned " (apply str (take 240 (pr-str result))))) + result))) + +(defslimefn swank-toggle-trace [fname] + (when-let [sym (maybe-resolve-sym fname)] + (if-let [f# (get traced-fn-map sym)] + (do + (alter-var-root #'traced-fn-map dissoc sym) + (alter-var-root sym (constantly f#)) + (str " untraced.")) + (let [f# @sym] + (alter-var-root #'traced-fn-map assoc sym f#) + (alter-var-root sym + (constantly + (fn [& args] + (trace-fn-call sym f# args)))) + (str " traced."))))) + +(defslimefn untrace-all [] + (doseq [sym (keys traced-fn-map)] + (swank-toggle-trace (.sym sym)))) + +;;;; Source Locations +(comment + "Sets the default directory (java's user.dir). Note, however, that + this will not change the search path of load-file. ") +(defslimefn set-default-directory + ([directory & ignore] + (System/setProperty "user.dir" directory) + directory)) + + +;;;; meta dot find + +(defn- clean-windows-path [#^String path] + ;; Decode file URI encoding and remove an opening slash from + ;; /c:/program%20files/... in jar file URLs and file resources. + (or (and (.startsWith (System/getProperty "os.name") "Windows") + (second (re-matches #"^/([a-zA-Z]:/.*)$" path))) + path)) + +(defn- slime-zip-resource [#^java.net.URL resource] + (let [jar-connection #^java.net.JarURLConnection (.openConnection resource) + jar-file (.getPath (.toURI (.getJarFileURL jar-connection)))] + (list :zip (clean-windows-path jar-file) (.getEntryName jar-connection)))) + +(defn- slime-file-resource [#^java.net.URL resource] + (list :file (clean-windows-path (.getFile resource)))) + +(defn- slime-find-resource [#^String file] + (if-let [resource (.getResource (clojure.lang.RT/baseLoader) file)] + (if (= (.getProtocol resource) "jar") + (slime-zip-resource resource) + (slime-file-resource resource)))) + +(defn- slime-find-file [#^String file] + (if (.isAbsolute (File. file)) + (list :file file) + (slime-find-resource file))) + +(defn- namespace-to-path [ns] + (let [#^String ns-str (name (ns-name ns)) + last-dot-index (.lastIndexOf ns-str ".")] + (if (pos? last-dot-index) + (-> (.substring ns-str 0 last-dot-index) + (.replace \- \_) + (.replace \. \/))))) + +(defn- classname-to-path [class-name] + (namespace-to-path + (symbol (.replace class-name \_ \-)))) + + +(defn- location-in-file [path line] + `(:location ~path (:line ~line) nil)) + +(defn- location-label [name type] + (if type + (str "(" type " " name ")") + (str name))) + +(defn- location [name type path line] + `((~(location-label name type) + ~(if path + (location-in-file path line) + (list :error (format "%s - definition not found." name)))))) + +(defn- location-not-found [name type] + (location name type nil nil)) + +(defn source-location-for-frame [#^StackTraceElement frame] + (let [line (.getLineNumber frame) + filename (if (.. frame getFileName (endsWith ".java")) + (.. frame getClassName (replace \. \/) + (substring 0 (.lastIndexOf (.getClassName frame) ".")) + (concat (str File/separator (.getFileName frame)))) + (let [ns-path (classname-to-path + ((re-find #"(.*?)\$" + (.getClassName frame)) 1))] + (if ns-path + (str ns-path File/separator (.getFileName frame)) + (.getFileName frame)))) + path (slime-find-file filename)] + (location-in-file path line))) + +(defn- namespace-to-filename [ns] + (str (-> (str ns) + (.replaceAll "\\." File/separator) + (.replace \- \_ )) + ".clj")) + +(defn- source-location-for-meta [meta xref-type-name] + (location (:name meta) + xref-type-name + (slime-find-file (:file meta)) + (:line meta))) + +(defn- find-ns-definition [sym-name] + (if-let [ns (maybe-resolve-ns sym-name)] + (when-let [path (slime-find-file (namespace-to-filename ns))] + (location ns nil path 1)))) + +(defn- find-var-definition [sym-name] + (if-let [meta (meta (maybe-resolve-sym sym-name))] + (source-location-for-meta meta "defn"))) + +(defslimefn find-definitions-for-emacs [name] + (let [sym-name (read-string name)] + (or (find-var-definition sym-name) + (find-ns-definition sym-name) + (location name nil nil nil)))) + +(defn who-specializes [class] + (letfn [(xref-lisp [sym] ; see find-definitions-for-emacs + (if-let [meta (meta sym)] + (source-location-for-meta meta "method") + (location-not-found (.getName sym) "method")))] + (let [methods (try (. class getMethods) + (catch java.lang.IllegalArgumentException e nil) + (catch java.lang.NullPointerException e nil))] + (map xref-lisp methods)))) + +(defn who-calls [name] + (letfn [(xref-lisp [sym-var] ; see find-definitions-for-emacs + (when-let [meta (meta sym-var)] + (source-location-for-meta meta nil)))] + (let [callers (xref/all-vars-who-call name) ] + (map first (map xref-lisp callers))))) + +(defslimefn xref [type name] + (let [sexp (maybe-resolve-sym name)] + (condp = type + :specializes (who-specializes sexp) + :calls (who-calls (symbol name)) + :callers nil + :not-implemented))) + +(defslimefn throw-to-toplevel [] + (throw debug-quit-exception)) + +(defn invoke-restart [restart] + ((nth restart 2))) + +(defslimefn invoke-nth-restart-for-emacs [level n] + ((invoke-restart (*sldb-restarts* (nth (keys *sldb-restarts*) n))))) + +(defslimefn throw-to-toplevel [] + (if-let [restart (*sldb-restarts* :quit)] + (invoke-restart restart))) + +(defslimefn sldb-continue [] + (if-let [restart (*sldb-restarts* :continue)] + (invoke-restart restart))) + +(defslimefn sldb-abort [] + (if-let [restart (*sldb-restarts* :abort)] + (invoke-restart restart))) + + +(defslimefn backtrace [start end] + (build-backtrace start end)) + +(defslimefn buffer-first-change [file-name] nil) + +(defn locals-for-emacs [m] + (sort-by second + (map #(list :name (name (first %)) :id 0 + :value (pr-str (second %))) m))) + +(defslimefn frame-catch-tags-for-emacs [n] nil) +(defslimefn frame-locals-for-emacs [n] + (if (and (zero? n) (seq *current-env*)) + (locals-for-emacs *current-env*))) + +(defslimefn frame-locals-and-catch-tags [n] + (list (frame-locals-for-emacs n) + (frame-catch-tags-for-emacs n))) + +(defslimefn debugger-info-for-emacs [start end] + (build-debugger-info-for-emacs start end)) + +(defslimefn eval-string-in-frame [expr n] + (if (and (zero? n) *current-env*) + (with-bindings *current-env* + (eval expr)))) + +(defslimefn frame-source-location [n] + (source-location-for-frame + (nth (.getStackTrace *current-exception*) n))) + +;; Older versions of slime use this instead of the above. +(defslimefn frame-source-location-for-emacs [n] + (source-location-for-frame + (nth (.getStackTrace *current-exception*) n))) + +(defslimefn create-repl [target] '("user" "user")) + +;;; Threads + +(def #^{:private true} thread-list (atom [])) + +(defn- get-root-group [#^java.lang.ThreadGroup tg] + (if-let [parent (.getParent tg)] + (recur parent) + tg)) + +(defn- get-thread-list [] + (let [rg (get-root-group (.getThreadGroup (Thread/currentThread))) + arr (make-array Thread (.activeCount rg))] + (.enumerate rg arr true) + (seq arr))) + +(defn- extract-info [#^Thread t] + (map str [(.getId t) (.getName t) (.getPriority t) (.getState t)])) + +(defslimefn list-threads + "Return a list (LABELS (ID NAME STATUS ATTRS ...) ...). +LABELS is a list of attribute names and the remaining lists are the +corresponding attribute values per thread." + [] + (reset! thread-list (get-thread-list)) + (let [labels '(id name priority state)] + (cons labels (map extract-info @thread-list)))) + +;;; TODO: Find a better way, as Thread.stop is deprecated +(defslimefn kill-nth-thread [index] + (when index + (when-let [thread (nth @thread-list index nil)] + (println "Thread: " thread) + (.stop thread)))) + +(defslimefn quit-thread-browser [] + (reset! thread-list [])) diff --git a/vim/bundle/slimv/swank-clojure/swank/commands/completion.clj b/vim/bundle/slimv/swank-clojure/swank/commands/completion.clj new file mode 100644 index 0000000..4fc2b20 --- /dev/null +++ b/vim/bundle/slimv/swank-clojure/swank/commands/completion.clj @@ -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)))) diff --git a/vim/bundle/slimv/swank-clojure/swank/commands/contrib.clj b/vim/bundle/slimv/swank-clojure/swank/commands/contrib.clj new file mode 100644 index 0000000..6c0ed07 --- /dev/null +++ b/vim/bundle/slimv/swank-clojure/swank/commands/contrib.clj @@ -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)))))
\ No newline at end of file diff --git a/vim/bundle/slimv/swank-clojure/swank/commands/contrib/swank_arglists.clj b/vim/bundle/slimv/swank-clojure/swank/commands/contrib/swank_arglists.clj new file mode 100644 index 0000000..232a116 --- /dev/null +++ b/vim/bundle/slimv/swank-clojure/swank/commands/contrib/swank_arglists.clj @@ -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)) + ""))) diff --git a/vim/bundle/slimv/swank-clojure/swank/commands/contrib/swank_c_p_c.clj b/vim/bundle/slimv/swank-clojure/swank/commands/contrib/swank_c_p_c.clj new file mode 100644 index 0000000..40ca3fd --- /dev/null +++ b/vim/bundle/slimv/swank-clojure/swank/commands/contrib/swank_c_p_c.clj @@ -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)))) diff --git a/vim/bundle/slimv/swank-clojure/swank/commands/contrib/swank_c_p_c/internal.clj b/vim/bundle/slimv/swank-clojure/swank/commands/contrib/swank_c_p_c/internal.clj new file mode 100644 index 0000000..89701dd --- /dev/null +++ b/vim/bundle/slimv/swank-clojure/swank/commands/contrib/swank_c_p_c/internal.clj @@ -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)))))) diff --git a/vim/bundle/slimv/swank-clojure/swank/commands/contrib/swank_fuzzy.clj b/vim/bundle/slimv/swank-clojure/swank/commands/contrib/swank_fuzzy.clj new file mode 100644 index 0000000..5aebb55 --- /dev/null +++ b/vim/bundle/slimv/swank-clojure/swank/commands/contrib/swank_fuzzy.clj @@ -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)))) + ) + ) diff --git a/vim/bundle/slimv/swank-clojure/swank/commands/indent.clj b/vim/bundle/slimv/swank-clojure/swank/commands/indent.clj new file mode 100644 index 0000000..bafa9a8 --- /dev/null +++ b/vim/bundle/slimv/swank-clojure/swank/commands/indent.clj @@ -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) diff --git a/vim/bundle/slimv/swank-clojure/swank/commands/inspector.clj b/vim/bundle/slimv/swank-clojure/swank/commands/inspector.clj new file mode 100644 index 0000000..f8d490c --- /dev/null +++ b/vim/bundle/slimv/swank-clojure/swank/commands/inspector.clj @@ -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))) diff --git a/vim/bundle/slimv/swank-clojure/swank/commands/xref.clj b/vim/bundle/slimv/swank-clojure/swank/commands/xref.clj new file mode 100644 index 0000000..16af826 --- /dev/null +++ b/vim/bundle/slimv/swank-clojure/swank/commands/xref.clj @@ -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))))))))) |