Inhibited non-core movement commands.
[vimpulse:vimpulse.git] / vimpulse-utils.el
1 ;;;; General utility code used by all of Vimpulse;
2 ;;;; may be useful to the end user
3
4 ;;; Autogenerated vi bindings
5
6 (defun vimpulse-augment-keymap
7   (map augment-alist &optional replace)
8   "Augment MAP with bindings from AUGMENT-ALIST.
9 If REPLACE is non-nil, bindings in MAP may be overwritten.
10 AUGMENT-ALIST has the format ((KEY . DEF) ...),
11 where KEY and DEF are passed to `define-key'."
12   (let (key def num)
13     (dolist (binding augment-alist)
14       (setq key (car binding)
15             def (cdr binding)
16             num (lookup-key map key))
17       (cond
18        (replace
19         (when (numberp num)
20           (define-key map (vimpulse-truncate key num) nil))
21         (define-key map key def))
22        (t
23         (when (numberp num)
24           (setq num (lookup-key map (vimpulse-truncate key num))))
25         (unless num
26           (define-key map key def)))))))
27
28 (defun vimpulse-add-vi-bindings (map cmds &optional replace filter)
29   "Add vi bindings for CMDS to MAP.
30 Add forcefully if REPLACE is t. Don't add keys matching FILTER,
31 which is a list of key vectors."
32   (let ((bindings (apply 'vimpulse-get-vi-bindings cmds)))
33     (unless filter
34       (when (and (boundp 'viper-want-ctl-h-help)
35                  viper-want-ctl-h-help)
36         (add-to-list 'filter [?\C-h]))
37       (unless (and (boundp 'vimpulse-want-C-u-like-Vim)
38                    vimpulse-want-C-u-like-Vim)
39         (add-to-list 'filter [?\C-u])))
40     (dolist (key filter)
41       (setq bindings (assq-delete-all key bindings)))
42     (vimpulse-augment-keymap map bindings replace)))
43
44 (defun vimpulse-get-bindings (cmd &rest maps)
45   "Return assocation list of bindings for CMD in MAPS."
46   (let (keys bindings)
47     (setq maps (or maps '(nil)))
48     (dolist (map maps bindings)
49       (unless (keymapp map)
50         (setq map (eval map)))
51       (setq keys (where-is-internal cmd map))
52       (dolist (key keys)
53         (unless (assq key bindings)
54           (add-to-list 'bindings (cons key cmd) t))))))
55
56 (defun vimpulse-get-vi-bindings (&rest cmds)
57   "Return assocation list of vi bindings for CMDS."
58   (let (bindings)
59     (dolist (cmd cmds bindings)
60       (dolist (binding (apply 'vimpulse-get-bindings cmd
61                               '(viper-vi-intercept-map
62                                 viper-vi-local-user-map
63                                 viper-vi-global-user-map
64                                 viper-vi-kbd-map
65                                 viper-vi-diehard-map
66                                 viper-vi-basic-map)))
67         (unless (assq (car binding) bindings)
68           (add-to-list 'bindings binding t))))))
69
70 (defun vimpulse-add-movement-cmds (map &optional replace)
71   "Add Viper/Vimpulse movement commands to MAP.
72 The commands are taken from `vimpulse-viper-movement-cmds' and looked
73 up in vi keymaps. If REPLACE is non-nil, may overwrite bindings
74 in MAP."
75   (vimpulse-add-vi-bindings map vimpulse-viper-movement-cmds replace))
76
77 ;; The default for this function is to replace rather than augment,
78 ;; as core navigation should be present everywhere
79 (defun vimpulse-add-core-movement-cmds (map &optional augment)
80   "Add \"core\" movement commands to MAP, forcefully.
81 The commands are taken from `vimpulse-core-movement-cmds'.
82 If AUGMENT is non-nil, don't overwrite bindings in MAP."
83   (vimpulse-add-vi-bindings map
84                             vimpulse-core-movement-cmds
85                             (not augment)))
86
87 (defun vimpulse-inhibit-cmds (map cmds &optional replace)
88   "Remap CMDS to `viper-nil' in MAP.
89 REPLACE is passed to `vimpulse-augment-keymap'."
90   (vimpulse-augment-keymap
91    map (mapcar (lambda (cmd)
92                  (cons `[remap ,cmd] 'viper-nil))
93                cmds) replace))
94
95 (defun vimpulse-inhibit-movement-cmds (map &optional replace)
96   "Remap Viper movement commands to `viper-nil' in MAP.
97 The commands are taken from `vimpulse-viper-movement-cmds'.
98 If REPLACE is non-nil, may overwrite bindings in MAP."
99   (vimpulse-inhibit-cmds map vimpulse-viper-movement-cmds replace))
100
101 (defun vimpulse-inhibit-other-movement-cmds (map &optional replace)
102   "Remap non-core Viper movement commands to `viper-nil' in MAP.
103 The commands are taken from `vimpulse-viper-movement-cmds'.
104 If REPLACE is non-nil, may overwrite bindings in MAP."
105   (let ((cmds vimpulse-viper-movement-cmds))
106     ;; Remove core movement commands
107     (dolist (cmd vimpulse-core-movement-cmds)
108       (setq cmds (delq cmd cmds)))
109     (vimpulse-inhibit-cmds map cmds replace)))
110
111 (defun vimpulse-inhibit-destructive-cmds (map &optional replace)
112   "Remap destructive Viper commands to `viper-nil' in MAP."
113   (let ((cmds '(viper-Append
114                 viper-Insert
115                 viper-append
116                 viper-change-to-eol
117                 viper-command-argument
118                 viper-insert
119                 viper-kill-line
120                 viper-substitute
121                 viper-substitute-line
122                 vimpulse-change
123                 vimpulse-delete
124                 vimpulse-visual-append
125                 vimpulse-visual-insert)))
126     (vimpulse-inhibit-cmds map cmds replace)))
127
128 (defmacro vimpulse-remap (keymap from to)
129   "Remap FROM to TO in KEYMAP.
130 For XEmacs compatibility, KEYMAP should have a `remap-alist'
131 property referring to a variable used for storing a \"remap
132 association list\"."
133   (if (featurep 'xemacs)
134       `(let ((remap-alist (get ',keymap 'remap-alist))
135              (from ,from) (to ,to))
136          (when remap-alist
137            (add-to-list remap-alist (cons from to))))
138     `(let ((keymap ,keymap) (from ,from) (to ,to))
139        (define-key keymap `[remap ,from] to))))
140
141 (defun vimpulse-vi-remap (from to &optional keymap)
142   "Remap FROM to TO in vi (command) state.
143 If KEYMAP is specified, take the keys that FROM is bound to
144 in vi state and bind them to TO in KEYMAP."
145   (if keymap
146       (vimpulse-augment-keymap
147        keymap
148        (mapcar (lambda (binding)
149                  (cons (car binding) to))
150                (vimpulse-get-vi-bindings from)))
151     (define-key viper-vi-basic-map `[remap ,from] to)))
152
153 ;;; Vector tools
154
155 (defun vimpulse-truncate (vector length &optional offset)
156   "Return a copy of VECTOR truncated to LENGTH.
157 If LENGTH is negative, skip last elements of VECTOR.
158 If OFFSET is specified, skip first elements of VECTOR."
159   ;; If LENGTH is too large, trim it
160   (when (> length (length vector))
161     (setq length (length vector)))
162   ;; If LENGTH is negative, convert it to the positive equivalent
163   (when (> 0 length)
164     (setq length (+ (length vector) length)))
165   (when (> 0 length)
166     (setq length 0))
167   (if offset
168       (setq length (- length offset))
169     (setq offset 0))
170   (let ((result (make-vector length t)))
171     (dotimes (idx length result)
172       (aset result idx (aref vector (+ idx offset))))))
173
174 (defun vimpulse-strip-prefix (key-sequence)
175   "Strip any prefix argument keypresses from KEY-SEQUENCE.
176 This is useful for deriving a \"standard\" key-sequence from
177 `this-command-keys', to be looked up in `vimpulse-modal-alist'."
178   (let* ((offset 0)
179          (temp-sequence (vconcat key-sequence))
180          (key (aref temp-sequence offset))
181          (length (length temp-sequence)))
182     ;; If XEmacs, get rid of the event object type
183     (and (featurep 'xemacs) (eventp key)
184          (setq key (event-to-character key nil t)))
185     ;; Any keys bound to `universal-argument', `digit-argument' or
186     ;; `negative-argument' or bound in `universal-argument-map'
187     ;; are considered prefix keys.
188     (while (and (or (memq (key-binding (vector key) t)
189                           '(universal-argument
190                             digit-argument
191                             negative-argument))
192                     (lookup-key universal-argument-map
193                                 (vector key)))
194                 (setq offset (1+ offset))
195                 (< offset length))
196       (setq key (aref temp-sequence offset))
197       (and (featurep 'xemacs) (eventp key)
198            (setq key (event-to-character key nil t))))
199     (vimpulse-truncate temp-sequence length offset)))
200
201 (defun vimpulse-memq-recursive (elt list)
202   "Return t if ELT is an element of LIST.
203 LIST may be nested."
204   (let ((this (car list))
205         (rest (cdr list)))
206     (cond
207      ((eq this elt)
208       t)
209      ((and this (listp this)) ; nil is a list
210       (vimpulse-memq-recursive elt this))
211      (rest
212       (vimpulse-memq-recursive elt rest)))))
213
214 ;;; Movement
215
216 (defun vimpulse-move-to-column (column &optional dir force)
217   "Move point to column COLUMN in the current line.
218 Places point at left of the tab character (at the right
219 if DIR is non-nil) and returns point.
220 If `vimpulse-visual-block-untabify' is non-nil, then
221 tabs are changed to spaces. (FORCE untabifies regardless.)"
222   (interactive "p")
223   (if (or vimpulse-visual-block-untabify force)
224       (move-to-column column t)
225     (move-to-column column)
226     (when (or (not dir) (and (numberp dir) (> 1 dir)))
227       (when (< column (current-column))
228         (unless (bolp)
229           (backward-char)))))
230   (point))
231
232 (defmacro vimpulse-limit (start end &rest body)
233   "Eval BODY, but limit point to buffer-positions START and END.
234 Both may be nil. Returns position."
235   (declare (indent 2))
236   `(let ((start (or ,start (point-min)))
237          (end   (or ,end   (point-max))))
238      (when (< end start)
239        (setq start (prog1 end
240                      (setq end start))))
241      (save-restriction
242        (narrow-to-region start end)
243        ,@body
244        (point))))
245
246 (defmacro vimpulse-skip (dir bounds &rest body)
247   "Eval BODY, but limit point to BOUNDS in DIR direction.
248 Returns position."
249   (declare (indent 2))
250   `(let ((dir ,dir) (bounds ,bounds) start end)
251      (setq dir (if (and (numberp dir) (> 0 dir)) -1 1))
252      (dolist (bound bounds)
253        (unless (numberp bound)
254          (setq bounds (delq bound bounds))))
255      (when bounds
256        (if (> 0 dir)
257            (setq start (apply 'min bounds))
258          (setq end (apply 'max bounds))))
259      (vimpulse-limit start end ,@body)))
260
261 (defun vimpulse-skip-regexp (regexp dir &rest bounds)
262   "Move point in DIR direction based on REGEXP and BOUNDS.
263 REGEXP is passed to `looking-at' or `looking-back'.
264 If DIR is positive, move forwards to the end of the regexp match,
265 but not beyond any buffer positions listed in BOUNDS.
266 If DIR is negative, move backwards to the beginning of the match.
267 Returns the new position."
268   (setq dir (if (and (numberp dir) (> 0 dir)) -1 1))
269   (setq regexp (or regexp ""))
270   (vimpulse-skip dir bounds
271     (if (> 0 dir)
272         (when (looking-back regexp nil t)
273           (goto-char (match-beginning 0)))
274       (when (looking-at regexp)
275         (goto-char (match-end 0))))))
276
277 ;; XEmacs only has `looking-at'
278 (unless (fboundp 'looking-back)
279   (defun looking-back (regexp &optional limit greedy)
280     "Return t if text before point matches regular expression REGEXP."
281     (let ((start (point))
282           (pos
283            (save-excursion
284              (and (re-search-backward
285                    (concat "\\(?:" regexp "\\)\\=") limit t)
286                   (point)))))
287       (if (and greedy pos)
288           (save-restriction
289             (narrow-to-region (point-min) start)
290             (while (and (> pos (point-min))
291                         (save-excursion
292                           (goto-char pos)
293                           (backward-char 1)
294                           (looking-at
295                            (concat "\\(?:" regexp "\\)\\'"))))
296               (setq pos (1- pos)))
297             (save-excursion
298               (goto-char pos)
299               (looking-at (concat "\\(?:"  regexp "\\)\\'")))))
300       (not (null pos)))))
301
302 (defun vimpulse-backward-up-list (&optional arg)
303   "Like `backward-up-list', but breaks out of strings."
304   (interactive "p")
305   (let ((orig (point)))
306     (setq arg (or arg 1))
307     (while (progn
308              (condition-case
309                  nil (backward-up-list arg)
310                (error nil))
311              (when (eq orig (point))
312                (backward-char)
313                (setq orig (point)))))))
314
315 ;;; Region
316
317 (defun vimpulse-region-face ()
318   "Return face of region."
319   (if (featurep 'xemacs) 'zmacs-region 'region))
320
321 (defun vimpulse-deactivate-region (&optional now)
322   "Deactivate region, respecting Emacs version."
323   (cond
324    ((and (boundp 'cua-mode) cua-mode
325          (fboundp 'cua--deactivate))
326     (cua--deactivate now))
327    ((featurep 'xemacs)
328     (let ((zmacs-region-active-p t))
329       (zmacs-deactivate-region)))
330    (now
331     (setq mark-active nil))
332    (t
333     (setq deactivate-mark t))))
334
335 (defun vimpulse-activate-region (&optional pos)
336   "Activate mark if there is one. Otherwise set mark at point.
337 If POS if specified, set mark at POS instead."
338   (setq pos (or pos (mark t) (point)))
339   (cond
340    ((and (boundp 'cua-mode) cua-mode)
341     (let ((opoint (point))
342           (oldmsg (current-message))
343           message-log-max
344           cua-toggle-set-mark)
345       (goto-char (or pos (mark t) (point)))
346       (unwind-protect
347           (and (fboundp 'cua-set-mark)
348                (cua-set-mark))
349         (message oldmsg))
350       (goto-char opoint)))
351    (t
352     (let (this-command)
353       (push-mark pos t t)))))
354
355 (defun vimpulse-set-region (beg end &optional widen dir)
356   "Set Emacs region to BEG and END.
357 Preserves the order of point and mark, unless specified by DIR:
358 a positive number means mark goes before or is equal to point,
359 a negative number means point goes before mark. If WIDEN is
360 non-nil, only modifies region if it does not already encompass
361 BEG and END. Returns nil if region is unchanged."
362   (cond
363    (widen
364     (vimpulse-set-region
365      (min beg end (or (region-beginning) (point)))
366      (max beg end (or (region-end) (point)))
367      nil dir))
368    (t
369     (unless (region-active-p)
370       (vimpulse-activate-region))
371     (let* ((oldpoint (point))
372            (oldmark  (or (mark t) oldpoint))
373            (newmark  (min beg end))
374            (newpoint (max beg end)))
375       (when (or (and (numberp dir) (> 0 dir))
376                 (and (not (numberp dir))
377                      (< oldpoint oldmark)))
378         (setq newpoint (prog1 newmark
379                          (setq newmark newpoint))))
380       (unless (or (and (numberp dir)
381                        (= (min oldpoint oldmark)
382                           (min newpoint newmark))
383                        (= (max oldpoint oldmark)
384                           (max newpoint newmark)))
385                   (and (= oldpoint newpoint)
386                        (= oldmark  newmark)))
387         (set-mark newmark)
388         (goto-char newpoint))))))
389
390 ;;; Overlays (extents in XEmacs)
391
392 (eval-and-compile
393   (cond
394    ((featurep 'xemacs)                   ; XEmacs
395     (fset 'vimpulse-delete-overlay 'delete-extent)
396     (fset 'vimpulse-overlays-at 'extents-at))
397    (t                                    ; GNU Emacs
398     (fset 'vimpulse-delete-overlay 'delete-overlay)
399     (fset 'vimpulse-overlays-at 'overlays-at))))
400
401 ;; `viper-make-overlay' doesn't handle FRONT-ADVANCE
402 ;; and REAR-ADVANCE properly in XEmacs
403 (defun vimpulse-make-overlay
404   (beg end &optional buffer front-advance rear-advance)
405   "Create a new overlay with range BEG to END in BUFFER.
406 In XEmacs, create an extent."
407   (cond
408    ((featurep 'xemacs)
409     (let ((extent (make-extent beg end buffer)))
410       (set-extent-property extent 'start-open front-advance)
411       (set-extent-property extent 'end-closed rear-advance)
412       (set-extent-property extent 'detachable nil)
413       extent))
414    (t
415     (make-overlay beg end buffer front-advance rear-advance))))
416
417 (defun vimpulse-overlay-before-string (overlay string &optional face)
418   "Set the `before-string' property of OVERLAY to STRING.
419 In XEmacs, change the `begin-glyph' property."
420   (cond
421    ((featurep 'xemacs)
422     (setq face (or face (get-text-property 0 'face string)))
423     (when (and string (not (glyphp string)))
424       (setq string (make-glyph string)))
425     (when face
426       (set-glyph-face string face))
427     (set-extent-begin-glyph overlay string))
428    (t
429     (viper-overlay-put overlay 'before-string string))))
430
431 (defun vimpulse-overlay-after-string (overlay string &optional face)
432   "Set the `after-string' property of OVERLAY to STRING.
433 In XEmacs, change the `end-glyph' property."
434   (cond
435    ((featurep 'xemacs)
436     (setq face (or face (get-text-property 0 'face string)))
437     (when (and string (not (glyphp string)))
438       (setq string (make-glyph string)))
439     (when face
440       (set-glyph-face string face))
441     (set-extent-end-glyph overlay string))
442    (t
443     (viper-overlay-put overlay 'after-string string))))
444
445 ;;; Motion type system
446
447 (defun vimpulse-range-p (object)
448   "Return t if OBJECT is a pure range (BEG END)."
449   (and (listp object)
450        (eq 2 (length object))
451        (numberp (car object))
452        (numberp (cadr object))))
453
454 (defun vimpulse-motion-range-p (object)
455   "Return t if OBJECT is a motion range (TYPE BEG END)."
456   (and (listp object)
457        (symbolp (car object))
458        (vimpulse-range-p (cdr object))))
459
460 (defun vimpulse-motion-range (object)
461   "Return the range part of OBJECT."
462   (cond
463    ((vimpulse-motion-range-p object)
464     (cdr object))
465    ((vimpulse-range-p object)
466     object)
467    (t
468     (list (point) (point)))))
469
470 (defun vimpulse-motion-type (object &optional raw)
471   "Return motion type of OBJECT.
472 The type is one of `exclusive', `inclusive', `line' and `block'.
473 Defaults to `exclusive' unless RAW is specified."
474   (let ((type (cond
475                ((symbolp object)
476                 (get object 'motion-type))
477                ((vimpulse-motion-range-p object)
478                 (car object)))))
479     (if raw
480         type
481       (or type 'exclusive))))
482
483 ;; This implements section 1 of motion.txt (Vim Reference Manual)
484 (defun vimpulse-normalize-motion-range (range &optional type)
485   "Normalize the beginning and end of a motion range (TYPE FROM TO).
486 Returns the normalized range.
487
488 Usually, a motion range should be normalized only once, as
489 information is lost in the process: an unnormalized motion range
490 has the form (TYPE FROM TO), while a normalized motion range has
491 the form (TYPE BEG END).
492
493 See also `vimpulse-block-range', `vimpulse-line-range',
494 `vimpulse-inclusive-range' and `vimpulse-exclusive-range'."
495   (let* ((type (or type (vimpulse-motion-type range)))
496          (range (vimpulse-motion-range range))
497          (from (car range))
498          (to   (cadr range)))
499     (cond
500      ((memq type '(blockwise block))
501       (vimpulse-block-range from to))
502      ((memq type '(linewise line))
503       (vimpulse-line-range from to))
504      ((eq 'inclusive type)
505       (vimpulse-inclusive-range from to))
506      (t
507       (vimpulse-exclusive-range from to t)))))
508
509 (defun vimpulse-block-range (mark point)
510   "Return a blockwise motion range (BLOCK BEG END).
511 Like `vimpulse-inclusive-range', but for rectangles:
512 the last column is included."
513   (let* ((point (or point (point)))
514          (mark  (or mark point))
515          (beg (min point mark))
516          (end (max point mark))
517          (beg-col (save-excursion
518                     (goto-char beg)
519                     (current-column)))
520          (end-col (save-excursion
521                     (goto-char end)
522                     (current-column))))
523     (save-excursion
524       (cond
525        ((= beg-col end-col)
526         (goto-char end)
527         (cond
528          ((eolp)
529           (goto-char beg)
530           (if (eolp)
531               (list 'block beg end)
532             (list 'block (1+ beg) end)))
533          (t
534           (list 'block beg (1+ end)))))
535        ((< beg-col end-col)
536         (goto-char end)
537         (if (eolp)
538             (list 'block beg end)
539           (list 'block beg (1+ end))))
540        (t
541         (goto-char beg)
542         (if (eolp)
543             (list 'block beg end)
544           (list 'block (1+ beg) end)))))))
545
546 (defun vimpulse-line-range (mark point)
547   "Return a linewise motion range (LINE BEG END)."
548   (let* ((point (or point (point)))
549          (mark  (or mark point))
550          (beg (min mark point))
551          (end (max mark point)))
552     (list 'line
553           (save-excursion
554             (goto-char beg)
555             (line-beginning-position))
556           (save-excursion
557             (goto-char end)
558             (line-beginning-position 2)))))
559
560 (defun vimpulse-inclusive-range (mark point)
561   "Return an inclusive motion range (INCLUSIVE BEG END).
562 That is, the last character is included."
563   (let* ((point (or point (point)))
564          (mark  (or mark point))
565          (beg (min mark point))
566          (end (max mark point)))
567     (save-excursion
568       (goto-char end)
569       (unless (or (eobp) (and (eolp) (not (bolp))))
570         (setq end (1+ end)))
571       (list 'inclusive beg end))))
572
573 (defun vimpulse-exclusive-range (mark point &optional normalize)
574   "Return an exclusive motion range (EXCLUSIVE BEG END).
575 However, if NORMALIZE is t and the end of the range is at the
576 beginning of a line, a different type of range is returned:
577
578   * If the start of the motion is at or before the first
579     non-blank in the line, the motion becomes `line' (normalized).
580
581   * Otherwise, the end of the motion is moved to the end of the
582     previous line and the motion becomes `inclusive' (normalized).
583
584 Thus, this function may return, e.g., (LINE BEG END) instead."
585   (let* ((point (or point (point)))
586          (mark  (or mark point))
587          (beg (min mark point))
588          (end (max mark point)))
589     (save-excursion
590       (cond
591        ((and normalize
592              (progn
593                (goto-char end)
594                (bolp)))
595         (viper-backward-char-carefully)
596         (setq end (max beg (point)))
597         (cond
598          ((save-excursion
599             (goto-char beg)
600             (looking-back "^[ \f\t\v]*"))
601           (vimpulse-normalize-motion-range (list 'line beg end)))
602          (t
603           (list 'inclusive beg end))))
604        (t
605         (list 'exclusive beg end))))))
606
607 (provide 'vimpulse-utils)