Skip to content

Commit

Permalink
slime-fancy-trace.el: New contrib.
Browse files Browse the repository at this point in the history
  • Loading branch information
Helmut Eller committed May 26, 2013
1 parent 95cab93 commit 4330484
Show file tree
Hide file tree
Showing 3 changed files with 105 additions and 61 deletions.
66 changes: 66 additions & 0 deletions contrib/slime-fancy-trace.el
View file
Original file line number Diff line number Diff line change
@@ -0,0 +1,66 @@

(define-slime-contrib slime-fancy-trace
"Enhanced version of slime-trace capable of tracing local functions,
methods, setf functions, and other entities supported by specific
swank:swank-toggle-trace backends. Invoke via C-u C-t."
(:authors "Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de>"
"Tobias C. Rittweiler <tcr@freebits.de>")
(:license "GPL")
(:slime-dependencies slime-parse))

(defun slime-trace-query (spec)
"Ask the user which function to trace; SPEC is the default.
The result is a string."
(cond ((null spec)
(slime-read-from-minibuffer "(Un)trace: "))
((stringp spec)
(slime-read-from-minibuffer "(Un)trace: " spec))
((symbolp spec) ; `slime-extract-context' can return symbols.
(slime-read-from-minibuffer "(Un)trace: " (prin1-to-string spec)))
(t
(destructure-case spec
((setf n)
(slime-read-from-minibuffer "(Un)trace: " (prin1-to-string spec)))
((:defun n)
(slime-read-from-minibuffer "(Un)trace: " (prin1-to-string n)))
((:defgeneric n)
(let* ((name (prin1-to-string n))
(answer (slime-read-from-minibuffer "(Un)trace: " name)))
(cond ((and (string= name answer)
(y-or-n-p (concat "(Un)trace also all "
"methods implementing "
name "? ")))
(prin1-to-string `(:defgeneric ,n)))
(t
answer))))
((:defmethod &rest _)
(slime-read-from-minibuffer "(Un)trace: " (prin1-to-string spec)))
((:call caller callee)
(let* ((callerstr (prin1-to-string caller))
(calleestr (prin1-to-string callee))
(answer (slime-read-from-minibuffer "(Un)trace: "
calleestr)))
(cond ((and (string= calleestr answer)
(y-or-n-p (concat "(Un)trace only when " calleestr
" is called by " callerstr "? ")))
(prin1-to-string `(:call ,caller ,callee)))
(t
answer))))
(((:labels :flet) &rest _)
(slime-read-from-minibuffer "(Un)trace local function: "
(prin1-to-string spec)))
(t (error "Don't know how to trace the spec %S" spec))))))

(defun slime-toggle-fancy-trace (&optional using-context-p)
"Toggle trace."
(interactive "P")
(let* ((spec (if using-context-p
(slime-extract-context)
(slime-symbol-at-point)))
(spec (slime-trace-query spec)))
(message "%s" (slime-eval `(swank:swank-toggle-trace ,spec)))))

;; override slime-toggle-trace-fdefinition
(define-key slime-prefix-map "\C-t" 'slime-toggle-fancy-trace)

(provide 'slime-fancy-trace)
1 change: 1 addition & 0 deletions contrib/slime-fancy.el
View file
Original file line number Diff line number Diff line change
Expand Up @@ -9,6 +9,7 @@
slime-c-p-c
slime-editing-commands
slime-fancy-inspector
slime-fancy-trace
slime-fuzzy
slime-presentations
slime-scratch
Expand Down
99 changes: 38 additions & 61 deletions contrib/slime-parse.el
View file
Original file line number Diff line number Diff line change
Expand Up @@ -124,24 +124,44 @@ that the character is not escaped."
(def-slime-test form-up-to-point.1
(buffer-sexpr result-form &optional skip-trailing-test-p)
""
'(("(char= #\\(*HERE*" ("char=" "#\\(" swank::%cursor-marker%))
("(char= #\\( *HERE*" ("char=" "#\\(" "" swank::%cursor-marker%))
("(char= #\\) *HERE*" ("char=" "#\\)" "" swank::%cursor-marker%))
("(char= #\\*HERE*" ("char=" "#\\" swank::%cursor-marker%) t)
("(defun*HERE*" ("defun" swank::%cursor-marker%))
("(defun foo*HERE*" ("defun" "foo" swank::%cursor-marker%))
("(defun foo (x y)*HERE*" ("defun" "foo" ("x" "y") swank::%cursor-marker%))
("(defun foo (x y*HERE*" ("defun" "foo" ("x" "y" swank::%cursor-marker%)))
("(apply 'foo*HERE*" ("apply" "'foo" swank::%cursor-marker%))
("(apply #'foo*HERE*" ("apply" "#'foo" swank::%cursor-marker%))
("(declare ((vector bit *HERE*" ("declare" (("vector" "bit" "" swank::%cursor-marker%))))
("(with-open-file (*HERE*" ("with-open-file" ("" swank::%cursor-marker%)))
("(((*HERE*" ((("" swank::%cursor-marker%))))
("(defun #| foo #| *HERE*" ("defun" "" swank::%cursor-marker%))
("(defun #-(and) (bar) f*HERE*" ("defun" "f" swank::%cursor-marker%))
("(remove-if #'(lambda (x)*HERE*" ("remove-if" ("lambda" ("x") swank::%cursor-marker%)))
("`(remove-if ,(lambda (x)*HERE*" ("remove-if" ("lambda" ("x") swank::%cursor-marker%)))
("`(remove-if ,@(lambda (x)*HERE*" ("remove-if" ("lambda" ("x") swank::%cursor-marker%))))
'(("(char= #\\(*HERE*"
("char=" "#\\(" swank::%cursor-marker%))
("(char= #\\( *HERE*"
("char=" "#\\(" "" swank::%cursor-marker%))
("(char= #\\) *HERE*"
("char=" "#\\)" "" swank::%cursor-marker%))
("(char= #\\*HERE*"
("char=" "#\\" swank::%cursor-marker%) t)
("(defun*HERE*"
("defun" swank::%cursor-marker%))
("(defun foo*HERE*"
("defun" "foo" swank::%cursor-marker%))
("(defun foo (x y)*HERE*"
("defun" "foo"
("x" "y") swank::%cursor-marker%))
("(defun foo (x y*HERE*"
("defun" "foo"
e("x" "y" swank::%cursor-marker%)))
("(apply 'foo*HERE*"
("apply" "'foo" swank::%cursor-marker%))
("(apply #'foo*HERE*"
("apply" "#'foo" swank::%cursor-marker%))
("(declare ((vector bit *HERE*"
("declare" (("vector" "bit" "" swank::%cursor-marker%))))
("(with-open-file (*HERE*"
e("with-open-file" ("" swank::%cursor-marker%)))
("(((*HERE*"
((("" swank::%cursor-marker%))))
("(defun #| foo #| *HERE*"
("defun" "" swank::%cursor-marker%))
("(defun #-(and) (bar) f*HERE*"
("defun" "f" swank::%cursor-marker%))
("(remove-if #'(lambda (x)*HERE*"
("remove-if" ("lambda" ("x") swank::%cursor-marker%)))
("`(remove-if ,(lambda (x)*HERE*"
("remove-if" ("lambda" ("x") swank::%cursor-marker%)))
("`(remove-if ,@(lambda (x)*HERE*"
("remove-if" ("lambda" ("x") swank::%cursor-marker%))))
(slime-check-top-level)
(with-temp-buffer
(lisp-mode)
Expand All @@ -154,49 +174,6 @@ that the character is not escaped."
(slime-check-buffer-form result-form))
))

(defun slime-trace-query (spec)
"Ask the user which function to trace; SPEC is the default.
The result is a string."
(cond ((null spec)
(slime-read-from-minibuffer "(Un)trace: "))
((stringp spec)
(slime-read-from-minibuffer "(Un)trace: " spec))
((symbolp spec) ; `slime-extract-context' can return symbols.
(slime-read-from-minibuffer "(Un)trace: " (prin1-to-string spec)))
(t
(destructure-case spec
((setf n)
(slime-read-from-minibuffer "(Un)trace: " (prin1-to-string spec)))
((:defun n)
(slime-read-from-minibuffer "(Un)trace: " (prin1-to-string n)))
((:defgeneric n)
(let* ((name (prin1-to-string n))
(answer (slime-read-from-minibuffer "(Un)trace: " name)))
(cond ((and (string= name answer)
(y-or-n-p (concat "(Un)trace also all "
"methods implementing "
name "? ")))
(prin1-to-string `(:defgeneric ,n)))
(t
answer))))
((:defmethod &rest _)
(slime-read-from-minibuffer "(Un)trace: " (prin1-to-string spec)))
((:call caller callee)
(let* ((callerstr (prin1-to-string caller))
(calleestr (prin1-to-string callee))
(answer (slime-read-from-minibuffer "(Un)trace: "
calleestr)))
(cond ((and (string= calleestr answer)
(y-or-n-p (concat "(Un)trace only when " calleestr
" is called by " callerstr "? ")))
(prin1-to-string `(:call ,caller ,callee)))
(t
answer))))
(((:labels :flet) &rest _)
(slime-read-from-minibuffer "(Un)trace local function: "
(prin1-to-string spec)))
(t (error "Don't know how to trace the spec %S" spec))))))

(defun slime-extract-context ()
"Parse the context for the symbol at point.
Nil is returned if there's no symbol at point. Otherwise we detect
Expand Down

0 comments on commit 4330484

Please sign in to comment.