From 33a9eef11ffad3f2b2a21d2eac1e34bb72978db8 Mon Sep 17 00:00:00 2001 From: Nicolas Goaziou Date: Thu, 25 Jan 2018 23:43:37 +0100 Subject: [PATCH] Allow editing partially shrunk columns * lisp/org-table.el (org-table-with-shrunk-field): New macro. (org-table-get-field): (org-table-toggle-column-width): Use new macro. (org-table--shrunk-field): Update function. (org-table--shrink-field): When there is a width cookie, leave first characters editable. * lisp/org.el (org-self-insert-command): (org-delete-backward-char): (org-delete-char): Small refactoring. Handle shrink overlays. * testing/lisp/test-org-table.el (test-org-table/toggle-column-width): Update tests. --- lisp/org-table.el | 95 ++++++++++++++++++---------------- lisp/org.el | 78 +++++++++++++++------------- testing/lisp/test-org-table.el | 29 +++++++---- 3 files changed, 109 insertions(+), 93 deletions(-) diff --git a/lisp/org-table.el b/lisp/org-table.el index 05bdf0985..b9b895b1a 100644 --- a/lisp/org-table.el +++ b/lisp/org-table.el @@ -526,6 +526,17 @@ Field is restored even in case of abnormal exit." (org-table-goto-column ,column) (set-marker ,line nil))))) +(defmacro org-table-with-shrunk-field (&rest body) + "Save field shrunk state, execute BODY and restore state." + (declare (debug (body))) + (org-with-gensyms (end shrunk size) + `(let* ((,shrunk (save-match-data (org-table--shrunk-field))) + (,end (and ,shrunk (copy-marker (overlay-end ,shrunk) t))) + (,size (and ,shrunk (- ,end (overlay-start ,shrunk))))) + (when ,shrunk (delete-overlay ,shrunk)) + (unwind-protect (progn ,@body) + (when ,shrunk (move-overlay ,shrunk (- ,end ,size) ,end)))))) + (defmacro org-table-with-shrunk-columns (&rest body) "Expand all columns before executing BODY, then shrink them again." (declare (debug (body))) @@ -1265,16 +1276,8 @@ value." (let* ((pos (match-beginning 0)) (val (buffer-substring pos (match-end 0)))) (when replace - ;; Since we are going to remove any hidden field, do not rely - ;; on `org-table--hidden-field' as it could be GC'ed before - ;; second check. - (let* ((hide-overlay (org-table--shrunk-field)) - (begin (and hide-overlay (overlay-start hide-overlay)))) - (when hide-overlay (delete-overlay hide-overlay)) - (replace-match (if (equal replace "") " " replace) t t) - (when hide-overlay - (move-overlay hide-overlay - begin (+ begin (min 1 (length replace))))))) + (org-table-with-shrunk-field + (replace-match (if (equal replace "") " " replace) t t))) (goto-char (min (line-end-position) (1+ pos))) val))) @@ -3838,7 +3841,9 @@ When non-nil, return the overlay narrowing the field." (cl-some (lambda (o) (and (eq 'table-column-hide (overlay-get o 'org-overlay-type)) o)) - (overlays-in (1- (point)) (1+ (point))))) + (overlays-at (save-excursion + (skip-chars-forward "^|" (line-end-position)) + (1- (point)))))) (defun org-table--list-shrunk-columns () "List currently shrunk columns in table at point." @@ -3898,38 +3903,38 @@ Whenever the text behind or next to the overlay is modified, all the overlays in the column are deleted, effectively displaying the column again. -Return overlay used to hide the field." +Return overlay hiding the field." (unless (org-table--shrunk-field) - (let ((display - (cond - ((= width 0) org-table-shrunk-column-indicator) - ((eq contents 'hline) - (concat (make-string (1+ width) ?-) - org-table-shrunk-column-indicator)) - (t - ;; Remove invisible parts from links in CONTENTS. Since - ;; shrinking could happen before first fontification - ;; (e.g., using a #+STARTUP keyword), this cannot be done - ;; using text properties. - (let* ((contents (org-string-display contents)) - (field-width (string-width contents))) - (if (>= width field-width) - ;; Expand field. - (format " %s%s%s" - contents - (make-string (- width field-width) ?\s) - org-table-shrunk-column-indicator) - ;; Truncate field. - (format " %s%s" - (substring contents 0 width) - org-table-shrunk-column-indicator)))))) - (show-before-edit - (list (lambda (o &rest _) - ;; Removing one overlay removes all other overlays - ;; in the same column. - (mapc #'delete-overlay - (cdr (overlay-get o 'org-table-column-overlays)))))) - (o (make-overlay start end))) + (let* ((overlay-start + (cond + ((= 0 width) start) ;hide everything + ((<= (- end start) 1) start) ;column too short + ((>= width (- end start)) (1- end)) ;enough room + ((eq contents 'hline) (+ start width)) + (t + ;; Find cut location so that WIDTH characters are + ;; visible. + (let* ((begin start) + (lower begin) + (upper (1- end))) + (catch :exit + (while (> (- upper lower) 1) + (let ((mean (+ (ash lower -1) + (ash upper -1) + (logand lower upper 1)))) + (pcase (org-string-width (buffer-substring begin mean)) + ((pred (= width)) (throw :exit mean)) + ((pred (< width)) (setq upper mean)) + (_ (setq lower mean))))) + upper))))) + (display org-table-shrunk-column-indicator) + (show-before-edit + (list (lambda (o &rest _) + ;; Removing one overlay removes all other overlays + ;; in the same column. + (mapc #'delete-overlay + (cdr (overlay-get o 'org-table-column-overlays)))))) + (o (make-overlay overlay-start end))) (overlay-put o 'insert-behind-hooks show-before-edit) (overlay-put o 'insert-in-front-hooks show-before-edit) (overlay-put o 'modification-hooks show-before-edit) @@ -4069,10 +4074,8 @@ prefix, expand all columns." (`(16) (org-table-expand begin end)) (_ (org-table-expand begin end) - (org-table--shrink-columns (cl-set-exclusive-or columns shrunk) begin end) - ;; Move before overlay if point is under it. - (let ((o (org-table--shrunk-field))) - (when o (goto-char (overlay-start o)))))))) + (org-table--shrink-columns + (cl-set-exclusive-or columns shrunk) begin end))))) ;;;###autoload (defun org-table-shrink (&optional begin end) diff --git a/lisp/org.el b/lisp/org.el index 1f66c1f0e..c3711df17 100644 --- a/lisp/org.el +++ b/lisp/org.el @@ -19235,12 +19235,13 @@ overwritten, and the table is not marked as requiring realignment." (t (let (org-use-speed-commands) (call-interactively 'org-self-insert-command))))) ((and - (org-at-table-p) - (eq N 1) + (= N 1) (not (org-region-active-p)) + (org-at-table-p) (progn ;; Check if we blank the field, and if that triggers align. - (and (featurep 'org-table) org-table-auto-blank-field + (and (featurep 'org-table) + org-table-auto-blank-field (memq last-command '(org-cycle org-return org-shifttab org-ctrl-c-ctrl-c)) (if (or (eq (char-after) ?\s) (looking-at "[^|\n]* |")) @@ -19251,10 +19252,16 @@ overwritten, and the table is not marked as requiring realignment." ;; width. (org-table-blank-field))) t) - (looking-at "[^|\n]* \\( \\)|")) + (looking-at "[^|\n]* |")) ;; There is room for insertion without re-aligning the table. - (delete-region (match-beginning 1) (match-end 1)) - (self-insert-command N)) + (self-insert-command N) + (org-table-with-shrunk-field + (save-excursion + (skip-chars-forward "^|") + ;; Do not delete last space, which is + ;; `org-table-separator-space', but the regular space before + ;; it. + (delete-region (- (point) 2) (1- (point)))))) (t (setq org-table-may-need-update t) (self-insert-command N) @@ -19355,22 +19362,14 @@ because, in this case the deletion might narrow the column." (interactive "p") (save-match-data (org-check-before-invisible-edit 'delete-backward) - (if (and (org-at-table-p) - (eq N 1) + (if (and (= N 1) + (not overwrite-mode) (not (org-region-active-p)) - (string-match "|" (buffer-substring (point-at-bol) (point))) - (looking-at ".*?|")) - (let ((pos (point)) - (noalign (looking-at "[^|\n\r]* |")) - (c org-table-may-need-update)) - (backward-delete-char N) - (unless overwrite-mode - (skip-chars-forward "^|") - (insert " ") - (goto-char (1- pos))) - ;; noalign: if there were two spaces at the end, this field - ;; does not determine the width of the column. - (when noalign (setq org-table-may-need-update c))) + (not (eq (char-before) ?|)) + (save-excursion (skip-chars-backward " \t") (not (bolp))) + (looking-at-p ".*?|") + (org-at-table-p)) + (progn (forward-char -1) (org-delete-char 1)) (backward-delete-char N) (org-fix-tags-on-the-fly)))) @@ -19383,23 +19382,28 @@ because, in this case the deletion might narrow the column." (interactive "p") (save-match-data (org-check-before-invisible-edit 'delete) - (if (and (org-at-table-p) - (not (bolp)) - (not (= (char-after) ?|)) - (eq N 1)) - (if (looking-at ".*?|") - (let ((pos (point)) - (noalign (looking-at "[^|\n\r]* |")) - (c org-table-may-need-update)) - (replace-match - (concat (substring (match-string 0) 1 -1) " |") nil t) - (goto-char pos) - ;; noalign: if there were two spaces at the end, this field - ;; does not determine the width of the column. - (when noalign (setq org-table-may-need-update c))) - (delete-char N)) + (cond + ((or (/= N 1) + (eq (char-after) ?|) + (save-excursion (skip-chars-backward " \t") (bolp)) + (not (org-at-table-p))) (delete-char N) - (org-fix-tags-on-the-fly)))) + (org-fix-tags-on-the-fly)) + ((looking-at ".\\(.*?\\)|") + (let* ((update? org-table-may-need-update) + (noalign (looking-at-p ".*? |"))) + (delete-char 1) + (org-table-with-shrunk-field + (save-excursion + ;; Last space is `org-table-separator-space', so insert + ;; a regular one before it instead. + (goto-char (- (match-end 0) 2)) + (insert " "))) + ;; If there were two spaces at the end, this field does not + ;; determine the width of the column. + (when noalign (setq org-table-may-need-update update?)))) + (t + (delete-char N))))) ;; Make `delete-selection-mode' work with Org mode and Orgtbl mode (put 'org-self-insert-command 'delete-selection diff --git a/testing/lisp/test-org-table.el b/testing/lisp/test-org-table.el index 7c078d9f1..87b5c1f12 100644 --- a/testing/lisp/test-org-table.el +++ b/testing/lisp/test-org-table.el @@ -2401,21 +2401,30 @@ See also `test-org-table/copy-field'." ;; With a column width cookie, limit overlay to the specified number ;; of characters. (should - (equal (concat " abc" org-table-shrunk-column-indicator) - (org-test-with-temp-text "| <3> |\n| abcd |" + (equal "| ab" + (org-test-with-temp-text "| <3> |\n| abcd |" (org-table-toggle-column-width) - (overlay-get (car (overlays-at (point))) 'display)))) + (buffer-substring (line-beginning-position) + (overlay-start + (car (overlays-in (line-beginning-position) + (line-end-position)))))))) (should - (equal (concat " a " org-table-shrunk-column-indicator) - (org-test-with-temp-text "| <3> |\n| a |" + (equal "| a " + (org-test-with-temp-text "| <3> |\n| a |" (org-table-toggle-column-width) - (overlay-get (car (overlays-at (point))) 'display)))) - ;; Only overlay visible characters of the field. + (buffer-substring (line-beginning-position) + (overlay-start + (car (overlays-in (line-beginning-position) + (line-end-position)))))))) + ;; Width only takes into account visible characters. (should - (equal (concat " htt" org-table-shrunk-column-indicator) - (org-test-with-temp-text "| <3> |\n| [[http://orgmode.org]] |" + (equal "| [[htt" + (org-test-with-temp-text "| <4> |\n| [[http://orgmode.org]] |" (org-table-toggle-column-width) - (overlay-get (car (overlays-at (point))) 'display)))) + (buffer-substring (line-beginning-position) + (overlay-start + (car (overlays-in (line-beginning-position) + (line-end-position)))))))) ;; Before the first column or after the last one, ask for columns ;; ranges. (should