/[climacs]/climacs/gui.lisp
ViewVC logotype

Contents of /climacs/gui.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.35 - (show annotations)
Thu Dec 30 10:42:45 2004 UTC (9 years, 3 months ago) by ejohnson
Branch: MAIN
Changes since 1.34: +3 -2 lines
Wrapped an (EVAL-WHEN (:compile-toplevel) ...) around COMPLETABLE-PATHNAME to rid us of an asdf style warning
1 ;;; -*- Mode: Lisp; Package: CLIMACS-GUI -*-
2
3 ;;; (c) copyright 2004 by
4 ;;; Robert Strandh (strandh@labri.fr)
5 ;;; (c) copyright 2004 by
6 ;;; Elliott Johnson (ejohnson@fasl.info)
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 ;;; GUI for the Climacs editor.
24
25 (in-package :climacs-gui)
26
27 (defclass filename-mixin ()
28 ((filename :initform nil :accessor filename)))
29
30 (defclass climacs-buffer (standard-buffer abbrev-mixin filename-mixin)
31 ((name :initform "*scratch*" :accessor name)
32 (needs-saving :initform nil :accessor needs-saving)))
33
34 (defclass climacs-pane (application-pane)
35 ((buffer :initform (make-instance 'climacs-buffer) :accessor buffer)
36 (point :initform nil :initarg :point :reader point)
37 (syntax :initarg :syntax :accessor syntax)
38 (mark :initform nil :initarg :mark :reader mark)))
39
40 (defmethod initialize-instance :after ((pane climacs-pane) &rest args)
41 (declare (ignore args))
42 (with-slots (buffer point syntax mark) pane
43 (when (null point)
44 (setf point (make-instance 'standard-right-sticky-mark
45 :buffer buffer)))
46 (when (null mark)
47 (setf mark (make-instance 'standard-right-sticky-mark
48 :buffer buffer)))
49 (setf syntax (make-instance 'texinfo-syntax :pane pane))))
50
51 (defclass minibuffer-pane (application-pane) ())
52
53 (defmethod stream-accept :before ((pane minibuffer-pane) type &rest args)
54 (declare (ignore type args))
55 (window-clear pane))
56
57 (define-application-frame climacs ()
58 ((win :reader win))
59 (:panes
60 (win (make-pane 'climacs-pane
61 :width 900 :height 400
62 :name 'win
63 :incremental-redisplay t
64 :display-function 'display-win))
65 (info :application
66 :width 900 :height 20 :max-height 20
67 :name 'info :background +light-gray+
68 :scroll-bars nil
69 :incremental-redisplay t
70 :display-function 'display-info)
71 (int (make-pane 'minibuffer-pane
72 :width 900 :height 20 :max-height 20 :min-height 20
73 :scroll-bars nil)))
74 (:layouts
75 (default
76 (vertically (:scroll-bars nil)
77 (scrolling (:width 900 :height 400) win)
78 info
79 int)))
80 (:top-level (climacs-top-level)))
81
82 (defmethod redisplay-frame-panes :after ((frame climacs) &rest args)
83 (declare (ignore args))
84 (clear-modify (buffer (win frame))))
85
86 (defun climacs ()
87 "Starts up a climacs session"
88 (let ((frame (make-application-frame 'climacs)))
89 (run-frame-top-level frame)))
90
91 (defun display-message (format-string &rest format-args)
92 (apply #'format *standard-input* format-string format-args))
93
94 (defun display-info (frame pane)
95 (let* ((win (win frame))
96 (buf (buffer win))
97 (name-info (format nil " ~a ~a"
98 (if (needs-saving buf) "**" "--")
99 (name buf))))
100 (princ name-info pane)))
101
102 (defun display-win (frame pane)
103 "The display function used by the climacs application frame."
104 (declare (ignore frame))
105 (redisplay-pane pane))
106
107 (defun find-gestures (gestures start-table)
108 (loop with table = (find-command-table start-table)
109 for (gesture . rest) on gestures
110 for item = (find-keystroke-item gesture table :errorp nil)
111 while item
112 do (if (eq (command-menu-item-type item) :command)
113 (return (if (null rest) item nil))
114 (setf table (command-menu-item-value item)))
115 finally (return item)))
116
117 (defvar *kill-ring* (initialize-kill-ring 7))
118 (defparameter *current-gesture* nil)
119
120 (defun climacs-top-level (frame &key
121 command-parser command-unparser
122 partial-command-parser prompt)
123 (declare (ignore command-parser command-unparser partial-command-parser prompt))
124 (setf (slot-value frame 'win) (find-pane-named frame 'win))
125 (let ((*standard-output* (find-pane-named frame 'win))
126 (*standard-input* (find-pane-named frame 'int))
127 (*print-pretty* nil)
128 (*abort-gestures* nil))
129 (redisplay-frame-panes frame :force-p t)
130 (loop with gestures = '()
131 do (setf *current-gesture* (read-gesture :stream *standard-input*))
132 (when (or (characterp *current-gesture*)
133 (and (typep *current-gesture* 'keyboard-event)
134 (or (keyboard-event-character *current-gesture*)
135 (not (member (keyboard-event-key-name
136 *current-gesture*)
137 '(:control-left :control-right
138 :shift-left :shift-right
139 :meta-left :meta-right
140 :super-left :super-right
141 :hyper-left :hyper-right
142 :shift-lock :caps-lock))))))
143 (setf gestures (nconc gestures (list *current-gesture*)))
144 (let ((item (find-gestures gestures 'global-climacs-table)))
145 (cond ((not item)
146 (beep) (setf gestures '()))
147 ((eq (command-menu-item-type item) :command)
148 (handler-case
149 (funcall (command-menu-item-value item))
150 (error (condition)
151 (beep)
152 (format *error-output* "~a~%" condition)))
153 (setf gestures '()))
154 (t nil))))
155 (let ((buffer (buffer (win frame))))
156 (when (modified-p buffer)
157 (setf (needs-saving buffer) t)))
158 (redisplay-frame-panes frame))))
159
160 (defmacro define-named-command (command-name args &body body)
161 `(define-climacs-command ,(if (listp command-name) `(,@command-name :name t) `(,command-name :name t)) ,args ,@body))
162
163 (define-named-command (com-quit) ()
164 (frame-exit *application-frame*))
165
166 (define-command com-self-insert ()
167 (unless (constituentp *current-gesture*)
168 (possibly-expand-abbrev (point (win *application-frame*))))
169 (insert-object (point (win *application-frame*)) *current-gesture*))
170
171 (define-named-command com-backward-object ()
172 (decf (offset (point (win *application-frame*)))))
173
174 (define-named-command com-forward-object ()
175 (incf (offset (point (win *application-frame*)))))
176
177 (define-named-command com-beginning-of-line ()
178 (beginning-of-line (point (win *application-frame*))))
179
180 (define-named-command com-end-of-line ()
181 (end-of-line (point (win *application-frame*))))
182
183 (define-named-command com-delete-object ()
184 (delete-range (point (win *application-frame*))))
185
186 (define-named-command com-backward-delete-object ()
187 (delete-range (point (win *application-frame*)) -1))
188
189 (define-named-command com-previous-line ()
190 (previous-line (point (win *application-frame*))))
191
192 (define-named-command com-next-line ()
193 (next-line (point (win *application-frame*))))
194
195 (define-named-command com-open-line ()
196 (open-line (point (win *application-frame*))))
197
198 (define-named-command com-kill-line ()
199 (kill-line (point (win *application-frame*))))
200
201 (define-named-command com-forward-word ()
202 (forward-word (point (win *application-frame*))))
203
204 (define-named-command com-backward-word ()
205 (backward-word (point (win *application-frame*))))
206
207 (define-named-command com-delete-word ()
208 (delete-word (point (win *application-frame*))))
209
210 (define-named-command com-backward-delete-word ()
211 (backward-delete-word (point (win *application-frame*))))
212
213 (define-named-command com-toggle-layout ()
214 (setf (frame-current-layout *application-frame*)
215 (if (eq (frame-current-layout *application-frame*) 'default)
216 'with-interactor
217 'default)))
218
219 (define-command com-extended-command ()
220 (let ((item (accept 'command :prompt "Extended Command")))
221 (execute-frame-command *application-frame* item)))
222
223 (eval-when (:compile-toplevel)
224 (define-presentation-type completable-pathname ()
225 :inherit-from 'pathname))
226
227 (defun filename-completer (so-far mode)
228 (flet ((remove-trail (s)
229 (subseq s 0 (let ((pos (position #\/ s :from-end t)))
230 (if pos (1+ pos) 0)))))
231 (let* ((directory-prefix
232 (if (and (plusp (length so-far)) (eql (aref so-far 0) #\/))
233 ""
234 (namestring #+sbcl (car (directory ".")) #+cmu (ext:default-directory))))
235 (full-so-far (concatenate 'string directory-prefix so-far))
236 (pathnames
237 (loop with length = (length full-so-far)
238 for path in (directory (concatenate 'string
239 (remove-trail so-far)
240 "*.*"))
241 when (let ((mismatch (mismatch (namestring path) full-so-far)))
242 (or (null mismatch) (= mismatch length)))
243 collect path))
244 (strings (mapcar #'namestring pathnames))
245 (first-string (car strings))
246 (length-common-prefix nil)
247 (completed-string nil)
248 (full-completed-string nil))
249 (unless (null pathnames)
250 (setf length-common-prefix
251 (loop with length = (length first-string)
252 for string in (cdr strings)
253 do (setf length (min length (or (mismatch string first-string) length)))
254 finally (return length))))
255 (unless (null pathnames)
256 (setf completed-string
257 (subseq first-string (length directory-prefix)
258 (if (null (cdr pathnames)) nil length-common-prefix)))
259 (setf full-completed-string
260 (concatenate 'string directory-prefix completed-string)))
261 (case mode
262 ((:complete-limited :complete-maximal)
263 (cond ((null pathnames)
264 (values so-far nil nil 0 nil))
265 ((null (cdr pathnames))
266 (values completed-string t (car pathnames) 1 nil))
267 (t
268 (values completed-string nil nil (length pathnames) nil))))
269 (:complete
270 (cond ((null pathnames)
271 (values so-far t so-far 1 nil))
272 ((null (cdr pathnames))
273 (values completed-string t (car pathnames) 1 nil))
274 ((find full-completed-string strings :test #'string-equal)
275 (let ((pos (position full-completed-string strings :test #'string-equal)))
276 (values completed-string
277 t (elt pathnames pos) (length pathnames) nil)))
278 (t
279 (values completed-string nil nil (length pathnames) nil))))
280 (:possibilities
281 (values nil nil nil (length pathnames)
282 (loop with length = (length directory-prefix)
283 for name in pathnames
284 collect (list (subseq (namestring name) length nil)
285 name))))))))
286
287 (define-presentation-method accept
288 ((type completable-pathname) stream (view textual-view) &key)
289 (multiple-value-bind (pathname success string)
290 (complete-input stream
291 #'filename-completer
292 :partial-completers '(#\Space)
293 :allow-any-input t)
294 (declare (ignore success))
295 (or pathname string)))
296
297 (defun pathname-filename (pathname)
298 (if (null (pathname-type pathname))
299 (pathname-name pathname)
300 (concatenate 'string (pathname-name pathname)
301 "." (pathname-type pathname))))
302
303 (define-named-command com-find-file ()
304 (let ((filename (accept 'completable-pathname
305 :prompt "Find File")))
306 (with-slots (buffer point syntax) (win *application-frame*)
307 (setf buffer (make-instance 'climacs-buffer)
308 point (make-instance 'standard-right-sticky-mark :buffer buffer)
309 syntax (make-instance 'texinfo-syntax :pane (win *application-frame*)))
310 (with-open-file (stream filename :direction :input :if-does-not-exist :create)
311 (input-from-stream stream buffer 0))
312 (setf (filename buffer) filename
313 (name buffer) (pathname-filename filename)
314 (needs-saving buffer) nil)
315 ;; this one is needed so that the buffer modification protocol
316 ;; resets the low and high marks after redisplay
317 (redisplay-frame-panes *application-frame*)
318 (beginning-of-buffer point))))
319
320 (define-named-command com-save-buffer ()
321 (let* ((buffer (buffer (win *application-frame*)))
322 (filename (or (filename buffer)
323 (accept 'completable-pathname
324 :prompt "Save Buffer to File"))))
325 (if (or (null (filename buffer))
326 (needs-saving buffer))
327 (progn (with-open-file (stream filename :direction :output :if-exists :supersede)
328 (output-to-stream stream buffer 0 (size buffer)))
329 (setf (filename buffer) filename
330 (name buffer) (pathname-filename filename))
331 (display-message "Wrote: ~a" (filename buffer)))
332 (display-message "No changes need to be saved from ~a" (name buffer)))
333 (setf (needs-saving buffer) nil)))
334
335 (define-named-command com-write-buffer ()
336 (let ((filename (accept 'completable-pathname
337 :prompt "Write Buffer to File"))
338 (buffer (buffer (win *application-frame*))))
339 (with-open-file (stream filename :direction :output :if-exists :supersede)
340 (output-to-stream stream buffer 0 (size buffer)))
341 (setf (filename buffer) filename
342 (name buffer) (pathname-filename filename)
343 (needs-saving buffer) nil)
344 (display-message "Wrote: ~a" (filename buffer))))
345
346 (define-named-command com-beginning-of-buffer ()
347 (beginning-of-buffer (point (win *application-frame*))))
348
349 (define-named-command com-end-of-buffer ()
350 (end-of-buffer (point (win *application-frame*))))
351
352 (define-named-command com-back-to-indentation ()
353 (let ((point (point (win *application-frame*))))
354 (beginning-of-line point)
355 (loop until (end-of-line-p point)
356 while (whitespacep (object-after point))
357 do (incf (offset point)))))
358
359 (define-named-command com-goto-position ()
360 (setf (offset (point (win *application-frame*)))
361 (accept 'integer :prompt "Goto Position")))
362
363 (define-named-command com-goto-line ()
364 (loop with mark = (make-instance 'standard-right-sticky-mark
365 :buffer (buffer (win *application-frame*)))
366 do (end-of-line mark)
367 until (end-of-buffer-p mark)
368 repeat (accept 'integer :prompt "Goto Line")
369 do (incf (offset mark))
370 (end-of-line mark)
371 finally (beginning-of-line mark)
372 (setf (offset (point (win *application-frame*)))
373 (offset mark))))
374
375 (define-named-command com-browse-url ()
376 (accept 'url :prompt "Browse URL"))
377
378 (define-named-command com-set-mark ()
379 (with-slots (point mark) (win *application-frame*)
380 (setf mark (clone-mark point))))
381
382 ;;;;;;;;;;;;;;;;;;;;
383 ;; Kill ring commands
384
385 ;; Copies an element from a kill-ring to a buffer at the given offset
386 (define-named-command com-copy-in ()
387 (insert-sequence (point (win *application-frame*)) (kr-copy *kill-ring*)))
388
389 ;; Cuts an element from a kill-ring out to a buffer at a given offset
390 (define-named-command com-cut-in ()
391 (insert-sequence (point (win *application-frame*)) (kr-pop *kill-ring*)))
392
393 ;; Destructively cut a given buffer region into the kill-ring
394 (define-named-command com-cut-out ()
395 (with-slots (buffer point mark)(win *application-frame*)
396 (if (< (offset point) (offset mark))
397 ((lambda (b o1 o2)
398 (kr-push *kill-ring* (buffer-sequence b o1 o2))
399 (delete-buffer-range b o1 (- o2 o1)))
400 buffer (offset point) (offset mark))
401 ((lambda (b o1 o2)
402 (kr-push *kill-ring* (buffer-sequence b o2 o1))
403 (delete-buffer-range b o1 (- o2 o1)))
404 buffer (offset mark) (offset point)))))
405
406
407 ;; Non destructively copies in buffer region to the kill ring
408 (define-named-command com-copy-out ()
409 (with-slots (buffer point mark)(win *application-frame*)
410 (let ((off1 (offset point))
411 (off2 (offset mark)))
412 (if (< off1 off2)
413 (kr-push *kill-ring* (buffer-sequence buffer off1 off2))
414 (kr-push *kill-ring* (buffer-sequence buffer off2 off1))))))
415
416 ;; Needs adjustment to be like emacs M-y
417 (define-named-command com-kr-rotate ()
418 (kr-rotate *kill-ring* -1))
419
420 ;; Not bound to a key yet
421 (define-named-command com-kr-resize ()
422 (let ((size (accept 'fixnum :prompt "New kill ring size: ")))
423 (kr-resize *kill-ring* size)))
424
425 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
426 ;;;
427 ;;; Global command table
428
429 (make-command-table 'global-climacs-table :errorp nil)
430
431 (defun global-set-key (gesture command)
432 (add-command-to-command-table command 'global-climacs-table
433 :keystroke gesture :errorp nil))
434
435 (loop for code from (char-code #\space) to (char-code #\~)
436 do (global-set-key (code-char code) 'com-self-insert))
437
438 (global-set-key #\newline 'com-self-insert)
439 (global-set-key #\tab 'com-self-insert)
440 (global-set-key '(#\f :control) 'com-forward-object)
441 (global-set-key '(#\b :control) 'com-backward-object)
442 (global-set-key '(#\a :control) 'com-beginning-of-line)
443 (global-set-key '(#\e :control) 'com-end-of-line)
444 (global-set-key '(#\d :control) 'com-delete-object)
445 (global-set-key '(#\p :control) 'com-previous-line)
446 (global-set-key '(#\n :control) 'com-next-line)
447 (global-set-key '(#\o :control) 'com-open-line)
448 (global-set-key '(#\k :control) 'com-kill-line)
449 (global-set-key '(#\Space :control) 'com-set-mark)
450 (global-set-key '(#\y :control) 'com-copy-in)
451 (global-set-key '(#\w :control) 'com-cut-out)
452 (global-set-key '(#\f :meta) 'com-forward-word)
453 (global-set-key '(#\b :meta) 'com-backward-word)
454 (global-set-key '(#\x :meta) 'com-extended-command)
455 (global-set-key '(#\y :meta) 'com-kr-rotate) ;currently rotates only
456 (global-set-key '(#\w :meta) 'com-copy-out)
457 (global-set-key '(#\< :shift :meta) 'com-beginning-of-buffer)
458 (global-set-key '(#\> :shift :meta) 'com-end-of-buffer)
459 (global-set-key '(#\u :meta) 'com-browse-url)
460 (global-set-key '(#\m :meta) 'com-back-to-indentation)
461 (global-set-key '(#\d :meta) 'com-delete-word)
462 (global-set-key '(#\Backspace :meta) 'com-backward-delete-word)
463
464 (global-set-key '(:up) 'com-previous-line)
465 (global-set-key '(:down) 'com-next-line)
466 (global-set-key '(:left) 'com-backward-object)
467 (global-set-key '(:right) 'com-forward-object)
468 (global-set-key '(:left :control) 'com-backward-word)
469 (global-set-key '(:right :control) 'com-forward-word)
470 (global-set-key '(:home) 'com-beginning-of-line)
471 (global-set-key '(:end) 'com-end-of-line)
472 (global-set-key '(:home :control) 'com-beginning-of-buffer)
473 (global-set-key '(:end :control) 'com-end-of-buffer)
474 (global-set-key #\Rubout 'com-delete-object)
475 (global-set-key #\Backspace 'com-backward-delete-object)
476
477 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
478 ;;;
479 ;;; C-x command table
480
481 (make-command-table 'c-x-climacs-table :errorp nil)
482
483 (add-menu-item-to-command-table 'global-climacs-table "C-x"
484 :menu 'c-x-climacs-table
485 :keystroke '(#\x :control))
486
487 (defun c-x-set-key (gesture command)
488 (add-command-to-command-table command 'c-x-climacs-table
489 :keystroke gesture :errorp nil))
490
491 (c-x-set-key '(#\c :control) 'com-quit)
492 (c-x-set-key '(#\f :control) 'com-find-file)
493 (c-x-set-key '(#\s :control) 'com-save-buffer)
494 (c-x-set-key '(#\w :control) 'com-write-buffer)

  ViewVC Help
Powered by ViewVC 1.1.5