/[climacs]/climacs/climacs-lisp-syntax.lisp
ViewVC logotype

Contents of /climacs/climacs-lisp-syntax.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.17 - (show annotations)
Sun Jun 15 09:11:23 2008 UTC (5 years, 10 months ago) by thenriksen
Branch: MAIN
CVS Tags: HEAD
Changes since 1.16: +1 -1 lines
Use ESA-UTILS:FORMAT-SYM for formatting symbols.
1 ;;; -*- Mode: Lisp; Package: DREI-LISP-SYNTAX -*-
2
3 ;;; (c) copyright 2005 by
4 ;;; Robert Strandh (strandh@labri.fr)
5 ;;; (c) copyright 2006 by
6 ;;; Troels Henriksen (athas@sigkill.dk)
7 ;;;
8 ;;; This library is free software; you can redistribute it and/or
9 ;;; modify it under the terms of the GNU Library General Public
10 ;;; License as published by the Free Software Foundation; either
11 ;;; version 2 of the License, or (at your option) any later version.
12 ;;;
13 ;;; This library is distributed in the hope that it will be useful,
14 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
16 ;;; Library General Public License for more details.
17 ;;;
18 ;;; You should have received a copy of the GNU Library General Public
19 ;;; License along with this library; if not, write to the
20 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
21 ;;; Boston, MA 02111-1307 USA.
22
23 ;;; Add Climacs-dependent functionality to the stock Lisp syntax.
24
25 (in-package :drei-lisp-syntax)
26
27 (defmethod frame-clear-completions ((frame climacs-gui:climacs))
28 (let ((completions-pane
29 (when (typep *application-frame* 'esa-frame-mixin)
30 (find "Completions" (windows *application-frame*)
31 :key #'pane-name
32 :test #'string=))))
33 (unless (null completions-pane)
34 (climacs-gui:delete-window completions-pane)
35 (setf completions-pane nil))))
36
37 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
38 ;;;
39 ;;; Compiler note hyperlinking
40
41 (defclass location ()()
42 (:documentation "The base for all locations."))
43
44 (defclass error-location (location)
45 ((error-message :initarg :error-message :accessor error-message)))
46
47 (defclass actual-location (location)
48 ((source-position :initarg :position :accessor source-position)
49 (snippet :initarg :snippet :accessor snippet :initform nil))
50 (:documentation "The base for all non-error locations."))
51
52 (defclass view-location (actual-location)
53 ((view-name :initarg :view :accessor view-name)))
54
55 (defclass file-location (actual-location)
56 ((file-name :initarg :file :accessor file-name)))
57
58 (defclass source-location (actual-location)
59 ((source-form :initarg :source-form :accessor source-form)))
60
61 (defclass basic-position () ()
62 (:documentation "The base for all positions."))
63
64 (defclass char-position (basic-position)
65 ((char-position :initarg :position :accessor char-position)
66 (align-p :initarg :align-p :initform nil :accessor align-p)))
67
68 (defun make-char-position (position-list)
69 (make-instance 'char-position :position (second position-list)
70 :align-p (third position-list)))
71
72 (defclass line-position (basic-position)
73 ((start-line :initarg :line :accessor start-line)
74 (end-line :initarg :end-line :initform nil :accessor end-line)))
75
76 (defun make-line-position (position-list)
77 (make-instance 'line-position :line (second position-list)
78 :end-line (third position-list)))
79
80 (defclass function-name-position (basic-position)
81 ((function-name :initarg :function-name)))
82
83 (defun make-function-name-position (position-list)
84 (make-instance 'function-name-position :function-name (second position-list)))
85
86 (defclass source-path-position (basic-position)
87 ((path :initarg :source-path :accessor path)
88 (start-position :initarg :start-position :accessor start-position)))
89
90 (defun make-source-path-position (position-list)
91 (make-instance 'source-path-position :source-path (second position-list)
92 :start-position (third position-list)))
93
94 (defclass text-anchored-position (basic-position)
95 ((start :initarg :text-anchored :accessor start)
96 (text :initarg :text :accessor text)
97 (delta :initarg :delta :accessor delta)))
98
99 (defun make-text-anchored-position (position-list)
100 (make-instance 'text-anchored-position :text-anchored (second position-list)
101 :text (third position-list)
102 :delta (fourth position-list)))
103
104 (defclass method-position (basic-position)
105 ((name :initarg :method :accessor name)
106 (specializers :initarg :specializers :accessor specializers)
107 (qualifiers :initarg :qualifiers :accessor qualifiers)))
108
109 (defun make-method-position (position-list)
110 (make-instance 'method-position :method (second position-list)
111 :specializers (third position-list)
112 :qualifiers (last position-list)))
113
114 (defun make-location (location-list)
115 (ecase (first location-list)
116 (:error (make-instance 'error-location :error-message (second location-list)))
117 (:location
118 (destructuring-bind (l buf pos hints) location-list
119 (declare (ignore l))
120 (let ((location
121 (apply #'make-instance
122 (ecase (first buf)
123 (:file 'file-location)
124 (:buffer 'view-location)
125 (:source-form 'source-location))
126 (case (first buf)
127 (:buffer (cons :view (rest buf)))
128 (t buf))))
129 (position
130 (funcall
131 (ecase (first pos)
132 (:position #'make-char-position)
133 (:line #'make-line-position)
134 (:function-name #'make-function-name-position)
135 (:source-path #'make-source-path-position)
136 (:text-anchored #'make-text-anchored-position)
137 (:method #'make-method-position))
138 pos)))
139 (setf (source-position location) position)
140 (when hints
141 (setf (snippet location) (rest hints)))
142 location)))))
143
144 (defmethod initialize-instance :after ((note compiler-note) &rest args)
145 (declare (ignore args))
146 (setf (location note) (make-location (location note))))
147
148 (defun show-note-counts (notes &optional seconds)
149 (loop with nerrors = 0
150 with nwarnings = 0
151 with nstyle-warnings = 0
152 with nnotes = 0
153 for note in notes
154 do (etypecase note
155 (error-compiler-note (incf nerrors))
156 (read-error-compiler-note (incf nerrors))
157 (warning-compiler-note (incf nwarnings))
158 (style-warning-compiler-note (incf nstyle-warnings))
159 (note-compiler-note (incf nnotes)))
160 finally
161 (esa:display-message "Compilation finished: ~D error~:P ~
162 ~D warning~:P ~D style-warning~:P ~D note~:P ~
163 ~@[[~D secs]~]"
164 nerrors nwarnings nstyle-warnings nnotes seconds)))
165
166 (defun one-line-ify (string)
167 "Return a single-line version of STRING.
168 Each newline and following whitespace is replaced by a single space."
169 (loop with count = 0
170 while (< count (length string))
171 with new-string = (make-array 0 :element-type 'character :adjustable t
172 :fill-pointer 0)
173 when (char= (char string count) #\Newline)
174 do (loop while (and (< count (length string))
175 (whitespacep (current-syntax) (char string count)))
176 do (incf count)
177 ;; Just ignore whitespace if it is last in the
178 ;; string.
179 finally (when (< count (length string))
180 (vector-push-extend #\Space new-string)))
181 else
182 do (vector-push-extend (char string count) new-string)
183 (incf count)
184 finally (return new-string)))
185
186 (defgeneric print-for-menu (object stream))
187
188 (defun print-note-for-menu (note stream severity ink)
189 (with-accessors ((message message) (short-message short-message)) note
190 (with-drawing-options (stream :ink ink
191 :text-style (make-text-style :sans-serif :italic nil))
192 (princ severity stream)
193 (princ " " stream))
194 (princ (if short-message
195 (one-line-ify short-message)
196 (one-line-ify message))
197 stream)))
198
199 (defmacro def-print-for-menu (class name colour)
200 `(defmethod print-for-menu ((object ,class) stream)
201 (print-note-for-menu object stream ,name ,colour)))
202
203 (def-print-for-menu error-compiler-note "Error" +red+)
204 (def-print-for-menu read-error-compiler-note "Read Error" +red+)
205 (def-print-for-menu warning-compiler-note "Warning" +dark-red+)
206 (def-print-for-menu style-warning-compiler-note "Style Warning" +brown+)
207 (def-print-for-menu note-compiler-note "Note" +brown+)
208
209 (defun show-notes (notes view-name definition)
210 (climacs-gui:with-typeout-view (stream (format nil "Compiler Notes: ~A ~A" view-name definition))
211 (loop for note in notes
212 do (with-output-as-presentation (stream note 'compiler-note)
213 (print-for-menu note stream))
214 (terpri stream)
215 count note into length
216 finally (change-space-requirements stream
217 :height (* length (stream-line-height stream)))
218 (scroll-extent stream 0 0))))
219
220 (defgeneric goto-location (location))
221
222 (defmethod goto-location ((location error-location))
223 (esa:display-message (error-message location)))
224
225 (defmethod goto-location ((location view-location))
226 (let ((view (find (view-name location)
227 (climacs-gui:views *esa-instance*)
228 :test #'string= :key #'name)))
229 (unless view
230 (esa:display-message "No view ~A" (view-name location))
231 (beep)
232 (return-from goto-location))
233 (climacs-core:switch-to-view (current-window) view)
234 (goto-position (point)
235 (char-position (source-position location)))))
236
237 (defmethod goto-location ((location file-location))
238 (let ((view (find (file-name location)
239 (views *application-frame*)
240 :test #'string= :key #'(lambda (view)
241 (when (typep view 'drei-buffer-view)
242 (let ((path (filepath (buffer view))))
243 (when path
244 (namestring path))))))))
245 (if view
246 (climacs-core:switch-to-view (current-window) view)
247 (find-file (file-name location)))
248 (goto-position (point (current-view))
249 (char-position (source-position location)))))
250
251 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
252 ;;;
253 ;;; Macroexpansion and evaluation
254
255 (defun macroexpand-token (syntax token &optional (all nil))
256 (with-syntax-package (syntax (start-offset token))
257 (let* ((string (form-string syntax token))
258 (expression (read-from-string string))
259 (expansion (macroexpand-for-drei (get-usable-image syntax)
260 expression
261 all))
262 (expansion-string (with-output-to-string (s)
263 (pprint expansion s))))
264 (let ((view (climacs-core:switch-or-move-to-view (current-window) "*Macroexpansion*")))
265 (set-syntax view "Lisp"))
266 (let ((header-string (one-line-ify (subseq string 0
267 (min 40 (length string))))))
268 (end-of-buffer (point))
269 (unless (beginning-of-buffer-p (point))
270 (insert-object (point) #\Newline))
271 (insert-sequence (point)
272 (format nil ";;; Macroexpand-~:[1~;all~] ~A...~%"
273 all header-string))
274 (insert-sequence (point) expansion-string)
275 (insert-object (point) #\Newline)))))
276
277 (defun compile-definition-interactively (view mark)
278 (let* ((syntax (syntax view))
279 (token (definition-at-mark syntax mark))
280 (string (form-string syntax token))
281 (m (clone-mark mark))
282 (*read-base* (base syntax)))
283 (with-syntax-package (syntax mark)
284 (forward-definition m syntax 1 nil)
285 (if (backward-definition m syntax 1 nil)
286 (multiple-value-bind (result notes)
287 (compile-form-for-drei (get-usable-image syntax)
288 (form-to-object syntax token
289 :read t
290 :package (package-at-mark syntax mark))
291 view m)
292 (show-note-counts notes (second result))
293 (when (not (null notes))
294 (show-notes notes (name view)
295 (one-line-ify (subseq string 0 (min (length string) 20))))))
296 (display-message "No definition at point")))))
297
298 (defun compile-file-interactively (view &optional load-p)
299 (let ((buffer (buffer view)))
300 (cond ((null (filepath buffer))
301 (esa:display-message "View ~A is not associated with a file" (name view)))
302 (t
303 (when (and (needs-saving buffer)
304 (accept 'boolean :prompt (format nil "Save buffer ~A ?" (name view))))
305 (climacs-core:save-buffer buffer))
306 (let ((*read-base* (base (syntax view))))
307 (multiple-value-bind (result notes)
308 (compile-file-for-drei (get-usable-image (syntax view))
309 (filepath buffer)
310 (package-at-mark (syntax view) 0) load-p)
311 (show-note-counts notes (second result))
312 (when notes (show-notes notes (name view) ""))))))))
313
314 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
315 ;;;
316 ;;; Definition editing
317
318 (defparameter *find-definition-stack* '())
319
320 (defun pop-find-definition-stack ()
321 (unless (null *find-definition-stack*)
322 (let* ((offset+view (pop *find-definition-stack*))
323 (offset (first offset+view))
324 (view (second offset+view)))
325 (if (find view (views *esa-instance*))
326 (progn (climacs-core:switch-to-view (current-window) view)
327 (goto-position (point) offset))
328 (pop-find-definition-stack)))))
329
330 ;; KLUDGE: We need to put more info in the definition objects to begin
331 ;; with.
332 (defun definition-type (definition)
333 (let ((data (read-from-string (first definition))))
334 (case (first data)
335 ((cl:defclass)
336 'cl:class)
337 ((cl:defgeneric
338 cl:defmethod
339 cl:defun
340 cl:defmacro)
341 'cl:function)
342 (t t))))
343
344 (defvar *local-function-definers* '(flet labels macrolet)
345 "A list of macros that define local functions, as per
346 `find-local-definition.")
347
348 (defun find-local-definition (syntax symbol-form)
349 "Return a form locally defining `symbol-form' as a
350 function (explicitly via `flet' or `labels', does not expand
351 macros or similar). If no such form can be found, return NIL."
352 (labels ((locally-binding-p (form)
353 (when (form-operator form)
354 (find-if #'(lambda (symbol)
355 (form-equal syntax (form-operator form) (string symbol)))
356 *local-function-definers*)))
357 (match (form-operator)
358 (when form-operator
359 (form-equal syntax form-operator symbol-form)))
360 (find-local-binding (form)
361 (when form
362 (or (when (locally-binding-p form)
363 (loop for binding in (form-children (first (form-operands form)))
364 when (and (form-list-p binding)
365 (match (form-operator binding)))
366 return binding))
367 (unless (form-at-top-level-p form)
368 (find-local-binding (parent form)))))))
369 (find-local-binding (list-at-mark syntax (start-offset symbol-form)))))
370
371 (defun edit-definition (symbol &optional type)
372 (let ((all-definitions (find-definitions-for-drei
373 (get-usable-image (when (syntax-view-p (current-view))
374 (current-syntax)))
375 symbol)))
376 (let ((definitions (if (not type)
377 all-definitions
378 (remove-if-not #'(lambda (definition)
379 (eq (definition-type definition) type))
380 all-definitions))))
381 (cond ((null definitions)
382 (esa:display-message "No known definitions for: ~A" symbol)
383 (beep))
384 (t
385 (goto-definition symbol definitions))))))
386
387 (defun goto-definition (name definitions)
388 (when (point-mark-view-p (current-view))
389 (push (list (offset (point)) (current-view)) *find-definition-stack*))
390 (cond ((null (cdr definitions))
391 (let* ((def (car definitions))
392 (xref (make-xref def)))
393 (goto-location xref)))
394 (t
395 (let ((xref (show-definitions name definitions)))
396 (when xref (goto-location xref))))))
397
398 (defclass xref ()
399 ((dspec :initarg :dspec :accessor dspec)
400 (location :initarg :location :accessor location)))
401
402 (defun make-xref (xref-list)
403 (destructuring-bind (dspec location) xref-list
404 (make-instance 'xref
405 :dspec dspec
406 :location (make-location location))))
407
408 (defmethod goto-location ((xref xref))
409 (goto-location (location xref)))
410
411 (defun show-definitions (name definitions)
412 (show-xrefs (loop for xref-list in definitions
413 collect (make-xref xref-list))
414 'definition name))
415
416 (defun show-xrefs (xrefs type symbol)
417 (cond ((null xrefs)
418 (esa:display-message "No references found for ~A." symbol)
419 (beep))
420 (t
421 (flet ((printer (item stream)
422 (with-drawing-options (stream :ink +dark-blue+
423 :text-style (make-text-style :fixed nil nil))
424 (princ (dspec item) stream))))
425 (climacs-gui:with-typeout-view (stream (format-sym "~A ~A" type symbol))
426 (loop for xref in xrefs
427 do (with-output-as-presentation (stream xref 'xref)
428 (printer xref stream))
429 (terpri stream)
430 count xref into length
431 finally (change-space-requirements stream
432 :height (* length (stream-line-height stream)))
433 (scroll-extent stream 0 0)))))))
434
435 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
436 ;;;
437 ;;; Some group support
438
439 ;; WARNING, using this group can be dangerous, as Climacs is not
440 ;; really suited to opening up a large amount of buffers that each
441 ;; require a full syntax reparse.
442 (climacs-core:define-group "ASDF System Files" (group (system (asdf:find-system (accept 'symbol :prompt "System"))))
443 (declare (ignore group))
444 (when system
445 (mapcar #'asdf:component-pathname
446 (remove-if-not (lambda (c)
447 (typep c 'asdf:cl-source-file))
448 (asdf:module-components system)))))

  ViewVC Help
Powered by ViewVC 1.1.5