/[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.13 - (hide annotations)
Sun Jan 20 19:51:48 2008 UTC (6 years, 3 months ago) by thenriksen
Branch: MAIN
Changes since 1.12: +8 -9 lines
Revamped typeout panes and turned them into typeout views.

Stability not guaranteed, the code is... special.

Some things are still known to be suboptimal.
1 thenriksen 1.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 thenriksen 1.6 (defclass view-location (actual-location)
53     ((view-name :initarg :view :accessor view-name)))
54 thenriksen 1.1
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 thenriksen 1.6 (:buffer 'view-location)
125 thenriksen 1.1 (:source-form 'source-location))
126 thenriksen 1.9 (case (first buf)
127     (:buffer (cons :view (rest buf)))
128     (t buf))))
129 thenriksen 1.1 (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 thenriksen 1.5 (whitespacep (current-syntax) (char string count)))
176 thenriksen 1.1 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 thenriksen 1.6 (defun show-notes (notes view-name definition)
210 thenriksen 1.13 (climacs-gui:with-typeout (stream (format nil "Compiler Notes: ~A ~A" view-name definition))
211 thenriksen 1.1 (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 thenriksen 1.13 :height (* length (stream-line-height stream)))
218 thenriksen 1.1 (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 thenriksen 1.6 (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 thenriksen 1.1 (beep)
232     (return-from goto-location))
233 thenriksen 1.6 (climacs-core:switch-to-view (current-window) view)
234     (goto-position (point)
235 thenriksen 1.1 (char-position (source-position location)))))
236    
237     (defmethod goto-location ((location file-location))
238 thenriksen 1.6 (let ((view (find (file-name location)
239     (views *application-frame*)
240     :test #'string= :key #'(lambda (view)
241 thenriksen 1.8 (when (typep view 'drei-buffer-view)
242     (let ((path (filepath (buffer view))))
243     (when path
244     (namestring path))))))))
245 thenriksen 1.6 (if view
246     (climacs-core:switch-to-view (current-window) view)
247 thenriksen 1.1 (find-file (file-name location)))
248 thenriksen 1.8 (goto-position (point (current-view))
249 thenriksen 1.1 (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 thenriksen 1.3 (let* ((string (form-string syntax token))
258 thenriksen 1.1 (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 thenriksen 1.12 (let ((view (climacs-core:switch-or-move-to-view (current-window) "*Macroexpansion*")))
265 thenriksen 1.6 (set-syntax view "Lisp"))
266     (let ((header-string (one-line-ify (subseq string 0
267 thenriksen 1.1 (min 40 (length string))))))
268 thenriksen 1.6 (end-of-buffer (point))
269     (unless (beginning-of-buffer-p (point))
270     (insert-object (point) #\Newline))
271     (insert-sequence (point)
272 thenriksen 1.1 (format nil ";;; Macroexpand-~:[1~;all~] ~A...~%"
273     all header-string))
274 thenriksen 1.6 (insert-sequence (point) expansion-string)
275     (insert-object (point) #\Newline)))))
276 thenriksen 1.1
277 thenriksen 1.6 (defun compile-definition-interactively (view mark)
278     (let* ((syntax (syntax view))
279     (token (definition-at-mark syntax mark))
280 thenriksen 1.3 (string (form-string syntax token))
281 thenriksen 1.2 (m (clone-mark mark))
282     (*read-base* (base syntax)))
283     (with-syntax-package (syntax mark)
284 thenriksen 1.4 (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 thenriksen 1.7 view m)
292 thenriksen 1.4 (show-note-counts notes (second result))
293     (when (not (null notes))
294 thenriksen 1.6 (show-notes notes (name view)
295 thenriksen 1.4 (one-line-ify (subseq string 0 (min (length string) 20))))))
296     (display-message "No definition at point")))))
297 thenriksen 1.2
298 thenriksen 1.6 (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 thenriksen 1.1
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 thenriksen 1.6 (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 thenriksen 1.1 (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 thenriksen 1.6 ((cl:defclass)
336 thenriksen 1.1 'cl:class)
337 thenriksen 1.6 ((cl:defgeneric
338 thenriksen 1.1 cl:defmethod
339     cl:defun
340 thenriksen 1.6 cl:defmacro)
341 thenriksen 1.1 'cl:function)
342     (t t))))
343    
344 thenriksen 1.11 (defvar *local-function-definers* '(flet labels macrolet)
345     "A list of macros that define local functions, as per
346     `find-local-definition.")
347    
348 thenriksen 1.10 (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 thenriksen 1.13 (when (form-operator form)
354     (find-if #'(lambda (symbol)
355     (form-equal syntax (form-operator form) (string symbol)))
356     *local-function-definers*)))
357 thenriksen 1.10 (match (form-operator)
358     (when form-operator
359     (form-equal syntax form-operator symbol-form)))
360     (find-local-binding (form)
361     (or (when (locally-binding-p form)
362     (loop for binding in (form-children (first (form-operands form)))
363     when (and (form-list-p binding)
364     (match (form-operator binding)))
365     return binding))
366     (unless (form-at-top-level-p form)
367     (find-local-binding (parent form))))))
368     (find-local-binding (list-at-mark syntax (start-offset symbol-form)))))
369    
370 thenriksen 1.1 (defun edit-definition (symbol &optional type)
371     (let ((all-definitions (find-definitions-for-drei
372 thenriksen 1.6 (get-usable-image (current-syntax))
373 thenriksen 1.1 symbol)))
374     (let ((definitions (if (not type)
375     all-definitions
376     (remove-if-not #'(lambda (definition)
377     (eq (definition-type definition) type))
378     all-definitions))))
379     (cond ((null definitions)
380     (esa:display-message "No known definitions for: ~A" symbol)
381     (beep))
382     (t
383     (goto-definition symbol definitions))))))
384    
385     (defun goto-definition (name definitions)
386 thenriksen 1.6 (push (list (offset (point)) (current-view)) *find-definition-stack*)
387 thenriksen 1.1 (cond ((null (cdr definitions))
388     (let* ((def (car definitions))
389     (xref (make-xref def)))
390     (goto-location xref)))
391     (t
392     (let ((xref (show-definitions name definitions)))
393     (when xref (goto-location xref))))))
394    
395     (defclass xref ()
396     ((dspec :initarg :dspec :accessor dspec)
397     (location :initarg :location :accessor location)))
398    
399     (defun make-xref (xref-list)
400     (destructuring-bind (dspec location) xref-list
401     (make-instance 'xref
402     :dspec dspec
403     :location (make-location location))))
404    
405     (defmethod goto-location ((xref xref))
406     (goto-location (location xref)))
407    
408     (defun show-definitions (name definitions)
409     (show-xrefs (loop for xref-list in definitions
410     collect (make-xref xref-list))
411     'definition name))
412    
413     (defun show-xrefs (xrefs type symbol)
414     (cond ((null xrefs)
415     (esa:display-message "No references found for ~A." symbol)
416     (beep))
417     (t
418     (flet ((printer (item stream)
419     (with-drawing-options (stream :ink +dark-blue+
420     :text-style (make-text-style :fixed nil nil))
421     (princ (dspec item) stream))))
422 thenriksen 1.13 (climacs-gui:with-typeout (stream (format nil "~A ~A" type symbol))
423 thenriksen 1.1 (loop for xref in xrefs
424     do (with-output-as-presentation (stream xref 'xref)
425     (printer xref stream))
426     (terpri stream)
427     count xref into length
428     finally (change-space-requirements stream
429 thenriksen 1.13 :height (* length (stream-line-height stream)))
430 thenriksen 1.1 (scroll-extent stream 0 0)))))))
431    
432     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
433     ;;;
434     ;;; Some group support
435    
436     ;; WARNING, using this group can be dangerous, as Climacs is not
437     ;; really suited to opening up a large amount of buffers that each
438 thenriksen 1.6 ;; require a full syntax reparse.
439     (climacs-core:define-group "ASDF System Files" (group (system (asdf:find-system (accept 'symbol :prompt "System"))))
440     (declare (ignore group))
441     (when system
442     (mapcar #'asdf:component-pathname
443     (remove-if-not (lambda (c)
444     (typep c 'asdf:cl-source-file))
445     (asdf:module-components system)))))

  ViewVC Help
Powered by ViewVC 1.1.5