basic.clj

(ns swank.commands.basic
  (:refer-clojure :exclude [load-file print-doc])
  (:use (swank util commands core)
        (swank.util.concurrent thread)
        (swank.util string clojure)
        (swank.clj-contrib pprint macroexpand))
  (:require (swank.util [sys :as sys])
            [swank.core.debugger-backends :as dbe]
            [clojure.tools.namespace :as ns]
            [clojure.string]
            )
  (:import
   (java.lang.ThreadGroup)
   (java.util.jar JarFile)
   (java.io File StringReader
            FileInputStream LineNumberReader
            InputStreamReader Reader PushbackReader)

   (clojure.lang LineNumberingPushbackReader Symbol)))

;;;; Connection

(defslimefn connection-info []
  `(:pid ~(sys/get-pid)
         :style :spawn
         :lisp-implementation (:type "Clojure"
                                     :name "clojure"
                                     :version ~(clojure-version))
         :package (:name ~(name (ns-name *ns*))
                         :prompt ~(name (ns-name *ns*)))
         :version ~(deref protocol-version)))

(defslimefn quit-lisp []
  (and @exit-on-quit?
       (System/exit 0)))

(defslimefn toggle-debug-on-swank-error []
  (alter-var-root #'swank.core/debug-swank-clojure not))

;;;; Evaluation

(defn- eval-region
  "Evaluate string, return the results of the last form as a list and
   a secondary value the last form."
  ([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)
                    (dbe/swank-eval 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. #^String file))))))


(defslimefn interactive-eval-region [string]
  (with-emacs-package
    (pr-str (first (eval-region string)))))

(defslimefn interactive-eval [string]
  (with-emacs-package
    (pr-str
     (let [value (first (eval-region string))]
       ;; If the result is a seq, consume it here instead of getting evaluated
       ;; from pr-str to allow side-effects to go to the repl.
       (if (instance? clojure.lang.LazySeq value)
       	 (doall value)
       	 value)
       ))))

(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 destroy-ns
  [ns]
  (doseq [sym (keys (ns-refers ns))]
    (ns-unmap ns sym))
  (doseq [a (keys (ns-aliases ns))]
    (ns-unalias ns a))
  (doseq [a (keys (ns-publics ns))]
    (ns-unmap ns a)))

(defn- compile-file-for-emacs*
  "Compiles a file for emacs. Because clojure doesn't compile, this is
   simple an alias for load file w/ timing and messages. This function
   is to reply with the following:
     (:swank-compilation-unit notes results durations)"
  ([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
        ns-form (ns/read-file-ns-decl (java.io.File. file-name))
        ns (second ns-form)]
    (try
      (when ns
        (destroy-ns ns))
      (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.
                                              #^String file))]
      (.skip f position)
      (.getLineNumber f))
    (catch Exception e 1)))

(defslimefn compile-string-for-emacs [string buffer position directory debug]
  (let [start (System/nanoTime)
        line (line-at-position directory position)
        ret (with-emacs-package
              (when-not (= (name (ns-name *ns*)) *current-package*)
                (throw (clojure.lang.Compiler$CompilerException.
                        directory line
                        (Exception. (str "No such namespace: "
                                         *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
  "Returns a Var or nil"
  [symbol-name]
  (try
    (ns-resolve (maybe-ns *current-package*) (symbol symbol-name))
    (catch ClassNotFoundException e nil)
    (catch RuntimeException e (if (instance? ClassNotFoundException (.getCause e))
                                nil
                                (throw e)))))

(defn- maybe-resolve-ns
  "Returns a Namespace or nil"
  [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 [fn-sym f args]
  (indent *trace-level*)
    (println (str *trace-level* ":")
             (apply str (take 240 (pr-str (when fn-sym (cons fn-sym args)) ))))
    (let [result (binding [*trace-level* (+ *trace-level* 1)] (apply f args))]
      (indent *trace-level*)
      (println (str *trace-level* ": "
                    fn-sym " returned "
                    (apply str (take 240 (pr-str result)))))
      result))

(defslimefn swank-toggle-trace [#^String fname]
  (when-let [f-var (maybe-resolve-sym fname)
             ]
    (if-let [f# (get traced-fn-map f-var)]
      (do
        (alter-var-root #'traced-fn-map dissoc f-var)
        (alter-var-root f-var (constantly f#))
        (str " untraced."))
      (let [f# @f-var]
        (alter-var-root #'traced-fn-map assoc f-var f#)
        (alter-var-root f-var
                        (constantly
                         (fn [& args]
                           (trace-fn-call (symbol fname) f# args))))
        (str " traced.")))))

(defslimefn untrace-all []
  (doseq [f-var (keys traced-fn-map)]
    (let [fname (str (:ns (meta f-var)) "/" (:name (meta f-var)))]
      (swank-toggle-trace fname))))

;;; Profiling
;; stubs
(defslimefn toggle-profile-fdefinition
  [fname]
  "`toggle-profile-fdefinition` is *not* implemented")

(defslimefn unprofile-all
  [] "`unprofile-all` is *not* implemented")

(defslimefn profile-report
  [] "`profile-report` is *not* implemented")

(defslimefn profile-reset
  [] "`profile-reset` is *not* implemented")
(defslimefn profiled-functions
  [] "`profiled-functions` is *not* implemented")

(defslimefn profile-package
  [package callers? methods?] "`profiled-package` is *not* implemented")

(defslimefn profile-by-substring
  [substring & [package]] "`profiled-by` is *not* implemented")

;;;; Source Locations
(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))

(defslimefn default-directory
  ([] (System/getProperty "user.dir")))

;;;; meta dot find

(defn- clean-windows-path [#^String path]
  ;; Decode file URI encoding and remove an opening slash from
  ;; /c:/program%20files/... in jar file URLs and file resources.
  (or (and (.startsWith (System/getProperty "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 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 #^String class-name \_ \-))))


(defn- location-in-file [path line]
  `(:location ~path (:line ~line) nil))

(defn- location-label [name type]
  (if type
    (str "(" type " " name ")")
    (str name)))

(defn- location [name type path line]
  `((~(location-label name type)
     ~(if path
        (location-in-file path line)
        (list :error (format "%s - definition not found." name))))))

(defn- location-not-found [name type]
  (location name type nil nil))

(defn source-location-for-frame [#^StackTraceElement frame]
  (let [line     (.getLineNumber frame)
        filename (if (.. frame getFileName (endsWith ".java"))
                   (.. frame getClassName (replace \. \/)
                       (substring 0 (.lastIndexOf (.getClassName frame) "."))
                       (concat (str File/separator (.getFileName frame))))
                   (let [ns-path (classname-to-path
                                  ((re-find #"(.*?)\$"
                                            (.getClassName frame)) 1))]
                     (if ns-path
                       (str ns-path File/separator (.getFileName frame))
                       (.getFileName frame))))
        path     (slime-find-file filename)]
    (if path
      (location-in-file path line)
      (list :error (format "%s - source not found." filename)))))

(defn- namespace-to-filename [ns]
  (str (-> (str ns)
           (.replaceAll "\\." File/separator)
           (.replace \- \_ ))
       ".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]
  ;; TODO this doesn't work if sym-name refers to a protocol function
  (if-let [meta (meta (maybe-resolve-sym sym-name))]
    (source-location-for-meta meta "defn")))

(defslimefn find-definitions-for-emacs [name]
  (let [sym-name (read-string name)]
    (or (find-var-definition sym-name)
        (find-ns-definition sym-name)
        (location name nil nil nil))))

;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; xref who-calls support (was in xref.clj)
(defn- get-jar-entry-as-stream [^String jarpath ^String entry-name]
  (let [jarfile (JarFile. jarpath)]
    (.getInputStream jarfile (.getEntry jarfile entry-name))))

(defn- get-resource-stream [filepath]
  (if-let [location (slime-find-file filepath)]
    (case (first location)
      :zip (apply get-jar-entry-as-stream (rest location))
      :file (java.io.FileInputStream. ^String (second location)))))

(defn- get-source-from-var
  "Returns a string of the source code for the given symbol, if it can
find it. This requires that the symbol resolve to a Var defined in
a namespace for which the .clj is in the classpath. Returns nil if
it can't find the source.
Example: (get-source-from-var 'filter)"
  [v]
  (when-let [filepath (:file (meta v))]
    (when-let [strm (get-resource-stream filepath)]
      (with-open [rdr (LineNumberReader. (InputStreamReader. strm))]
        (dotimes [_ (dec (:line (meta v)))] (.readLine rdr))
        (let [text (StringBuilder.)
              pbr (proxy [PushbackReader] [rdr]
                    (read [] (let [#^Reader this this
                                   i (proxy-super read)]
                               (.append text (char i))
                               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)))))))))

(defn who-calls [name]
  (letfn [(xref-lisp [sym-var]        ; see find-definitions-for-emacs
                     (when-let [meta (meta sym-var)]
                       (source-location-for-meta meta nil)))]
    (let [callers (all-vars-who-call name) ]
      (map first (map xref-lisp callers)))))

(defn- get-line-no-from-defmethod
  ;; TODO this is very simplistic at the moment and relies on a
  ;; brittle regex
  [multifn-name dispatch-val ns]
  (let [filepath (namespace-to-filename ns)
        re (re-pattern (str "defmethod *" multifn-name " *" dispatch-val))]
    (when-let [strm (get-resource-stream filepath)]
      (with-open [rdr (LineNumberReader. (InputStreamReader. strm))]
        (loop []
          (if-let [ln (.readLine rdr)]
            (if (re-find re ln)
              (location (str multifn-name " " dispatch-val)
                        "defmethod"
                        (slime-find-file filepath)
                        (.getLineNumber rdr))
              (recur))))
        #_(loop [results []]
          (if-let [ln (.readLine rdr)]
            (if (re-find re ln)
              (recur (conj results
                           (location multifn-name "defmulti"
                                     (slime-find-file filepath)
                                     (.getLineNumber rdr))))
              (recur results))
            results))))))

(defn- all-ns-who-defmulti [multifn]
  (for [[dispatch-val m] (methods multifn)]
    (let [ns-nm (-> m str (clojure.string/split #"\$") first)
          ns-nm-v2 (clojure.string/replace ns-nm "_" "-")]
      [dispatch-val (some (fn [ns]
                            (let [nm (-> ns ns-name str)]
                              (if (or (= ns-nm nm)
                                      (= ns-nm-v2 nm)) ns)))
                          (all-ns))])))

(defn who-specializes-multifn [multifn-var]
  (let [multifn-name (:name (meta multifn-var))]
    (map first (filter seq
            (for [[dispatch-val ns] (all-ns-who-defmulti @multifn-var)]
              (filter identity (get-line-no-from-defmethod
                                multifn-name dispatch-val ns)))))))

(defn who-specializes [class]
  ;; this appears to be broken
  ;; TODO make it work for multimethod
  ;; (map ns-name (all-ns))

  (letfn [(xref-lisp [sym] ; see find-definitions-for-emacs
            (if-let [meta (meta sym)]
              (source-location-for-meta meta "method")
              (location-not-found (name sym) "method")))]
    (let [methods (try (. #^java.lang.Class class getMethods)
                       (catch java.lang.IllegalArgumentException e nil)
                       (catch java.lang.NullPointerException e nil))]
      (map xref-lisp methods))))

(defslimefn xref [type name]
  (let [sexp (maybe-resolve-sym name)]
    (condp = type
      :specializes (who-specializes-multifn sexp) ;; (who-specializes sexp)
      :calls   (who-calls (symbol name))
      :callers nil
      :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]
  (try
    ((invoke-restart (*sldb-restarts* (nth (keys *sldb-restarts*) n))))
    (catch IndexOutOfBoundsException e (throw debug-invalid-restart-exception))))

(defslimefn throw-to-toplevel []
  (if-let [restart (*sldb-restarts* :quit)]
    (invoke-restart restart)))

(defslimefn sldb-continue []
  (if-let [restart (*sldb-restarts* :continue)]
    (invoke-restart restart)))

(defslimefn sldb-abort []
  (if-let [restart (*sldb-restarts* :abort)]
    (invoke-restart restart)))


(defslimefn backtrace [start end]
  (dbe/build-backtrace start end))

(defslimefn buffer-first-change [file-name] nil)

(defn locals-for-emacs [m]
  (sort-by second
           (map #(list :name (name (first %)) :id 0
                       :value (pr-str (second %))) m)))

(defslimefn frame-catch-tags-for-emacs [n] nil)
(defslimefn frame-locals-for-emacs [n]
  (if (and (zero? n) (seq *current-env*))
    (locals-for-emacs *current-env*)))

(defslimefn frame-locals-and-catch-tags [n]
  (list (frame-locals-for-emacs n)
        (frame-catch-tags-for-emacs n)))

(defslimefn debugger-info-for-emacs [start end]
  (build-debugger-info-for-emacs start end))

(defslimefn eval-string-in-frame [expr n]
  (dbe/eval-string-in-frame expr n))

(defslimefn eval-last-frame [expr]
  (dbe/eval-last-frame expr))

(defslimefn frame-source-location [n]
  (source-location-for-frame (dbe/get-stack-trace n)))

;; Older versions of slime use this instead of the above.
(defslimefn frame-source-location-for-emacs [n]
  (source-location-for-frame (dbe/get-stack-trace n)))

(defslimefn create-repl [target] '("user" "user"))

;;; Threads

(def #^{:private true} thread-list (atom []))

(defn- get-root-group [#^java.lang.ThreadGroup tg]
  (if-let [parent (.getParent tg)]
    (recur parent)
    tg))

(defn get-thread-list []
  (let [#^ThreadGroup rg (get-root-group (.getThreadGroup (Thread/currentThread)))
        #^"[Ljava.lang.Thread;" arr (make-array Thread (.activeCount rg))]
    (.enumerate rg arr true)            ;needs type hint
    (seq arr)))

(defn- extract-info [#^Thread t]
  (map str [(.getId t) (.getName t) (.getPriority t) (.getState t)]))

(defslimefn list-threads
  "Return a list (LABELS (ID NAME STATUS ATTRS ...) ...).
LABELS is a list of attribute names and the remaining lists are the
corresponding attribute values per thread."
  []
  (reset! thread-list (get-thread-list))
  (let [labels '(id name priority state)]
    (cons labels (map extract-info @thread-list))))

;;; TODO: Find a better way, as Thread.stop is deprecated
(defslimefn kill-nth-thread [index]
  (when index
    (when-let [#^Thread thread (nth @thread-list index nil)]
      (println "Thread: " thread)
      (.stop thread))))

(defslimefn quit-thread-browser []
  (reset! thread-list []))