summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorNicolas Goaziou <mail@nicolasgoaziou.fr>2019-02-17 18:42:23 +0100
committerNicolas Goaziou <mail@nicolasgoaziou.fr>2019-02-17 18:42:23 +0100
commit1227ad468dff230262463562c23e632254432bf5 (patch)
tree513dbe0a91326dccc55a7c1de7ce65614ca4ff87
parent6872088c7a531e9104d7599d40ade722823428ad (diff)
downloadorg-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.el167
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))))))))