/[mcclim]/mcclim/Drei/basic-commands.lisp
ViewVC logotype

Contents of /mcclim/Drei/basic-commands.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.14 - (show annotations)
Mon Apr 28 20:48:55 2008 UTC (5 years, 11 months ago) by thenriksen
Branch: MAIN
CVS Tags: HEAD
Changes since 1.13: +2 -2 lines
Filter shift modifier state in CLX backend.

Also updated a bunch of key bindings to not specify :SHIFT anymore.
1 ;;; -*- Mode: Lisp; Package: DREI-COMMANDS -*-
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 ;;; (c) copyright 2006 by
12 ;;; Taylor R. Campbell (campbell@mumble.net)
13 ;;; (c) copyright 2006 by
14 ;;; Troels Henriksen (athas@sigkill.dk)
15
16 ;;; This library is free software; you can redistribute it and/or
17 ;;; modify it under the terms of the GNU Library General Public
18 ;;; License as published by the Free Software Foundation; either
19 ;;; version 2 of the License, or (at your option) any later version.
20 ;;;
21 ;;; This library is distributed in the hope that it will be useful,
22 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
23 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
24 ;;; Library General Public License for more details.
25 ;;;
26 ;;; You should have received a copy of the GNU Library General Public
27 ;;; License along with this library; if not, write to the
28 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
29 ;;; Boston, MA 02111-1307 USA.
30
31 ;;; Definitions of basic commands that are necessary for DREI to be
32 ;;; functional at all.
33
34 (in-package :drei-commands)
35
36 (defmacro handling-motion-limit-errors ((unit-plural &key (beep t)
37 (display-message t))
38 &body body)
39 "Evaluate body, if a `motion-limit-error' is signalled, beep if
40 `beep' is true (the default), and display a message stating that
41 there are no more `unit-plural's if `display-message' is
42 true (the default)."
43 `(handler-case (progn ,@body)
44 (motion-limit-error ()
45 ,(when beep
46 `(beep))
47 ,(when display-message
48 `(display-message ,(concatenate 'string "No more " unit-plural))))))
49
50 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
51 ;;;
52 ;;; Motion commands.
53 ;;; See information in motion.lisp
54 ;;;
55 ;;; Given the general motion functions FORWARD-<unit> and
56 ;;; BACKWARD-<unit>,
57 ;;;
58 ;;; (DEFINE-MOTION-COMMANDS <unit> <command-table>)
59 ;;;
60 ;;; defines the motion commands Forward <unit> and Backward <unit> in
61 ;;; <command-table>. The following keyword parameters are recognized:
62 ;;;
63 ;;; :NOUN
64 ;;; Noun to use in the docstring: `Move point forward by one
65 ;;; <noun>.' Default is the unit name, downcased.
66 ;;;
67 ;;; :PLURAL
68 ;;; Plural form for the prompt, `Number of <plural>', and the rest
69 ;;; of the docstring; e.g.: `With a numeric argument N, move point
70 ;;; forward by N <plural>.'
71
72 (defmacro define-motion-commands (unit command-table &key
73 noun
74 plural)
75 (labels ((concat (&rest strings)
76 (apply #'concatenate 'STRING (mapcar #'string strings)))
77 (symbol (&rest strings)
78 (intern (apply #'concat strings))))
79 (let ((forward (symbol "FORWARD-" unit))
80 (backward (symbol "BACKWARD-" unit))
81 (com-forward (symbol "COM-FORWARD-" unit))
82 (com-backward (symbol "COM-BACKWARD-" unit))
83 (noun (or noun (string-downcase unit)))
84 (plural (or plural (concat (string-downcase unit) "s"))))
85 `(PROGN
86 (DEFINE-COMMAND (,com-forward :NAME T
87 :COMMAND-TABLE ,command-table)
88 ((COUNT 'INTEGER :PROMPT ,(concat "Number of " plural) :default 1))
89 ,(concat "Move point forward by one " noun ".
90 With a numeric argument N, move point forward by N " plural ".
91 With a negative argument -N, move point backward by N " plural ".")
92 (handling-motion-limit-errors (,plural)
93 (,forward (point)
94 (current-syntax)
95 COUNT)))
96 (DEFINE-COMMAND (,com-backward :NAME T
97 :COMMAND-TABLE ,command-table)
98 ((COUNT 'INTEGER :PROMPT ,(concat "Number of " plural) :default 1))
99 ,(concat "Move point backward by one " noun ".
100 With a numeric argument N, move point backward by N " plural ".
101 With a negative argument -N, move point forward by N " plural ".")
102 (handling-motion-limit-errors (,plural)
103 (,backward (point)
104 (current-syntax)
105 COUNT)))))))
106
107 ;;; Manually define some commands
108
109 (define-command (com-beginning-of-line :name t :command-table movement-table) ()
110 "Move point to the beginning of the current line."
111 (beginning-of-line (point)))
112
113 (define-command (com-end-of-line :name t :command-table movement-table) ()
114 "Move point to the end of the current line."
115 (end-of-line (point)))
116
117 ;; Object movement comands - defined specially because FORWARD-OBJECT
118 ;; and BACKWARD-OBJECT is part of the buffer protocol, not the
119 ;; high-level motion abstraction.
120 (define-command (com-forward-object :name t :command-table movement-table)
121 ((count 'integer :prompt "Number of objects" :default 1))
122 "Move point forward by one object.
123 With a numeric argument N, move point forward by N objects.
124 With a negative argument -N, move point backward by M objects."
125 (handling-motion-limit-errors ("objects")
126 (forward-object (point)
127 count)))
128
129 (define-command (com-backward-object :name t :command-table movement-table)
130 ((count 'integer :prompt "number of objects" :default 1))
131 "Move point backward by one object.
132 With a numeric argument N, move point backward by N objects.
133 With a negative argument -N, move point forward by N objects."
134 (handling-motion-limit-errors ("objects")
135 (backward-object (point)
136 count)))
137
138 ;;; Autogenerate commands
139 (define-motion-commands word movement-table)
140 (define-motion-commands page movement-table)
141 (define-motion-commands paragraph movement-table)
142 (define-motion-commands sentence movement-table)
143
144 ;;; Lines have goal-columns, so we have to define the commands
145 ;;; manually.
146 (define-command (com-forward-line :name t :command-table movement-table)
147 ((count 'integer :prompt "number of lines" :default 1))
148 "move point forward by one line.
149 with a numeric argument n, move point forward by n lines.
150 with a negative argument -n, move point backward by n lines."
151 (handling-motion-limit-errors ("lines")
152 (unless (member (unlisted (previous-command (drei-instance)))
153 '(com-forward-line com-backward-line))
154 (setf (goal-column (current-view)) (column-number (point))))
155 (forward-line (point) (current-syntax) count)
156 (setf (column-number (point)) (goal-column (current-view)))))
157
158 (define-command (com-backward-line :name t :command-table movement-table)
159 ((count 'integer :prompt "number of lines" :default 1))
160 "move point backward by one line.
161 with a numeric argument n, move point backward by n lines.
162 with a negative argument -n, move point forward by n lines."
163 (handling-motion-limit-errors ("lines")
164 (unless (member (unlisted (previous-command (drei-instance)))
165 '(com-forward-line com-backward-line))
166 (setf (goal-column (current-view)) (column-number (point))))
167 (backward-line (point) (current-syntax) count)
168 (setf (column-number (point)) (goal-column (current-view)))))
169
170 ;;; Bind gestures to commands
171 (set-key `(com-forward-object ,*numeric-argument-marker*)
172 'movement-table
173 '((#\f :control)))
174
175 (set-key `(com-forward-object ,*numeric-argument-marker*)
176 'movement-table
177 '((#+(or mcclim building-mcclim) :right #-(or mcclim building-mcclim) :right-arrow)))
178
179 (set-key `(com-backward-object ,*numeric-argument-marker*)
180 'movement-table
181 '((#\b :control)))
182
183 (set-key `(com-backward-object ,*numeric-argument-marker*)
184 'movement-table
185 '((#+(or mcclim building-mcclim) :left #-(or mcclim building-mcclim) :left-arrow)))
186
187 (set-key `(com-forward-word ,*numeric-argument-marker*)
188 'movement-table
189 '((#\f :meta)))
190
191 (set-key `(com-forward-word ,*numeric-argument-marker*)
192 'movement-table
193 '((#+(or mcclim building-mcclim) :right #-(or mcclim building-mcclim) :right-arrow :control)))
194
195 (set-key `(com-backward-word ,*numeric-argument-marker*)
196 'movement-table
197 '((#\b :meta)))
198
199 (set-key `(com-backward-word ,*numeric-argument-marker*)
200 'movement-table
201 '((#+(or mcclim building-mcclim) :left #-(or mcclim building-mcclim) :left-arrow :control)))
202
203 (set-key `(com-forward-line ,*numeric-argument-marker*)
204 'movement-table
205 '((#\n :control)))
206
207 (set-key `(com-forward-line ,*numeric-argument-marker*)
208 'movement-table
209 '((#+(or mcclim building-mcclim) :down #-(or mcclim building-mcclim) :down-arrow)))
210
211 (set-key `(com-backward-line ,*numeric-argument-marker*)
212 'movement-table
213 '((#\p :control)))
214
215 (set-key `(com-backward-line ,*numeric-argument-marker*)
216 'movement-table
217 '((#+(or mcclim building-mcclim) :up #-(or mcclim building-mcclim) :up-arrow)))
218
219 (set-key 'com-beginning-of-line
220 'movement-table
221 '((:home)))
222
223 (set-key 'com-beginning-of-line
224 'movement-table
225 '((#\a :control)))
226
227 (set-key 'com-end-of-line
228 'movement-table
229 '((#\e :control)))
230
231 (set-key 'com-end-of-line
232 'movement-table
233 '((:end)))
234
235 (set-key `(com-forward-page ,*numeric-argument-marker*)
236 'movement-table
237 '((#\x :control) (#\])))
238
239 (set-key `(com-backward-page ,*numeric-argument-marker*)
240 'movement-table
241 '((#\x :control) (#\[)))
242
243 (set-key `(com-backward-paragraph ,*numeric-argument-marker*)
244 'movement-table
245 '((#\{ :meta)))
246
247 (set-key `(com-backward-paragraph ,*numeric-argument-marker*)
248 'movement-table
249 '((#+(or mcclim building-mcclim) :up #-(or mcclim building-mcclim) :up-arrow :control)))
250
251 (set-key `(com-forward-paragraph ,*numeric-argument-marker*)
252 'movement-table
253 '((#\} :meta)))
254
255 (set-key `(com-forward-paragraph ,*numeric-argument-marker*)
256 'movement-table
257 '((#+(or mcclim building-mcclim) :down #-(or mcclim building-mcclim) :down-arrow :control)))
258
259 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
260 ;;;
261 ;;; Editing commands.
262 ;;;
263 ;;; Commands for deleting, killing and moving stuff See information in
264 ;;; motion.lisp
265 ;;;
266 ;;; A deletion command is a command named Kill <Unit>, Backward Kill
267 ;;; <Unit>, Delete <Unit> or Backward Delete <Unit>. corresponding to
268 ;;; the editing functions FORWARD-KILL-<unit>, BACKWARD-KILL-<unit>,
269 ;;; FORWARD-DELETE-<unit> and BACKWARD-DELETE-<unit> respectively
270 ;;; (note that the "forward" prefix is gone in the command name).
271 ;;;
272 ;;; An editing command is a command named Transpose <Unit>s.
273 ;;;
274 ;;; This file also holds command definitions for other functions
275 ;;; defined in the DREI-EDITING package.
276
277 (defmacro define-deletion-commands (unit command-table &key
278 noun
279 plural)
280 (labels ((concat (&rest strings)
281 (apply #'concatenate 'STRING (mapcar #'string strings)))
282 (symbol (&rest strings)
283 (intern (apply #'concat strings)))
284 (try-to-find (&rest strings)
285 (find-symbol (apply #'concat
286 (mapcar #'string-upcase
287 (mapcar #'string strings))))))
288 (let ((forward-kill (try-to-find "FORWARD-KILL-" unit))
289 (backward-kill (try-to-find "BACKWARD-KILL-" unit))
290 (forward-delete (try-to-find "FORWARD-DELETE-" unit))
291 (backward-delete (try-to-find "BACKWARD-DELETE-" unit))
292 (com-kill (symbol "COM-KILL-" unit))
293 (com-backward-kill (symbol "COM-BACKWARD-KILL-" unit))
294 (com-delete (symbol "COM-DELETE-" unit))
295 (com-backward-delete (symbol "COM-BACKWARD-DELETE-" unit))
296 (noun (or noun (string-downcase unit))))
297 (unless (and forward-kill backward-kill forward-delete backward-delete)
298 (error "The unit ~A is not known." unit))
299 (let ((plural (or plural (concat (string-downcase unit) "s"))))
300 `(progn
301
302 ;; Kill Unit
303 (define-command (,com-kill :name t
304 :command-table ,command-table)
305 ((count 'integer :prompt ,(concat "Number of " plural) :default 1))
306 ,(concat "Kill " plural " up to the next " noun " end.
307 With a numeric argument, kill forward (backward if negative)
308 that many " plural ".
309
310 Successive kills append to the kill ring.")
311 (handling-motion-limit-errors (,plural)
312 (,forward-kill (point)
313 (current-syntax)
314 count
315 (eq (command-name *previous-command*) ',com-kill))))
316
317 ;; Backward Kill Unit
318 (define-command (,com-backward-kill
319 :name t
320 :command-table ,command-table)
321 ((count 'integer :prompt ,(concat "Number of " plural) :default 1))
322 ,(concat "Kill from point until the previous " noun " beginning.
323 With a numeric argument, kill backward (forward, if negative)
324 that many " plural ".
325
326 Successive kills append to the kill ring.")
327 (handling-motion-limit-errors (,plural)
328 (,backward-kill (point)
329 (current-syntax)
330 count
331 (eq (command-name *previous-command*) ',com-backward-kill))))
332
333 ;; Delete Unit
334 (define-command (,com-delete :name t :command-table ,command-table)
335 ((count 'integer :prompt ,(concat "Number of " plural) :default 1))
336 ,(concat "Delete from point until the next " noun " end.
337 With a positive numeric argument, delete that many " plural " forward.")
338 (handling-motion-limit-errors (,plural)
339 (,backward-delete (point) (current-syntax) count)))
340
341 ;; Backward Delete Unit
342 (define-command (,com-backward-delete :name t :command-table ,command-table)
343 ((count 'integer :prompt ,(concat "Number of " plural) :default 1))
344 ,(concat "Delete from point until the previous " noun " beginning.
345 With a positive numeric argument, delete that many " plural " backward.")
346 (handling-motion-limit-errors (,plural)
347 (,backward-delete (point) (current-syntax) count))))))))
348
349 (defmacro define-editing-commands (unit command-table &key
350 noun
351 plural)
352 (labels ((concat (&rest strings)
353 (apply #'concatenate 'STRING (mapcar #'string strings)))
354 (symbol (&rest strings)
355 (intern (apply #'concat strings)))
356 (try-to-find (&rest strings)
357 (find-symbol (apply #'concat
358 (mapcar #'string-upcase
359 (mapcar #'string strings))))))
360 (let* ((plural (or plural (concat (string-downcase unit) "s")))
361 (upcase-plural (string-upcase plural))
362 (noun (or noun (string-downcase unit)))
363 (transpose (try-to-find "TRANSPOSE-" upcase-plural))
364 (com-transpose (symbol "COM-TRANSPOSE-" upcase-plural)))
365 (unless (and transpose)
366 (error "The unit ~A is not known." unit))
367 `(progn
368 ;; Transpose Units
369 (define-command (,com-transpose :name t :command-table ,command-table)
370 ()
371 ,(concat "Transpose the " plural " around point,
372 leaving point at the end of them. With point in the
373 whitespace between words, transpose the " plural "
374 before and after point. With point inside a " noun ",
375 transpose that " noun " with the next one. With point
376 before the first " noun " of the buffer, transpose the
377 first two " plural " of the buffer.")
378 (handling-motion-limit-errors (,plural)
379 (,transpose (point) (current-syntax))))))))
380
381 ;;; Some manually defined commands
382
383 (define-command (com-transpose-objects :name t :command-table editing-table) ()
384 "Transpose the objects before and after point, advancing point.
385 At the end of a line transpose the previous two objects without
386 advancing point. At the beginning of the buffer do nothing. At
387 the beginning of any line other than the first effectively move
388 the first object of that line to the end of the previous line."
389 (transpose-objects (point)))
390
391 (define-command (com-delete-object :name t :command-table deletion-table)
392 ((count 'integer :prompt "Number of Objects" :default 1)
393 (killp 'boolean :prompt "Kill?" :default nil))
394 "Delete the object after point.
395 With a numeric argument, kill that many objects
396 after (or before, if negative) point."
397 (handling-motion-limit-errors ("objects")
398 (if killp
399 (forward-kill-object (point) count)
400 (forward-delete-object (point) count))))
401
402 (define-command (com-backward-delete-object :name t :command-table deletion-table)
403 ((count 'integer :prompt "Number of Objects" :default 1)
404 (killp 'boolean :prompt "Kill?" :default nil))
405 "Delete the object before point.
406 With a numeric argument, kills that many objects
407 before (or after, if negative) point."
408 (handling-motion-limit-errors ("objects")
409 (if killp
410 (backward-kill-object (point) count #'error-limit-action)
411 (backward-delete-object (point) count #'error-limit-action))))
412
413 ;; We require somewhat special behavior from Kill Line, so define a
414 ;; new function and use that to implement the Kill Line command.
415 (defun user-kill-line (mark &optional (count 1) (whole-lines-p nil) (concatenate-p nil))
416 (let ((start (offset mark)))
417 (cond ((= 0 count)
418 (beginning-of-line mark))
419 ((< count 0)
420 (loop repeat (- count)
421 until (beginning-of-buffer-p mark)
422 do (beginning-of-line mark)
423 until (beginning-of-buffer-p mark)
424 do (backward-object mark)))
425 ((or whole-lines-p (> count 1))
426 (loop repeat count
427 until (end-of-buffer-p mark)
428 do (end-of-line mark)
429 until (end-of-buffer-p mark)
430 do (forward-object mark)))
431 (t
432 (cond ((end-of-buffer-p mark) nil)
433 ((end-of-line-p mark) (forward-object mark))
434 (t (end-of-line mark)))))
435 (unless (mark= mark start)
436 (if concatenate-p
437 (kill-ring-concatenating-push *kill-ring*
438 (region-to-sequence start mark))
439 (kill-ring-standard-push *kill-ring*
440 (region-to-sequence start mark)))
441 (delete-region start mark))))
442
443 (define-command (com-kill-line :name t :command-table deletion-table)
444 ((numarg 'integer :prompt "Kill how many lines?" :default 1)
445 (numargp 'boolean :prompt "Kill entire lines?" :default nil))
446 "Kill the objects on the current line after point.
447 When at the end of a line, kill the #\\Newline.
448 With a numeric argument of 0, kill the objects on the current line before point.
449 With a non-zero numeric argument, kill that many lines forward (backward,
450 if negative) from point.
451
452 Successive kills append to the kill ring."
453 (let* ((concatenate-p (eq (command-name *previous-command*) 'com-kill-line)))
454 (user-kill-line (point) numarg numargp concatenate-p)))
455
456 ;;; Autogenerate commands
457
458 (define-deletion-commands word deletion-table)
459 (define-editing-commands word editing-table)
460 (define-editing-commands line editing-table)
461 (define-deletion-commands definition deletion-table)
462 (define-editing-commands definition editing-table)
463 (define-deletion-commands paragraph deletion-table)
464 (define-editing-commands paragraph editing-table)
465
466 ;;; Bind gestures to commands
467
468 (set-key `(com-kill-word ,*numeric-argument-marker*)
469 'deletion-table
470 '((#\d :meta)))
471
472 (set-key `(com-backward-kill-word ,*numeric-argument-marker*)
473 'deletion-table
474 '((#\Backspace :meta)))
475
476 (set-key 'com-transpose-words
477 'editing-table
478 '((#\t :meta)))
479
480 (set-key 'com-transpose-lines
481 'editing-table
482 '((#\x :control) (#\t :control)))
483
484 (set-key `(com-delete-object ,*numeric-argument-marker*
485 ,*numeric-argument-marker*)
486 'deletion-table
487 '(#\Rubout))
488
489 (set-key `(com-delete-object ,*numeric-argument-marker*
490 ,*numeric-argument-marker*)
491 'deletion-table
492 '((#\d :control)))
493
494 (set-key `(com-backward-delete-object ,*numeric-argument-marker*
495 ,*numeric-argument-marker*)
496 'deletion-table
497 '(#\Backspace))
498
499 (set-key 'com-transpose-objects
500 'editing-table
501 '((#\t :control)))
502
503 (set-key `(com-kill-line ,*numeric-argument-marker* ,*numeric-argument-marker*)
504 'deletion-table
505 '((#\k :control)))
506
507 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
508 ;;;
509 ;;; Self-insertion-commands.
510 ;;;
511 ;;; These are what do the basic keypress->character inserted in buffer
512 ;;; mapping.
513
514 (define-command com-self-insert
515 ((count 'integer :default 1))
516 "Insert the gesture used to invoke this command into the
517 current buffer `count' times. `Count' should get its value from
518 the numeric arguments."
519 (loop repeat count
520 do (insert-character *current-gesture*)))
521
522 (defmethod command-for-unbound-gestures ((view textual-drei-syntax-view) gestures)
523 (when (and (= (length gestures) 1)
524 (characterp (first gestures))
525 (graphic-char-p (first gestures)))
526 `(com-self-insert ,*numeric-argument-marker*)))
527
528 (set-key `(com-self-insert ,*numeric-argument-marker*)
529 'self-insert-table
530 '((#\Newline)))

  ViewVC Help
Powered by ViewVC 1.1.5