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

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

Use [Class] instead of [Type] for CCL doc.

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