389 lines
13 KiB
Clojure
389 lines
13 KiB
Clojure
(ns swank.core
|
|
(:use (swank util commands)
|
|
(swank.util hooks)
|
|
(swank.util.concurrent thread)
|
|
(swank.core connection hooks threadmap))
|
|
(:require (swank.util.concurrent [mbox :as mb])))
|
|
|
|
;; Protocol version
|
|
(defonce protocol-version (atom "20100404"))
|
|
|
|
;; Emacs packages
|
|
(def #^{:dynamic true} *current-package*)
|
|
|
|
;; current emacs eval id
|
|
(def #^{:dynamic true} *pending-continuations* '())
|
|
|
|
(def sldb-stepping-p nil)
|
|
(def sldb-initial-frames 10)
|
|
(def #^{:dynamic true} #^{:doc "The current level of recursive debugging."}
|
|
*sldb-level* 0)
|
|
(def #^{:dynamic true} #^{:doc "The current restarts."}
|
|
*sldb-restarts* 0)
|
|
|
|
(def #^{:doc "Include swank-clojure thread in stack trace for debugger."}
|
|
debug-swank-clojure false)
|
|
|
|
(defonce active-threads (ref ()))
|
|
|
|
(defn maybe-ns [package]
|
|
(cond
|
|
(symbol? package) (or (find-ns package) (maybe-ns 'user))
|
|
(string? package) (maybe-ns (symbol package))
|
|
(keyword? package) (maybe-ns (name package))
|
|
(instance? clojure.lang.Namespace package) package
|
|
:else (maybe-ns 'user)))
|
|
|
|
(defmacro with-emacs-package [& body]
|
|
`(binding [*ns* (maybe-ns *current-package*)]
|
|
~@body))
|
|
|
|
(defmacro with-package-tracking [& body]
|
|
`(let [last-ns# *ns*]
|
|
(try
|
|
~@body
|
|
(finally
|
|
(when-not (= last-ns# *ns*)
|
|
(send-to-emacs `(:new-package ~(str (ns-name *ns*))
|
|
~(str (ns-name *ns*)))))))))
|
|
|
|
(defmacro dothread-swank [& body]
|
|
`(dothread-keeping-clj [*current-connection*]
|
|
~@body))
|
|
|
|
;; Exceptions for debugging
|
|
(defonce debug-quit-exception (Exception. "Debug quit"))
|
|
(defonce debug-continue-exception (Exception. "Debug continue"))
|
|
(defonce debug-abort-exception (Exception. "Debug abort"))
|
|
|
|
(def #^{:dynamic true} #^Throwable *current-exception* nil)
|
|
|
|
;; Local environment
|
|
(def #^{:dynamic true} *current-env* nil)
|
|
|
|
(let [&env :unavailable]
|
|
(defmacro local-bindings
|
|
"Produces a map of the names of local bindings to their values."
|
|
[]
|
|
(if-not (= &env :unavailable)
|
|
(let [symbols (keys &env)]
|
|
(zipmap (map (fn [sym] `(quote ~sym)) symbols) symbols)))))
|
|
|
|
;; Handle Evaluation
|
|
(defn send-to-emacs
|
|
"Sends a message (msg) to emacs."
|
|
([msg]
|
|
(mb/send @(*current-connection* :control-thread) msg)))
|
|
|
|
(defn send-repl-results-to-emacs [val]
|
|
(send-to-emacs `(:write-string ~(str (pr-str val) "\n") :repl-result)))
|
|
|
|
(defn with-env-locals
|
|
"Evals a form with given locals. The locals should be a map of symbols to
|
|
values."
|
|
[form]
|
|
(if (seq *current-env*)
|
|
`(let ~(vec (mapcat #(list % `(*current-env* '~%)) (keys *current-env*)))
|
|
~form)
|
|
form))
|
|
|
|
(defn eval-in-emacs-package [form]
|
|
(with-emacs-package
|
|
(eval form)))
|
|
|
|
|
|
(defn eval-from-control
|
|
"Blocks for a mbox message from the control thread and executes it
|
|
when received. The mbox message is expected to be a slime-fn."
|
|
([] (let [form (mb/receive (current-thread))]
|
|
(apply (ns-resolve *ns* (first form)) (rest form)))))
|
|
|
|
(defn eval-loop
|
|
"A loop which continuosly reads actions from the control thread and
|
|
evaluates them (will block if no mbox message is available)."
|
|
([] (continuously (eval-from-control))))
|
|
|
|
(defn exception-causes [#^Throwable t]
|
|
(lazy-seq
|
|
(cons t (when-let [cause (.getCause t)]
|
|
(exception-causes cause)))))
|
|
|
|
(defn- debug-quit-exception? [t]
|
|
(some #(identical? debug-quit-exception %) (exception-causes t)))
|
|
|
|
(defn- debug-continue-exception? [t]
|
|
(some #(identical? debug-continue-exception %) (exception-causes t)))
|
|
|
|
(defn- debug-abort-exception? [t]
|
|
(some #(identical? debug-abort-exception %) (exception-causes t)))
|
|
|
|
(defn exception-stacktrace [t]
|
|
(map #(list %1 %2 '(:restartable nil))
|
|
(iterate inc 0)
|
|
(map str (.getStackTrace t))))
|
|
|
|
(defn debugger-condition-for-emacs []
|
|
(list (or (.getMessage *current-exception*) "No message.")
|
|
(str " [Thrown " (class *current-exception*) "]")
|
|
nil))
|
|
|
|
(defn make-restart [kw name description f]
|
|
[kw [name description f]])
|
|
|
|
(defn add-restart-if [condition restarts kw name description f]
|
|
(if condition
|
|
(conj restarts (make-restart kw name description f))
|
|
restarts))
|
|
|
|
(declare sldb-debug)
|
|
(defn cause-restart-for [thrown depth]
|
|
(make-restart
|
|
(keyword (str "cause" depth))
|
|
(str "CAUSE" depth)
|
|
(str "Invoke debugger on cause "
|
|
(apply str (take depth (repeat " ")))
|
|
(.getMessage thrown)
|
|
" [Thrown " (class thrown) "]")
|
|
(partial sldb-debug nil thrown *pending-continuations*)))
|
|
|
|
(defn add-cause-restarts [restarts thrown]
|
|
(loop [restarts restarts
|
|
cause (.getCause thrown)
|
|
level 1]
|
|
(if cause
|
|
(recur
|
|
(conj restarts (cause-restart-for cause level))
|
|
(.getCause cause)
|
|
(inc level))
|
|
restarts)))
|
|
|
|
(defn calculate-restarts [thrown]
|
|
(let [restarts [(make-restart :quit "QUIT" "Quit to the SLIME top level"
|
|
(fn [] (throw debug-quit-exception)))]
|
|
restarts (add-restart-if
|
|
(pos? *sldb-level*)
|
|
restarts
|
|
:abort "ABORT" (str "ABORT to SLIME level " (dec *sldb-level*))
|
|
(fn [] (throw debug-abort-exception)))
|
|
restarts (add-restart-if
|
|
(and (.getMessage thrown)
|
|
(.contains (.getMessage thrown) "BREAK"))
|
|
restarts
|
|
:continue "CONTINUE" (str "Continue from breakpoint")
|
|
(fn [] (throw debug-continue-exception)))
|
|
restarts (add-cause-restarts restarts thrown)]
|
|
(into (array-map) restarts)))
|
|
|
|
(defn format-restarts-for-emacs []
|
|
(doall (map #(list (first (second %)) (second (second %))) *sldb-restarts*)))
|
|
|
|
(defn build-backtrace [start end]
|
|
(doall (take (- end start) (drop start (exception-stacktrace *current-exception*)))))
|
|
|
|
(defn build-debugger-info-for-emacs [start end]
|
|
(list (debugger-condition-for-emacs)
|
|
(format-restarts-for-emacs)
|
|
(build-backtrace start end)
|
|
*pending-continuations*))
|
|
|
|
(defn sldb-loop
|
|
"A loop that is intented to take over an eval thread when a debug is
|
|
encountered (an continue to perform the same thing). It will
|
|
continue until a *debug-quit* exception is encountered."
|
|
[level]
|
|
(try
|
|
(send-to-emacs
|
|
(list* :debug (current-thread) level
|
|
(build-debugger-info-for-emacs 0 sldb-initial-frames)))
|
|
([] (continuously
|
|
(do
|
|
(send-to-emacs `(:debug-activate ~(current-thread) ~level nil))
|
|
(eval-from-control))))
|
|
(catch Throwable t
|
|
(send-to-emacs
|
|
`(:debug-return ~(current-thread) ~*sldb-level* ~sldb-stepping-p))
|
|
(if-not (debug-continue-exception? t)
|
|
(throw t)))))
|
|
|
|
(defn invoke-debugger
|
|
[locals #^Throwable thrown id]
|
|
(binding [*current-env* locals
|
|
*current-exception* thrown
|
|
*sldb-restarts* (calculate-restarts thrown)
|
|
*sldb-level* (inc *sldb-level*)]
|
|
(sldb-loop *sldb-level*)))
|
|
|
|
(defn sldb-debug [locals thrown id]
|
|
(try
|
|
(invoke-debugger nil thrown id)
|
|
(catch Throwable t
|
|
(when (and (pos? *sldb-level*)
|
|
(not (debug-abort-exception? t)))
|
|
(throw t)))))
|
|
|
|
(defmacro break
|
|
[]
|
|
`(invoke-debugger (local-bindings) (Exception. "BREAK:") *pending-continuations*))
|
|
|
|
(defn doall-seq [coll]
|
|
(if (seq? coll)
|
|
(doall coll)
|
|
coll))
|
|
|
|
(defn eval-for-emacs [form buffer-package id]
|
|
(try
|
|
(binding [*current-package* buffer-package
|
|
*pending-continuations* (cons id *pending-continuations*)]
|
|
(if-let [f (slime-fn (first form))]
|
|
(let [form (cons f (rest form))
|
|
result (doall-seq (eval-in-emacs-package form))]
|
|
(run-hook pre-reply-hook)
|
|
(send-to-emacs `(:return ~(thread-name (current-thread))
|
|
(:ok ~result) ~id)))
|
|
;; swank function not defined, abort
|
|
(send-to-emacs `(:return ~(thread-name (current-thread)) (:abort) ~id))))
|
|
(catch Throwable t
|
|
;; Thread/interrupted clears this thread's interrupted status; if
|
|
;; Thread.stop was called on us it may be set and will cause an
|
|
;; InterruptedException in one of the send-to-emacs calls below
|
|
(Thread/interrupted)
|
|
|
|
;; (.printStackTrace t #^java.io.PrintWriter *err*)
|
|
|
|
(cond
|
|
(debug-quit-exception? t)
|
|
(do
|
|
(send-to-emacs `(:return ~(thread-name (current-thread)) (:abort) ~id))
|
|
(if-not (zero? *sldb-level*)
|
|
(throw t)))
|
|
|
|
(debug-abort-exception? t)
|
|
(do
|
|
(send-to-emacs `(:return ~(thread-name (current-thread)) (:abort) ~id))
|
|
(if-not (zero? *sldb-level*)
|
|
(throw debug-abort-exception)))
|
|
|
|
(debug-continue-exception? t)
|
|
(do
|
|
(send-to-emacs `(:return ~(thread-name (current-thread)) (:abort) ~id))
|
|
(throw t))
|
|
|
|
:else
|
|
(do
|
|
(set! *e t)
|
|
(try
|
|
(sldb-debug
|
|
nil
|
|
(if debug-swank-clojure t (or (.getCause t) t))
|
|
id)
|
|
;; reply with abort
|
|
(finally (send-to-emacs `(:return ~(thread-name (current-thread)) (:abort) ~id)))))))))
|
|
|
|
(defn- add-active-thread [thread]
|
|
(dosync
|
|
(commute active-threads conj thread)))
|
|
|
|
(defn- remove-active-thread [thread]
|
|
(dosync
|
|
(commute active-threads (fn [threads] (remove #(= % thread) threads)))))
|
|
|
|
(defn spawn-worker-thread
|
|
"Spawn an thread that blocks for a single command from the control
|
|
thread, executes it, then terminates."
|
|
([conn]
|
|
(dothread-swank
|
|
(try
|
|
(add-active-thread (current-thread))
|
|
(thread-set-name "Swank Worker Thread")
|
|
(eval-from-control)
|
|
(finally
|
|
(remove-active-thread (current-thread)))))))
|
|
|
|
(defn spawn-repl-thread
|
|
"Spawn an thread that sets itself as the current
|
|
connection's :repl-thread and then enters an eval-loop"
|
|
([conn]
|
|
(dothread-swank
|
|
(thread-set-name "Swank REPL Thread")
|
|
(with-connection conn
|
|
(eval-loop)))))
|
|
|
|
(defn find-or-spawn-repl-thread
|
|
"Returns the current connection's repl-thread or create a new one if
|
|
the existing one does not exist."
|
|
([conn]
|
|
;; TODO - check if an existing repl-agent is still active & doesn't have errors
|
|
(dosync
|
|
(or (when-let [conn-repl-thread @(conn :repl-thread)]
|
|
(when (.isAlive #^Thread conn-repl-thread)
|
|
conn-repl-thread))
|
|
(ref-set (conn :repl-thread)
|
|
(spawn-repl-thread conn))))))
|
|
|
|
(defn thread-for-evaluation
|
|
"Given an id and connection, find or create the appropiate agent."
|
|
([id conn]
|
|
(cond
|
|
(= id true) (spawn-worker-thread conn)
|
|
(= id :repl-thread) (find-or-spawn-repl-thread conn)
|
|
:else (find-thread id))))
|
|
|
|
;; Handle control
|
|
(defn read-loop
|
|
"A loop that reads from the socket (will block when no message
|
|
available) and dispatches the message to the control thread."
|
|
([conn control]
|
|
(with-connection conn
|
|
(continuously (mb/send control (read-from-connection conn))))))
|
|
|
|
(defn dispatch-event
|
|
"Dispatches/executes an event in the control thread's mailbox queue."
|
|
([ev conn]
|
|
(let [[action & args] ev]
|
|
(cond
|
|
(= action :emacs-rex)
|
|
(let [[form-string package thread id] args
|
|
thread (thread-for-evaluation thread conn)]
|
|
(mb/send thread `(eval-for-emacs ~form-string ~package ~id)))
|
|
|
|
(= action :return)
|
|
(let [[thread & ret] args]
|
|
(binding [*print-level* nil, *print-length* nil]
|
|
(write-to-connection conn `(:return ~@ret))))
|
|
|
|
(one-of? action
|
|
:presentation-start :presentation-end
|
|
:new-package :new-features :ed :percent-apply
|
|
:indentation-update
|
|
:eval-no-wait :background-message :inspect)
|
|
(binding [*print-level* nil, *print-length* nil]
|
|
(write-to-connection conn ev))
|
|
|
|
(= action :write-string)
|
|
(write-to-connection conn ev)
|
|
|
|
(one-of? action
|
|
:debug :debug-condition :debug-activate :debug-return)
|
|
(let [[thread & args] args]
|
|
(write-to-connection conn `(~action ~(thread-map-id thread) ~@args)))
|
|
|
|
(= action :emacs-interrupt)
|
|
(let [[thread & args] args]
|
|
(dosync
|
|
(cond
|
|
(and (true? thread) (seq @active-threads))
|
|
(.stop #^Thread (first @active-threads))
|
|
(= thread :repl-thread) (.stop #^Thread @(conn :repl-thread)))))
|
|
:else
|
|
nil))))
|
|
|
|
;; Main loop definitions
|
|
(defn control-loop
|
|
"A loop that reads from the mbox queue and runs dispatch-event on
|
|
it (will block if no mbox control message is available). This is
|
|
intended to only be run on the control thread."
|
|
([conn]
|
|
(binding [*1 nil, *2 nil, *3 nil, *e nil]
|
|
(with-connection conn
|
|
(continuously (dispatch-event (mb/receive (current-thread)) conn))))))
|