Index: ChangeLog =================================================================== RCS file: /project/slime/cvsroot/slime/ChangeLog,v retrieving revision 1.2412 diff -b -u -5 -r1.2412 ChangeLog --- ChangeLog 17 Nov 2013 07:59:04 -0000 1.2412 +++ ChangeLog 24 Nov 2013 23:30:08 -0000 @@ -1,5 +1,16 @@ +2013-11-20 João Távora + + * swank-backend.lisp (wrap, unwrap, wrapped-p): new wrapping + interface with default implementation. + * swank-allegro.lisp (wrap,unwrap,wrapped-p): implement wrapping + interface + * swank-sbcl.lisp (wrap,unwrap,wrapped-p): implement wrapping interface + * swank.lisp (*after-toggle-trace-hook*): new exported variable, + defaults to nil. + * swank-loader.lisp (*contribs*): add swank-trace-dialog contrib + 2013-11-17 Helmut Eller * swank-sbcl.lisp (swank-compile-string): Load the fasl file even if there were warnings. Just like the other backends do. Index: swank-allegro.lisp =================================================================== RCS file: /project/slime/cvsroot/slime/swank-allegro.lisp,v retrieving revision 1.161 diff -b -u -5 -r1.161 swank-allegro.lisp --- swank-allegro.lisp 2 Apr 2013 14:41:08 -0000 1.161 +++ swank-allegro.lisp 24 Nov 2013 23:30:09 -0000 @@ -967,5 +967,38 @@ (defimplementation character-completion-set (prefix matchp) (loop for name being the hash-keys of excl::*name-to-char-table* when (funcall matchp prefix name) collect (string-capitalize name))) + + +;;;; wrap interface implementation + +(defimplementation wrap (spec indicator &key before after replace) + (let ((allegro-spec (process-fspec-for-allegro spec))) + (excl:fwrap allegro-spec + indicator + (excl:def-fwrapper allegro-wrapper (&rest args) + (let (retlist completed) + (unwind-protect + (progn + (when before + (funcall before args)) + (setq retlist (multiple-value-list + (if replace + (funcall replace args) + (excl:call-next-fwrapper)))) + (setq completed t) + (values-list retlist)) + (when after + (funcall after (if completed + retlist + :exited-non-locally))))))) + allegro-spec)) + +(defimplementation unwrap (spec indicator) + (let ((allegro-spec (process-fspec-for-allegro spec))) + (excl:funwrap allegro-spec indicator) + allegro-spec)) + +(defimplementation wrapped-p (spec indicator) + (getf (excl:fwrap-order (process-fspec-for-allegro spec)) indicator)) Index: swank-backend.lisp =================================================================== RCS file: /project/slime/cvsroot/slime/swank-backend.lisp,v retrieving revision 1.224 diff -b -u -5 -r1.224 swank-backend.lisp --- swank-backend.lisp 2 Feb 2013 10:11:16 -0000 1.224 +++ swank-backend.lisp 24 Nov 2013 23:30:09 -0000 @@ -1509,5 +1509,74 @@ (defun deinit-log-output () ;; Can't hang on to an fd-stream from a previous session. (setf (symbol-value (find-symbol "*LOG-OUTPUT*" 'swank)) nil)) + + +;;;; Wrapping + +(definterface wrap (spec indicator &key before after replace) + "Intercept future calls to SPEC and surround them in callbacks. + +INDICATOR is a symbol identifying a particular wrapping, and is used +to differentiate between multiple wrappings. + +Implementations intercept calls to SPEC and call, in this order: + +* the BEFORE callback, if it's provided, with a single argument set to + the list of arguments passed to the intercepted call; + +* the original definition of SPEC recursively honouring any wrappings + previously established under different values of INDICATOR. If the + compatible function REPLACE is provided, call that instead. + +* the AFTER callback, if it's provided, with a single set to the list + of values returned by the previous call, or, if that call exited + non-locally, a single descriptive symbol, like :EXITED-NON-LOCALLY." + (declare (ignore indicator)) + (assert (symbolp spec) nil + "The default implementation for WRAP allows only simple names") + (assert (null (get spec 'slime-wrap)) nil + "The default implementation for WRAP allows a single wrapping") + (let* ((saved (symbol-function spec)) + (replacement (lambda (&rest args) + (let (retlist completed) + (unwind-protect + (progn + (when before + (funcall before args)) + (setq retlist (multiple-value-list + (apply (or replace + saved) args))) + (setq completed t) + (values-list retlist)) + (when after + (funcall after (if completed + retlist + :exited-non-locally)))))))) + (setf (get spec 'slime-wrap) (list saved replacement)) + (setf (symbol-function spec) replacement)) + spec) + +(definterface unwrap (spec indicator) + "Remove from SPEC any wrappings tagged with INDICATOR." + (if (wrapped-p spec indicator) + (setf (symbol-function spec) (first (get spec 'slime-wrap))) + (cerror "All right, so I did" + "Hmmm, ~a is not correctly wrapped, you probably redefined it" + spec)) + (setf (get spec 'slime-wrap) nil) + spec) + +(definterface wrapped-p (spec indicator) + "Returns true if SPEC is wrapped with INDICATOR." + (declare (ignore indicator)) + (and (symbolp spec) + (let ((prop-value (get spec 'slime-wrap))) + (cond ((and prop-value + (not (eq (second prop-value) + (symbol-function spec)))) + (warn "~a appears to be incorrectly wrapped" spec) + nil) + (prop-value t) + (t nil))))) Index: swank-loader.lisp =================================================================== RCS file: /project/slime/cvsroot/slime/swank-loader.lisp,v retrieving revision 1.117 diff -b -u -5 -r1.117 swank-loader.lisp --- swank-loader.lisp 5 Jan 2013 08:50:12 -0000 1.117 +++ swank-loader.lisp 24 Nov 2013 23:30:09 -0000 @@ -226,11 +226,11 @@ #+(or asdf sbcl ecl) swank-asdf swank-package-fu swank-hyperdoc #+sbcl swank-sbcl-exts swank-mrepl - ) + swank-trace-dialog) "List of names for contrib modules.") (defun append-dir (absolute name) (merge-pathnames (make-pathname :directory `(:relative ,name) :defaults absolute) Index: swank-sbcl.lisp =================================================================== RCS file: /project/slime/cvsroot/slime/swank-sbcl.lisp,v retrieving revision 1.331 diff -b -u -5 -r1.331 swank-sbcl.lisp --- swank-sbcl.lisp 17 Nov 2013 07:59:04 -0000 1.331 +++ swank-sbcl.lisp 24 Nov 2013 23:30:10 -0000 @@ -1880,5 +1880,45 @@ (assert (sb-posix:wifexited status)) (funcall completion-function (zerop (sb-posix:wexitstatus status)))))))))))) (pushnew 'deinit-log-output sb-ext:*save-hooks*) + + +;;;; wrap interface implementation + +(defimplementation wrap (spec indicator &key before after replace) + (when (wrapped-p spec indicator) + (warn "~a already wrapped with indicator ~a, unwrapping first" + spec indicator) + (sb-int:unencapsulate spec indicator)) + (sb-int:encapsulate spec indicator `(sbcl-wrap ',spec + ,before + ,after + ,replace))) + +(defimplementation unwrap (spec indicator) + (sb-int:unencapsulate spec indicator)) + +(defimplementation wrapped-p (spec indicator) + (sb-int:encapsulated-p spec indicator)) + +(in-package :sb-int) + +(defun swank-backend::sbcl-wrap (spec before after replace) + (declare (special sb-int:basic-definition sb-int:arg-list)) + (let (retlist completed) + (unwind-protect + (progn + (when before + (funcall before sb-int:arg-list)) + (setq retlist (multiple-value-list (if replace + (funcall replace + sb-int:arg-list) + (apply sb-int:basic-definition + sb-int:arg-list)))) + (setq completed t) + (values-list retlist)) + (when after + (funcall after (if completed retlist :exited-non-locally)))))) + +(in-package :swank-backend) Index: swank.lisp =================================================================== RCS file: /project/slime/cvsroot/slime/swank.lisp,v retrieving revision 1.805 diff -b -u -5 -r1.805 swank.lisp --- swank.lisp 10 Nov 2013 08:11:44 -0000 1.805 +++ swank.lisp 24 Nov 2013 23:30:11 -0000 @@ -63,11 +63,12 @@ #:quit-lisp #:eval-for-emacs #:eval-in-emacs #:y-or-n-p-in-emacs #:*find-definitions-right-trim* - #:*find-definitions-left-trim*)) + #:*find-definitions-left-trim* + #:*after-toggle-trace-hook*)) (in-package :swank) ;;;; Top-level variables, constants, macros @@ -2843,20 +2844,36 @@ ;; Use eval for the sake of portability... (defun tracedp (fspec) (member fspec (eval '(trace)))) +(defvar *after-toggle-trace-hook* nil + "Hook called whenever a SPEC is traced or untraced. + +If non-nil, called with two arguments SPEC and TRACED-P." ) (defslimefun swank-toggle-trace (spec-string) - (let ((spec (from-string spec-string))) - (cond ((consp spec) ; handle complicated cases in the backend + (let* ((spec (from-string spec-string)) + (retval (cond ((consp spec) ; handle complicated cases in the backend (toggle-trace spec)) ((tracedp spec) (eval `(untrace ,spec)) (format nil "~S is now untraced." spec)) (t (eval `(trace ,spec)) - (format nil "~S is now traced." spec))))) + (format nil "~S is now traced." spec)))) + (traced-p (let* ((tosearch "is now traced.") + (start (- (length retval) + (length tosearch))) + (end (+ start (length tosearch)))) + (search tosearch (subseq retval start end)))) + (hook-msg (when *after-toggle-trace-hook* + (funcall *after-toggle-trace-hook* + spec + traced-p)))) + (if hook-msg + (format nil "~a~%(also ~a)" retval hook-msg) + retval))) (defslimefun untrace-all () (untrace)) Index: contrib/ChangeLog =================================================================== RCS file: /project/slime/cvsroot/slime/contrib/ChangeLog,v retrieving revision 1.574 diff -b -u -5 -r1.574 ChangeLog --- contrib/ChangeLog 13 May 2013 13:16:24 -0000 1.574 +++ contrib/ChangeLog 24 Nov 2013 23:30:12 -0000 @@ -1,5 +1,16 @@ +2013-11-20 João Távora + + * swank-trace-dialog.lisp: New file, new :swank-trace-dialog + package, uses new wrapping interface in swank-backend.el to trace + fspecs. Report the trace tree to emacs. + * slime-trace-dialog.el: New file, collect and render a + interactive tree of traces collected from the Lisp + backend. Inspect trace arguments and return values. + * slime-fancy.el: Enable new contrib slime-trace-dialog. Call + slime-fancy trace init function. + 2013-05-11 Marco Baringer * slime-repl.el (slime-repl-sexp-at-point): New function; similar to slime-sexp-at-point but ignore repl prompt text. (slime-repl-inspect): New function; similar to slime-inspect but Index: contrib/slime-fancy.el =================================================================== RCS file: /project/slime/cvsroot/slime/contrib/slime-fancy.el,v retrieving revision 1.14 diff -b -u -5 -r1.14 slime-fancy.el --- contrib/slime-fancy.el 26 May 2013 08:20:17 -0000 1.14 +++ contrib/slime-fancy.el 24 Nov 2013 23:30:12 -0000 @@ -13,17 +13,20 @@ slime-fuzzy slime-presentations slime-scratch slime-references slime-package-fu - slime-fontifying-fu) + slime-fontifying-fu + slime-trace-dialog) (:on-load + (slime-trace-dialog-init) (slime-repl-init) (slime-autodoc-init) (slime-c-p-c-init) (slime-editing-commands-init) (slime-fancy-inspector-init) + (slime-fancy-trace-init) (slime-fuzzy-init) (slime-presentations-init) (slime-scratch-init) (slime-references-init) (slime-package-fu-init) Index: contrib/slime-trace-dialog.el =================================================================== RCS file: contrib/slime-trace-dialog.el diff -N contrib/slime-trace-dialog.el --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ contrib/slime-trace-dialog.el 24 Nov 2013 23:30:12 -0000 @@ -0,0 +1,759 @@ +;;; -*- coding: utf-8; lexical-binding: t -*- +;;; +;;; slime-trace-dialog.el -- a navigable dialog of inspectable trace entries +;;; +;;; TODO: implement better wrap interface for sbcl method, labels and such +;;; TODO: test with multiple connections +;;; TODO: backtrace printing is very slow +;;; + +(define-slime-contrib slime-trace-dialog + "Provide an interfactive trace dialog buffer for managing and +inspecting details of traced functions. Invoke this dialog with C-c T." + (:authors "João Távora ") + (:license "GPL") + (:swank-dependencies swank-trace-dialog) + (:on-load (define-key slime-prefix-map + "T" 'slime-trace-dialog) + (define-key slime-prefix-map + "\M-t" 'slime-trace-dialog-toggle-trace)) + (:on-unload (define-key slime-prefix-map "T" nil))) + + +;;;; Variables +;;; +(defvar slime-trace-dialog-autofollow nil) + +(defvar slime-trace-dialog--brief-mode nil) + +(defvar slime-trace-dialog-flash t) + +(defvar slime-trace-dialog--specs-overlay nil) + +(defvar slime-trace-dialog--progress-overlay nil) + +(defvar slime-trace-dialog--tree-overlay nil) + +(defvar slime-trace-dialog--local-control-overlay nil) + +(defvar slime-trace-dialog--collapse-chars (cons "-" "+")) + + +;;;; Local trace entry model +(defvar slime-trace-dialog--traces nil) + +(cl-defstruct (slime-trace-dialog--trace + (:constructor slime-trace-dialog--make-trace)) + id + parent + spec + args + retlist + depth + beg + end + collapse-button-marker + summary-beg + children-end + collapsed-p) + +(defun slime-trace-dialog--find-trace (id) + (gethash id slime-trace-dialog--traces)) + + +;;;; Modes and mode maps +;;; +(define-derived-mode slime-trace-dialog--mode slime-inspector-mode + "Slime-Trace-Dialog" "Mode for controlling slime's trace dialog") + +(setq slime-trace-dialog--mode-map + (let ((map (make-sparse-keymap)) + (remaps '((slime-inspector-operate-on-point . nil) + (slime-inspector-operate-on-click . nil) + (slime-inspector-reinspect + . slime-trace-dialog-fetch-status) + (slime-inspector-next-inspectable-object + . slime-trace-dialog-next-button) + (slime-inspector-previous-inspectable-object + . slime-trace-dialog-prev-button)))) + (set-keymap-parent map slime-inspector-mode-map) + (loop for (old . new) in remaps + do (substitute-key-definition old new map)) + (set-keymap-parent map slime-parent-map) + (define-key map (kbd "G") 'slime-trace-dialog-fetch-traces) + + map)) + +(define-derived-mode slime-trace-dialog--detail-mode slime-inspector-mode + "Slime-Trace-Detail" + "Mode for viewing a particular trace from slime's trace dialog") + +(setq slime-trace-dialog--detail-mode-map + (let ((map (make-sparse-keymap)) + (remaps '((slime-inspector-next-inspectable-object + . slime-trace-dialog-next-button) + (slime-inspector-previous-inspectable-object + . slime-trace-dialog-prev-button)))) + (set-keymap-parent map slime-trace-dialog--mode-map) + (loop for (old . new) in remaps + do (substitute-key-definition old new map)) + map)) + + +;;;; Helper functions +;;; +(defun slime-trace-dialog--call-refreshing (buffer + overlay + dont-erase + recover-point-p + fn) + (with-current-buffer buffer + (let ((inhibit-point-motion-hooks t) + (inhibit-read-only t) + (saved (point))) + (save-restriction + (when overlay + (narrow-to-region (overlay-start overlay) + (overlay-end overlay))) + (unwind-protect + (if dont-erase + (goto-char (point-max)) + (delete-region (point-min) (point-max))) + (funcall fn) + (when recover-point-p + (goto-char saved))) + (when slime-trace-dialog-flash + (slime-flash-region (point-min) (point-max))))) + buffer)) + +(cl-defmacro slime-trace-dialog--refresh ((buffer &key + overlay + dont-erase + recover-point-p) + &rest body) + (declare (indent 1) + (debug (sexp &rest form))) + `(slime-trace-dialog--call-refreshing ,buffer + ,overlay + ,dont-erase + ,recover-point-p + #'(lambda () ,@body))) + +(defmacro slime-trace-dialog--insert-and-overlay (string overlay) + `(save-restriction + (let ((inhibit-read-only t)) + (narrow-to-region (point) (point)) + (insert ,string "\n") + (setq ,overlay + (let ((overlay (make-overlay (point-min) + (point-max) + (current-buffer) + nil + t))) + (move-overlay overlay (overlay-start overlay) + (1- (overlay-end overlay))) + ;; (overlay-put overlay 'face '(:background "darkslategrey")) + overlay))))) + +(defun slime-trace-dialog--get-buffer () + (or + (get-buffer "*trace-dialog*") + (slime-with-popup-buffer ("*trace-dialog*" :mode 'slime-trace-dialog--mode) + (save-excursion + (buffer-disable-undo) + (slime-trace-dialog--insert-and-overlay + "local control" + slime-trace-dialog--local-control-overlay) + (slime-trace-dialog--insert-and-overlay + "[waiting for the traced specs to be available]" + slime-trace-dialog--specs-overlay) + (slime-trace-dialog--insert-and-overlay + "[waiting for some info on trace download progress ]" + slime-trace-dialog--progress-overlay) + (slime-trace-dialog--insert-and-overlay + "[waiting for the actual traces to be available]" + slime-trace-dialog--tree-overlay) + (setq slime-trace-dialog--brief-mode nil) + (current-buffer))))) + +(defun slime-trace-dialog--make-autofollow-fn (id) + (let ((requested nil)) + #'(lambda (_before after) + (let ((inhibit-point-motion-hooks t) + (id-after (get-text-property after 'slime-trace-dialog--id))) + (when (and (= after (point)) + slime-trace-dialog-autofollow + id-after + (= id-after id) + (not requested)) + (setq requested t) + (slime-eval-async `(swank-trace-dialog:report-trace-detail + ,id-after) + #'(lambda (detail) + (setq requested nil) + (when detail + (let ((inhibit-point-motion-hooks t)) + (slime-trace-dialog--open-detail detail + 'no-pop)))))))))) + +(defun slime-trace-dialog--set-collapsed (collapsed-p trace button) + (save-excursion + (setf (slime-trace-dialog--trace-collapsed-p trace) collapsed-p) + (slime-trace-dialog--go-replace-char-at + button + (if collapsed-p + (cdr slime-trace-dialog--collapse-chars) + (car slime-trace-dialog--collapse-chars))) + (slime-trace-dialog--hide-unhide + (slime-trace-dialog--trace-summary-beg trace) + (slime-trace-dialog--trace-end trace) + (if collapsed-p 1 -1)) + (slime-trace-dialog--hide-unhide + (slime-trace-dialog--trace-end trace) + (slime-trace-dialog--trace-children-end trace) + (if collapsed-p 1 -1)))) + +(defun slime-trace-dialog--hide-unhide (start-pos end-pos delta) + (loop with inhibit-read-only = t + for pos = start-pos then next + for next = (next-single-property-change + pos + 'slime-trace-dialog--hidden-level + nil + end-pos) + for hidden-level = (+ (or (get-text-property + pos + 'slime-trace-dialog--hidden-level) + 0) + delta) + do (add-text-properties pos next + (list 'slime-trace-dialog--hidden-level + hidden-level + 'invisible + (plusp hidden-level))) + while (< next end-pos))) + +(defun slime-trace-dialog--set-brief-mode () + (loop for trace being the hash-values of slime-trace-dialog--traces + do (slime-trace-dialog--hide-unhide + (slime-trace-dialog--trace-summary-beg trace) + (slime-trace-dialog--trace-end trace) + (if slime-trace-dialog--brief-mode 1 -1)))) + +(defun slime-trace-dialog--format-part (part-id part-text trace-id type) + (slime-trace-dialog--button + (format "%s" part-text) + #'(lambda (_button) + (slime-eval-async + `(swank-trace-dialog:inspect-trace-part ,trace-id ,part-id ,type) + #'slime-open-inspector)) + 'mouse-face 'highlight + 'face 'slime-inspector-value-face)) + +(defun slime-trace-dialog--format-trace-entry (id external) + (slime-trace-dialog--button + (format "%s" external) + #'(lambda (_button) + (slime-eval-async + `(swank::inspect-object (swank-trace-dialog::find-trace ,id)) + #'slime-open-inspector)) + 'face 'slime-inspector-value-face)) + +(defun slime-trace-dialog--format (fmt-string &rest args) + (let* ((string (apply #'format fmt-string args)) + (indent (make-string (max 2 + (- 50 (length string))) ? ))) + (format "%s%s" string indent))) + +(defun slime-trace-dialog--button (title lambda &rest props) + (let ((string (format "%s" title))) + (apply #'make-text-button string nil + 'action #'(lambda (button) + (funcall lambda button)) + 'mouse-face 'highlight + 'face 'slime-inspector-action-face + props) + string)) + +(defun slime-trace-dialog--call-maintaining-properties (pos fn) + (save-excursion + (goto-char pos) + (let* ((saved-props (text-properties-at pos)) + (saved-point (point)) + (inhibit-read-only t) + (inhibit-point-motion-hooks t)) + (funcall fn) + (add-text-properties saved-point (point) saved-props) + (if (markerp pos) (set-marker pos saved-point))))) + +(cl-defmacro slime-trace-dialog--maintaining-properties (pos + &body body) + (declare (indent 1)) + `(slime-trace-dialog--call-maintaining-properties ,pos #'(lambda () ,@body))) + +(defun slime-trace-dialog--go-replace-char-at (pos char) + (slime-trace-dialog--maintaining-properties pos + (delete-char 1) + (insert char))) + + +;;;; Handlers for the *trace-dialog* and *trace-detail* buffers +;;; +(defun slime-trace-dialog--open-specs (traced-specs) + (cl-flet ((make-report-spec-fn + (&optional form) + #'(lambda (_button) + (slime-eval-async + `(cl:progn + ,form + (swank-trace-dialog:report-specs)) + #'(lambda (results) + (slime-trace-dialog--open-specs results)))))) + (slime-trace-dialog--refresh + ((slime-trace-dialog--get-buffer) + :overlay slime-trace-dialog--specs-overlay + :recover-point-p t) + (insert + (slime-trace-dialog--format "Traced specs (%s)" (length traced-specs)) + (slime-trace-dialog--button "[refresh]" + (make-report-spec-fn)) + "\n" (make-string 50 ? ) + (slime-trace-dialog--button + "[untrace all]" + (make-report-spec-fn `(swank-trace-dialog:dialog-untrace-all))) + "\n\n") + (loop for spec in traced-specs + do (insert + " " + (slime-trace-dialog--button + "[untrace]" + (make-report-spec-fn + `(swank-trace-dialog:dialog-untrace ',spec))) + (format " %s" spec) + "\n"))))) + +(defun slime-trace-dialog--open-local-control () + (slime-trace-dialog--refresh + ((slime-trace-dialog--get-buffer) + :overlay slime-trace-dialog--local-control-overlay + :recover-point-p t) + (insert + (slime-trace-dialog--format "Autofollow is %s. " + (if slime-trace-dialog-autofollow "on" "off")) + (slime-trace-dialog--button "[toggle]" + #'(lambda (_button) + (setq slime-trace-dialog-autofollow + (not slime-trace-dialog-autofollow)) + (slime-trace-dialog--open-local-control))) + "\n" + (slime-trace-dialog--format "Brief mode is %s. " + (if slime-trace-dialog--brief-mode "on" "off")) + (slime-trace-dialog--button "[toggle]" + #'(lambda (_button) + (setq slime-trace-dialog--brief-mode + (not slime-trace-dialog--brief-mode)) + (slime-trace-dialog--set-brief-mode) + (slime-trace-dialog--open-local-control))) + "\n"))) + +(defvar slime-trace-dialog--fetch-key nil) + +(defvar slime-trace-dialog--stop-fetching nil) + +(defun slime-trace-dialog--update-progress (done remaining + &optional show-stop-p) + (slime-trace-dialog--refresh + ((slime-trace-dialog--get-buffer) + :overlay slime-trace-dialog--progress-overlay + :recover-point-p t) + (insert + (slime-trace-dialog--format "Trace collection status (%d/%s)" + done + (if remaining + (+ done remaining) + "?")) + (slime-trace-dialog--button "[refresh]" + #'(lambda (_button) + (slime-eval-async + '(swank-trace-dialog:report-total) + #'(lambda (total) + (slime-trace-dialog--update-progress + done + (- total done))))))) + + (when (and remaining (plusp remaining)) + (insert "\n" (make-string 50 ? ) + (slime-trace-dialog--button + "[fetch next batch]" + #'(lambda (_button) + (slime-trace-dialog-fetch-traces nil))) + "\n" (make-string 50 ? ) + (slime-trace-dialog--button + "[fetch all]" + #'(lambda (_button) + (slime-trace-dialog-fetch-traces t))))) + (when (and done remaining (plusp done)) + (insert "\n" (make-string 50 ? ) + (slime-trace-dialog--button + "[clear]" + #'(lambda (_button) + (slime-eval-async + '(swank-trace-dialog:clear-trace-tree) + #'(lambda (_ignored) + (slime-trace-dialog--clear-local-tree 0))))))) + (when show-stop-p + (insert "\n" (make-string 50 ? ) + (slime-trace-dialog--button + "[stop]" + #'(lambda (_button) + (setq slime-trace-dialog--stop-fetching t))))) + (insert "\n\n"))) + +(defun slime-trace-dialog--open-detail (trace-tuple &optional no-pop) + (slime-trace-dialog--refresh + ((or (get-buffer "*trace-detail*") + (slime-with-popup-buffer ("*trace-detail*" + :mode 'slime-trace-dialog--detail-mode)) + (get-buffer "*trace-detail*"))) + (if no-pop + (display-buffer (current-buffer)) + (pop-to-buffer (current-buffer))) + (destructuring-bind (id _parent-id _spec args retlist backtrace external) + trace-tuple + (let ((headline (slime-trace-dialog--format-trace-entry id external))) + (setq headline (format "%s\n%s\n" + headline + (make-string (length headline) ?-))) + (insert headline)) + (loop for (type objects label) + in `((:arg ,args "Called with args:") + (:retval ,retlist "Returned values:")) + do (insert (format "\n%s\n" label)) + (insert (loop for object in objects + for i from 0 + concat (format " %s: %s\n" i + (slime-trace-dialog--format-part + (first object) + (second object) + id + type))))) + (when backtrace + (insert "\nBacktrace:\n" + (loop for (i spec) in backtrace + concat (format " %s: %s\n" i spec)))) + ))) + + +;;;; Rendering traces +;;; + +(defun slime-trace-dialog--draw-tree-lines (start offset direction) + (save-excursion + (let ((inhibit-point-motion-hooks t)) + (goto-char start) + (loop with replace-set = (if (eq direction 'down) + '(? ) + '(? ?`)) + for line-beginning = (line-beginning-position + (if (eq direction 'down) + 2 0)) + for pos = (+ line-beginning offset) + while (and (< (point-min) line-beginning) + (< line-beginning (point-max)) + (memq (char-after pos) replace-set)) + do + (slime-trace-dialog--go-replace-char-at pos "|") + (goto-char pos))))) + +(defun slime-trace-dialog--make-indent (depth suffix) + (concat (make-string (* 3 (max 0 (1- depth))) ? ) + (if (plusp depth) suffix))) + +(defun slime-trace-dialog--make-collapse-button (trace) + (slime-trace-dialog--button (if (slime-trace-dialog--trace-collapsed-p trace) + (cdr slime-trace-dialog--collapse-chars) + (car slime-trace-dialog--collapse-chars)) + #'(lambda (button) + (slime-trace-dialog--set-collapsed + (not (slime-trace-dialog--trace-collapsed-p + trace)) + trace + button)))) + + +(defun slime-trace-dialog--insert-trace (trace) + (let* ((id (slime-trace-dialog--trace-id trace)) + (parent (slime-trace-dialog--trace-parent trace)) + (has-children-p (slime-trace-dialog--trace-children-end trace)) + (indent-spec (slime-trace-dialog--make-indent + (slime-trace-dialog--trace-depth trace) + "`--")) + (indent-summary (slime-trace-dialog--make-indent + (slime-trace-dialog--trace-depth trace) + " ")) + (autofollow-fn (slime-trace-dialog--make-autofollow-fn id)) + (id-string (slime-trace-dialog--button + (format "%4s" id) + #'(lambda (_button) + (slime-eval-async + `(swank-trace-dialog:report-trace-detail + ,id) + #'slime-trace-dialog--open-detail)))) + (spec (slime-trace-dialog--trace-spec trace)) + (summary (loop for (type objects marker) in + `((:arg ,(slime-trace-dialog--trace-args trace) + " > ") + (:retval ,(slime-trace-dialog--trace-retlist trace) + " < ")) + concat (loop for object in objects + concat " " + concat indent-summary + concat marker + concat (slime-trace-dialog--format-part + (first object) + (second object) + id + type) + concat "\n")))) + (puthash id trace slime-trace-dialog--traces) + ;; insert and propertize the text + ;; + (setf (slime-trace-dialog--trace-beg trace) (point-marker)) + (insert id-string " ") + (insert indent-spec) + (if has-children-p + (insert (slime-trace-dialog--make-collapse-button trace)) + (setf (slime-trace-dialog--trace-collapse-button-marker trace) + (point-marker))) + (insert (format " %s\n" spec)) + (setf (slime-trace-dialog--trace-summary-beg trace) (point-marker)) + (insert summary) + (setf (slime-trace-dialog--trace-end trace) (point-marker)) + + (add-text-properties (slime-trace-dialog--trace-beg trace) + (slime-trace-dialog--trace-end trace) + (list 'slime-trace-dialog--id id + 'point-entered autofollow-fn + 'point-left autofollow-fn)) + ;; respect brief mode and collapsed state + ;; + (loop for condition in (list slime-trace-dialog--brief-mode + (slime-trace-dialog--trace-collapsed-p trace)) + when condition + do (slime-trace-dialog--hide-unhide + (slime-trace-dialog--trace-summary-beg + trace) + (slime-trace-dialog--trace-end trace) + 1)) + (loop for tr = trace then parent + for parent = (slime-trace-dialog--trace-parent tr) + while parent + when (slime-trace-dialog--trace-collapsed-p parent) + do (slime-trace-dialog--hide-unhide + (slime-trace-dialog--trace-beg trace) + (slime-trace-dialog--trace-end trace) + (+ 1 + (or (get-text-property (slime-trace-dialog--trace-beg parent) + 'slime-trace-dialog--hidden-level) + 0))) + (return)) + ;; maybe add the collapse-button to the parent in case it didn't + ;; have one already + ;; + (when (and parent + (slime-trace-dialog--trace-collapse-button-marker parent)) + (slime-trace-dialog--maintaining-properties + (slime-trace-dialog--trace-collapse-button-marker parent) + (insert (slime-trace-dialog--make-collapse-button parent)) + (setf (slime-trace-dialog--trace-collapse-button-marker parent) + nil))) + ;; draw the tree lines + ;; + (when parent + (slime-trace-dialog--draw-tree-lines (slime-trace-dialog--trace-beg trace) + (+ 2 (length indent-spec)) + 'up)) + (when has-children-p + (slime-trace-dialog--draw-tree-lines (slime-trace-dialog--trace-beg trace) + (+ 5 (length indent-spec)) + 'down)) + ;; set the "children-end" slot + ;; + (unless (slime-trace-dialog--trace-children-end trace) + (loop for parent = trace + then (slime-trace-dialog--trace-parent parent) + while parent + do + (setf (slime-trace-dialog--trace-children-end parent) + (slime-trace-dialog--trace-end trace)))))) + +(defun slime-trace-dialog--render-trace (trace) + ;; Render the trace entry in the appropriate place. + ;; + ;; A trace becomes a few lines of slightly propertized text in the + ;; buffer, inserted by `slime-trace-dialog--insert-trace', bound by + ;; point markers that we use here. + ;; + ;; The new trace might be replacing an existing one, or otherwise + ;; must be placed under its existing parent which might or might not + ;; be the last entry inserted. + ;; + (let ((existing (slime-trace-dialog--find-trace + (slime-trace-dialog--trace-id trace))) + (parent (slime-trace-dialog--trace-parent trace))) + (cond (existing + ;; Other traces might already reference `existing' and with + ;; need to maintain that eqness. Best way to do that is + ;; destructively modify `existing' with the new retlist... + ;; + (setf (slime-trace-dialog--trace-retlist existing) + (slime-trace-dialog--trace-retlist trace)) + ;; Now, before deleting and re-inserting `existing' at an + ;; arbitrary point in the tree, note that it's + ;; "children-end" marker is already non-nil, and informs us + ;; about its parenthood status. We want to 1. leave it + ;; alone if it's already a parent, or 2. set it to nil if + ;; it's a leaf, thus forcing the needed update of the + ;; parents' "children-end" marker. + ;; + (when (= (slime-trace-dialog--trace-children-end existing) + (slime-trace-dialog--trace-end existing)) + (setf (slime-trace-dialog--trace-children-end existing) nil)) + (delete-region (slime-trace-dialog--trace-beg existing) + (slime-trace-dialog--trace-end existing)) + (goto-char (slime-trace-dialog--trace-end existing)) + ;; Remember to set `trace' to be `existing' + ;; + (setq trace existing)) + (parent + (goto-char (1+ (slime-trace-dialog--trace-children-end parent)))) + (;; top level trace + t + (goto-char (point-max)))) + (goto-char (line-beginning-position)) + (slime-trace-dialog--insert-trace trace))) + +(defun slime-trace-dialog--update-tree (tuples) + (save-excursion + (slime-trace-dialog--refresh + ((slime-trace-dialog--get-buffer) + :overlay slime-trace-dialog--tree-overlay + :dont-erase t) + (loop for tuple in tuples + for parent = (slime-trace-dialog--find-trace (second tuple)) + for trace = (slime-trace-dialog--make-trace + :id (first tuple) + :parent parent + :spec (third tuple) + :args (fourth tuple) + :retlist (fifth tuple) + :depth (if parent + (1+ (slime-trace-dialog--trace-depth + parent)) + 0)) + do (slime-trace-dialog--render-trace trace))))) + +(defun slime-trace-dialog--clear-local-tree (&optional remaining) + (set (make-local-variable 'slime-trace-dialog--fetch-key) + (cl-gensym "slime-trace-dialog-fetch-key-")) + (set (make-local-variable 'slime-trace-dialog--traces) + (make-hash-table)) + (slime-trace-dialog--refresh + ((slime-trace-dialog--get-buffer) + :overlay slime-trace-dialog--tree-overlay)) + (slime-trace-dialog--update-progress 0 remaining)) + +(defun slime-trace-dialog--on-new-results (results &optional recurse) + (destructuring-bind (tuples remaining reply-key) + results + (cond ((and slime-trace-dialog--fetch-key + (string= (symbol-name slime-trace-dialog--fetch-key) + (symbol-name reply-key))) + (slime-trace-dialog--update-tree tuples) + (slime-trace-dialog--update-progress + (hash-table-count slime-trace-dialog--traces) + remaining + (and recurse + (plusp remaining))) + (when (and recurse + (not (prog1 slime-trace-dialog--stop-fetching + (setq slime-trace-dialog--stop-fetching nil))) + (plusp remaining)) + (slime-eval-async `(swank-trace-dialog:report-partial-tree + ',reply-key) + #'(lambda (results) (slime-trace-dialog--on-new-results + results + recurse)))))))) + + +;;;; Interactive functions +;;; +(defun slime-trace-dialog-fetch-status () + "Refresh just the status part of the trace dialog" + (interactive) + (with-current-buffer + (pop-to-buffer (slime-trace-dialog--get-buffer)) + (slime-trace-dialog--open-local-control) + (slime-eval-async `(swank-trace-dialog:report-specs) + #'slime-trace-dialog--open-specs))) + +(defun slime-trace-dialog-fetch-traces (&optional recurse) + (interactive "P") + (with-current-buffer + (pop-to-buffer (slime-trace-dialog--get-buffer)) + (setq slime-trace-dialog--stop-fetching nil) + (slime-eval-async `(swank-trace-dialog:report-partial-tree + ',slime-trace-dialog--fetch-key) + #'(lambda (results) (slime-trace-dialog--on-new-results results + recurse))))) + +(defun slime-trace-dialog-next-button (&optional goback) + (interactive) + (let ((finder (if goback + #'previous-single-property-change + #'next-single-property-change))) + (loop for pos = (funcall finder (point) 'action) + while pos + do (goto-char pos) + until (get-text-property pos 'action)))) + +(defun slime-trace-dialog-prev-button () + (interactive) + (slime-trace-dialog-next-button 'goback)) + +(defun slime-trace-dialog-toggle-trace (&optional using-context-p) + "Toggle the dialog-trace of the spec at point. + +When USING-CONTEXT-P, attempt to decipher lambdas. methods and +other complicated function specs." + (interactive "P") + ;; Notice the use of "spec strings" here as opposed to the + ;; proper cons specs we use on the swank side. + ;; + ;; Notice the conditional use of `slime-trace-query' found in + ;; swank-fancy-trace.el + ;; + (let* ((spec-string (if using-context-p + (slime-extract-context) + (slime-symbol-at-point))) + (spec-string (if (fboundp 'slime-trace-query) + (slime-trace-query spec-string) + spec-string))) + (message "%s" (slime-eval `(swank-trace-dialog:dialog-toggle-trace + (swank::from-string ,spec-string)))))) + +(defun slime-trace-dialog (&optional just-one-batch) + "Show trace dialog and fetch all traces from the beginning. + +With optional JUST-ONE-BATCH prefix arg, fetch just first batch of +traces." + (interactive "P") + (with-current-buffer + (pop-to-buffer (slime-trace-dialog--get-buffer)) + (slime-trace-dialog-fetch-status) + (overlay-put slime-trace-dialog--tree-overlay + 'slime-trace-dialog--collected nil) + (slime-trace-dialog--clear-local-tree) + (slime-trace-dialog-fetch-traces (not just-one-batch)))) + +(provide 'slime-trace-dialog) Index: contrib/swank-trace-dialog.lisp =================================================================== RCS file: contrib/swank-trace-dialog.lisp diff -N contrib/swank-trace-dialog.lisp --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ contrib/swank-trace-dialog.lisp 24 Nov 2013 23:30:12 -0000 @@ -0,0 +1,255 @@ +(defpackage :swank-trace-dialog + (:use :cl) + (:nicknames :std) + (:import-from :swank :defslimefun :from-string :to-string) + (:export #:clear-trace-tree + #:dialog-toggle-trace + #:dialog-trace + #:dialog-traced-p + #:dialog-untrace + #:dialog-untrace-all + #:inspect-trace-part + #:report-partial-tree + #:report-specs + #:report-total + #:report-trace-detail + #:report-specs + #:trace-format + #:still-inside + #:exited-non-locally + #:*record-backtrace* + #:*traces-per-report* + #:*dialog-trace-follows-trace*)) + +(in-package :swank-trace-dialog) + +(defparameter *record-backtrace* nil + "Record a backtrace of the last 20 calls for each trace. + +Beware that this may have a drastic performance impact on your +program.") + +(defparameter *traces-per-report* 150 + "Number of traces to report to emacs in each batch.") + + +;;;; `trace-entry' model +;;;; +(defvar *traces* (make-array 1000 :fill-pointer 0 + :adjustable t)) + +(defvar *trace-lock* (swank-backend:make-lock :name "swank-trace-dialog lock")) + +(defvar *current-trace-by-thread* (make-hash-table)) + +(defclass trace-entry () + ((id :reader id-of) + (children :accessor children-of :initform nil) + (backtrace :accessor backtrace-of :initform (when *record-backtrace* + (useful-backtrace))) + + (spec :initarg :spec :accessor spec-of + :initform (error "must provide a spec")) + (args :initarg :args :accessor args-of + :initform (error "must provide args")) + (parent :initarg :parent :reader parent-of + :initform (error "must provide a parent, even if nil")) + (retlist :initarg :retlist :accessor retlist-of + :initform 'still-inside))) + +(defmethod initialize-instance :after ((entry trace-entry) &rest initargs) + (declare (ignore initargs)) + (if (parent-of entry) + (nconc (children-of (parent-of entry)) (list entry))) + (swank-backend:call-with-lock-held + *trace-lock* + #'(lambda () + (setf (slot-value entry 'id) (fill-pointer *traces*)) + (vector-push-extend entry *traces*)))) + +(defmethod print-object ((entry trace-entry) stream) + (print-unreadable-object (entry stream) + (format stream "~a: ~a" (id-of entry) (spec-of entry)))) + +(defun completed-p (trace) (not (eq (retlist-of trace) 'still-inside))) + +(defun find-trace (id) + (when (<= 0 id (1- (length *traces*))) + (aref *traces* id))) + +(defun useful-backtrace () + (swank-backend:call-with-debugging-environment + #'(lambda () + (loop for i from 0 + for frame in (swank-backend:compute-backtrace 0 20) + collect (list i (swank::frame-to-string frame)))))) + +(defun current-trace () + (gethash (swank-backend:current-thread) *current-trace-by-thread*)) + +(defun (setf current-trace) (trace) + (setf (gethash (swank-backend:current-thread) *current-trace-by-thread*) + trace)) + + +;;;; Control of traced specs +;;; +(defvar *traced-specs* '()) + +(defslimefun dialog-trace (spec) + (flet ((before-hook (args) + (setf (current-trace) (make-instance 'trace-entry + :spec spec + :args args + :parent (current-trace)))) + (after-hook (retlist) + (let ((trace (current-trace))) + (when trace + ;; the current trace might have been wiped away if the + ;; user cleared the tree in the meantime. no biggie, + ;; don't do anything. + ;; + (setf (retlist-of trace) (or retlist + 'exited-non-locally) + (current-trace) (parent-of trace)))))) + (when (dialog-traced-p spec) + (warn "~a is apparently already traced! Untracing and retracing." spec) + (dialog-untrace spec)) + (swank-backend:wrap spec 'trace-dialog + :before #'before-hook + :after #'after-hook) + (pushnew spec *traced-specs*) + (format nil "~a is now traced for trace dialog" spec))) + +(defslimefun dialog-untrace (spec) + (swank-backend:unwrap spec 'trace-dialog) + (setq *traced-specs* (remove spec *traced-specs* :test #'equal)) + (format nil "~a is now untraced for trace dialog" spec)) + +(defslimefun dialog-toggle-trace (spec) + (if (dialog-traced-p spec) + (dialog-untrace spec) + (dialog-trace spec))) + +(defslimefun dialog-traced-p (spec) + (find spec *traced-specs* :test #'equal)) + +(defslimefun dialog-untrace-all () + (untrace) + (mapcar #'dialog-untrace *traced-specs*)) + +(defparameter *dialog-trace-follows-trace* nil) + +(setq swank:*after-toggle-trace-hook* + #'(lambda (spec traced-p) + (when *dialog-trace-follows-trace* + (cond (traced-p + (dialog-trace spec) + "traced for trace dialog as well") + (t + (dialog-untrace spec) + "untraced for the trace dialog as well"))))) + + +;;;; A special kind of trace call +;;; +(defun trace-format (format-spec &rest format-args) + "Make a string from FORMAT-SPEC and FORMAT-ARGS and as a trace." + (let* ((line (apply #'format nil format-spec format-args))) + (make-instance 'trace-entry :spec line + :args format-args + :parent (current-trace) + :retlist nil))) + + +;;;; Reporting to emacs +;;; +(defparameter *visitor-idx* 0) + +(defparameter *visitor-key* nil) + +(defvar *unfinished-traces* '()) + +(defun describe-trace-for-emacs (trace) + `(,(id-of trace) + ,(and (parent-of trace) (id-of (parent-of trace))) + ,(spec-of trace) + ,(loop for arg in (args-of trace) + for i from 0 + collect (list i (swank::to-line arg))) + ,(loop for retval in (swank::ensure-list (retlist-of trace)) + for i from 0 + collect (list i (swank::to-line retval))))) + +(defslimefun report-partial-tree (key) + (unless (equal key *visitor-key*) + (setq *visitor-idx* 0 + *visitor-key* key)) + (let* ((recently-finished + (loop with i = 0 + for trace in *unfinished-traces* + while (< i *traces-per-report*) + when (completed-p trace) + collect trace + and do + (incf i) + (setq *unfinished-traces* + (remove trace *unfinished-traces*)))) + (new (loop for i + from (length recently-finished) + below *traces-per-report* + while (< *visitor-idx* (length *traces*)) + for trace = (aref *traces* *visitor-idx*) + collect trace + unless (completed-p trace) + do (push trace *unfinished-traces*) + do (incf *visitor-idx*)))) + (list + (mapcar #'describe-trace-for-emacs + (append recently-finished new)) + (- (length *traces*) *visitor-idx*) + key))) + +(defslimefun report-trace-detail (trace-id) + (swank::call-with-bindings + swank::*inspector-printer-bindings* + #'(lambda () + (let ((trace (find-trace trace-id))) + (when trace + (append + (describe-trace-for-emacs trace) + (list (backtrace-of trace) + (swank::to-line trace)))))))) + +(defslimefun report-specs () + (sort (copy-list *traced-specs*) + #'string< + :key #'princ-to-string)) + +(defslimefun report-total () + (length *traces*)) + +(defslimefun clear-trace-tree () + (setf *current-trace-by-thread* (clrhash *current-trace-by-thread*) + *visitor-key* nil + *unfinished-traces* nil) + (swank-backend:call-with-lock-held + *trace-lock* + #'(lambda () (setf (fill-pointer *traces*) 0))) + nil) + +;; HACK: `swank::*inspector-history*' is unbound by default and needs +;; a reset in that case so that it won't error `swank::inspect-object' +;; before any other object is inspected in the slime session. +;; +(unless (boundp 'swank::*inspector-history*) + (swank::reset-inspector)) + +(defslimefun inspect-trace-part (trace-id part-id type) + (let* ((trace (find-trace trace-id)) + (list (ecase type + (:arg (args-of trace)) + (:retval (swank::ensure-list (retlist-of trace)))))) + (swank::inspect-object (nth part-id list)))) + +(provide :swank-trace-dialog)