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

[Tassilo Horn <tsdh@gnu.org>]

Eli Zaretskii <eliz@gnu.org> writes:

> Your code seems to update the overlays in a function called from
> post-command-hook, but post-command-hook runs before redisplay updates
> the window due to last command.  So you are using stale window-start
> and window-end values, and if the last command scrolls some file names
> into the view, those file names might not have overlays on them.
>
> I think the preferred method is to use jit-lock-register to register
> your function; see e.g. glasses.el for how this can be done.

Ok, here's a new version using that approach and basically it works.
However, there's a problem with the conditional 'display spec which
should in theory un-abbreviate the file name as soon as point enter's
the overlay's region.  Oftentimes that doesn't happen until I explicitly
force a redisplay with C-l or M-x.

Is there a good way to cope with that?

        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 <tsdh@gnu.org>
;; Keywords: TODO
;; 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 path 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 paths.")

(defcustom visual-file-name-abbrev-regex
  (concat "\\(?:file://\\)?/?"
	  "\\(?:[[:alnum:]@_.-]+/\\)+[[:alnum:]@_.-]*\\.\\w+")
  "Regexp matching paths.")

(defcustom visual-file-name-abbrev-replace-regex
  "[.@]?[[:alnum:]]\\([[:alnum:]]+\\)[-_/.]"
  "Regexp which will be visually replaced in paths.
All matches of this regexp's group number 1 in the paths matching
`visual-file-name-abbrev-regex' will be replaced by
`visual-file-name-abbrev-abbrev'.")

(defcustom visual-file-name-abbrev-abbrev "…"
  "String to be displayed instead of the match group 1 of
`visual-file-name-abbrev-regex'.")

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

(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--not-on-overlay-p (_buffer pos path abbrev)
  (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 path abbrev)
  (< (string-width abbrev)
     (string-width path)))

(defvar visual-file-name-abbrev-display-predicates
  (list #'visual-file-name-abbrev--not-on-overlay-p
	#'visual-file-name-abbrev--abbrev-shorter-p))

(defun visual-file-name-abbrev--display-p (buffer pos path abbrev)
  (seq-every-p (lambda (pred)
		 (funcall pred buffer pos path 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))
	   (path (match-string 0))
	   (abbrev (visual-file-name-abbrev--get-abbrev path))
	   (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 path)
      (overlay-put
       ol 'display `(when (visual-file-name-abbrev--display-p
			   object buffer-position ,path ,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)))

(define-minor-mode visual-file-name-abbrev-mode
  "Visually abbreviate file paths."
  nil " VFNAbbr" nil
  (if visual-file-name-abbrev-mode
      (progn
	(jit-lock-register #'visual-file-name-abbrev--jit-lock)
	(visual-file-name-abbrev--jit-lock (window-start)
					   (window-end)))
    (jit-lock-unregister #'visual-file-name-abbrev--jit-lock)
    (visual-file-name-abbrev--delete-overlays 1 (1+ (buffer-size)))))
--8<---------------cut here---------------end--------------->8---