source: trunk/source/cocoa-ide/hemlock/src/morecoms.lisp @ 11838

Last change on this file since 11838 was 11838, checked in by gz, 10 years ago

Fix for #389 - if there is a selection, m-u/m-l/m-c operate on the selection.

Add a Capitalize Region command, but remove the default key bindings for all of Lowercase/Uppercase/Capitalize? Region commands, since they're now largely redundant with m-u/m-l/m-c.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 18.9 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;;; Written by Bill Chiles and Rob MacLachlan.
13;;;
14;;; Even more commands...
15
16(in-package :hemlock)
17
18(defhvar "Region Query Size"
19  "A number-of-lines threshold that destructive, undoable region commands
20   should ask the user about when the indicated region is too big."
21  :value 30)
22
23(defun check-region-query-size (region)
24  "Checks the number of lines in region against \"Region Query Size\" and
25   asks the user if the region crosses this threshold.  If the user responds
26   negatively, then an editor error is signaled."
27  (let ((threshold (or (value region-query-size) 0)))
28    (if (and (plusp threshold)
29             (>= (count-lines region) threshold)
30             (not (prompt-for-y-or-n
31                   :prompt "Region size exceeds \"Region Query Size\".  Confirm: "
32                   :must-exist t)))
33        (editor-error))))
34
35;;; Do nothing, but do it well ...
36(defcommand "Do Nothing" (p)
37  "Do nothing."
38  "Absolutely nothing."
39  (declare (ignore p)))
40
41
42(defcommand "Abort Command" (p)
43  "Abort reading a command in current view"
44  "Aborts c-q, multi-key commands (e.g. c-x), prefix translation (e.g.
45ESC as Meta-), prefix arguments (e.g. c-u), ephemeral modes such as
46i-search, and prompted input (e.g. m-x)"
47  (declare (ignore p))
48  (abort-to-toplevel))
49
50;;;; Casing commands...
51
52(defcommand "Uppercase Word" (p)
53  "Uppercase a word at point.
54   With prefix argument uppercase that many words."
55  "Uppercase p words at the point."
56  (if (region-active-p)
57    (hemlock::uppercase-region-command p)
58    (filter-words p (current-point) #'string-upcase)))
59
60(defcommand "Lowercase Word" (p)
61  "Uppercase a word at point.
62   With prefix argument uppercase that many words."
63  "Uppercase p words at the point."
64  (if (region-active-p)
65    (hemlock::lowercase-region-command p)
66    (filter-words p (current-point) #'string-downcase)))
67
68;;; FILTER-WORDS implements "Uppercase Word" and "Lowercase Word".
69;;;
70(defun filter-words (p point function)
71  (let ((arg (or p 1)))
72    (with-mark ((mark point))
73      (if (word-offset (if (minusp arg) mark point) arg)
74          (filter-region function (region mark point))
75          (editor-error "Not enough words.")))))
76
77;;; "Capitalize Word" is different than uppercasing and lowercasing because
78;;; the differences between Hemlock's notion of what a word is and Common
79;;; Lisp's notion are too annoying.
80;;;
81(defcommand "Capitalize Word" (p)
82  "Lowercase a word capitalizing the first character.  With a prefix
83  argument, capitalize that many words.  A negative argument capitalizes
84  words before the point, but leaves the point where it was."
85  "Capitalize p words at the point."
86  (if (region-active-p)
87    (hemlock::capitalize-region-command p)
88    (let ((point (current-point))
89          (arg (or p 1)))
90      (with-mark ((start point)
91                  (end point))
92        (when (minusp arg)
93          (unless (word-offset start arg) (editor-error "No previous word.")))
94        (do ((region (region start end))
95             (cnt (abs arg) (1- cnt)))
96            ((zerop cnt) (move-mark point end))
97          (unless (find-not-attribute start :word-delimiter)
98            (editor-error "No next word."))
99          (move-mark end start)
100          (unless (find-attribute end :word-delimiter)
101            (buffer-end end))
102          (capitalize-one-word region))))))
103
104(defun capitalize-one-word (region)
105  "Capitalize first word in region, moving region-start to region-end"
106  (let* ((start (region-start region))
107         (end (region-end region)))
108    ;; (assert (mark<= start end))
109    (loop
110      (when (mark= start end)
111        (return nil))
112      (let ((ch (next-character start)))
113        (when (alpha-char-p ch)
114          (setf (next-character start) (char-upcase ch))
115          (hi::buffer-note-modification (current-buffer) start 1)
116          (mark-after start)
117          (filter-region #'string-downcase region)
118          (move-mark start end)
119          (return t)))
120      (mark-after start))))
121
122(defcommand "Uppercase Region" (p)
123  "Uppercase words from point to mark."
124  "Uppercase words from point to mark."
125  (declare (ignore p))
126  (twiddle-region (current-region) #'string-upcase "Uppercase Region"))
127
128(defcommand "Lowercase Region" (p)
129  "Lowercase words from point to mark."
130  "Lowercase words from point to mark."
131  (declare (ignore p))
132  (twiddle-region (current-region) #'string-downcase "Lowercase Region"))
133
134;;; TWIDDLE-REGION implements "Uppercase Region" and "Lowercase Region".
135;;;
136(defun twiddle-region (region function name)
137  (let* (;; don't delete marks start and end since undo stuff will.
138         (start (copy-mark (region-start region) :left-inserting))
139         (end (copy-mark (region-end region) :left-inserting)))
140    (let* ((region (region start end))
141           (undo-region (copy-region region)))
142      (filter-region function region)
143      (move-mark (current-point) end)
144      (make-region-undo :twiddle name region undo-region))))
145
146(defcommand "Capitalize Region" (p)
147  "Capitalize words from point to mark."
148  (declare (ignore p))
149  (let* ((current-region (current-region))
150         (start (copy-mark (region-start current-region) :left-inserting))
151         (end (copy-mark (region-end current-region) :left-inserting))
152         (region (region start end))
153         (undo-region (copy-region region)))
154    (capitalize-words-in-region region)
155    (move-mark (current-point) end)
156    (make-region-undo :twiddle "Capitalize Region" region undo-region)))
157
158(defun capitalize-words-in-region (region)
159  (let ((limit (region-end region)))
160    (with-mark ((start (region-start region)))
161      (with-mark ((end start))
162        (let ((region (region start end)))
163          (loop
164            (unless (and (find-not-attribute start :word-delimiter)
165                         (mark< start limit))
166              (return))
167            ;; start is at a word constituent, there is at least one start <  limit
168            (move-mark end start)
169            (unless (find-attribute end :word-delimiter)
170              (buffer-end end))
171            (when (mark< limit end)
172              (move-mark end limit))
173            (capitalize-one-word region)
174            (move-mark start end)))))))
175
176
177;;;; More stuff.
178
179(defcommand "Delete Previous Character Expanding Tabs" (p)
180  "Delete the previous character.
181  When deleting a tab pretend it is the equivalent number of spaces.
182  With prefix argument, do it that many times."
183  "Delete the P previous characters, expanding tabs into spaces."
184  (let* ((buffer (current-buffer))
185         (region (hi::%buffer-current-region buffer)))
186    (if region
187      (delete-region region)
188      (let ((point (current-point))
189            (n (or p 1)))
190        (when (minusp n)
191          (editor-error "Delete Previous Character Expanding Tabs only accepts ~
192                     positive arguments."))
193        ;; Pre-calculate the number of characters that need to be deleted
194        ;; and any remaining white space filling, allowing modification to
195        ;; be avoided if there are not enough characters to delete.
196        (let ((errorp nil)
197              (del 0)
198              (fill 0))
199          (with-mark ((mark point))
200            (dotimes (i n)
201              (if (> fill 0)
202                (decf fill)
203                (let ((prev (previous-character mark)))
204                  (cond ((and prev (char= prev #\tab))
205                         (let ((pos (mark-column mark)))
206                           (mark-before mark)
207                           (incf fill (- pos (mark-column mark) 1)))
208                         (incf del))
209                        ((mark-before mark)
210                         (incf del))
211                        (t
212                         (setq errorp t)
213                         (return)))))))
214          (cond ((and (not errorp) (kill-characters point (- del)))
215                 (with-mark ((mark point :left-inserting))
216                   (dotimes (i fill)
217                     (insert-character mark #\space))))
218                (t
219                 (editor-error "There were not ~D characters before point." n))))))))
220
221
222(defvar *scope-table*
223  (list (make-string-table :initial-contents
224                           '(("Global" . :global)
225                             ("Buffer" . :buffer)
226                             ("Mode" . :mode)))))
227
228(defun prompt-for-place (prompt help)
229  (multiple-value-bind (word val)
230                       (prompt-for-keyword :tables *scope-table*
231                                           :prompt prompt
232                                           :help help :default "Global")
233    (declare (ignore word))
234    (case val
235      (:buffer
236       (values :buffer (prompt-for-buffer :help "Buffer to be local to."
237                                          :default (current-buffer))))
238      (:mode
239       (values :mode (prompt-for-keyword 
240                      :tables (list *mode-names*)
241                      :prompt "Mode: "
242                      :help "Mode to be local to."
243                      :default (buffer-major-mode (current-buffer)))))
244      (:global :global))))
245
246(defcommand "Bind Key" (p)
247  "Bind a command to a key.
248  The command, key and place to make the binding are prompted for."
249  "Prompt for stuff to do a bind-key."
250  (declare (ignore p))
251  (multiple-value-call #'bind-key 
252    (values (prompt-for-keyword
253             :tables (list *command-names*)
254             :prompt "Command to bind: "
255             :help "Name of command to bind to a key."))
256    (values (prompt-for-key 
257             :must-exist nil
258             :prompt "Bind to: "
259             :help "Key to bind command to, confirm to complete."))
260    (prompt-for-place "Kind of binding: "
261                      "The kind of binding to make.")))
262
263(defcommand "Delete Key Binding" (p)
264  "Delete a key binding.
265  The key and place to remove the binding are prompted for."
266  "Prompt for stuff to do a delete-key-binding."
267  (declare (ignore p))
268  (let ((key (prompt-for-key 
269              :must-exist nil
270              :prompt "Delete binding: "
271              :help "Key to delete binding from.")))
272    (multiple-value-bind (kind where)
273                         (prompt-for-place "Kind of binding: "
274                                           "The kind of binding to make.")
275      (unless (get-command key kind where) 
276        (editor-error "No such binding: ~S" key))
277      (delete-key-binding key kind where))))
278
279
280(defcommand "Set Variable" (p)
281  "Prompt for a Hemlock variable and a new value."
282  "Prompt for a Hemlock variable and a new value."
283  (declare (ignore p))
284  (multiple-value-bind (name var)
285                       (prompt-for-variable
286                        :prompt "Variable: "
287                        :help "The name of a variable to set.")
288    (declare (ignore name))
289    (setf (variable-value var)
290          (handle-lisp-errors
291           (eval (prompt-for-expression
292                  :prompt "Value: "
293                  :help "Expression to evaluate for new value."))))))
294
295(defcommand "Defhvar" (p)
296  "Define a hemlock variable in some location.  If the named variable exists
297   currently, its documentation is propagated to the new instance, but this
298   never prompts for documentation."
299  "Define a hemlock variable in some location."
300  (declare (ignore p))
301  (let* ((name (nstring-capitalize (prompt-for-variable :must-exist nil)))
302         (var (string-to-variable name))
303         (doc (if (hemlock-bound-p var)
304                  (variable-documentation var)
305                  ""))
306         (hooks (if (hemlock-bound-p var) (variable-hooks var)))
307         (val (prompt-for-expression :prompt "Variable value: "
308                                     :help "Value for the variable.")))
309    (multiple-value-bind
310        (kind where)
311        (prompt-for-place
312         "Kind of binding: "
313         "Whether the variable is global, mode, or buffer specific.")
314      (if (eq kind :global)
315          (defhvar name doc :value val :hooks hooks)
316          (defhvar name doc kind where :value val :hooks hooks)))))
317
318
319;;; TRANSPOSE REGIONS uses CURRENT-REGION to signal an error if the current
320;;; region is not active and to get start2 and end2 in proper order.  Delete1,
321;;; delete2, and delete3 are necessary since we are possibly ROTATEF'ing the
322;;; locals end1/start1, start1/start2, and end1/end2, and we need to know which
323;;; marks to dispose of at the end of all this stuff.  When we actually get to
324;;; swapping the regions, we must delete both up front if they both are to be
325;;; deleted since we don't know what kind of marks are in start1, start2, end1,
326;;; and end2, and the marks will be moving around unpredictably as we insert
327;;; text at them.  We copy point into ipoint for insertion purposes since one
328;;; of our four marks is the point.
329;;;
330(defcommand "Transpose Regions" (p)
331  "Transpose two regions with endpoints defined by the mark stack and point.
332   To use:  mark start of region1, mark end of region1, mark start of region2,
333   and place point at end of region2.  Invoking this immediately following
334   one use will put the regions back, but you will have to activate the
335   current region."
336  "Transpose two regions with endpoints defined by the mark stack and point."
337  (declare (ignore p))
338  (unless (>= (ring-length (value buffer-mark-ring)) 3)
339    (editor-error "Need two marked regions to do Transpose Regions."))
340  (let* ((region (current-region))
341         (end2 (region-end region))
342         (start2 (region-start region))
343         (delete1 (pop-buffer-mark))
344         (end1 (pop-buffer-mark))
345         (delete2 end1)
346         (start1 (pop-buffer-mark))
347         (delete3 start1))
348    ;;get marks in the right order, to simplify the code that follows
349    (unless (mark<= start1 end1) (rotatef start1 end1))
350    (unless (mark<= start1 start2)
351      (rotatef start1 start2)
352      (rotatef end1 end2))
353    ;;order now guaranteed:  <Buffer Start> start1 end1 start2 end2 <Buffer End>
354    (unless (mark<= end1 start2)
355      (editor-error "Can't transpose overlapping regions."))
356    (let* ((adjacent-p (mark= end1 start2))
357           (region1 (delete-and-save-region (region start1 end1)))
358           (region2 (unless adjacent-p
359                      (delete-and-save-region (region start2 end2))))
360           (point (current-point)))
361      (with-mark ((ipoint point :left-inserting))
362        (let ((save-end2-loc (push-new-buffer-mark end2)))
363          (ninsert-region (move-mark ipoint end2) region1)
364          (push-new-buffer-mark ipoint)
365          (cond (adjacent-p
366                 (push-new-buffer-mark start2)
367                 (move-mark point save-end2-loc))
368                (t (push-new-buffer-mark end1)
369                   (ninsert-region (move-mark ipoint end1) region2)
370                   (move-mark point ipoint))))))
371    (delete-mark delete1)
372    (delete-mark delete2)
373    (delete-mark delete3)))
374
375
376(defcommand "Goto Absolute Line" (p)
377  "Goes to the indicated line, if you counted them starting at the beginning
378   of the buffer with the number one.  If a prefix argument is supplied, that
379   is the line number; otherwise, the user is prompted."
380  "Go to a user perceived line number."
381  (let ((p (or p (prompt-for-expression
382                  :prompt "Line number: "
383                  :help "Enter an absolute line number to goto."))))
384    (unless (and (integerp p) (plusp p))
385      (editor-error "Must supply a positive integer."))
386    (let ((point (current-point)))
387      (with-mark ((m point))
388        (unless (line-offset (buffer-start m) (1- p) 0)
389          (editor-error "Not enough lines in buffer."))
390        (move-mark point m)))))
391
392(defcommand "Goto Absolute Position" (p)
393  "Goes to the indicated character position, if you counted them
394   starting at the beginning of the buffer with the number zero.  If a
395   prefix argument is supplied, that is the line number; otherwise, the
396  user is prompted."
397  "Go to a user perceived character position."
398  (let ((p (or p (prompt-for-expression
399                  :prompt "Character Position: "
400                  :help "Enter an absolute character position to goto."))))
401    (unless (and (integerp p) (not (minusp p)))
402      (editor-error "Must supply a non-negatige integer."))
403    (let ((point (current-point-unless-selection)))
404      (when point
405        (unless (move-to-absolute-position point p)
406          (buffer-end point))))))
407
408(defcommand "What Cursor Position" (p)
409  "Print info on current point position"
410  "Print info on current point position"
411  (declare (ignore p))
412  (let* ((point (current-point))
413         (line-number (do* ((l 1 (1+ l))
414                            (mark-line (line-previous (mark-line point)) (line-previous mark-line)))
415                           ((null mark-line) l)))
416         (charpos (mark-charpos point))
417         (abspos (mark-absolute-position point))
418         (char (next-character point))
419         (size (count-characters (buffer-region (current-buffer)))))
420    (message "Char: ~s point = ~d of ~d(~d%) line ~d column ~d"
421             char abspos size (round (/ (* 100 abspos) size)) line-number charpos)))
422
423(defcommand "Count Lines" (p)
424  "Display number of lines in the region."
425  "Display number of lines in the region."
426  (declare (ignore p))
427  (multiple-value-bind (region activep) (get-count-region)
428    (message "~:[After point~;Active region~]: ~A lines"
429             activep (count-lines region))))
430
431(defcommand "Count Words" (p)
432  "Prints in the Echo Area the number of words in the region
433   between the point and the mark by using word-offset. The
434   argument is ignored."
435  "Prints Number of Words in the Region"
436  (declare (ignore p))
437  (multiple-value-bind (region activep) (get-count-region)
438    (let ((end-mark (region-end region)))
439      (with-mark ((beg-mark (region-start region)))
440        (let ((word-count 0))
441          (loop
442            (when (mark>= beg-mark end-mark)
443              (return))
444            (unless (word-offset beg-mark 1)
445              (return))
446            (incf word-count))
447          (message "~:[After point~;Active region~]: ~D Word~:P"
448                   activep word-count))))))
449
450;;; GET-COUNT-REGION -- Internal Interface.
451;;;
452;;; Returns the active region or the region between point and end-of-buffer.
453;;; As a second value, it returns whether the region was active.
454;;;
455;;; Some searching commands use this routine.
456;;;
457(defun get-count-region ()
458  (if (region-active-p)
459      (values (current-region) t)
460      (values (region (current-point) (buffer-end-mark (current-buffer)))
461              nil)))
462
463
464
465;;;; Some modes:
466
467(defcommand "Fundamental Mode" (p)
468  "Put the current buffer into \"Fundamental\" mode."
469  "Put the current buffer into \"Fundamental\" mode."
470  (declare (ignore p))
471  (setf (buffer-major-mode (current-buffer)) "Fundamental"))
472
473;;;
474;;; Text mode.
475;;;
476
477(defmode "Text" :major-p t)
478
479(defcommand "Text Mode" (p)
480  "Put the current buffer into \"Text\" mode."
481  "Put the current buffer into \"Text\" mode."
482  (declare (ignore p))
483  (setf (buffer-major-mode (current-buffer)) "Text"))
484
485;;;
486;;; Caps-lock mode.
487;;;
488
489(defmode "CAPS-LOCK")
490
491(defcommand "Caps Lock Mode" (p)
492  "Simulate having a CAPS LOCK key.  Toggle CAPS-LOCK mode.  Zero or a
493   negative argument turns it off, while a positive argument turns it
494   on."
495  "Simulate having a CAPS LOCK key.  Toggle CAPS-LOCK mode.  Zero or a
496   negative argument turns it off, while a positive argument turns it
497   on."
498  (setf (buffer-minor-mode (current-buffer) "CAPS-LOCK")
499        (if p
500            (plusp p)
501            (not (buffer-minor-mode (current-buffer) "CAPS-LOCK")))))
502
503(defcommand "Self Insert Caps Lock" (p)
504  "Insert the last character typed, or the argument number of them.
505   If the last character was an alphabetic character, then insert its
506   capital form."
507  "Insert the last character typed, or the argument number of them.
508   If the last character was an alphabetic character, then insert its
509   capital form."
510  (let ((char (char-upcase (last-char-typed))))
511    (if (and p (> p 1))
512        (insert-string (current-point) (make-string p :initial-element char))
513        (insert-character (current-point) char))))
Note: See TracBrowser for help on using the repository browser.