source: trunk/source/cocoa-ide/hemlock/src/command.lisp @ 8428

Last change on this file since 8428 was 8428, checked in by gz, 13 years ago

Merge of the 'event-ide' branch. Hemlock's thread model has been changed
so that Hemlock commands now run in the Cocoa event thread -- see the
Hemlock file view.lisp for an overview.

IDE compilation has also been reorganized. Hemlock is now more fully
integrated into the IDE and cannot be compiled separately, sorry.

The hemlock-ext package has been repurposed to contain all interfaces
to window-system specific functionality.

There are also many many assorted other changes, cleanups and fixes.

The Hemlock documentation (Hemlock Command Implementor's Manual) in
http://trac.clozure.com/openmcl/wiki now correctly reflects the
implementation, although it doesn't (yet) describe the integration
with Cocoa or the threading model.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 19.2 KB
Line 
1;;; -*- Log: hemlock.log; Package: Hemlock -*-
2;;;
3;;; **********************************************************************
4;;; This code was written as part of the CMU Common Lisp project at
5;;; Carnegie Mellon University, and has been placed in the public domain.
6;;;
7#+CMU (ext:file-comment
8  "$Header$")
9;;;
10;;; **********************************************************************
11;;;
12;;; This file contains the definitions for the basic Hemlock commands.
13;;;
14
15(in-package :hemlock)
16
17
18;;; Make a mark for buffers as they're consed:
19
20(defun hcmd-new-buffer-hook-fun (buff)
21  (let ((ring (make-ring 10 #'delete-mark)))
22    (defhvar "Buffer Mark Ring" 
23      "This variable holds this buffer's mark ring."
24      :buffer buff
25      :value ring)
26    (setf (hi::buffer-%mark buff) (copy-mark (buffer-point buff) :right-inserting))))
27
28(add-hook make-buffer-hook #'hcmd-new-buffer-hook-fun)
29(dolist (buff *buffer-list*) (hcmd-new-buffer-hook-fun buff))
30
31
32
33
34
35
36
37;;;; Simple character manipulation:
38
39(defcommand "Self Insert" (p)
40  "Insert the last character typed.
41  With prefix argument insert the character that many times."
42  "Implements ``Self Insert'', calling this function is not meaningful."
43  (let ((char (last-char-typed)))
44    (unless char (editor-error "Can't insert that character."))
45    (if (and p (> p 1))
46        (insert-string
47         (current-point-for-insertion)
48         (make-string p :initial-element char))
49        (insert-character (current-point-for-insertion) char))))
50
51(defcommand "Quoted Insert" (p)
52  "Causes the next character typed to be inserted in the current
53   buffer, even if would normally be interpreted as an editor command."
54  (declare (ignore p))
55  (setf (hi::hemlock-view-quote-next-p hi::*current-view*) t))
56
57(defcommand "Forward Character" (p)
58  "Move the point forward one character, collapsing the selection.
59   With prefix argument move that many characters, with negative argument
60   go backwards."
61  "Move the point of the current buffer forward p characters, collapsing the selection."
62  (let* ((p (or p 1))
63         (point (current-point-collapsing-selection)))
64    (cond ((character-offset point p))
65          ((= p 1)
66           (editor-error "No next character."))
67          ((= p -1)
68           (editor-error "No previous character."))
69          (t
70           (if (plusp p)
71               (buffer-end point)
72               (buffer-start point))
73           (editor-error "Not enough characters.")))))
74
75(defcommand "Select Forward Character" (p)
76  "Move the point forward one character, extending the selection.
77   With prefix argument move that many characters, with negative argument
78   go backwards."
79  "Move the point of the current buffer forward p characters, extending the selection."
80  (let* ((p (or p 1))
81         (point (current-point-extending-selection)))
82    (cond ((character-offset point p))
83          ((= p 1)
84           (editor-error "No next character."))
85          ((= p -1)
86           (editor-error "No previous character."))
87          (t
88           (if (plusp p)
89               (buffer-end point)
90               (buffer-start point))
91           (editor-error "Not enough characters.")))))
92
93(defcommand "Backward Character" (p)
94  "Move the point backward one character, collapsing the selection.
95  With prefix argument move that many characters backward."
96  "Move the point p characters backward, collapsing the selection."
97  (forward-character-command (if p (- p) -1)))
98
99(defcommand "Select Backward Character" (p)
100  "Move the point backward one character, extending the selection.
101  With prefix argument move that many characters backward."
102  "Move the point p characters backward, extending the selection."
103  (select-forward-character-command (if p (- p) -1)))
104
105#|
106(defcommand "Delete Next Character" (p)
107  "Deletes the character to the right of the point.
108  With prefix argument, delete that many characters to the right
109  (or left if prefix is negative)."
110  "Deletes p characters to the right of the point."
111  (unless (delete-characters (current-point) (or p 1))
112    (buffer-end (current-point))
113    (editor-error "No next character.")))
114
115(defcommand "Delete Previous Character" (p)
116  "Deletes the character to the left of the point.
117  With prefix argument, delete that many characters to the left
118  (or right if prefix is negative)."
119  "Deletes p characters to the left of the point."
120  (unless (delete-characters (current-point) (if p (- p) -1))
121    (editor-error "No previous character.")))
122|#
123
124(defcommand "Delete Next Character" (p)
125  "Deletes the character to the right of the point.
126   With prefix argument, delete that many characters to the right
127  (or left if prefix is negative)."
128  "Deletes p characters to the right of the point."
129  (let* ((point (current-point-for-deletion)))
130    (when point
131      (cond ((kill-characters point (or p 1)))
132            ((and p (minusp p))
133             (editor-error "Not enough previous characters."))
134            (t
135             (editor-error "Not enough next characters."))))))
136
137(defcommand "Delete Previous Character" (p)
138  "Deletes the character to the left of the point.
139   Will push characters from successive deletes on to the kill ring."
140  "Deletes the character to the left of the point.
141   Will push characters from successive deletes on to the kill ring."
142  (delete-next-character-command (- (or p 1))))
143
144(defcommand "Transpose Characters" (p)
145  "Exchanges the characters on either side of the point and moves forward
146  With prefix argument, does this that many times.  A negative prefix
147  argument causes the point to be moved backwards instead of forwards."
148  "Exchanges the characters on either side of the point and moves forward."
149  (let ((arg (or p 1))
150        (point (current-point-unless-selection)))
151    (when point
152      (dotimes (i (abs arg))
153        (when (minusp arg) (mark-before point))
154        (let ((prev (previous-character point))
155              (next (next-character point)))
156
157          (cond ((not prev) (editor-error "No previous character."))
158                ((not next) (editor-error "No next character."))
159                (t
160                 (setf (previous-character point) next)
161                 (setf (next-character point) prev))))
162        (when (plusp arg) (mark-after point))))))
163
164;;;; Word hacking commands:
165
166;;; WORD-OFFSET
167;;;
168;;;    Move a mark forward/backward some words.
169;;;
170(defun word-offset (mark offset)
171  "Move Mark by Offset words."
172  (if (minusp offset)
173      (do ((cnt offset (1+ cnt)))
174          ((zerop cnt) mark)
175        (cond
176         ((null (reverse-find-attribute mark :word-delimiter #'zerop))
177          (return nil))
178         ((reverse-find-attribute mark :word-delimiter))
179         (t
180          (move-mark
181           mark (buffer-start-mark (mark-buffer mark))))))
182      (do ((cnt offset (1- cnt)))
183          ((zerop cnt) mark)
184        (cond
185         ((null (find-attribute mark :word-delimiter #'zerop))
186          (return nil))
187         ((null (find-attribute mark :word-delimiter))
188          (return nil))))))
189
190(defcommand "Forward Word" (p)
191  "Moves forward one word, collapsing the selection.
192  With prefix argument, moves the point forward over that many words."
193  "Moves the point forward p words, collapsing the selection."
194  (let* ((point (current-point-collapsing-selection)))
195    (cond ((word-offset point (or p 1)))
196          ((and p (minusp p))
197           (buffer-start point)
198           (editor-error "No previous word."))
199          (t
200           (buffer-end point)
201           (editor-error "No next word.")))))
202
203(defcommand "Select Forward Word" (p)
204  "Moves forward one word, extending the selection.
205  With prefix argument, moves the point forward over that many words."
206  "Moves the point forward p words, extending the selection."
207  (let* ((point (current-point-extending-selection)))
208    (cond ((word-offset point (or p 1)))
209          ((and p (minusp p))
210           (buffer-start point)
211           (editor-error "No previous word."))
212          (t
213           (buffer-end point)
214           (editor-error "No next word.")))))
215
216(defcommand "Backward Word" (p)
217  "Moves forward backward word.
218  With prefix argument, moves the point back over that many words."
219  "Moves the point backward p words."
220  (forward-word-command (- (or p 1))))
221
222(defcommand "Select Backward Word" (p)
223  "Moves forward backward word, extending the selection.
224  With prefix argument, moves the point back over that many words."
225  "Moves the point backward p words, extending the selection."
226  (select-forward-word-command (- (or p 1))))
227
228
229
230;;;; Moving around:
231
232(defun set-target-column (mark)
233  (if (eq (last-command-type) :line-motion)
234    (hi::hemlock-target-column hi::*current-view*)
235    (setf (hi::hemlock-target-column hi::*current-view*) (mark-column mark))))
236
237(defhvar "Next Line Inserts Newlines"
238    "If true, causes the \"Next Line\" command to insert newlines when
239     moving past the end of the buffer."
240  :value nil)
241
242
243(defcommand "Next Line" (p)
244  "Moves the point to the next line, collapsing the selection.
245   With prefix argument, moves the point that many lines down (or up if
246   the prefix is negative)."
247  "Moves the down p lines, collapsing the selection."
248  (let* ((point (current-point-collapsing-selection))
249         (target (set-target-column point))
250         (count (or p 1)))
251    (unless (line-offset point count)
252      (cond ((and (not p) (value next-line-inserts-newlines))
253             (when (same-line-p point (buffer-end-mark (current-buffer)))
254               (line-end point))
255             (insert-character point #\newline))
256            ((minusp count)
257             (buffer-start point)
258             (editor-error "No previous line."))
259            (t
260             (buffer-end point)
261             (editor-error "No next line."))))
262    (unless (move-to-position point target) (line-end point))
263    (setf (last-command-type) :line-motion)))
264
265(defcommand "Select Next Line" (p)
266  "Moves the point to the next line, extending the selection.
267   With prefix argument, moves the point that many lines down (or up if
268   the prefix is negative)."
269  "Moves the down p lines, extendin the selection."
270  (let* ((point (current-point-extending-selection))
271         (target (set-target-column point)))
272    (unless (line-offset point (or p 1))
273      (when (value next-line-inserts-newlines)
274        (cond ((not p)
275               (when (same-line-p point (buffer-end-mark (current-buffer)))
276                 (line-end point))
277               (insert-character point #\newline))
278              ((minusp p)
279               (buffer-start point)
280               (editor-error "No previous line."))
281              (t
282               (buffer-end point)
283               (when p (editor-error "No next line."))))))
284    (unless (move-to-position point target) (line-end point))
285    (setf (last-command-type) :line-motion)))
286
287
288(defcommand "Previous Line" (p)
289  "Moves the point to the previous line, collapsing the selection.
290  With prefix argument, moves the point that many lines up (or down if
291  the prefix is negative)."
292  "Moves the point up p lines, collapsing the selection."
293  (next-line-command (- (or p 1))))
294
295(defcommand "Select Previous Line" (p)
296  "Moves the point to the previous line, collapsing the selection.
297  With prefix argument, moves the point that many lines up (or down if
298  the prefix is negative)."
299  "Moves the point up p lines, collapsing the selection."
300  (select-next-line-command (- (or p 1))))
301
302(defcommand "Mark to End of Buffer" (p)
303  "Sets the current region from point to the end of the buffer."
304  "Sets the current region from point to the end of the buffer."
305  (declare (ignore p))
306  (buffer-end (push-new-buffer-mark (current-point) t)))
307
308(defcommand "Mark to Beginning of Buffer" (p)
309  "Sets the current region from the beginning of the buffer to point."
310  "Sets the current region from the beginning of the buffer to point."
311  (declare (ignore p))
312  (buffer-start (push-new-buffer-mark (current-point) t)))
313
314(defcommand "Beginning of Buffer" (p)
315  "Moves the point to the beginning of the current buffer, collapsing the selection."
316  "Moves the point to the beginning of the current buffer, collapsing the selection."
317  (declare (ignore p))
318  (let ((point (current-point-collapsing-selection)))
319    (push-new-buffer-mark point)
320    (buffer-start point)))
321
322(defcommand "End of Buffer" (p)
323  "Moves the point to the end of the current buffer."
324  "Moves the point to the end of the current buffer."
325  (declare (ignore p))
326  (let ((point (current-point-collapsing-selection)))
327    (push-new-buffer-mark point)
328    (buffer-end point)))
329
330(defcommand "Beginning of Line" (p)
331  "Moves the point to the beginning of the current line, collapsing the selection.
332  With prefix argument, moves the point to the beginning of the prefix'th
333  next line."
334  "Moves the point down p lines and then to the beginning of the line, collapsing the selection."
335  (let ((point (current-point-collapsing-selection)))
336    (unless (line-offset point (if p p 0)) (editor-error "No such line."))
337    (line-start point)))
338
339(defcommand "Select to Beginning of Line" (p)
340  "Moves the point to the beginning of the current line, extending the selection.
341  With prefix argument, moves the point to the beginning of the prefix'th
342  next line."
343  "Moves the point down p lines and then to the beginning of the line, extending the selection."
344  (let ((point (current-point-extending-selection)))
345    (unless (line-offset point (if p p 0)) (editor-error "No such line."))
346    (line-start point)))
347
348(defcommand "End of Line" (p)
349  "Moves the point to the end of the current line, collapsing the selection.
350  With prefix argument, moves the point to the end of the prefix'th next line."
351  "Moves the point down p lines and then to the end of the line, collapsing the selection."
352  (let ((point (current-point-collapsing-selection)))
353    (unless (line-offset point (if p p 0)) (editor-error "No such line."))
354    (line-end point)))
355
356(defcommand "Select to End of Line" (p)
357  "Moves the point to the end of the current line, extending the selection.
358  With prefix argument, moves the point to the end of the prefix'th next line."
359  "Moves the point down p lines and then to the end of the line, extending the selection."
360  (let ((point (current-point-extending-selection)))
361    (unless (line-offset point (if p p 0)) (editor-error "No such line."))
362    (line-end point)))
363
364(defhvar "Scroll Overlap"
365  "The \"Scroll Window\" commands leave this much overlap between screens."
366  :value 2)
367
368(defhvar "Scroll Redraw Ratio"
369  "This is a ratio of \"inserted\" lines to the size of a window.  When this
370   ratio is exceeded, insert/delete line terminal optimization is aborted, and
371   every altered line is simply redrawn as efficiently as possible.  For example,
372   setting this to 1/4 will cause scrolling commands to redraw the entire window
373   instead of moving the bottom two lines of the window to the top (typically
374   3/4 of the window is being deleted upward and inserted downward, hence a
375   redraw); however, commands line \"New Line\" and \"Open Line\" will still
376   efficiently, insert a line moving the rest of the window's text downward."
377  :value nil)
378
379(defcommand "Scroll Window Down" (p)
380  "Move down one screenfull.
381  With prefix argument scroll down that many lines."
382  "If P is NIL then scroll Window, which defaults to the current
383  window, down one screenfull.  If P is supplied then scroll that
384  many lines."
385  (if p
386    (set-scroll-position :lines-down p)
387    (set-scroll-position :page-down)))
388
389(defcommand "Scroll Window Up" (p)
390  "Move up one screenfull.
391  With prefix argument scroll up that many lines."
392  "If P is NIL then scroll Window, which defaults to the current
393  window, up one screenfull.  If P is supplied then scroll that
394  many lines."
395  (if p
396    (set-scroll-position :lines-up p)
397    (set-scroll-position :page-up)))
398
399;;;; Kind of miscellaneous commands:
400
401(defcommand "Refresh Screen" (p)
402  "Refreshes everything in the window, centering current line.
403With prefix argument, puts moves current line to top of window"
404  (if p
405    (set-scroll-position :line (current-point))
406    (set-scroll-position :center-selection)))
407
408
409(defcommand "Extended Command" (p)
410  "Prompts for and executes an extended command."
411  "Prompts for and executes an extended command.  The prefix argument is
412  passed to the command."
413  (let* ((name (prompt-for-keyword :tables (list *command-names*)
414                                   :prompt "Extended Command: "
415                                   :help "Name of a Hemlock command"))
416         (function (command-function (getstring name *command-names*))))
417    (funcall function p)))
418
419(defhvar "Universal Argument Default"
420  "Default value for \"Universal Argument\" command."
421  :value 4)
422
423(defstruct (prefix-argument-state (:conc-name "PS-"))
424  sign
425  multiplier
426  read-some-digit-p
427  ;; This is NIL if haven't started and don't have a universal argument, else a number
428  result
429  ;; This is cleared by prefix-argument-resetting-state (called at the start of each
430  ;; command) and can be set by a command to avoid the state being reset at
431  ;; the end of the command.
432  set-p)
433
434(defun prefix-argument-resetting-state (&optional (ps (current-prefix-argument-state)))
435  "Fetches the prefix argument and uses it up, i.e. marks it as not being set"
436  (unless (ps-set-p ps)
437    (setf (ps-sign ps) 1
438          (ps-multiplier ps) 1
439          (ps-read-some-digit-p ps) nil
440          (ps-result ps) nil))
441  (setf (ps-set-p ps) nil) ;; mark it for death unless explicitly revived.
442  (when (ps-result ps)
443    (* (ps-sign ps)
444       (if (ps-read-some-digit-p ps)
445         (ps-result ps)
446         (expt (value universal-argument-default) (ps-multiplier ps))))))
447
448(defun note-prefix-argument-set (ps)
449  (assert (ps-result ps))
450  (setf (ps-set-p ps) t)
451  (message (with-output-to-string (s)
452             (dotimes (i (ps-multiplier ps))
453               (write-string "C-U " s))
454             (cond ((ps-read-some-digit-p ps)
455                    (format s "~d" (* (ps-sign ps) (ps-result ps))))
456                   ((< (ps-sign ps) 0)
457                    (write-string "-" s))))))
458
459(defcommand "Universal Argument" (p)
460  "Sets prefix argument for next command.
461   Typing digits, regardless of any modifier keys, specifies the argument.
462   Optionally, you may first type a sign (- or +).  While typing digits, if you
463   type C-U or C-u, the digits following the C-U form a number this command
464   multiplies by the digits preceding the C-U.  The default value for this
465   command and any number following a C-U is the value of \"Universal Argument
466   Default\"."
467  (declare (ignore p)) ;; we operate on underlying state instead
468  (let ((ps (current-prefix-argument-state)))
469    (if (ps-result ps)
470      (incf (ps-multiplier ps))
471      (setf (ps-result ps) 0))
472    (note-prefix-argument-set ps)))
473
474(defcommand "Argument Digit" (p)
475  "This command is equivalent to invoking \"Universal Argument\" and typing
476   the key used to invoke this command.  It waits for more digits and a
477   command to which to give the prefix argument."
478  (declare (ignore p)) ;; we operate on underlying state instead
479  (let* ((ps (current-prefix-argument-state))
480         (key-event (last-key-event-typed))
481         (stripped-key-event (make-key-event key-event))
482         (char (key-event-char stripped-key-event))
483         (digit (if char (digit-char-p char))))
484    (when (null (ps-result ps))
485      (setf (ps-result ps) 0))
486    (case char
487      (#\-
488       (when (ps-read-some-digit-p ps) ;; could just insert it up front...
489         (editor-error "Must type minus sign first."))
490       (setf (ps-sign ps) (- (ps-sign ps))))
491      (#\+
492       (when (ps-read-some-digit-p ps) ;; could just insert it up front...
493         (editor-error "Must type plus sign first.")))
494      (t
495       (unless digit
496         (editor-error "Argument Digit must be bound to a digit!"))
497       (setf (ps-read-some-digit-p ps) t)
498       (setf (ps-result ps) (+ digit (* (ps-result ps) 10)))))
499    (note-prefix-argument-set ps)))
500
501(defcommand "Digit" (p)
502  "With a numeric argument, this command extends the argument.
503   Otherwise it does self insert"
504  (if p
505    (argument-digit-command p)
506    (self-insert-command p)))
Note: See TracBrowser for help on using the repository browser.