diff options
author | Nicolas Goaziou <mail@nicolasgoaziou.fr> | 2019-02-17 18:42:23 +0100 |
---|---|---|
committer | Nicolas Goaziou <mail@nicolasgoaziou.fr> | 2019-02-17 18:42:23 +0100 |
commit | 1227ad468dff230262463562c23e632254432bf5 (patch) | |
tree | 513dbe0a91326dccc55a7c1de7ce65614ca4ff87 | |
parent | 6872088c7a531e9104d7599d40ade722823428ad (diff) | |
download | org-mode-1227ad468dff230262463562c23e632254432bf5.tar.gz |
org-table: Shrunk columns obey to alignment cookies
* lisp/org-table.el (org-table--make-shrinking-overlay): Take care of
concatenating `org-table-separator-space' and
`org-table-shrunk-column-indicator'.
(org-table--shrink-field): Change signature to include column's
alignment. Improve algorithm.
(org-table--shrink-columns): Apply signature change.
-rw-r--r-- | lisp/org-table.el | 167 |
1 files changed, 108 insertions, 59 deletions
diff --git a/lisp/org-table.el b/lisp/org-table.el index 3368c6a..bf37679 100644 --- a/lisp/org-table.el +++ b/lisp/org-table.el @@ -3879,6 +3879,11 @@ buffer positions. FIELD is the real contents of the field, as a string, or nil. It is meant to be displayed upon moving the mouse onto the overlay. +When optional argument PRE is non-nil, assume the overlay is +located at the beginning of the field, and prepend +`org-table-separator-space' to it. Otherwise, concatenate +`org-table-shrunk-column-indicator' at its end. + Return the overlay." (let ((show-before-edit (lambda (o &rest _) @@ -3887,7 +3892,7 @@ Return the overlay." (mapc #'delete-overlay (cdr (overlay-get o 'org-table-column-overlays))))) (o (make-overlay start end))) - (overlay-put o 'insert-behind-hooks (and (not pre) (list show-before-edit))) + (overlay-put o 'insert-behind-hooks (list show-before-edit)) (overlay-put o 'insert-in-front-hooks (list show-before-edit)) (overlay-put o 'modification-hooks (list show-before-edit)) (overlay-put o 'org-overlay-type 'table-column-hide) @@ -3895,17 +3900,20 @@ Return the overlay." ;; Make sure overlays stays on top of table coordinates overlays. ;; See `org-table-overlay-coordinates'. (overlay-put o 'priority 1) - (org-overlay-display o display 'org-table t) + (let ((d (if pre (concat org-table-separator-space display) + (concat display org-table-shrunk-column-indicator)))) + (org-overlay-display o d 'org-table t)) o)) -(defun org-table--shrink-field (width start end contents) +(defun org-table--shrink-field (width align start end contents) "Shrink a table field to a specified width. WIDTH is an integer representing the number of characters to -display, in addition to `org-table-shrunk-column-indicator'. START -and END are, respectively, the beginning and ending positions of -the field. CONTENTS is its trimmed contents, as a string, or -`hline' for table rules. +display, in addition to `org-table-shrunk-column-indicator'. +ALIGN is the alignment of the current column, as either \"l\", +\"c\" or \"r\". START and END are, respectively, the beginning +and ending positions of the field. CONTENTS is its trimmed +contents, as a string, or `hline' for table rules. Real field is hidden under one or two overlays. They have the following properties: @@ -3932,55 +3940,92 @@ already hidden." ((or (= 0 width) ;shrink to one character (>= 1 (org-string-width (buffer-substring start end)))) (list (org-table--make-shrinking-overlay - start end org-table-shrunk-column-indicator - (if (eq 'hline contents) "" contents)))) + start end "" (if (eq 'hline contents) "" contents)))) ((eq contents 'hline) ;no contents to hide (list (org-table--make-shrinking-overlay - start end - (concat (make-string (max 0 (1+ width)) ?-) - org-table-shrunk-column-indicator) - ""))) + start end (make-string (max 0 (1+ width)) ?-) ""))) (t - ;; If the field is not empty, consider using two overlays: one for - ;; the blanks at the beginning of the field, and another one at - ;; the end of the field. The former ensures a shrunk field is - ;; always displayed with a single white space character in front - ;; of it -- e.g., so that even right-aligned fields appear to the - ;; left -- and the latter cuts the field at WIDTH visible - ;; characters. - (let* ((pre-overlay - (and (not (equal contents "")) - (org-with-point-at start (looking-at "\\( [ \t]+\\)\\S-")) - (org-table--make-shrinking-overlay - start (match-end 1) org-table-separator-space nil 'pre))) - (post-overlay - (let* ((start (if pre-overlay (overlay-end pre-overlay) - (1+ start))) - (w (org-string-width (buffer-substring start (1- end))))) - (if (>= width w) - ;; Field is too short. Extend its size by adding - ;; white space characters to the right overlay. - (org-table--make-shrinking-overlay - (1- end) end (concat (make-string (- width w) ?\s) - org-table-shrunk-column-indicator) - contents) - ;; Find cut location so that WIDTH characters are visible. - (org-table--make-shrinking-overlay - (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)) - end org-table-shrunk-column-indicator contents))))) - (delq nil (list pre-overlay post-overlay)))))) + ;; If the field is not empty, display exactly WIDTH characters. + ;; It can mean to partly hide the field, or extend it with virtual + ;; blanks. To that effect, we use one or two overlays. The + ;; first, optional, one may add or hide white spaces before the + ;; contents of the field. The other, mandatory, one cuts the + ;; field or displays white spaces at the end of the field. It + ;; also always displays `org-table-shrunk-column-indicator'. + (let* ((lead (org-with-point-at start (skip-chars-forward " "))) + (trail (org-with-point-at end (abs (skip-chars-backward " ")))) + (contents-width (org-string-width + (buffer-substring (+ start lead) (- end trail))))) + (cond + ;; Contents are too large to fit in WIDTH character. Limit, if + ;; possible, blanks at the beginning of the field to a single + ;; white space, and cut the field at an appropriate location. + ((<= width contents-width) + (let ((pre + (and (> lead 0) + (org-table--make-shrinking-overlay + start (+ start lead) "" contents t))) + (post + (org-table--make-shrinking-overlay + ;; Find cut location so that WIDTH characters are + ;; visible using dichotomy. + (let* ((begin (+ start lead)) + (lower begin) + (upper (1- end)) + ;; Compensate the absence of leading space, + ;; thus preserving alignment. + (width (if (= lead 0) (1+ width) width))) + (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)) + end "" contents))) + (if pre (list pre post) (list post)))) + ;; Contents fit it WIDTH characters. First compute number of + ;; white spaces needed on each side of contents, then expand or + ;; compact blanks on each side of the field in order to + ;; preserve width and obey to alignment constraints. + (t + (let* ((required (- width contents-width)) + (before + (pcase align + ;; Compensate the absence of leading space, thus + ;; preserving alignment. + ((guard (= lead 0)) -1) + ("l" 0) + ("r" required) + ("c" (/ required 2)))) + (after (- required before)) + (pre + (pcase (1- lead) + ((or (guard (= lead 0)) (pred (= before))) nil) + ((pred (< before)) + (org-table--make-shrinking-overlay + start (+ start (- lead before)) "" contents t)) + (_ + (org-table--make-shrinking-overlay + start (1+ start) + (make-string (- before (1- lead)) ?\s) + contents t)))) + (post + (pcase (1- trail) + ((pred (= after)) + (org-table--make-shrinking-overlay (1- end) end "" contents)) + ((pred (< after)) + (org-table--make-shrinking-overlay + (+ after (- end trail)) end "" contents)) + (_ + (org-table--make-shrinking-overlay + (1- end) end + (make-string (- after (1- trail)) ?\s) + contents))))) + (if pre (list pre post) (list post))))))))) (defun org-table--read-column-selection (select max) "Read column selection select as a list of numbers. @@ -4021,7 +4066,8 @@ table." (org-font-lock-ensure beg end) (dolist (c columns) (goto-char beg) - (let ((width nil) + (let ((align nil) + (width nil) (fields nil)) (while (< (point) end) (catch :continue @@ -4043,16 +4089,19 @@ table." (contents (if hline? 'hline (org-trim (buffer-substring start end))))) (push (list start end contents) fields) - (when (and (null width) - (not hline?) - (string-match "\\`<[lrc]?\\([0-9]+\\)>\\'" contents)) - (setq width (string-to-number (match-string 1 contents))))))) + (when (and (not hline?) + (string-match "\\`<\\([lrc]\\)?\\([0-9]+\\)>\\'" + contents)) + (unless align (setq align (match-string 1 contents))) + (unless width + (setq width (string-to-number (match-string 2 contents)))))))) (forward-line)) ;; Link overlays for current field to the other overlays in the ;; same column. (let ((chain (list 'siblings))) (dolist (field fields) - (dolist (new (apply #'org-table--shrink-field (or width 0) field)) + (dolist (new (apply #'org-table--shrink-field + (or width 0) (or align "l") field)) (push new (cdr chain)) (overlay-put new 'org-table-column-overlays chain)))))))) |