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

Contents of /climacs/gui.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.80 - (show annotations)
Tue Jan 18 05:58:24 2005 UTC (9 years, 3 months ago) by rstrandh
Branch: MAIN
Changes since 1.79: +84 -92 lines
Cleaned up some useless code.

Introduced a macro `current-window' in preparation for true
multi-window support.  Please use it now instead of the previous idiom
(win *application-frame*).

A key sequence such as ESC <key> now works the same way as they
keystroke M-<key>.
(thanks to Ignas Mikalajunas)
1 ;;; -*- Mode: Lisp; Package: CLIMACS-GUI -*-
2
3 ;;; (c) copyright 2004-2005 by
4 ;;; Robert Strandh (strandh@labri.fr)
5 ;;; (c) copyright 2004-2005 by
6 ;;; Elliott Johnson (ejohnson@fasl.info)
7 ;;; (c) copyright 2005 by
8 ;;; Matthieu Villeneuve (matthieu.villeneuve@free.fr)
9 ;;; (c) copyright 2005 by
10 ;;; Aleksandar Bakic (a_bakic@yahoo.com)
11
12 ;;; This library is free software; you can redistribute it and/or
13 ;;; modify it under the terms of the GNU Library General Public
14 ;;; License as published by the Free Software Foundation; either
15 ;;; version 2 of the License, or (at your option) any later version.
16 ;;;
17 ;;; This library is distributed in the hope that it will be useful,
18 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
20 ;;; Library General Public License for more details.
21 ;;;
22 ;;; You should have received a copy of the GNU Library General Public
23 ;;; License along with this library; if not, write to the
24 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
25 ;;; Boston, MA 02111-1307 USA.
26
27 ;;; GUI for the Climacs editor.
28
29 (in-package :climacs-gui)
30
31 (defclass extended-pane (climacs-pane)
32 (;; allows a certain number of commands to have some minimal memory
33 (previous-command :initform nil :accessor previous-command)
34 ;; for next-line and previous-line commands
35 (goal-column :initform nil)
36 ;; for dynamic abbrev expansion
37 (original-prefix :initform nil)
38 (prefix-start-offset :initform nil)
39 (dabbrev-expansion-mark :initform nil)
40 (overwrite-mode :initform nil)))
41
42 (defclass minibuffer-pane (application-pane) ())
43
44 (defmethod stream-accept :before ((pane minibuffer-pane) type &rest args)
45 (declare (ignore type args))
46 (window-clear pane))
47
48 (define-application-frame climacs ()
49 ((win :reader win)
50 (buffers :initform '() :accessor buffers))
51 (:panes
52 (win (vertically ()
53 (scrolling ()
54 (make-pane 'extended-pane
55 :width 900 :height 400
56 :name 'bla
57 :incremental-redisplay t
58 :display-function 'display-win))
59 (make-pane 'application-pane
60 :width 900 :height 20 :max-height 20 :min-height 20
61 ::background +gray85+
62 :scroll-bars nil
63 :borders nil
64 :incremental-redisplay t
65 :display-function 'display-info)))
66 (int (make-pane 'minibuffer-pane
67 :width 900 :height 20 :max-height 20 :min-height 20
68 :scroll-bars nil)))
69 (:layouts
70 (default
71 (vertically (:scroll-bars nil)
72 win
73 int)))
74 (:top-level (climacs-top-level)))
75
76 (defmacro current-window ()
77 `(win *application-frame*))
78
79 (defmethod redisplay-frame-panes :around ((frame climacs) &rest args)
80 (declare (ignore args))
81 (let ((buffer (buffer (win frame))))
82 (update-syntax buffer (syntax buffer))
83 (call-next-method)
84 (clear-modify buffer)))
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 Syntax: ~a ~a"
98 (if (needs-saving buf) "**" "--")
99 (name buf)
100 (name (syntax buf))
101 (if (slot-value win 'overwrite-mode)
102 "Ovwrt"
103 ""))))
104 (princ name-info pane)))
105
106 (defun display-win (frame pane)
107 "The display function used by the climacs application frame."
108 (declare (ignore frame))
109 (redisplay-pane pane))
110
111 (defun find-gestures (gestures start-table)
112 (loop with table = (find-command-table start-table)
113 for (gesture . rest) on gestures
114 for item = (find-keystroke-item gesture table :errorp nil)
115 while item
116 do (if (eq (command-menu-item-type item) :command)
117 (return (if (null rest) item nil))
118 (setf table (command-menu-item-value item)))
119 finally (return item)))
120
121 (defvar *kill-ring* (make-instance 'kill-ring :max-size 7))
122 (defparameter *current-gesture* nil)
123
124 (defun meta-digit (gesture)
125 (position gesture
126 '((#\0 :meta) (#\1 :meta) (#\2 :meta) (#\3 :meta) (#\4 :meta)
127 (#\5 :meta) (#\6 :meta) (#\7 :meta) (#\8 :meta) (#\9 :meta))
128 :test #'event-matches-gesture-name-p))
129
130 (defun climacs-read-gesture ()
131 (loop for gesture = (read-gesture :stream *standard-input*)
132 when (event-matches-gesture-name-p gesture '(#\g :control))
133 do (throw 'outer-loop nil)
134 until (or (characterp gesture)
135 (and (typep gesture 'keyboard-event)
136 (or (keyboard-event-character gesture)
137 (not (member (keyboard-event-key-name
138 gesture)
139 '(:control-left :control-right
140 :shift-left :shift-right
141 :meta-left :meta-right
142 :super-left :super-right
143 :hyper-left :hyper-right
144 :shift-lock :caps-lock
145 :alt-left :alt-right))))))
146 finally (return gesture)))
147
148 (defun read-numeric-argument (&key (stream *standard-input*))
149 (let ((gesture (climacs-read-gesture)))
150 (cond ((event-matches-gesture-name-p gesture '(:keyboard #\u 512)) ; FIXME
151 (let ((numarg 4))
152 (loop for gesture = (climacs-read-gesture)
153 while (event-matches-gesture-name-p gesture '(:keyboard #\u 512)) ; FIXME
154 do (setf numarg (* 4 numarg))
155 finally (unread-gesture gesture :stream stream))
156 (let ((gesture (climacs-read-gesture)))
157 (cond ((and (characterp gesture)
158 (digit-char-p gesture 10))
159 (setf numarg (- (char-code gesture) (char-code #\0)))
160 (loop for gesture = (climacs-read-gesture)
161 while (and (characterp gesture)
162 (digit-char-p gesture 10))
163 do (setf numarg (+ (* 10 numarg)
164 (- (char-code gesture) (char-code #\0))))
165 finally (unread-gesture gesture :stream stream)
166 (return (values numarg t))))
167 (t
168 (unread-gesture gesture :stream stream)
169 (values numarg t))))))
170 ((meta-digit gesture)
171 (let ((numarg (meta-digit gesture)))
172 (loop for gesture = (climacs-read-gesture)
173 while (meta-digit gesture)
174 do (setf numarg (+ (* 10 numarg) (meta-digit gesture)))
175 finally (unread-gesture gesture :stream stream)
176 (return (values numarg t)))))
177 (t (unread-gesture gesture :stream stream)
178 (values 1 nil)))))
179
180 ;;; we know the vbox pane has a scroller pane and an info
181 ;;; pane in it. The scroller pane has a viewport in it,
182 ;;; and the viewport contains the climacs-pane as its only child.
183 (defun find-climacs-pane (vbox)
184 (first (sheet-children
185 (find-if-not (lambda (pane) (typep pane 'scroll-bar-pane))
186 (sheet-children
187 (find-if (lambda (pane) (typep pane 'scroller-pane))
188 (sheet-children vbox)))))))
189
190 (defun climacs-top-level (frame &key
191 command-parser command-unparser
192 partial-command-parser prompt)
193 (declare (ignore command-parser command-unparser partial-command-parser prompt))
194 (with-slots (win) frame
195 (setf win (find-climacs-pane (find-pane-named frame 'win)))
196 (push (buffer win) (buffers frame))
197 (let ((*standard-output* win)
198 (*standard-input* (find-pane-named frame 'int))
199 (*print-pretty* nil)
200 (*abort-gestures* nil))
201 (redisplay-frame-panes frame :force-p t)
202 (loop (catch 'outer-loop
203 (loop for gestures = '()
204 for numarg = (read-numeric-argument :stream *standard-input*)
205 do (loop (setf *current-gesture* (climacs-read-gesture))
206 (setf gestures (nconc gestures (list *current-gesture*)))
207 (let ((item (find-gestures gestures 'global-climacs-table)))
208 (cond ((not item)
209 (beep) (return))
210 ((eq (command-menu-item-type item) :command)
211 (let ((command (command-menu-item-value item)))
212 (unless (consp command)
213 (setf command (list command)))
214 (setf command (substitute-numeric-argument-marker command numarg))
215 (handler-case
216 (execute-frame-command frame command)
217 (error (condition)
218 (beep)
219 (format *error-output* "~a~%" condition)))
220 (setf (previous-command *standard-output*)
221 (if (consp command)
222 (car command)
223 command))
224 (return)))
225 (t nil))))
226 (let ((buffer (buffer (win frame))))
227 (when (modified-p buffer)
228 (setf (needs-saving buffer) t)))
229 (redisplay-frame-panes frame)))
230 (beep)
231 (let ((buffer (buffer (win frame))))
232 (when (modified-p buffer)
233 (setf (needs-saving buffer) t)))
234 (redisplay-frame-panes frame)))))
235
236 (defun region-limits (pane)
237 (if (mark< (mark pane) (point pane))
238 (values (mark pane) (point pane))
239 (values (point pane) (mark pane))))
240
241 (defmacro define-named-command (command-name args &body body)
242 `(define-climacs-command ,(if (listp command-name)
243 `(,@command-name :name t)
244 `(,command-name :name t)) ,args ,@body))
245
246 (define-named-command (com-quit) ()
247 (frame-exit *application-frame*))
248
249 (define-named-command com-toggle-overwrite-mode ()
250 (let ((win (current-window)))
251 (setf (slot-value win 'overwrite-mode)
252 (not (slot-value win 'overwrite-mode)))))
253
254 (define-command com-self-insert ()
255 (let* ((win (current-window))
256 (point (point win)))
257 (unless (constituentp *current-gesture*)
258 (possibly-expand-abbrev point))
259 (if (and (slot-value win 'overwrite-mode) (not (end-of-line-p point)))
260 (progn
261 (delete-range point)
262 (insert-object point *current-gesture*))
263 (insert-object point *current-gesture*))))
264
265 (define-named-command com-beginning-of-line ()
266 (beginning-of-line (point (current-window))))
267
268 (define-named-command com-end-of-line ()
269 (end-of-line (point (current-window))))
270
271 (define-named-command com-delete-object ((count 'integer :prompt "Number of Objects"))
272 (delete-range (point (current-window)) count))
273
274 (define-named-command com-backward-delete-object ((count 'integer :prompt "Number of Objects"))
275 (delete-range (point (current-window)) (- count)))
276
277 (define-named-command com-transpose-objects ()
278 (let* ((point (point (current-window))))
279 (unless (beginning-of-buffer-p point)
280 (when (end-of-line-p point)
281 (backward-object point))
282 (let ((object (object-after point)))
283 (delete-range point)
284 (backward-object point)
285 (insert-object point object)
286 (forward-object point)))))
287
288 (define-named-command com-backward-object ((count 'integer :prompt "Number of Objects"))
289 (backward-object (point (current-window)) count))
290
291 (define-named-command com-forward-object ((count 'integer :prompt "Number of Objects"))
292 (forward-object (point (current-window)) count))
293
294 (define-named-command com-transpose-words ()
295 (let* ((point (point (current-window))))
296 (let (bw1 bw2 ew1 ew2)
297 (backward-word point)
298 (setf bw1 (offset point))
299 (forward-word point)
300 (setf ew1 (offset point))
301 (forward-word point)
302 (when (= (offset point) ew1)
303 ;; this is emacs' message in the minibuffer
304 (error "Don't have two things to transpose"))
305 (setf ew2 (offset point))
306 (backward-word point)
307 (setf bw2 (offset point))
308 (let ((w2 (buffer-sequence (buffer point) bw2 ew2))
309 (w1 (buffer-sequence (buffer point) bw1 ew1)))
310 (delete-word point)
311 (insert-sequence point w1)
312 (backward-word point)
313 (backward-word point)
314 (delete-word point)
315 (insert-sequence point w2)
316 (forward-word point)))))
317
318 (define-named-command com-transpose-lines ()
319 (let ((point (point (current-window))))
320 (beginning-of-line point)
321 (unless (beginning-of-buffer-p point)
322 (previous-line point))
323 (let* ((bol (offset point))
324 (eol (progn (end-of-line point)
325 (offset point)))
326 (line (buffer-sequence (buffer point) bol eol)))
327 (delete-region bol point)
328 ;; Remove newline at end of line as well.
329 (unless (end-of-buffer-p point)
330 (delete-range point))
331 ;; If the current line is at the end of the buffer, we want to
332 ;; be able to insert past it, so we need to get an extra line
333 ;; at the end.
334 (when (progn (end-of-line point)
335 (end-of-buffer-p point))
336 (insert-object point #\Newline))
337 (next-line point)
338 (insert-sequence point line)
339 (insert-object point #\Newline))))
340
341 (define-named-command com-previous-line ()
342 (let* ((win (current-window))
343 (point (point win)))
344 (unless (or (eq (previous-command win) 'com-previous-line)
345 (eq (previous-command win) 'com-next-line))
346 (setf (slot-value win 'goal-column) (column-number point)))
347 (previous-line point (slot-value win 'goal-column))))
348
349 (define-named-command com-next-line ()
350 (let* ((win (current-window))
351 (point (point win)))
352 (unless (or (eq (previous-command win) 'com-previous-line)
353 (eq (previous-command win) 'com-next-line))
354 (setf (slot-value win 'goal-column) (column-number point)))
355 (next-line point (slot-value win 'goal-column))))
356
357 (define-named-command com-open-line ()
358 (open-line (point (current-window))))
359
360 (define-named-command com-kill-line ()
361 (let* ((pane (current-window))
362 (point (point pane))
363 (mark (offset point)))
364 (cond ((end-of-buffer-p point) nil)
365 ((end-of-line-p point)(forward-object point))
366 (t
367 (end-of-line point)
368 (cond ((beginning-of-buffer-p point) nil)
369 ((beginning-of-line-p point)(forward-object point)))))
370 (if (eq (previous-command pane) 'com-kill-line)
371 (kill-ring-concatenating-push *kill-ring*
372 (region-to-sequence mark point))
373 (kill-ring-standard-push *kill-ring*
374 (region-to-sequence mark point)))
375 (delete-region mark point)))
376
377 (define-named-command com-forward-word ()
378 (forward-word (point (current-window))))
379
380 (define-named-command com-backward-word ()
381 (backward-word (point (current-window))))
382
383 (define-named-command com-delete-word ()
384 (delete-word (point (current-window))))
385
386 (define-named-command com-backward-delete-word ()
387 (backward-delete-word (point (current-window))))
388
389 (define-named-command com-upcase-region ()
390 (multiple-value-bind (start end) (region-limits (current-window))
391 (upcase-region start end)))
392
393 (define-named-command com-downcase-region ()
394 (multiple-value-bind (start end) (region-limits (current-window))
395 (downcase-region start end)))
396
397 (define-named-command com-capitalize-region ()
398 (multiple-value-bind (start end) (region-limits (current-window))
399 (capitalize-region start end)))
400
401 (define-named-command com-upcase-word ()
402 (upcase-word (point (current-window))))
403
404 (define-named-command com-downcase-word ()
405 (downcase-word (point (current-window))))
406
407 (define-named-command com-capitalize-word ()
408 (capitalize-word (point (current-window))))
409
410 (define-named-command com-tabify-region ()
411 (let ((pane (current-window)))
412 (multiple-value-bind (start end) (region-limits pane)
413 (tabify-region start end (tab-space-count (stream-default-view pane))))))
414
415 (define-named-command com-untabify-region ()
416 (let ((pane (current-window)))
417 (multiple-value-bind (start end) (region-limits pane)
418 (untabify-region start end (tab-space-count (stream-default-view pane))))))
419
420 (defun indent-current-line (pane point)
421 (let* ((buffer (buffer pane))
422 (view (stream-default-view pane))
423 (tab-space-count (tab-space-count view))
424 (indentation (syntax-line-indentation point
425 tab-space-count
426 (syntax buffer))))
427 (indent-line point indentation (and (indent-tabs-mode buffer)
428 tab-space-count))))
429
430 (define-named-command com-indent-line ()
431 (let* ((pane (current-window))
432 (point (point pane)))
433 (indent-current-line pane point)))
434
435 (define-named-command com-newline-and-indent ()
436 (let* ((pane (current-window))
437 (point (point pane)))
438 (insert-object point #\Newline)
439 (indent-current-line pane point)))
440
441 (define-named-command com-delete-indentation ()
442 (delete-indentation (point (current-window))))
443
444 (define-command com-extended-command ()
445 (let ((item (accept 'command :prompt "Extended Command")))
446 (execute-frame-command *application-frame* item)))
447
448 (eval-when (:compile-toplevel :load-toplevel)
449 (define-presentation-type completable-pathname ()
450 :inherit-from 'pathname))
451
452 (defun filename-completer (so-far mode)
453 (flet ((remove-trail (s)
454 (subseq s 0 (let ((pos (position #\/ s :from-end t)))
455 (if pos (1+ pos) 0)))))
456 (let* ((directory-prefix
457 (if (and (plusp (length so-far)) (eql (aref so-far 0) #\/))
458 ""
459 (namestring #+sbcl *default-pathname-defaults*
460 #+cmu (ext:default-directory)
461 #-(or sbcl cmu) *default-pathname-defaults*)))
462 (full-so-far (concatenate 'string directory-prefix so-far))
463 (pathnames
464 (loop with length = (length full-so-far)
465 for path in (directory (concatenate 'string
466 (remove-trail so-far)
467 "*.*"))
468 when (let ((mismatch (mismatch (namestring path) full-so-far)))
469 (or (null mismatch) (= mismatch length)))
470 collect path))
471 (strings (mapcar #'namestring pathnames))
472 (first-string (car strings))
473 (length-common-prefix nil)
474 (completed-string nil)
475 (full-completed-string nil))
476 (unless (null pathnames)
477 (setf length-common-prefix
478 (loop with length = (length first-string)
479 for string in (cdr strings)
480 do (setf length (min length (or (mismatch string first-string) length)))
481 finally (return length))))
482 (unless (null pathnames)
483 (setf completed-string
484 (subseq first-string (length directory-prefix)
485 (if (null (cdr pathnames)) nil length-common-prefix)))
486 (setf full-completed-string
487 (concatenate 'string directory-prefix completed-string)))
488 (case mode
489 ((:complete-limited :complete-maximal)
490 (cond ((null pathnames)
491 (values so-far nil nil 0 nil))
492 ((null (cdr pathnames))
493 (values completed-string t (car pathnames) 1 nil))
494 (t
495 (values completed-string nil nil (length pathnames) nil))))
496 (:complete
497 (cond ((null pathnames)
498 (values so-far t so-far 1 nil))
499 ((null (cdr pathnames))
500 (values completed-string t (car pathnames) 1 nil))
501 ((find full-completed-string strings :test #'string-equal)
502 (let ((pos (position full-completed-string strings :test #'string-equal)))
503 (values completed-string
504 t (elt pathnames pos) (length pathnames) nil)))
505 (t
506 (values completed-string nil nil (length pathnames) nil))))
507 (:possibilities
508 (values nil nil nil (length pathnames)
509 (loop with length = (length directory-prefix)
510 for name in pathnames
511 collect (list (subseq (namestring name) length nil)
512 name))))))))
513
514 (define-presentation-method accept
515 ((type completable-pathname) stream (view textual-view) &key)
516 (multiple-value-bind (pathname success string)
517 (complete-input stream
518 #'filename-completer
519 :partial-completers '(#\Space)
520 :allow-any-input t)
521 (declare (ignore success))
522 (or pathname string)))
523
524 (defun pathname-filename (pathname)
525 (if (null (pathname-type pathname))
526 (pathname-name pathname)
527 (concatenate 'string (pathname-name pathname)
528 "." (pathname-type pathname))))
529
530 (define-named-command com-find-file ()
531 (let ((filename (accept 'completable-pathname
532 :prompt "Find File"))
533 (buffer (make-instance 'climacs-buffer))
534 (pane (current-window)))
535 (push buffer (buffers *application-frame*))
536 (setf (buffer (current-window)) buffer)
537 (setf (syntax buffer) (make-instance 'basic-syntax))
538 (with-open-file (stream filename :direction :input :if-does-not-exist :create)
539 (input-from-stream stream buffer 0))
540 (setf (filename buffer) filename
541 (name buffer) (pathname-filename filename)
542 (needs-saving buffer) nil)
543 (beginning-of-buffer (point pane))
544 ;; this one is needed so that the buffer modification protocol
545 ;; resets the low and high marks after redisplay
546 (redisplay-frame-panes *application-frame*)))
547
548 (define-named-command com-save-buffer ()
549 (let* ((buffer (buffer (current-window)))
550 (filename (or (filename buffer)
551 (accept 'completable-pathname
552 :prompt "Save Buffer to File"))))
553 (if (or (null (filename buffer))
554 (needs-saving buffer))
555 (progn (with-open-file (stream filename :direction :output :if-exists :supersede)
556 (output-to-stream stream buffer 0 (size buffer)))
557 (setf (filename buffer) filename
558 (name buffer) (pathname-filename filename))
559 (display-message "Wrote: ~a" (filename buffer)))
560 (display-message "No changes need to be saved from ~a" (name buffer)))
561 (setf (needs-saving buffer) nil)))
562
563 (define-named-command com-write-buffer ()
564 (let ((filename (accept 'completable-pathname
565 :prompt "Write Buffer to File"))
566 (buffer (buffer (current-window))))
567 (with-open-file (stream filename :direction :output :if-exists :supersede)
568 (output-to-stream stream buffer 0 (size buffer)))
569 (setf (filename buffer) filename
570 (name buffer) (pathname-filename filename)
571 (needs-saving buffer) nil)
572 (display-message "Wrote: ~a" (filename buffer))))
573
574 (define-presentation-method accept
575 ((type buffer) stream (view textual-view) &key)
576 (multiple-value-bind (object success string)
577 (complete-input stream
578 (lambda (so-far action)
579 (complete-from-possibilities
580 so-far (buffers *application-frame*) '() :action action
581 :name-key #'name
582 :value-key #'identity))
583 :partial-completers '(#\Space)
584 :allow-any-input t)
585 (declare (ignore success))
586 (or object
587 (car (push (make-instance 'climacs-buffer :name string)
588 (buffers *application-frame*))))))
589
590 (define-named-command com-switch-to-buffer ()
591 (let ((buffer (accept 'buffer
592 :prompt "Switch to buffer")))
593 (setf (buffer (current-window)) buffer)
594 (setf (syntax buffer) (make-instance 'basic-syntax))
595 (beginning-of-buffer (point (current-window)))
596 (full-redisplay (current-window))))
597
598 (define-named-command com-full-redisplay ()
599 (full-redisplay (current-window)))
600
601 (define-named-command com-load-file ()
602 (let ((filename (accept 'completable-pathname
603 :prompt "Load File")))
604 (load filename)))
605
606 (define-named-command com-beginning-of-buffer ()
607 (beginning-of-buffer (point (current-window))))
608
609 (define-named-command com-page-down ()
610 (let ((pane (current-window)))
611 (page-down pane)))
612
613 (define-named-command com-page-up ()
614 (let ((pane (current-window)))
615 (page-up pane)))
616
617 (define-named-command com-end-of-buffer ()
618 (end-of-buffer (point (current-window))))
619
620 (define-named-command com-back-to-indentation ()
621 (let ((point (point (current-window))))
622 (beginning-of-line point)
623 (loop until (end-of-line-p point)
624 while (whitespacep (object-after point))
625 do (incf (offset point)))))
626
627 (define-named-command com-goto-position ()
628 (setf (offset (point (current-window)))
629 (accept 'integer :prompt "Goto Position")))
630
631 (define-named-command com-goto-line ()
632 (loop with mark = (make-instance 'standard-right-sticky-mark
633 :buffer (buffer (current-window)))
634 do (end-of-line mark)
635 until (end-of-buffer-p mark)
636 repeat (accept 'integer :prompt "Goto Line")
637 do (incf (offset mark))
638 (end-of-line mark)
639 finally (beginning-of-line mark)
640 (setf (offset (point (current-window)))
641 (offset mark))))
642
643 (define-named-command com-browse-url ()
644 (accept 'url :prompt "Browse URL"))
645
646 (define-named-command com-set-mark ()
647 (let ((pane (current-window)))
648 (setf (mark pane) (clone-mark (point pane)))))
649
650 (define-named-command com-exchange-point-and-mark ()
651 (let ((pane (current-window)))
652 (psetf (offset (mark pane)) (offset (point pane))
653 (offset (point pane)) (offset (mark pane)))))
654
655 (define-named-command com-set-syntax ()
656 (let* ((pane (current-window))
657 (buffer (buffer pane)))
658 (setf (syntax buffer)
659 (make-instance (accept 'syntax :prompt "Set Syntax")))
660 (setf (offset (low-mark buffer)) 0
661 (offset (high-mark buffer)) (size buffer))))
662
663 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
664 ;;;
665 ;;; Commands for splitting windows
666
667 (define-named-command com-split-window-vertically ()
668 (with-look-and-feel-realization
669 ((frame-manager *application-frame*) *application-frame*)
670 (let* ((pane (current-window))
671 (new-pane (make-pane 'extended-pane
672 :width 900 :height 400
673 :name 'win
674 :incremental-redisplay t
675 :display-function 'display-win))
676 (parent (sheet-parent (sheet-parent (sheet-parent pane)))))
677 (setf (buffer new-pane) (buffer pane))
678 (sheet-adopt-child parent
679 (vertically ()
680 (scrolling () new-pane)
681 (make-pane 'application-pane
682 :width 900 :height 20
683 :max-height 20 :min-height 20
684 ::background +gray85+
685 :scroll-bars nil
686 :borders nil
687 :incremental-redisplay t
688 :display-function 'display-info)))
689 (setf (sheet-enabled-p new-pane) t)
690 (full-redisplay pane)
691 (full-redisplay new-pane))))
692
693 ;;;;;;;;;;;;;;;;;;;;
694 ;; Kill ring commands
695
696 ;; Copies an element from a kill-ring to a buffer at the given offset
697 (define-named-command com-yank ()
698 (insert-sequence (point (current-window)) (kill-ring-yank *kill-ring*)))
699
700 ;; Destructively cut a given buffer region into the kill-ring
701 (define-named-command com-cut-out ()
702 (multiple-value-bind (start end) (region-limits (current-window))
703 (kill-ring-standard-push *kill-ring* (region-to-sequence start end))
704 (delete-region (offset start) end)))
705
706 ;; Non destructively copies in buffer region to the kill ring
707 (define-named-command com-copy-out ()
708 (let ((pane (current-window)))
709 (kill-ring-standard-push *kill-ring* (region-to-sequence (point pane) (mark pane)))))
710
711 (define-named-command com-rotate-yank ()
712 (let* ((pane (current-window))
713 (point (point pane))
714 (last-yank (kill-ring-yank *kill-ring*)))
715 (if (eq (previous-command pane)
716 'com-rotate-yank)
717 (progn
718 (delete-range point (* -1 (length last-yank)))
719 (rotate-yank-position *kill-ring*)))
720 (insert-sequence point (kill-ring-yank *kill-ring*))))
721
722 (define-named-command com-resize-kill-ring ()
723 (let ((size (accept 'integer :prompt "New kill ring size")))
724 (setf (kill-ring-max-size *kill-ring*) size)))
725
726 (define-named-command com-search-forward ()
727 (search-forward (point (current-window))
728 (accept 'string :prompt "Search Forward")
729 :test (lambda (a b)
730 (and (characterp b) (char-equal a b)))))
731
732 (define-named-command com-search-backward ()
733 (search-backward (point (current-window))
734 (accept 'string :prompt "Search Backward")
735 :test (lambda (a b)
736 (and (characterp b) (char-equal a b)))))
737
738 (define-named-command com-dabbrev-expand ()
739 (let* ((win (current-window))
740 (point (point win)))
741 (with-slots (original-prefix prefix-start-offset dabbrev-expansion-mark) win
742 (flet ((move () (cond ((beginning-of-buffer-p dabbrev-expansion-mark)
743 (setf (offset dabbrev-expansion-mark)
744 (offset point))
745 (forward-word dabbrev-expansion-mark))
746 ((mark< dabbrev-expansion-mark point)
747 (backward-object dabbrev-expansion-mark))
748 (t (forward-object dabbrev-expansion-mark)))))
749 (unless (or (beginning-of-buffer-p point)
750 (not (constituentp (object-before point))))
751 (unless (and (eq (previous-command win) 'com-dabbrev-expand)
752 (not (null prefix-start-offset)))
753 (setf dabbrev-expansion-mark (clone-mark point))
754 (backward-word dabbrev-expansion-mark)
755 (setf prefix-start-offset (offset dabbrev-expansion-mark))
756 (setf original-prefix (region-to-sequence prefix-start-offset point))
757 (move))
758 (loop until (or (end-of-buffer-p dabbrev-expansion-mark)
759 (and (or (beginning-of-buffer-p dabbrev-expansion-mark)
760 (not (constituentp (object-before dabbrev-expansion-mark))))
761 (looking-at dabbrev-expansion-mark original-prefix)))
762 do (move))
763 (if (end-of-buffer-p dabbrev-expansion-mark)
764 (progn (delete-region prefix-start-offset point)
765 (insert-sequence point original-prefix)
766 (setf prefix-start-offset nil))
767 (progn (delete-region prefix-start-offset point)
768 (insert-sequence point
769 (let ((offset (offset dabbrev-expansion-mark)))
770 (prog2 (forward-word dabbrev-expansion-mark)
771 (region-to-sequence offset dabbrev-expansion-mark)
772 (setf (offset dabbrev-expansion-mark) offset))))
773 (move))))))))
774
775 (define-named-command com-beginning-of-paragraph ()
776 (let* ((pane (current-window))
777 (point (point pane))
778 (syntax (syntax (buffer pane))))
779 (beginning-of-paragraph point syntax)))
780
781 (define-named-command com-end-of-paragraph ()
782 (let* ((pane (current-window))
783 (point (point pane))
784 (syntax (syntax (buffer pane))))
785 (end-of-paragraph point syntax)))
786
787 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
788 ;;;
789 ;;; Global and dead-escape command tables
790
791 (make-command-table 'global-climacs-table :errorp nil)
792
793 (make-command-table 'dead-escape-climacs-table :errorp nil)
794
795 (add-menu-item-to-command-table 'global-climacs-table "dead-escape"
796 :menu 'dead-escape-climacs-table
797 :keystroke '(:escape))
798
799 (defun dead-escape-set-key (gesture command)
800 (add-command-to-command-table command 'dead-escape-climacs-table
801 :keystroke gesture :errorp nil))
802
803 (defun global-set-key (gesture command)
804 (add-command-to-command-table command 'global-climacs-table
805 :keystroke gesture :errorp nil)
806 (when (and
807 (listp gesture)
808 (find :meta gesture))
809 (dead-escape-set-key (remove :meta gesture) command)))
810
811 (loop for code from (char-code #\space) to (char-code #\~)
812 do (global-set-key (code-char code) 'com-self-insert))
813
814 (global-set-key #\newline 'com-self-insert)
815 (global-set-key #\tab 'com-indent-line)
816 (global-set-key '(#\j :control) 'com-newline-and-indent)
817 (global-set-key '(#\f :control) `(com-forward-object ,*numeric-argument-marker*))
818 (global-set-key '(#\b :control) `(com-backward-object ,*numeric-argument-marker*))
819 (global-set-key '(#\a :control) 'com-beginning-of-line)
820 (global-set-key '(#\e :control) 'com-end-of-line)
821 (global-set-key '(#\d :control) `(com-delete-object ,*numeric-argument-marker*))
822 (global-set-key '(#\p :control) 'com-previous-line)
823 (global-set-key '(#\l :control) 'com-full-redisplay)
824 (global-set-key '(#\n :control) 'com-next-line)
825 (global-set-key '(#\o :control) 'com-open-line)
826 (global-set-key '(#\k :control) 'com-kill-line)
827 (global-set-key '(#\t :control) 'com-transpose-objects)
828 (global-set-key '(#\Space :control) 'com-set-mark)
829 (global-set-key '(#\y :control) 'com-yank)
830 (global-set-key '(#\w :control) 'com-cut-out)
831 (global-set-key '(#\f :meta) 'com-forward-word)
832 (global-set-key '(#\b :meta) 'com-backward-word)
833 (global-set-key '(#\t :meta) 'com-transpose-words)
834 (global-set-key '(#\u :meta) 'com-upcase-word)
835 (global-set-key '(#\l :meta) 'com-downcase-word)
836 (global-set-key '(#\c :meta) 'com-capitalize-word)
837 (global-set-key '(#\x :meta) 'com-extended-command)
838 (global-set-key '(#\y :meta) 'com-rotate-yank)
839 (global-set-key '(#\w :meta) 'com-copy-out)
840 (global-set-key '(#\v :control) 'com-page-down)
841 (global-set-key '(#\v :meta) 'com-page-up)
842 (global-set-key '(#\< :shift :meta) 'com-beginning-of-buffer)
843 (global-set-key '(#\> :shift :meta) 'com-end-of-buffer)
844 (global-set-key '(#\m :meta) 'com-back-to-indentation)
845 (global-set-key '(#\^ :shift :meta) 'com-delete-indentation)
846 (global-set-key '(#\d :meta) 'com-delete-word)
847 (global-set-key '(#\Backspace :meta) 'com-backward-delete-word)
848 (global-set-key '(#\/ :meta) 'com-dabbrev-expand)
849 (global-set-key '(#\a :control :meta) 'com-beginning-of-paragraph)
850 (global-set-key '(#\e :control :meta) 'com-end-of-paragraph)
851
852 (global-set-key '(:up) 'com-previous-line)
853 (global-set-key '(:down) 'com-next-line)
854 (global-set-key '(:left) `(com-backward-object ,*numeric-argument-marker*))
855 (global-set-key '(:right) `(com-forward-object ,*numeric-argument-marker*))
856 (global-set-key '(:left :control) 'com-backward-word)
857 (global-set-key '(:right :control) 'com-forward-word)
858 (global-set-key '(:home) 'com-beginning-of-line)
859 (global-set-key '(:end) 'com-end-of-line)
860 (global-set-key '(:prior) 'com-page-up)
861 (global-set-key '(:next) 'com-page-down)
862 (global-set-key '(:home :control) 'com-beginning-of-buffer)
863 (global-set-key '(:end :control) 'com-end-of-buffer)
864 (global-set-key #\Rubout `(com-delete-object ,*numeric-argument-marker*))
865 (global-set-key #\Backspace `(com-backward-delete-object ,*numeric-argument-marker*))
866
867 (global-set-key '(:insert) 'com-toggle-overwrite-mode)
868
869 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
870 ;;;
871 ;;; C-x command table
872
873 (make-command-table 'c-x-climacs-table :errorp nil)
874
875 (add-menu-item-to-command-table 'global-climacs-table "C-x"
876 :menu 'c-x-climacs-table
877 :keystroke '(#\x :control))
878
879 (defun c-x-set-key (gesture command)
880 (add-command-to-command-table command 'c-x-climacs-table
881 :keystroke gesture :errorp nil))
882
883 (c-x-set-key '(#\2) 'com-split-window-vertically)
884 (c-x-set-key '(#\b) 'com-switch-to-buffer)
885 (c-x-set-key '(#\c :control) 'com-quit)
886 (c-x-set-key '(#\f :control) 'com-find-file)
887 (c-x-set-key '(#\l :control) 'com-load-file)
888 (c-x-set-key '(#\s :control) 'com-save-buffer)
889 (c-x-set-key '(#\t :control) 'com-transpose-lines)
890 (c-x-set-key '(#\w :control) 'com-write-buffer)
891 (c-x-set-key '(#\x :control) 'com-exchange-point-and-mark)
892
893 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
894 ;;;
895 ;;; Some Unicode stuff
896
897 (define-named-command com-insert-charcode ((code 'integer :prompt "Code point"))
898 (insert-object (point (current-window)) (code-char code)))
899
900 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
901 ;;;
902 ;;; Dead-acute command table
903
904 (make-command-table 'dead-acute-climacs-table :errorp nil)
905
906 (add-menu-item-to-command-table 'global-climacs-table "dead-acute"
907 :menu 'dead-acute-climacs-table
908 :keystroke '(:dead--acute))
909
910 (defun dead-acute-set-key (gesture command)
911 (add-command-to-command-table command 'dead-acute-climacs-table
912 :keystroke gesture :errorp nil))
913
914 (dead-acute-set-key '(#\A) '(com-insert-charcode 193))
915 (dead-acute-set-key '(#\E) '(com-insert-charcode 201))
916 (dead-acute-set-key '(#\I) '(com-insert-charcode 205))
917 (dead-acute-set-key '(#\O) '(com-insert-charcode 211))
918 (dead-acute-set-key '(#\U) '(com-insert-charcode 218))
919 (dead-acute-set-key '(#\Y) '(com-insert-charcode 221))
920 (dead-acute-set-key '(#\a) '(com-insert-charcode 225))
921 (dead-acute-set-key '(#\e) '(com-insert-charcode 233))
922 (dead-acute-set-key '(#\i) '(com-insert-charcode 237))
923 (dead-acute-set-key '(#\o) '(com-insert-charcode 243))
924 (dead-acute-set-key '(#\u) '(com-insert-charcode 250))
925 (dead-acute-set-key '(#\y) '(com-insert-charcode 253))
926 (dead-acute-set-key '(#\C) '(com-insert-charcode 199))
927 (dead-acute-set-key '(#\c) '(com-insert-charcode 231))
928 (dead-acute-set-key '(#\x) '(com-insert-charcode 215))
929 (dead-acute-set-key '(#\-) '(com-insert-charcode 247))
930 (dead-acute-set-key '(#\T) '(com-insert-charcode 222))
931 (dead-acute-set-key '(#\t) '(com-insert-charcode 254))
932 (dead-acute-set-key '(#\s) '(com-insert-charcode 223))
933 (dead-acute-set-key '(#\Space) '(com-insert-charcode 39))
934
935 (make-command-table 'dead-acute-dead-accute-climacs-table :errorp nil)
936
937 (add-menu-item-to-command-table 'dead-acute-climacs-table "dead-acute-dead-accute"
938 :menu 'dead-acute-dead-accute-climacs-table
939 :keystroke '(:dead--acute))
940
941 (defun dead-acute-dead-accute-set-key (gesture command)
942 (add-command-to-command-table command 'dead-acute-dead-accute-climacs-table
943 :keystroke gesture :errorp nil))
944
945 (dead-acute-dead-accute-set-key '(#\A) '(com-insert-charcode 197))
946 (dead-acute-dead-accute-set-key '(#\a) '(com-insert-charcode 229))
947 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
948 ;;;
949 ;;; Dead-grave command table
950
951 (make-command-table 'dead-grave-climacs-table :errorp nil)
952
953 (add-menu-item-to-command-table 'global-climacs-table "dead-grave"
954 :menu 'dead-grave-climacs-table
955 :keystroke '(:dead--grave))
956
957 (defun dead-grave-set-key (gesture command)
958 (add-command-to-command-table command 'dead-grave-climacs-table
959 :keystroke gesture :errorp nil))
960
961 (dead-grave-set-key '(#\A) '(com-insert-charcode 192))
962 (dead-grave-set-key '(#\E) '(com-insert-charcode 200))
963 (dead-grave-set-key '(#\I) '(com-insert-charcode 204))
964 (dead-grave-set-key '(#\O) '(com-insert-charcode 210))
965 (dead-grave-set-key '(#\U) '(com-insert-charcode 217))
966 (dead-grave-set-key '(#\a) '(com-insert-charcode 224))
967 (dead-grave-set-key '(#\e) '(com-insert-charcode 232))
968 (dead-grave-set-key '(#\i) '(com-insert-charcode 236))
969 (dead-grave-set-key '(#\o) '(com-insert-charcode 242))
970 (dead-grave-set-key '(#\u) '(com-insert-charcode 249))
971 (dead-grave-set-key '(#\Space) '(com-insert-charcode 96))
972
973 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
974 ;;;
975 ;;; Dead-diaeresis command table
976
977 (make-command-table 'dead-diaeresis-climacs-table :errorp nil)
978
979 (add-menu-item-to-command-table 'global-climacs-table "dead-diaeresis"
980 :menu 'dead-diaeresis-climacs-table
981 :keystroke '(:dead--diaeresis :shift))
982
983 (defun dead-diaeresis-set-key (gesture command)
984 (add-command-to-command-table command 'dead-diaeresis-climacs-table
985 :keystroke gesture :errorp nil))
986
987 (dead-diaeresis-set-key '(#\A) '(com-insert-charcode 196))
988 (dead-diaeresis-set-key '(#\E) '(com-insert-charcode 203))
989 (dead-diaeresis-set-key '(#\I) '(com-insert-charcode 207))
990 (dead-diaeresis-set-key '(#\O) '(com-insert-charcode 214))
991 (dead-diaeresis-set-key '(#\U) '(com-insert-charcode 220))
992 (dead-diaeresis-set-key '(#\a) '(com-insert-charcode 228))
993 (dead-diaeresis-set-key '(#\e) '(com-insert-charcode 235))
994 (dead-diaeresis-set-key '(#\i) '(com-insert-charcode 239))
995 (dead-diaeresis-set-key '(#\o) '(com-insert-charcode 246))
996 (dead-diaeresis-set-key '(#\u) '(com-insert-charcode 252))
997 (dead-diaeresis-set-key '(#\y) '(com-insert-charcode 255))
998 (dead-diaeresis-set-key '(#\Space) '(com-insert-charcode 34))
999
1000 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1001 ;;;
1002 ;;; Dead-tilde command table
1003
1004 (make-command-table 'dead-tilde-climacs-table :errorp nil)
1005
1006 (add-menu-item-to-command-table 'global-climacs-table "dead-tilde"
1007 :menu 'dead-tilde-climacs-table
1008 :keystroke '(:dead--tilde :shift))
1009
1010 (defun dead-tilde-set-key (gesture command)
1011 (add-command-to-command-table command 'dead-tilde-climacs-table
1012 :keystroke gesture :errorp nil))
1013
1014 (dead-tilde-set-key '(#\A) '(com-insert-charcode 195))
1015 (dead-tilde-set-key '(#\N) '(com-insert-charcode 209))
1016 (dead-tilde-set-key '(#\a) '(com-insert-charcode 227))
1017 (dead-tilde-set-key '(#\n) '(com-insert-charcode 241))
1018 (dead-tilde-set-key '(#\E) '(com-insert-charcode 198))
1019 (dead-tilde-set-key '(#\e) '(com-insert-charcode 230))
1020 (dead-tilde-set-key '(#\D) '(com-insert-charcode 208))
1021 (dead-tilde-set-key '(#\d) '(com-insert-charcode 240))
1022 (dead-tilde-set-key '(#\O) '(com-insert-charcode 216))
1023 (dead-tilde-set-key '(#\o) '(com-insert-charcode 248))
1024 (dead-tilde-set-key '(#\Space) '(com-insert-charcode 126))
1025
1026 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1027 ;;;
1028 ;;; Dead-circumflex command table
1029
1030 (make-command-table 'dead-circumflex-climacs-table :errorp nil)
1031
1032 (add-menu-item-to-command-table 'global-climacs-table "dead-circumflex"
1033 :menu 'dead-circumflex-climacs-table
1034 :keystroke '(:dead--circumflex :shift))
1035
1036 (defun dead-circumflex-set-key (gesture command)
1037 (add-command-to-command-table command 'dead-circumflex-climacs-table
1038 :keystroke gesture :errorp nil))
1039
1040 (dead-circumflex-set-key '(#\A) '(com-insert-charcode 194))
1041 (dead-circumflex-set-key '(#\E) '(com-insert-charcode 202))
1042 (dead-circumflex-set-key '(#\I) '(com-insert-charcode 206))
1043 (dead-circumflex-set-key '(#\O) '(com-insert-charcode 212))
1044 (dead-circumflex-set-key '(#\U) '(com-insert-charcode 219))
1045 (dead-circumflex-set-key '(#\a) '(com-insert-charcode 226))
1046 (dead-circumflex-set-key '(#\e) '(com-insert-charcode 234))
1047 (dead-circumflex-set-key '(#\i) '(com-insert-charcode 238))
1048 (dead-circumflex-set-key '(#\o) '(com-insert-charcode 244))
1049 (dead-circumflex-set-key '(#\u) '(com-insert-charcode 251))
1050 (dead-circumflex-set-key '(#\Space) '(com-insert-charcode 94))

  ViewVC Help
Powered by ViewVC 1.1.5