From: martin rudalics <rudalics@gmx.at>
To: Chong Yidong <cyd@stupidchicken.com>
Cc: emacs-devel <emacs-devel@gnu.org>
Subject: Re: transpose-regions
Date: Thu, 22 Mar 2007 22:32:31 +0100 [thread overview]
Message-ID: <4602F5EF.4080604@gmx.at> (raw)
In-Reply-To: <871wjh9gcy.fsf@stupidchicken.com>
[-- Attachment #1: Type: text/plain, Size: 841 bytes --]
> Does the problem occur when you compile with no optimizations?
I never use any options to compile. What shall I use?
>>I could send you the Elisp code I use to trigger this. You'd have
>>to play around with it a bit, though.
>
>
> Is this the m&d-drag-line-up function that KFS already posted? I've
> been trying it out on various buffers, and have been unable to
> reproduce it---is there a specific buffer you act on to produce the
> error?
There's also a m&d-drag-line-down function and a pre-command hook.
Initially written while I worked with Emacs 20 (and transpose-regions
was somehow broken IIRC) and awfully patched a couple of times
afterwards. I attach it. To reproduce bind the drag-line functions to
a key and use the auto-repeat functionality of the keyboard (I use a
hyper key and the arrow keys for this purpose).
[-- Attachment #2: m&d.el --]
[-- Type: text/plain, Size: 33556 bytes --]
;;; m&d.el --- move'n drag support functions
;; Copyright (C) 2005 Martin Rudalics
;; Time-stamp: "2007-02-26 07:56:15 martin"
;; Author: Martin Rudalics <rudalics@gmx.at>
;; Keywords: sexps
;; Version: 0.1
;; m&d.el is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; m&d.el is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;; Commentary:
;; move and drag support functions for GNU Emacs.
;;; Code:
;; _____________________________________________________________________________
;;
;;; Faces
;; _____________________________________________________________________________
;;
(defgroup m&d nil
"Move and drag."
:version "22.1"
:group 'faces)
(defcustom m&d-alert-delay 0.2
"*Time m&d alerts when saving or replacing the m&d-region."
:type '(choice number (const :tag "Don't alert" nil))
:group 'm&d)
(defface m&d-alert
'((((class color)) :background "Bisque")
(t :bold t))
"Face for highlighting m&d alerts."
:group 'm&d)
(defface m&d-before
'((((class color)) :foreground "Black" :background "Yellow")
(t :bold t))
"Face for highlighting delimiter before m&d-region."
:group 'm&d)
(defface m&d-after
'((((class color)) :foreground "Black" :background "Yellow")
(t :bold t))
"Face for highlighting delimiter after m&d-region."
:group 'm&d)
(defface m&d-left
'((((class color)) :background "Azure")
(t :bold t))
"Face for highlighting sexp left to m&d-region."
:group 'm&d)
(defface m&d-right
'((((class color)) :background "Azure")
(t :bold t))
"Face for highlighting sexp right to m&d-region."
:group 'm&d)
(defface m&d-save
'((t :underline t))
"Face for highlighting sexp right to m&d-region."
:group 'm&d)
;; _____________________________________________________________________________
;;
;;; Overlays
;; _____________________________________________________________________________
;;
;; Observe: The following overlays are window-local
(defvar m&d-alert-overlay (make-overlay 1 1))
(overlay-put m&d-alert-overlay 'face 'm&d-alert)
(defvar m&d-before-overlay (make-overlay 1 1))
(overlay-put m&d-before-overlay 'face 'm&d-before)
(defvar m&d-after-overlay (make-overlay 1 1))
(overlay-put m&d-after-overlay 'face 'm&d-after)
(defvar m&d-left-overlay (make-overlay 1 1))
(overlay-put m&d-left-overlay 'face 'm&d-left)
(defvar m&d-right-overlay (make-overlay 1 1))
(overlay-put m&d-right-overlay 'face 'm&d-right)
;; _____________________________________________________________________________
;;
;;; Move
;; _____________________________________________________________________________
;;
(defsubst m&d-syntax-class-after (&optional at)
(let ((at (or at (point))))
(syntax-class (syntax-after at))))
(defsubst m&d-syntax-class-before (&optional at)
(let ((at (or at (point))))
(syntax-class (syntax-after (1- at)))))
(defsubst m&d-escaped-p (&optional at)
(save-excursion
(when at (goto-char at))
(while (and (eq (m&d-syntax-class-before) '9)
(eq (m&d-syntax-class-before (1- (point))) '9))
(backward-char 2))
(eq (m&d-syntax-class-before) '9)))
(defun m&d-forward-sexp (&optional arg)
"Like `forward-sexp' but within literal narrow to literal before.
With `point' before character with close paren syntax highlight
enclosing expression with `m&d-alert' face. Don't generate an error in
any case."
(interactive "p")
(let ((at (point))
(state (syntax-ppss)))
(condition-case nil
(if (or (nth 3 state) (nth 4 state))
(save-restriction
(narrow-to-region
(nth 8 state)
(condition-case nil
(save-excursion
(parse-partial-sexp
(point) (point-max) nil nil state 'syntax-table)
(point))
(error (point-max))))
(forward-sexp arg))
(forward-sexp arg))
(error
(move-overlay
m&d-alert-overlay
(condition-case nil
(save-excursion
(m&d-beginning-of-list)
(point))
(error (point-min)))
at)
(overlay-put m&d-alert-overlay 'window (selected-window))
(ding)))))
(defun m&d-backward-sexp (&optional arg)
"Like `backward-sexp' but within literal narrow to literal before.
With `point' after character with open paren syntax highlight enclosing
expression with `m&d-alert' face. Don't generate an error in any case."
(interactive "p")
(let ((at (point))
(state (syntax-ppss)))
(condition-case nil
(if (or (nth 3 state) (nth 4 state))
(save-restriction
(narrow-to-region
(nth 8 state)
(condition-case nil
(save-excursion
(parse-partial-sexp
(point) (point-max) nil nil state 'syntax-table)
(point))
(error (point-max))))
(backward-sexp arg))
(backward-sexp arg))
(error
(move-overlay
m&d-alert-overlay
at
(condition-case nil
(save-excursion
(m&d-end-of-list)
(point))
(error (point-max))))
(overlay-put m&d-alert-overlay 'window (selected-window))
(ding)))))
(defun m&d-beginning-of-defun (&optional arg)
"Like `beginning-of-defun' but don't generate an error."
(interactive "p")
(let ((at (point)))
(condition-case nil
(beginning-of-defun arg)
(error (ding)))))
(defun m&d-end-of-defun (&optional arg)
"Like `end-of-defun' but don't generate an error."
(interactive "p")
(let ((at (point)))
(condition-case nil
(end-of-defun arg)
(error (ding)))))
(defun m&d-beginning-of-list (&optional arg)
(interactive "p")
(let ((at (point)))
(condition-case nil
(progn
(backward-up-list arg)
(forward-char))
(error (ding)))))
(defun m&d-end-of-list (&optional arg)
(interactive "p")
(let ((at (point)))
(condition-case nil
(progn
(up-list arg)
(backward-char))
(error (ding)))))
(defun m&d-forward-up (&optional arg)
(interactive "p")
(let ((at (point)))
(condition-case nil
(up-list arg)
(error (ding)))))
(defun m&d-backward-up (&optional arg)
(interactive "p")
(let ((at (point)))
(condition-case nil
(backward-up-list arg)
(error (ding)))))
(defun m&d-home ()
"In first call move point to beginning of line, in subsequent calls to
beginning of buffer."
(interactive)
(if (eq last-command 'm&d-home)
(goto-char (point-min))
(beginning-of-line)))
(defun m&d-end ()
"In first call move point to end of line, in subsequent calls to end of
buffer."
(interactive)
(if (eq last-command 'm&d-end)
(goto-char (point-max))
(end-of-line)))
;; _____________________________________________________________________________
;;
;;; Mark
;; _____________________________________________________________________________
;;
(defvar m&d-mark-history () ; remove duplicates, eventually
"History for actual `m&d-mark-sexp', reset by `m&d-pre-command'.
Each entry is a cons pair whose car is point and whose cdr mark.")
(defvar m&d-mark nil)
(defun m&d-ensure-mark ()
(when mark-active (setq deactivate-mark nil)))
(defun m&d-mark-highlight (&optional from to)
"Highlight various parts of m&d-region."
(unless (memq major-mode '(sobar-mode sonderbar-mode))
(let ((from (or from
(and mark-active (min (point) (mark)))
(point)))
(to (or to
(and mark-active (max (point) (mark)))
(point)))
(window (selected-window))
before after beg end)
(setq m&d-mark t)
(condition-case nil
(save-excursion
(condition-case nil
(progn
(goto-char from)
(backward-up-list)
(setq before (point))
(move-overlay m&d-before-overlay before (1+ before))
(overlay-put m&d-before-overlay 'window window))
(error nil))
(condition-case nil
(progn
(goto-char to)
(up-list)
(setq after (point))
(move-overlay m&d-after-overlay (1- after) after)
(overlay-put m&d-after-overlay 'window window))
(error nil))
(condition-case nil
(progn
(goto-char from)
(backward-sexp)
(setq beg (point))
(forward-sexp)
(setq end (point))
(when (and (< beg end) (<= end from))
(move-overlay m&d-left-overlay beg end)
(overlay-put m&d-left-overlay 'window window)))
(error nil))
(condition-case nil
(progn
(goto-char to)
(forward-sexp)
(setq end (point))
(backward-sexp)
(setq beg (point))
(when (and (<= to beg) (< beg end))
(move-overlay m&d-right-overlay beg end)
(overlay-put m&d-right-overlay 'window window)))
(error nil)))
(error nil)))))
(defun m&d-exchange-point-and-mark ()
"Like `exchange-point-and-mark' but highlight marked region."
(interactive)
(exchange-point-and-mark)
(m&d-mark-highlight (min (point) (mark)) (max (point) (mark))))
(defun m&d-mark-sexp ()
"Enlarge m&d-region.
Pushes previous values of `point' and `mark' on `m&d-mark-history'."
(interactive)
(if mark-active
(let* ((state (syntax-ppss))
(beg (min (mark) (point)))
(end (max (mark) (point)))
(point-is-beg (= beg (point)))
(point-mark (cons (point) (mark)))
from to before-after)
(cond
((eq (m&d-syntax-class-before beg) '6)
(save-excursion
(goto-char beg)
(skip-syntax-backward "'")
(setq from (point)))
(save-excursion
(goto-char end)
(skip-syntax-forward "'")
(setq to (point)))
(setq before-after t))
((or (nth 3 state) (nth 4 state))
;; Within string or comment, mark entire string or comment.
(setq from (nth 8 state))
(setq to (save-excursion
(condition-case nil
(progn
(parse-partial-sexp
(point) (point-max) nil nil state 'syntax-table)
(point))
(error nil))))
(cond
((nth 3 state)
(setq before-after t))
((and from to (nth 4 state)
(or (> from beg) (< to end)
(and (= from beg) (= to end))))
;; Failed to expand comment.
(save-excursion
(goto-char from)
(forward-comment (- (buffer-size)))
(setq from (point)))
(save-excursion
(goto-char to)
(forward-comment (buffer-size))
(setq to (point))))))
((let ((class-first (syntax-class (syntax-after beg)))
(class-last (syntax-class (syntax-after (1- end))))
from-white to-white)
;; Before or after a comment: Mark entire sequence of comments
;; before and after the present. `from-white' and `to-white'
;; shall guarantee that the marked region encompasses entire
;; marked region before applying the present step.
(and (or (memq class-first '(11 14))
(memq class-last '(12 14)))
(condition-case nil
(progn
;; The following is weird but I do want to distinguish
;; newlines that terminate comments from newlines that
;; don't. Hence I skip all comments before or after
;; point first.
(save-excursion
(setq from beg)
(while (forward-comment -1)
(setq from (point)))
(setq from-white (point)))
(save-excursion
(setq to end)
(while (forward-comment 1)
(setq to (point)))
(setq to-white (point)))
;; Something should have been enlarged here.
(unless (and (<= from beg) (>= to end))
;; Symmetrically include previously marked whitespace.
(setq from from-white)
(setq to to-white))
(or (< from beg) (> to end)))
(error nil)))))
((nth 1 state)
(setq from
(save-excursion
(goto-char (nth 1 state))
(point)))
(condition-case nil
(progn
(parse-partial-sexp
(point) (point-max) (1- (nth 0 state)) nil state)
(setq to (point))
(setq before-after t))
(error nil)))
(t
(setq from (point-min))
(setq to (point-max))
(m&d-mark-highlight from to)))
(if (and from to)
(progn
(setq m&d-mark-history (cons point-mark m&d-mark-history))
(when before-after (m&d-mark-highlight from to))
(set-mark (if point-is-beg to from))
(goto-char (if point-is-beg from to)))
;; This shouldn't happen.
(message "Can't mark") (ding)))
;; Region inactive, move to some significant position:
(let* ((at (save-excursion
(skip-chars-forward " \t") (point)))
(class (syntax-class (syntax-after at)))
(point-mark (cons (point) nil))
from to before-after)
(save-excursion
(goto-char at)
(cond
((memq class '(2 3 8 9 10 13))
;; Word, symbol, open paren, and some others.
(save-excursion
(condition-case nil
(backward-sexp)
(error nil))
(skip-syntax-forward "'")
(skip-syntax-backward "/\\")
(setq from (point)))
(forward-sexp)
(backward-prefix-chars)
(setq to (point))
(setq before-after 'check))
((memq class '(4 6))
;; Expression prefix.
(save-excursion
(skip-syntax-backward "'")
(setq from (point)))
(forward-sexp)
(setq to (point))
(setq before-after 'check))
((eq class '5)
;; Close paren.
(forward-char)
(condition-case nil
(progn
(backward-sexp)
(setq from (point))
(forward-sexp)
(backward-prefix-chars)
(setq to (point))
(setq before-after 'check))
(error nil)))
((memq class '(7 15))
(let ((state (syntax-ppss)))
(if (nth 3 state)
;; Within string.
(save-restriction
(narrow-to-region
(nth 8 state)
(condition-case nil
(save-excursion
(parse-partial-sexp (point) (point-max) nil nil state 'syntax-table)
(point))
(error (point-max))))
(forward-char)
(condition-case nil
(progn
(backward-sexp)
(setq from (point))
(forward-sexp)
(backward-prefix-chars)
(setq to (point))
(when (and (= from (point-min)) (= to (point-max)))
(setq before-after t)))
(error nil)))
;; Before string
(forward-sexp)
(backward-prefix-chars)
(setq to (point))
(condition-case nil
(backward-sexp)
(error nil))
(skip-syntax-forward "'")
(setq from (point))
(setq before-after t))))
((and (memq class '(11 12 14))
;; Around comment, we wrap this in an `and' to give the
;; subsequent steps a chance.
(let ((state (syntax-ppss)))
(cond
((nth 4 state)
;; Within comment.
(setq from (nth 8 state))
(condition-case nil
(save-excursion
(parse-partial-sexp
(point) (point-max) nil nil state 'syntax-table)
(setq to (point)))
(error nil)))
((memq class '(11 14))
;; Probably before comment.
(setq from (point))
(condition-case nil
(save-excursion
(forward-comment 1)
(setq to (point)))
(error nil)))))))
((eq class '1)
;; Mark punctuation syntax.
(save-excursion
(skip-syntax-forward ".")
(setq to (point)))
(skip-syntax-backward ".")
(setq from (point)))
((eq (char-after) ?\n)
;; Mark whitespace around newline, mark nothing at end of not
;; newline terminated buffer.
(save-excursion
(when (forward-comment -1)
(forward-comment 1))
(setq from (point)))
(save-excursion
(when (forward-comment 1)
(forward-comment -1))
(setq to (point))))))
(if (and from to)
(progn
(when before-after
(if (eq before-after 'check)
(let ((state (syntax-ppss))
narrow-from narrow-to)
(if (or (nth 3 state) (nth 4 state))
(save-excursion
(setq narrow-from (nth 8 state))
(setq narrow-to
(condition-case nil
(progn
(parse-partial-sexp
(point) (point-max)
nil nil state 'syntax-table)
(point))
(error nil)))
(when (and narrow-from narrow-to)
(save-restriction
(narrow-to-region narrow-from narrow-to)
(m&d-mark-highlight from to))))
(m&d-mark-highlight from to)))
(m&d-mark-highlight from to)))
(setq m&d-mark-history (cons point-mark m&d-mark-history))
(push-mark to t t)
(goto-char from))
(message "Can't mark") (ding)))))
(defun m&d-mark-undo ()
"Pop `m&d-mark-history'."
(interactive)
(if m&d-mark-history
(let ((mark (cdar m&d-mark-history)))
(when mark (set-mark mark))
(setq mark-active mark)
(goto-char (caar m&d-mark-history))
(when mark
(m&d-mark-highlight (min (point) (mark)) (max (point) (mark))))
(setq m&d-mark-history (cdr m&d-mark-history)))
(message "No undo information")
(ding)))
;; Maybe this should become a ring.
(defvar m&d-saved-region nil
"Region saved by last `m&d-save-region'.")
(defun m&d-alert-region (beg end)
"Temporarily highlight region with `m&d-alert' face."
(when m&d-alert-delay
(setq mark-active nil)
(let ((overlay (make-overlay beg end)))
(overlay-put overlay 'face 'm&d-alert)
(overlay-put overlay 'priority 100000)
(delete-overlay overlay))
(sit-for m&d-alert-delay)
(setq mark-active t)))
(defun m&d-save-region (beg end)
"Save m&d-region into `m&d-saved-region'.
Does not modify `m&d-mark-undo'."
(interactive "r")
(setq m&d-saved-region (buffer-substring-no-properties beg end))
(m&d-alert-region beg end)
(m&d-mark-highlight beg end))
(defun m&d-replace-region (beg end)
"Replace m&d-region by `m&d-saved-region'.
Clears `m&d-mark-undo'."
(interactive "r")
(if m&d-saved-region
(let ((to (+ beg (length m&d-saved-region))))
(delete-region beg end)
(insert m&d-saved-region)
(goto-char beg)
(set-mark to)
(setq deactivate-mark nil)
(m&d-alert-region beg to)
(m&d-mark-highlight beg to))
(error "Nothing saved")))
(defun m&d-kill-region (beg end)
(interactive "r")
(let (from to left right)
(if (and (save-excursion
(goto-char beg)
(skip-chars-backward " \t")
(cond
((bolp) (setq from (point)))
((bobp) nil)
(t
(setq from beg)
(setq left t))))
(save-excursion
(goto-char end)
(skip-chars-forward " \t")
(cond
((eolp) (setq to (point)))
((eobp) nil)
(t
(setq to end)
(setq right t)))))
(cond
((and left right)
(delete-region end to)
(kill-region beg end)
(delete-region from beg)
(fixup-whitespace))
(left
;; Remove everything from end till first non-whitespace.
(goto-char end)
(skip-chars-forward " \t\n\f")
(delete-region end (point))
(kill-region beg end)
(delete-region from beg))
(right
(delete-region end to)
(kill-region beg end)
(goto-char beg)
(skip-chars-backward " \t\n\f")
(if (nth 4 (syntax-ppss))
(delete-region (1+ (point)) beg)
(delete-region (point) beg)))
(t
(delete-region end (if (= to (point-max)) to (1+ to)))
(kill-region beg end)
(delete-region from beg)))
(kill-region beg end))))
(defun m&d-copy ()
"Copy region or line and point and activate it."
(interactive)
(let ((copied-string
(if mark-active
(buffer-substring
(min (mark) (point)) (max (mark) (point)))
(buffer-substring
(line-beginning-position) (line-beginning-position 2)))))
(goto-char (if mark-active
(max (mark) (point))
(line-beginning-position 2)))
(insert copied-string)
(set-mark (point))
(goto-char (- (point) (length copied-string)))
(setq deactivate-mark nil)
(setq mark-active t)))
;; _____________________________________________________________________________
;;
;;; Drag
;; _____________________________________________________________________________
;;
(defun m&d-drag-char-right ()
"If region is active drag it right by one char else drag char at point right."
(interactive)
(cond
(mark-active
(let* ((beg (min (mark) (point)))
(end (max (mark) (point)))
(mark-beg (1+ (- (mark) beg)))
(point-beg (1+ (- (point) beg))))
(if (= end (point-max))
(progn (message "Can't drag") (ding))
(transpose-regions beg end end (1+ end))
(set-mark (+ mark-beg beg))
(setq deactivate-mark nil)
(goto-char (+ point-beg beg)))))
((or (eobp) (= (point) (1- (point-max))))
(m&d-ensure-mark)
(message "Can't drag") (ding))
(t (let ((to (1+ (point))))
(transpose-regions (point) to to (1+ to))
(goto-char to)))))
(defun m&d-drag-char-left ()
"If region is active drag it left by one char else drag char at point left."
(interactive)
(cond
(mark-active
(let* ((beg (min (mark) (point)))
(end (max (mark) (point)))
(mark-beg (- (mark) beg 1))
(point-beg (- (point) beg 1)))
(if (= beg (point-min))
(progn (message "Can't drag") (ding))
(transpose-regions (1- beg) beg beg end)
(set-mark (+ mark-beg beg))
(setq deactivate-mark nil)
(goto-char (+ point-beg beg)))))
((or (bobp) (eobp))
(m&d-ensure-mark)
(message "Can't drag") (ding))
(t (let ((to (1- (point))))
(transpose-regions to (point) (point) (1+ (point)))
(goto-char to)))))
(defun m&d-drag-line-down (&optional beg end)
"Drag region down by one line. Region defaults to current line.
Region is always rounded up to whole lines."
(interactive)
(let* ((beg (save-excursion
(goto-char
(or beg (and mark-active (min (point) (mark))) (point)))
(line-beginning-position)))
(end (save-excursion
(goto-char
(or end (and mark-active (max (point) (mark)))
(line-beginning-position 2)))
(if (bolp) (point) (line-beginning-position 2))))
(point-beg (and (<= beg (point)) (<= (point) end)
(- (point) beg)))
(mark-beg (and mark-active (<= beg (mark)) (<= (mark) end)
(- (mark) beg)))
(to (save-excursion
(goto-char end)
(line-beginning-position 2)))
(recenter (when (= beg (window-start))
(1+ (count-lines beg end)))))
(unless (and (>= (point) beg) (<= (point) end))
;; `point' should be within dragged region.
(goto-char end))
;;; (condition-case nil
;; Wrapped in condition-case until we find out why `transpose-regions'
;; is broken.
(if (> to end)
(progn
(if (save-excursion (goto-char to) (not (bolp)))
;; Pobably at eob.
(progn
(when (= (point) end) (backward-char))
(transpose-regions beg (1- end) end to))
(transpose-regions beg end end to))
;; Don't push mark.
(when mark-beg
(set-mark (+ mark-beg beg (- to end)))
(setq deactivate-mark nil))
(when point-beg
(goto-char (+ point-beg beg (- to end))))
(when recenter
(recenter recenter)))
(m&d-ensure-mark)
(message "Can't drag")
(ding))
;;; (error (m&d-ensure-mark)))))
))
(defun m&d-drag-line-up (&optional beg end)
"Drag region up by one line. Region defaults to current line.
Region is always rounded up to whole lines."
(interactive)
(let* ((beg (save-excursion
(goto-char
(or beg (and mark-active (min (point) (mark))) (point)))
(line-beginning-position)))
(end (save-excursion
(goto-char
(or end (and mark-active (max (point) (mark)))
(line-beginning-position 2)))
(if (bolp) (point) (line-beginning-position 2))))
(point-beg (and (<= beg (point)) (<= (point) end)
(- (point) beg)))
(mark-beg (and mark-active (<= beg (mark)) (<= (mark) end)
(- (mark) beg)))
(from (save-excursion
(goto-char beg)
(line-beginning-position 0)))
(recenter (when (= from (window-start))
(count-lines beg end))))
;;; (condition-case nil
;; Wrapped in condition-case until we find out why `transpose-regions'
;; is broken.
(if (> beg from)
(progn
(if (save-excursion (goto-char end) (not (bolp)))
;; Probably at eob.
(transpose-regions from (1- beg) beg end)
(transpose-regions from beg beg end))
(when mark-beg
(set-mark (+ mark-beg from))
(setq deactivate-mark nil))
(when point-beg
(goto-char (+ point-beg from)))
(when recenter
(recenter recenter)))
(m&d-ensure-mark)
(message "Can't drag")
(ding))
;;; (error (m&d-ensure-mark)))))
))
(defun m&d-drag-sexp-right (&optional beg end)
"Drag region right by one sexp. Region defaults to sexp at point.
When the mark is active, this function may move point and set mark to
make the dragged region suitable for further dragging."
(interactive)
(let* ((end (or end
(and mark-active
(save-excursion
(goto-char (max (point) (mark)))
(skip-chars-backward " \n\t\f")
;; The following might not skip any more newlines:
(skip-syntax-backward " .") (point)))
(save-excursion
(forward-sexp) (backward-prefix-chars) (point))))
(beg (or beg
(and mark-active
(save-excursion
(goto-char (min (point) (mark)))
(skip-chars-forward " \n\t\f")
;; The following might not skip any more newlines:
(skip-syntax-forward " .") (point)))
(save-excursion (goto-char end) (backward-sexp) (point))))
(point-beg (and (<= beg (point)) (<= (point) end)
(- (point) beg)))
(mark-beg (and mark-active (<= beg (mark)) (<= (mark) end)
(- (mark) beg)))
(to (save-excursion
(goto-char end)
(condition-case nil
(save-excursion
(forward-sexp) (backward-prefix-chars) (point))
(error nil))))
(from (when to
(save-excursion
(goto-char to)
(condition-case nil
(save-excursion
(backward-sexp)
(point))
(error nil)))))
point-beg mark-beg)
(when mark-active
(cond
((< (mark) beg) (set-mark beg))
((< end (mark)) (set-mark end)))
(setq mark-beg (- (mark) beg)))
(setq point-beg
(cond
((< (point) beg) 0)
((< end (point)) (- end beg))
(t (- (point) beg))))
(if (and from to (> to from) (>= from end))
(progn
(transpose-regions beg end from to)
(when mark-beg
(set-mark (+ mark-beg beg (- to end)))
(setq deactivate-mark nil))
(goto-char (+ point-beg beg (- to end)))
(when mark-active
(m&d-mark-highlight (min (point) (mark)) (max (point) (mark)))))
(when mark-active
(setq deactivate-mark nil)
(m&d-mark-highlight (min (point) (mark)) (max (point) (mark))))
(message "Can't drag")
(ding))))
(defun m&d-drag-sexp-left (&optional beg end)
"Drag region left by one sexp. Region defaults to sexp at point.
When the mark is active, this function may move point and set mark to
make the dragged region suitable for further dragging."
(interactive)
(let* ((end (or end
(and mark-active
(save-excursion
(goto-char (max (point) (mark)))
(skip-chars-backward " \n\t\f")
;; The following might not skip any more newlines:
(skip-syntax-backward " .") (point)))
(save-excursion
(forward-sexp) (backward-prefix-chars) (point))))
(beg (or beg
(and mark-active
(save-excursion
(goto-char (min (point) (mark)))
(skip-chars-forward " \n\t\f")
;; The following might not skip any more newlines:
(skip-syntax-forward " .") (point)))
(save-excursion (goto-char end) (backward-sexp) (point))))
(from (save-excursion
(goto-char beg)
(condition-case nil
(save-excursion
(backward-sexp) (point))
(error nil))))
(to (when from
(save-excursion
(goto-char from)
(condition-case nil
(save-excursion
(forward-sexp) (backward-prefix-chars) (point))
(error nil)))))
point-beg mark-beg)
(when mark-active
(cond
((< (mark) beg) (set-mark beg))
((< end (mark)) (set-mark end)))
(setq mark-beg (- (mark) beg)))
(setq point-beg
(cond
((< (point) beg) 0)
((< end (point)) (- end beg))
(t (- (point) beg))))
(if (and from to (> to from) (<= to beg))
(progn
(transpose-regions from to beg end)
(when mark-beg
(set-mark (+ mark-beg from))
(setq deactivate-mark nil))
(goto-char (+ point-beg from))
(when mark-active
(m&d-mark-highlight (min (point) (mark)) (max (point) (mark)))))
(when mark-active
(setq deactivate-mark nil)
(m&d-mark-highlight (min (point) (mark)) (max (point) (mark))))
(message "Can't drag")
(ding))))
;; _____________________________________________________________________________
;;
;;; Key bindings
;; _____________________________________________________________________________
;;
(global-set-key [(control right)] 'm&d-forward-sexp)
(global-set-key [(control left)] 'm&d-backward-sexp)
(global-set-key [(control up)] 'm&d-beginning-of-defun)
(global-set-key [(control down)] 'm&d-end-of-defun)
(global-set-key [(control meta left)] 'm&d-beginning-of-list)
(global-set-key [(control meta right)] 'm&d-end-of-list)
(global-set-key [(control meta up)] 'm&d-backward-up)
(global-set-key [(control meta down)] 'm&d-forward-up)
(global-set-key [home] 'm&d-home)
(global-set-key [end] 'm&d-end)
(define-key text-mode-map [(control right)] 'forward-word)
(define-key text-mode-map [(control left)] 'backward-word)
(define-key text-mode-map [(control down)] 'forward-paragraph)
(define-key text-mode-map [(control up)] 'backward-paragraph)
(define-key text-mode-map [(control meta right)] 'forward-sentence)
(define-key text-mode-map [(control meta left)] 'backward-sentence)
(global-set-key [capslock] 'm&d-mark-sexp)
(global-set-key [(meta capslock)] 'm&d-exchange-point-and-mark)
(global-set-key [(shift capslock)] 'm&d-mark-undo)
(global-set-key [(hyper capslock)] 'm&d-save-region)
(global-set-key [(hyper shift capslock)] 'm&d-kill-region)
(global-set-key [(hyper meta capslock)] 'm&d-replace-region)
(global-set-key [(hyper control left)] 'm&d-drag-sexp-left)
(global-set-key [(hyper control right)] 'm&d-drag-sexp-right)
(global-set-key [(hyper up)] 'm&d-drag-line-up)
(global-set-key [(hyper down)] 'm&d-drag-line-down)
(global-set-key [(hyper left)] 'm&d-drag-char-left)
(global-set-key [(hyper right)] 'm&d-drag-char-right)
(global-set-key [(kp-enter)] 'm&d-copy)
;; _____________________________________________________________________________
;;
;;; Pre-command
;; _____________________________________________________________________________
;;
(dolist (cmd
'(forward-char backward-char
next-line previous-line
forward-word backward-word
end-of-line beginning-of-line
move-end-of-line move-beginning-of-line
end-of-buffer beginning-of-buffer
scroll-up scroll-down
up-list down-list backward-up-list
end-of-defun beginning-of-defun
m&d-forward-sexp m&d-backward-sexp
m&d-beginning-of-defun m&d-end-of-defun
m&d-beginning-of-list m&d-end-of-list
m&d-forward-up m&d-backward-up
m&d-home m&d-end
forward-sexp backward-sexp
forward-list backward-list
forward-sentence backward-sentence
forward-paragraph backward-paragraph))
(put cmd 'm&d 'move))
(dolist (cmd
'(m&d-mark-sexp m&d-mark-undo m&d-mark-save m&d-exchange-point-and-mark))
(put cmd 'm&d 'save))
;; REDO completely ......
(defun m&d-pre-command ()
(condition-case nil
;; We need a condition case to avoid that things like imenu mess up things.
(progn
(when (and m&d-mark-history (not (eq (get this-command 'm&d) 'save)))
;; Remove mark history.
(setq m&d-mark-history nil))
;; Delete overlays, make this conditional - they can be reused.
(unless (memq major-mode '(sobar-mode sonderbar-mode))
(dolist (overlay (list m&d-alert-overlay m&d-before-overlay m&d-after-overlay
m&d-left-overlay m&d-right-overlay
;; Delete show-paren's overlays to avoid flickering.
show-paren-overlay show-paren-overlay-1))
(when (overlayp overlay)
(delete-overlay overlay)))
;; Shifted movement.
(if (not (eq (get this-command 'm&d) 'move))
(setq m&d-mark nil)
(if (memq 'shift (event-modifiers (aref (this-single-command-raw-keys) 0)))
(progn
(unless mark-active
(push-mark-command nil t))
(if m&d-mark
(add-hook 'post-command-hook 'm&d-mark-highlight)
(remove-hook 'post-command-hook 'm&d-mark-highlight)))
(unless (eq (get last-command 'm&d) 'move)
(push-mark-command nil t))
(remove-hook 'post-command-hook 'm&d-mark-highlight)
(setq mark-active nil)
(setq deactivate-mark t)))))
(error nil)))
(add-hook 'pre-command-hook 'm&d-pre-command)
(provide 'm&d)
;;; up / down have to conceptually do: (1) Check whether the region is balanced,
;;; and if it is not try to extract the balanced part, remove that, adjust, (2)
;;; do the move, and (3) check whether the region is balanced again.
;;; m&d.el ends here
;; (1) m&d-mark-highlight can be wrong after shifted movement, use a stronger
;; criterium.
;; (2) backward-prefix-chars should not skip "'" after a `foo'. Hence, within
;; literals we should check whether these are used for this particular
;; thing.
;; (3) push-mark doesn't work correctly yet.
;; (4) shifted forward-/backward-char within string is awfully slow
(defun m&d-mark-dwim ()
(interactive)
(cond
((and (eq last-command this-command) mark-ring)
(pop-to-mark-command))
((mark t)
(exchange-point-and-mark))
(t
(let ((mark (marker-position (point-marker))))
(push-mark nil t))))
(setq deactivate-mark t))
(global-set-key [(hyper .)] 'm&d-mark-dwim)
;;; Debugger entered--Lisp error: (wrong-type-argument listp 4159323)
;;; transpose-regions(306379 306408 306408 306504)
;;; m&d-drag-line-up()
;;; call-interactively(m&d-drag-line-up)
[-- Attachment #3: Type: text/plain, Size: 142 bytes --]
_______________________________________________
Emacs-devel mailing list
Emacs-devel@gnu.org
http://lists.gnu.org/mailman/listinfo/emacs-devel
next prev parent reply other threads:[~2007-03-22 21:32 UTC|newest]
Thread overview: 37+ messages / expand[flat|nested] mbox.gz Atom feed top
2007-03-22 11:03 transpose-regions martin rudalics
2007-03-22 14:49 ` transpose-regions Kim F. Storm
2007-03-22 20:13 ` transpose-regions Nick Roberts
2007-03-22 21:30 ` transpose-regions martin rudalics
2007-03-22 21:36 ` transpose-regions David Kastrup
2007-03-22 21:59 ` transpose-regions martin rudalics
2007-03-23 13:52 ` transpose-regions Eli Zaretskii
2007-03-22 15:04 ` transpose-regions Chong Yidong
2007-03-22 15:26 ` transpose-regions martin rudalics
2007-03-22 15:59 ` transpose-regions Chong Yidong
2007-03-22 17:07 ` transpose-regions martin rudalics
2007-03-22 18:06 ` transpose-regions Chong Yidong
2007-03-22 19:19 ` transpose-regions martin rudalics
2007-03-22 20:24 ` transpose-regions Chong Yidong
2007-03-22 21:32 ` martin rudalics [this message]
2007-03-22 22:13 ` transpose-regions martin rudalics
2007-03-22 21:51 ` transpose-regions Andreas Schwab
2007-03-23 13:46 ` transpose-regions Eli Zaretskii
2007-03-23 1:28 ` transpose-regions Chong Yidong
2007-03-23 9:05 ` transpose-regions martin rudalics
2007-03-23 10:55 ` transpose-regions Andreas Schwab
2007-03-23 11:50 ` transpose-regions Kim F. Storm
2007-03-23 12:08 ` transpose-regions martin rudalics
2007-03-23 14:09 ` transpose-regions Chong Yidong
2007-03-23 15:36 ` transpose-regions Kim F. Storm
2007-03-23 16:42 ` transpose-regions Stefan Monnier
2007-03-23 17:34 ` transpose-regions Chong Yidong
2007-03-23 18:17 ` transpose-regions martin rudalics
2007-03-23 22:32 ` transpose-regions Richard Stallman
2007-03-23 22:50 ` transpose-regions Stefan Monnier
2007-03-28 4:56 ` transpose-regions Richard Stallman
2007-03-24 20:24 ` transpose-regions Karl Fogel
2007-03-23 18:00 ` transpose-regions Richard Stallman
2007-03-23 22:39 ` transpose-regions Stefan Monnier
2007-03-24 15:51 ` transpose-regions Chong Yidong
2007-03-25 17:28 ` transpose-regions Richard Stallman
2007-03-23 15:39 ` transpose-regions Chong Yidong
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=4602F5EF.4080604@gmx.at \
--to=rudalics@gmx.at \
--cc=cyd@stupidchicken.com \
--cc=emacs-devel@gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this external index
https://git.savannah.gnu.org/cgit/emacs.git
https://git.savannah.gnu.org/cgit/emacs/org-mode.git
This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.