source: trunk/source/contrib/foy/hemlock-commands-cm/hemlock-commands-new.lisp @ 12745

Last change on this file since 12745 was 12745, checked in by gfoy, 11 years ago

Added 'Show Callers', control-meta-c

File size: 7.1 KB
Line 
1;;;-*-Mode: LISP; Package: HEMLOCK-COMMANDS-TOOL -*-
2
3;;; ----------------------------------------------------------------------------
4;;;
5;;;      hemlock-commands-new.lisp
6;;;
7;;;      copyright (c) 2009 Glen Foy
8;;;      (Permission is granted to Clozure Associates to distribute this file.)
9;;;
10;;;      This code implements a two new Hemlock commands.
11;;;
12;;;      This software is offered "as is", without warranty of any kind.
13;;;
14;;;      Mod History, most recent first:
15;;;      9/2/9   Added "Show Callers" command.
16;;;      8/31/9  version 0.1b1
17;;;              First cut.
18;;;
19;;; ----------------------------------------------------------------------------
20
21(in-package "HEMLOCK-COMMANDS")
22
23(defparameter *MCL-doc* (merge-pathnames ";MCL-doc.lisp" cl-user::*hemlock-commands-directory*))
24
25;;; Hemlock has some internal code to do this, but it appears to be broken
26;;; and definitely does not work for ObjC methods.
27(defun parse-symbol ()
28  "Parse and return the symbol at point."
29  (let ((point (hi::current-point)))
30    (hemlock::pre-command-parse-check point)
31    (hi::with-mark ((mark1 point)
32                    (mark2 point))
33      (hemlock::mark-symbol mark1 mark2)
34      ;; For an objc method, mark-symbol removes the prepended #\#
35      (let* ((string (hi::region-to-string (hi::region mark1 mark2)))
36             (objc-p (when string (char= (elt string 0) #\/)))
37             (colons-start-position (when string
38                                      (unless objc-p (position #\: string))))
39             (colons-end-position (when colons-start-position
40                                    (if (char= (elt string (1+ colons-start-position)) #\:)
41                                      (1+ colons-start-position)
42                                      colons-start-position)))
43             (package-prefix (when colons-start-position
44                               (string-upcase (subseq string 0 colons-start-position))))
45             (sym-string (if colons-end-position
46                           (subseq string (incf colons-end-position))
47                           string))
48             (package (if objc-p
49                        (find-package "NEXTSTEP-FUNCTIONS")
50                        (when package-prefix (find-package package-prefix))))
51             symbol)
52        (when (and sym-string objc-p)
53          (setq sym-string (subseq sym-string 1))) ;chuck the #\/
54        (setq symbol (if package
55                       (if objc-p
56                         (find-symbol sym-string package)
57                         (find-symbol (string-upcase sym-string) package))
58                       (find-symbol (string-upcase sym-string) (hemlock::buffer-package hi::*current-buffer*))))
59        symbol))))
60
61(hemlock::defcommand "Inspect Symbol" (p)
62  "Open the Inspector for the symbol at point."
63  (declare (ignore p))
64  (let ((symbol (parse-symbol)))
65    (cond (symbol 
66           (inspect symbol))
67          (t
68           (hi::editor-error "Could not parse a valid symbol at point.")))))
69
70(hi::bind-key "Inspect Symbol" #k"control-x control-i")
71
72(defun MCL-documentation (symbol)
73  "Fetch the MCL documentation for SYMBOL."
74  (let ((path *MCL-doc*))
75    (when (probe-file path)
76      (with-open-file (stream path :direction :input)
77        (let (sym args type doc)
78          (loop
79            (setq sym (read stream nil :eof))
80            (setq args (read stream nil :eof))
81            (setq type (read stream nil :eof))
82            (setq doc (read stream nil :eof))
83            (cond ((eq sym :eof)
84                   (return-from MCL-documentation))
85                  ((eq sym symbol)
86                   (return (values args type doc))))))))))
87
88(defun display-ccl-doc (sym text-view)
89  "Display the CCL documentation for SYM, if it exists."
90  (let (docstring args)
91    (dolist (doctype '(compiler-macro function method-combination
92                                      setf structure t type variable))
93      (when (setq docstring (documentation sym doctype))
94        (when (eq doctype 'function) 
95          (setq args (arglist sym))
96          (when (macro-function sym) (setq doctype 'macro))
97          (when (special-form-p sym) (setq doctype 'special-form)))
98        (when (eq doctype 'type)
99          (when (find-class sym nil)
100            (setq doctype 'class)))
101        (open-documentation-dialog
102         (if args
103           (format nil "~A  ~A" (string-upcase sym) 
104                   (string-downcase (format nil "~A" args)))
105           (string-upcase sym))
106         (format nil "[~A]" (string-capitalize (string-downcase (string doctype))))
107         docstring :text-view text-view :symbol sym)
108        (return t)))))
109
110(defun display-mcl-doc (sym text-view)
111  "Display the MCL documentation for SYM, if it exists."
112  (multiple-value-bind (args type doc)
113                       (MCL-documentation sym)
114    (when doc
115      (setq doc (substitute #\space #\newline doc))
116      (open-documentation-dialog
117       (if args
118         (format nil "~A  ~A" (string-upcase sym) 
119                 (string-downcase (format nil "~A" args)))
120         (string-upcase sym)) 
121       type 
122       (concatenate 'string doc "    (MCL)")
123       :text-view text-view :symbol sym) t)))
124 
125(hi:defcommand "Symbol Documentation" (p)
126  "Display the documentation for the symbol at point."
127  (declare (ignore p))
128  (let* ((sym (parse-symbol))
129         (hemlock-view (hi::current-view))
130         (pane (when hemlock-view (hi::hemlock-view-pane hemlock-view)))
131         (text-view (when pane (gui::text-pane-text-view pane))))
132      (cond ((and sym text-view)
133             (cond ((eq (symbol-package sym) (find-package :common-lisp))
134                    (or (display-ccl-doc sym text-view)
135                        (display-mcl-doc sym text-view)
136                        (gui::lookup-hyperspec-symbol sym text-view)))
137                   (t
138                    (or (display-ccl-doc sym text-view)
139                        (open-documentation-dialog
140                         (format nil "No documentation found for ~S" sym) nil nil)))))
141            (t
142             (hi::editor-error "Could not parse a valid symbol at point.")))))
143
144(hi::bind-key "Symbol Documentation" #k"control-x control-d")
145
146(hi:defcommand "Show Callers" (p)
147  "Display a scrolling list of the callers of the symbol at point.
148   Double-click a row to go to the caller's definition."
149  (declare (ignore p))
150  (let* ((symbol (parse-symbol))
151         (callers (ccl::callers symbol)))
152    (cond (symbol
153           (if callers
154             (make-instance 'gui::sequence-window-controller
155               :title (format nil "Callers of ~a" symbol)
156               :sequence (mapcar #'(lambda (entry)
157                                     (if (listp entry)
158                                       (car (last entry))
159                                       entry))
160                                 (ccl::callers symbol))
161               :result-callback #'hemlock::edit-definition
162               :display #'princ)
163             (gui::alert-window :title "Notification"
164                                :message (format nil "Could not find any callers for ~S" symbol))))
165          (t
166           (hi::editor-error "Could not parse a valid symbol at point.")))))
167
168(hi::bind-key "Show Callers" #k"control-meta-c")
169
170
171
172
173
174
175
176
Note: See TracBrowser for help on using the repository browser.