Re: [ELPA] New package proposal: visual-path-abbrev.el

[Tassilo Horn]

Eli Zaretskii <address@hidden> writes:

> For your feature to work reliably, you need one or more overlays
> examined even if the user just moves point, something that triggers a
> heavily optimized version of redisplay (because moving point is a very
> frequent operation).  You need to disable some of these optimizations.
>
> One way of disabling those optimizations is to make some immaterial
> change in one or more overlays, because overlay changes cause a more
> thorough redisplay of the buffer.  You can, for example, change some
> overlay property that will have no effect on display.
>
> Another possibility is to have a buffer-local variable that you add to
> the list of variables which trigger thorough redisplay of its buffer,
> see the end of frame.el for how this is done.  Then whenever you want
> redisplay to re-evaluate one or more of your overlays, you change the
> value of that variable.
>
> Both of those techniques will need to use post-command-hook, I think.
>
> Caveat: I didn't try any of my suggestions, so I cannot be sure they
> will work, although they should, of course.  (I did add the above
> caveats to the ELisp manual, so they are now documented.)

I'm now using option 1 and set the visual-file-name-abbrev overlay
property which I'm using to know which overlays are mine to (random)
instead of just t on the current and the last file name point was one in
a post-command-hook function.

That seems to do the trick although it's a bit sluggish when, e.g.,
pressing and holding C-n in a *grep* buffer in column 1 (which is
probably the worst case).

I haven't yet debugged what's the slow part but I guess it is the new
predicate `visual-file-name-abbrev--abbrev-visually-shorter-p' which
ensures that the abbreviation is only displayed if it is visually
shorter than the normal file name, i.e., it takes into account the
current font and the replacement ellipsis.  The standard one … is
twice as wide as a "normal" character on a non-terminal frame.

Other than that, do you think it's ok to add this package to ELPA?  If
so, is the (C) FSF and "This file is part of GNU Emacs" correct for an
ELPA(-only) package?

      Tassilo

--8<---------------cut here---------------start------------->8---
;;; visual-file-name-abbrev.el --- Visually abbreviate file names  -*- 
lexical-binding: t; -*-

;; Copyright (C) 2019 Free Software Foundation, Inc

;; Author: Tassilo Horn <address@hidden>
;; Keywords: tools
;; Version: TODO

;; This file is part of GNU Emacs.

;; GNU Emacs 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 3 of the License, or
;; (at your option) any later version.

;; GNU Emacs 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.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:
;;
;; This minor mode abbreviates the directory part of file names by using
;; overlays.  For example, a longish file name like
;;
;;    /home/myuser/Documents/Letters/Personal-Family/Letter-to-John.tex
;;
;; will be displayed like this:
;;
;;   /h…/m…/D…/L…/P…-F…/Letter-to-John.tex
;;
;; By default, the abbreviate display is disabled when point enters the overlay
;; so that you can edit the file name normally.  Also, abbreviated file names
;; are only shown if the abbreviation as actually shorter as the original one
;; (which depends on what you add as replacement).
;;
;; There's stuff to customize, just check `M-x customize-group RET
;; visual-file-name-abbrev RET'.

;;; Code:

(require 'subr-x)
(require 'seq)

(defgroup visual-file-name-abbrev nil
  "Visually abbreviate the directory part of file names."
  :group 'tools)

(defcustom visual-file-name-abbrev-regex
  (concat "\\(?:file://\\)?/?"
          "\\(?:[[:alnum:address@hidden/\\)+[[:alnum:address@hidden")
  "Regexp matching file names."
  :group 'visual-file-name-abbrev
  :type 'regexp)

(defcustom visual-file-name-abbrev-replace-regex
  "address@hidden:alnum:]]\\([[:alnum:]]\\{2,\\}\\)[-_/address@hidden"
  "Regexp which will be visually replaced in file names.
All matches of this regexp's group number 1 in the file names
matching `visual-file-name-abbrev-regex' will be replaced by
`visual-file-name-abbrev-ellipsis'."
  :group 'visual-file-name-abbrev
  :type 'regexp)

(defcustom visual-file-name-abbrev-ellipsis "…"
  "String displayed instead of group 1 of `visual-file-name-abbrev-regex'."
  :group 'visual-file-name-abbrev
  :type 'string)

(defun visual-file-name-abbrev--get-abbrev (file-name)
  (let ((file (file-name-nondirectory file-name))
        (dir (file-name-directory file-name)))
    (concat
     (file-name-as-directory
      (replace-regexp-in-string
       visual-file-name-abbrev-replace-regex
       visual-file-name-abbrev-ellipsis dir nil nil 1))
     file)))

(defvar visual-file-name-abbrev--last-overlay nil)
(make-variable-buffer-local 'visual-file-name-abbrev--last-overlay)

(defsubst visual-file-name-abbrev--get-overlay (pos)
  (car (seq-filter
        (lambda (o) (overlay-get o 'visual-file-name-abbrev))
        (overlays-at pos))))

(defun visual-file-name-abbrev--post-command ()
  "Modifies the last and possibly current overlay to trigger their redisplay."
  (when visual-file-name-abbrev--last-overlay
    (overlay-put visual-file-name-abbrev--last-overlay 'visual-file-name-abbrev 
(random))
    (setq visual-file-name-abbrev--last-overlay nil))
  (when-let ((ol (visual-file-name-abbrev--get-overlay (point))))
    (overlay-put ol 'visual-file-name-abbrev (random))
    (setq visual-file-name-abbrev--last-overlay ol)))

(defun visual-file-name-abbrev--not-on-overlay-p (_buffer pos file-name abbrev)
  "Return non-nil if point is not inside the overlay at POS."
  (when-let ((ol (visual-file-name-abbrev--get-overlay pos)))
    (or (< (point) (overlay-start ol))
        (> (point) (overlay-end ol)))))

(defun visual-file-name-abbrev--abbrev-shorter-p (_buffer _pos file-name abbrev)
  "Return non-nil if ABBREV is shorter than FILE-NAME.
Shorter means less characters here."
  (< (string-width abbrev)
     (string-width file-name)))

(defsubst visual-file-name-abbrev--get-visual-width (str font)
  (with-current-buffer (get-buffer-create " *VFNAbbr work*")
    (setq buffer-undo-list t)
    (erase-buffer)
    (insert str)
    (seq-reduce (lambda (acc g) (+ acc (aref g 4)))
                (font-get-glyphs font (point-min) (point-max))
                0)))

(defun visual-file-name-abbrev--abbrev-visually-shorter-p (_buffer pos 
file-name abbrev)
  "Return non-nil if ABBREV's display representation is shorter than FILE-NAME.
This takes the font into account."
  (let ((font (font-at pos)))
    (< (visual-file-name-abbrev--get-visual-width abbrev font)
       (visual-file-name-abbrev--get-visual-width file-name font))))

(defcustom visual-file-name-abbrev-display-predicates
  (list #'visual-file-name-abbrev--not-on-overlay-p
        #'visual-file-name-abbrev--abbrev-visually-shorter-p)
  "A list of predicates inhibiting abbreviation of a file name.
A file name is only abbreviate if all predicates in this list
return true.

Each predicate is called with the following four arguments:

  - BUFFER: The buffer holding the abbreviation overlay.
  - POS: The position in BUFFER of the overlay.
  - FILE: The file name to be abbreviated.
  - ABBREV: The abbreviated version of the file name.

These predicates are available:

  - `visual-file-name-abbrev--not-on-overlay-p' ensures that an
    abbreviation is not shown when `point' in inside the overlays
    region.

  - `visual-file-name-abbrev--abbrev-shorter-p' ensures that an
    abbreviation is only shown if it is shorter (in the number of
    characters) than the original file name.

  - `visual-file-name-abbrev--abbrev-visually-shorter-p' ensures
    that an abbreviation is only shown if it is visually shorter
    than the original file name, i.e., it takes the current font
    and, e.g., double-width unicode characters into account."
  :group 'visual-file-name-abbrev
  :type '(repeat function))

(defun visual-file-name-abbrev--display-p (buffer pos file-name abbrev)
  (seq-every-p (lambda (pred)
                 (funcall pred buffer pos file-name abbrev))
               visual-file-name-abbrev-display-predicates))

(defun visual-file-name-abbrev--delete-overlays (beg end)
  (dolist (ol (overlays-in beg end))
    (when (overlay-get ol 'visual-file-name-abbrev)
      (delete-overlay ol))))

(defun visual-file-name-abbrev--place-overlays (start end)
  (goto-char start)
  (while (re-search-forward visual-file-name-abbrev-regex end t)
    (let* ((m-beg (match-beginning 0))
           (m-end (match-end 0))
           (file-name (match-string 0))
           (abbrev (visual-file-name-abbrev--get-abbrev file-name))
           (ol (or (when-let ((o (visual-file-name-abbrev--get-overlay m-beg)))
                     (move-overlay o m-beg m-end)
                     o)
                   (make-overlay m-beg m-end nil t))))
      (overlay-put ol 'visual-file-name-abbrev t)
      (overlay-put ol 'evaporate t)
      (overlay-put ol 'help-echo file-name)
      (overlay-put
       ol 'display `(when (visual-file-name-abbrev--display-p
                           object buffer-position ,file-name ,abbrev)
                      . ,abbrev)))))

(defun visual-file-name-abbrev--jit-lock (beg end &optional _old-len)
  "Function registered for jit-lock."
  (let ((beg-line (save-excursion (goto-char beg) (line-beginning-position)))
        (end-line (save-excursion (goto-char end) (line-end-position))))
    (visual-file-name-abbrev--place-overlays beg-line end-line)))

;;###autoload
(define-minor-mode visual-file-name-abbrev-mode
  "Visually abbreviate the directory part of file names."
  nil " VFNAbbr" nil
  (if visual-file-name-abbrev-mode
      (progn
        (jit-lock-register #'visual-file-name-abbrev--jit-lock)
        (add-hook 'post-command-hook #'visual-file-name-abbrev--post-command 
nil t)
        (visual-file-name-abbrev--jit-lock (window-start)
                                           (window-end)))
    (jit-lock-unregister #'visual-file-name-abbrev--jit-lock)
    (remove-hook 'post-command-hook #'visual-file-name-abbrev--post-command t)
    (visual-file-name-abbrev--delete-overlays 1 (1+ (buffer-size)))))

(provide 'visual-file-name-abbrev)

;;; visual-file-name-abbrev.el ends here
--8<---------------cut here---------------end--------------->8---