[Emacs-diffs] trunk r117359: * lisp/rect.el (rectangle-preview): New custom.

[Stefan Monnier]

------------------------------------------------------------
revno: 117359
revision-id: address@hidden
parent: address@hidden
committer: Stefan Monnier <address@hidden>
branch nick: trunk
timestamp: Tue 2014-06-17 15:33:58 -0400
message:
  * lisp/rect.el (rectangle-preview): New custom.
  (rectangle): New group.
  (rectangle--pos-cols): Add `window' argument.
  (rectangle--string-preview-state, rectangle--string-preview-window):
  New vars.
  (rectangle--string-flush-preview, rectangle--string-erase-preview)
  (rectangle--space-to, rectangle--string-preview): New functions.
  (string-rectangle): Use them.
  (rectangle--inhibit-region-highlight): New var.
  (rectangle--highlight-for-redisplay): Obey it.  Make sure
  `apply-on-region' uses the point-crutches of the right window.
  Use :align-to rather than multiple spaces.
modified:
  etc/NEWS                       news-20100311060928-aoit31wvzf25yr1z-1
  lisp/ChangeLog                 changelog-20091113204419-o5vbwnq5f7feedwu-1432
  lisp/rect.el                   rect.el-20091113204419-o5vbwnq5f7feedwu-83

=== modified file 'etc/NEWS'
--- a/etc/NEWS  2014-06-15 20:49:10 +0000
+++ b/etc/NEWS  2014-06-17 19:33:58 +0000
@@ -72,8 +72,10 @@
 
 * Changes in Specialized Modes and Packages in Emacs 24.5
 
-** Rectangle Mark mode can now have corners past EOL or in the middle of a TAB.
-Also C-x C-x in rectangle-mark-mode now cycles through the four corners.
+** Rectangle editing
+*** Rectangle Mark mode can have corners past EOL or in the middle of a TAB.
+*** C-x C-x in rectangle-mark-mode now cycles through the four corners.
+*** `string-rectangle' provides on-the-fly preview of the result.
 
 ** New font-lock functions font-lock-ensure and font-lock-flush, which
 should be used instead of font-lock-fontify-buffer when called from Elisp.

=== modified file 'lisp/ChangeLog'
--- a/lisp/ChangeLog    2014-06-16 06:37:37 +0000
+++ b/lisp/ChangeLog    2014-06-17 19:33:58 +0000
@@ -1,3 +1,18 @@
+2014-06-17  Stefan Monnier  <address@hidden>
+
+       * rect.el (rectangle-preview): New custom.
+       (rectangle): New group.
+       (rectangle--pos-cols): Add `window' argument.
+       (rectangle--string-preview-state, rectangle--string-preview-window):
+       New vars.
+       (rectangle--string-flush-preview, rectangle--string-erase-preview)
+       (rectangle--space-to, rectangle--string-preview): New functions.
+       (string-rectangle): Use them.
+       (rectangle--inhibit-region-highlight): New var.
+       (rectangle--highlight-for-redisplay): Obey it.  Make sure
+       `apply-on-region' uses the point-crutches of the right window.
+       Use :align-to rather than multiple spaces.
+
 2014-06-16  Andrea Rossetti  <address@hidden>  (tiny change)
 
        * ruler-mode.el (ruler-mode-window-col)
@@ -7,10 +22,13 @@
 
 2014-06-16  Ron Schnell  <address@hidden>
 
-       * play/dunnet.el (dun-doassign): Fixed bug where UNIX variable 
assignment without varname or rhs causes crash.
-       * play/dunnet.el (dun-ftp): Fixed bug where blank ftp password is 
allowed, making it impossible to win endgame.
-       * play/dunnet.el (dun-unix-verbs): Added ssh as alias to rlogin, 
because nobody knows what rlogin is anymore.
-       * play/dunnet.el (dun-help): Bumped version number, updated contact 
info.
+       * play/dunnet.el (dun-doassign): Fix bug where UNIX variable assignment
+       without varname or rhs causes crash.
+       (dun-ftp): Fix bug where blank ftp password is allowed, making it
+       impossible to win endgame.
+       (dun-unix-verbs): Add ssh as alias to rlogin, because nobody knows what
+       rlogin is anymore.
+       (dun-help): Bump version number; update contact info.
 
 2014-06-15  Michael Albinus  <address@hidden>
 
@@ -19,8 +37,8 @@
        * net/tramp.el (tramp-methods): Tweak docstring.
        (tramp-handle-file-accessible-directory-p): Check for
        `file-readable-p' instead of `file-executable-p'.
-       (tramp-check-cached-permissions): Use
-       `tramp-compat-file-attributes'.
+       (tramp-check-cached-permissions):
+       Use `tramp-compat-file-attributes'.
        (tramp-call-process): Add new argument VEC.  Adapt callees in all
        tramp*.el files.
 

=== modified file 'lisp/rect.el'
--- a/lisp/rect.el      2014-06-11 21:51:44 +0000
+++ b/lisp/rect.el      2014-06-17 19:33:58 +0000
@@ -33,6 +33,11 @@
 
 (eval-when-compile (require 'cl-lib))
 
+(defgroup rectangle nil
+  "Operations on rectangles."
+  :version "24.5"
+  :group 'editing)
+
 ;; FIXME: this function should be replaced by `apply-on-rectangle'
 (defun operate-on-rectangle (function start end coerce-tabs)
   "Call FUNCTION for each line of rectangle with corners at START, END.
@@ -68,11 +73,11 @@
 (defvar-local rectangle--mark-crutches nil
   "(POS . COL) to override the column to use for the mark.")
 
-(defun rectangle--pos-cols (start end)
+(defun rectangle--pos-cols (start end &optional window)
   ;; At this stage, we don't know which of start/end is point/mark :-(
   ;; And in case start=end, it might still be that point and mark have
   ;; different crutches!
-  (let ((cw (window-parameter nil 'rectangle--point-crutches)))
+  (let ((cw (window-parameter window 'rectangle--point-crutches)))
     (cond
      ((eq start (car cw))
       (let ((sc (cdr cw))
@@ -365,6 +370,67 @@
       (delete-rectangle-line startcol endcol nil))
   (insert string))
 
+(defvar-local rectangle--string-preview-state nil)
+(defvar-local rectangle--string-preview-window nil)
+
+(defun rectangle--string-flush-preview ()
+  (mapc #'delete-overlay (nthcdr 3 rectangle--string-preview-state))
+  (setf (nthcdr 3 rectangle--string-preview-state) nil))
+
+(defun rectangle--string-erase-preview ()
+  (with-selected-window rectangle--string-preview-window
+    (rectangle--string-flush-preview)))
+
+(defun rectangle--space-to (col)
+  (propertize " " 'display `(space :align-to ,col)))
+
+(defface rectangle-preview-face '((t :inherit region))
+  "The face to use for the `string-rectangle' preview.")
+
+(defcustom rectangle-preview t
+  "If non-nil, `string-rectangle' will show an-the-fly preview."
+  :type 'boolean)
+
+(defun rectangle--string-preview ()
+  (let ((str (minibuffer-contents)))
+    (when (equal str "")
+      (setq str (or (car-safe minibuffer-default)
+                    (if (stringp minibuffer-default) minibuffer-default))))
+    (setq str (propertize str 'face 'region))
+    (with-selected-window rectangle--string-preview-window
+      (unless (or (null rectangle--string-preview-state)
+                  (equal str (car rectangle--string-preview-state)))
+        (rectangle--string-flush-preview)
+        (apply-on-rectangle
+         (lambda (startcol endcol)
+           (let* ((sc (move-to-column startcol))
+                  (start (if (<= sc startcol) (point)
+                           (forward-char -1)
+                           (setq sc (current-column))
+                           (point)))
+                  (ec (move-to-column endcol))
+                  (end (point))
+                  (ol (make-overlay start end)))
+             (push ol (nthcdr 3 rectangle--string-preview-state))
+             ;; FIXME: The extra spacing doesn't interact correctly with
+             ;; the extra spacing added by the rectangular-region-highlight.
+             (when (< sc startcol)
+               (overlay-put ol 'before-string (rectangle--space-to startcol)))
+             (let ((as (when (< endcol ec)
+                         ;; (rectangle--space-to ec)
+                         (spaces-string (- ec endcol))
+                         )))
+               (if (= start end)
+                   (overlay-put ol 'after-string (if as (concat str as) str))
+                 (overlay-put ol 'display str)
+                 (if as (overlay-put ol 'after-string as))))))
+         (nth 1 rectangle--string-preview-state)
+         (nth 2 rectangle--string-preview-state))))))
+
+;; FIXME: Should this be turned into inhibit-region-highlight and made to apply
+;; to non-rectangular regions as well?
+(defvar rectangle--inhibit-region-highlight nil)
+
 ;;;###autoload
 (defun string-rectangle (start end string)
   "Replace rectangle contents with STRING on each line.
@@ -372,14 +438,31 @@
 
 Called from a program, takes three args; START, END and STRING."
   (interactive
-   (progn (barf-if-buffer-read-only)
-         (list
-          (region-beginning)
-          (region-end)
+   (progn
+     (make-local-variable 'rectangle--string-preview-state)
+     (make-local-variable 'rectangle--inhibit-region-highlight)
+     (let* ((buf (current-buffer))
+            (win (if (eq (window-buffer) buf) (selected-window)))
+            (start (region-beginning))
+            (end (region-end))
+            (rectangle--string-preview-state `(nil ,start ,end))
+            ;; Rectangle-region-highlighting doesn't work well in the presence
+            ;; of the preview overlays.  We could work harder to try and make
+            ;; it work better, but it's easier to just disable it temporarily.
+            (rectangle--inhibit-region-highlight t))
+       (barf-if-buffer-read-only)
+       (list start end
+             (minibuffer-with-setup-hook
+                 (lambda ()
+                   (setq rectangle--string-preview-window win)
+                   (add-hook 'minibuffer-exit-hook
+                             #'rectangle--string-erase-preview nil t)
+                   (add-hook 'post-command-hook
+                             #'rectangle--string-preview nil t))
           (read-string (format "String rectangle (default %s): "
                                (or (car string-rectangle-history) ""))
                        nil 'string-rectangle-history
-                       (car string-rectangle-history)))))
+                            (car string-rectangle-history)))))))
   (goto-char
    (apply-on-rectangle 'string-rectangle-line start end string t)))
 
@@ -635,6 +718,9 @@
   (cond
    ((not rectangle-mark-mode)
     (funcall orig start end window rol))
+   (rectangle--inhibit-region-highlight
+    (rectangle--unhighlight-for-redisplay orig rol)
+    nil)
    ((and (eq 'rectangle (car-safe rol))
          (eq (nth 1 rol) (buffer-chars-modified-tick))
          (eq start (nth 2 rol))
@@ -648,69 +734,84 @@
                       (nthcdr 5 rol)
                     (funcall redisplay-unhighlight-region-function rol)
                     nil)))
-        (apply-on-rectangle
-         (lambda (leftcol rightcol)
-           (let* ((mleft (move-to-column leftcol))
-                  (left (point))
-                  (mright (move-to-column rightcol))
-                  (right (point))
-                  (ol
-                   (if (not old)
-                       (let ((ol (make-overlay left right)))
-                         (overlay-put ol 'window window)
-                         (overlay-put ol 'face 'region)
-                         ol)
-                     (let ((ol (pop old)))
-                       (move-overlay ol left right (current-buffer))
-                       ol))))
-             ;; `move-to-column' may stop before the column (if bumping into
-             ;; EOL) or overshoot it a little, when column is in the middle
-             ;; of a char.
-             (cond
-              ((< mleft leftcol)        ;`leftcol' is past EOL.
-               (overlay-put ol 'before-string
-                            (spaces-string (- leftcol mleft)))
-               (setq mright (max mright leftcol)))
-              ((and (> mleft leftcol)   ;`leftcol' is in the middle of a char.
-                    (eq (char-before left) ?\t))
-               (setq left (1- left))
-               (move-overlay ol left right)
-               (goto-char left)
-               (overlay-put ol 'before-string
-                            (spaces-string (- leftcol (current-column)))))
-              ((overlay-get ol 'before-string)
-               (overlay-put ol 'before-string nil)))
-             (cond
-              ((< mright rightcol)      ;`rightcol' is past EOL.
-               (let ((str (make-string (- rightcol mright) ?\s)))
-                 (put-text-property 0 (length str) 'face 'region str)
-                 ;; If cursor happens to be here, draw it at the right place.
-                 (rectangle--place-cursor leftcol left str)
-                 (overlay-put ol 'after-string str)))
-              ((and (> mright rightcol) ;`rightcol's in the middle of a char.
-                    (eq (char-before right) ?\t))
-               (setq right (1- right))
-               (move-overlay ol left right)
-               (if (= rightcol leftcol)
-                   (overlay-put ol 'after-string nil)
-                 (goto-char right)
-                 (let ((str (make-string
-                             (- rightcol (max leftcol (current-column)))
-                             ?\s)))
+        (cl-assert (eq (window-buffer window) (current-buffer)))
+        ;; `rectangle--pos-cols' looks up the `selected-window's parameter!
+        (with-selected-window window
+          (apply-on-rectangle
+           (lambda (leftcol rightcol)
+             (let* ((mleft (move-to-column leftcol))
+                    (left (point))
+                    ;; BEWARE: In the presence of other overlays with
+                    ;; before/after/display-strings, this happens to move to
+                    ;; the column "as if the overlays were not applied", which
+                    ;; is sometimes what we want, tho it can be
+                    ;; considered a bug in move-to-column (it should arguably
+                    ;; pay attention to the before/after-string/display
+                    ;; properties when computing the column).
+                    (mright (move-to-column rightcol))
+                    (right (point))
+                    (ol
+                     (if (not old)
+                         (let ((ol (make-overlay left right)))
+                           (overlay-put ol 'window window)
+                           (overlay-put ol 'face 'region)
+                           ol)
+                       (let ((ol (pop old)))
+                         (move-overlay ol left right (current-buffer))
+                         ol))))
+               ;; `move-to-column' may stop before the column (if bumping into
+               ;; EOL) or overshoot it a little, when column is in the middle
+               ;; of a char.
+               (cond
+                ((< mleft leftcol)      ;`leftcol' is past EOL.
+                 (overlay-put ol 'before-string (rectangle--space-to leftcol))
+                 (setq mright (max mright leftcol)))
+                ((and (> mleft leftcol) ;`leftcol' is in the middle of a char.
+                      (eq (char-before left) ?\t))
+                 (setq left (1- left))
+                 (move-overlay ol left right)
+                 (goto-char left)
+                 (overlay-put ol 'before-string (rectangle--space-to leftcol)))
+                ((overlay-get ol 'before-string)
+                 (overlay-put ol 'before-string nil)))
+               (cond
+                ;; While doing rectangle--string-preview, the two sets of
+                ;; overlays steps on the other's toes.  I fixed some of the
+                ;; problems, but others remain.  The main one is the two
+                ;; (rectangle--space-to rightcol) below which try to virtually
+                ;; insert missing text, but during "preview", the text is not
+                ;; missing (it's provided by preview's own overlay).
+                (rectangle--string-preview-state
+                 (if (overlay-get ol 'after-string)
+                     (overlay-put ol 'after-string nil)))
+                ((< mright rightcol)    ;`rightcol' is past EOL.
+                 (let ((str (rectangle--space-to rightcol)))
                    (put-text-property 0 (length str) 'face 'region str)
-                   (when (= left right)
-                     (rectangle--place-cursor leftcol left str))
-                   (overlay-put ol 'after-string str))))
-              ((overlay-get ol 'after-string)
-               (overlay-put ol 'after-string nil)))
-             (when (and (= leftcol rightcol) (display-graphic-p))
-               ;; Make zero-width rectangles visible!
-               (overlay-put ol 'after-string
-                            (concat (propertize " "
-                                                'face '(region (:height 0.2)))
-                                    (overlay-get ol 'after-string))))
-             (push ol nrol)))
-         start end)
+                   ;; If cursor happens to be here, draw it at the right place.
+                   (rectangle--place-cursor leftcol left str)
+                   (overlay-put ol 'after-string str)))
+                ((and (> mright rightcol) ;`rightcol's in the middle of a char.
+                      (eq (char-before right) ?\t))
+                 (setq right (1- right))
+                 (move-overlay ol left right)
+                 (if (= rightcol leftcol)
+                     (overlay-put ol 'after-string nil)
+                   (goto-char right)
+                   (let ((str (rectangle--space-to rightcol)))
+                     (put-text-property 0 (length str) 'face 'region str)
+                     (when (= left right)
+                       (rectangle--place-cursor leftcol left str))
+                     (overlay-put ol 'after-string str))))
+                ((overlay-get ol 'after-string)
+                 (overlay-put ol 'after-string nil)))
+               (when (and (= leftcol rightcol) (display-graphic-p))
+                 ;; Make zero-width rectangles visible!
+                 (overlay-put ol 'after-string
+                              (concat (propertize " "
+                                                  'face '(region (:height 
0.2)))
+                                      (overlay-get ol 'after-string))))
+               (push ol nrol)))
+           start end))
         (mapc #'delete-overlay old)
         `(rectangle ,(buffer-chars-modified-tick)
                     ,start ,end ,(rectangle--crutches)