;;; visual-filename-abbrev.el --- Visually abbreviate filenames  -*- lexical-binding: t; -*-

;; Copyright (C) 2019-2022, 2024 Free Software Foundation, Inc

;; Author: Tassilo Horn <tsdh@gnu.org>
;; Maintainer: Tassilo Horn <tsdh@gnu.org>
;; Keywords: tools
;; Package-Requires: ((emacs "26.1"))
;; Version: 1.3

;; 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 <https://www.gnu.org/licenses/>.

;;; Commentary:
;;
;; This minor mode abbreviates the directory part of filenames by using
;; overlays.  For example, a longish filename 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-filename-abbrev RET'.

;;; Code:

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

(defgroup visual-filename-abbrev nil
  "Visually abbreviate the directory part of filenames."
  :group 'tools)

(defcustom visual-filename-abbrev-regex
  (concat "\\(?:file://\\)?/?"
	  "\\(?:[[:alnum:]@_.-]+/\\)+[[:alnum:]@_.-]*\\.\\w+")
  "Regexp matching filenames."
  :group 'visual-filename-abbrev
  :type 'regexp)

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

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

(defcustom visual-filename-abbrev-unabbreviate-under-point t
  "If non-nil, filenames under point are displayed unabbreviated."
  :group 'visual-filename-abbrev
  :type 'boolean)

(defun visual-filename-abbrev--get-abbrev (filename)
  "Return an abbreviated name for FILENAME.
Replaces matches of `visual-filename-abbrev-replace-regex' with
`visual-filename-abbrev-ellipsis'."
  (let ((file (file-name-nondirectory filename))
	(dir (file-name-directory filename)))
    (concat
     (file-name-as-directory
      (replace-regexp-in-string
       visual-filename-abbrev-replace-regex
       visual-filename-abbrev-ellipsis dir nil nil 1))
     file)))

(defsubst visual-filename-abbrev--get-overlay (pos)
  "Get the `visual-filename-abbrev' overlay at POS."
  (car (seq-filter
	(lambda (o) (overlay-get o 'visual-filename-abbrev))
	(overlays-at pos))))

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

(defsubst visual-filename-abbrev--get-visual-width (str font)
  "Get the pixel width of STR with FONT."
  (seq-reduce (lambda (acc g) (+ acc (aref g 4)))
	      (font-get-glyphs font 0 (length str) str)
	      0))

(defun visual-filename-abbrev--abbrev-visually-shorter-p (_buffer pos filename abbrev)
  "Return non-nil if ABBREV's display representation is shorter than FILENAME.
This takes the font at POS into account."
  ;; When activated from a hook, this function may run before the
  ;; current buffer is shown in a window.  In that case, `font-at'
  ;; would error with "Specified window is not displaying the current
  ;; buffer".
  (let ((window (selected-window)))
    (when (and window
	       (eq (window-buffer window) (current-buffer)))
      (let ((font (font-at pos window)))
	(< (visual-filename-abbrev--get-visual-width abbrev font)
	   (visual-filename-abbrev--get-visual-width filename font))))))

(defun visual-filename-abbrev--line-wider-than-window-p (_buffer pos _filename _abbrev)
  "Return non-nil if the line with POS is wider than the width of the window."
  (save-excursion
    (goto-char pos)
    (< (window-width nil t)
       (string-pixel-width
        (buffer-substring (line-beginning-position)
                          (line-end-position))))))

(defcustom visual-filename-abbrev-predicates
  (list #'visual-filename-abbrev--abbrev-visually-shorter-p)
  "A list of predicates inhibiting abbreviation of a filename.
A filename 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 filename to be abbreviated.
  - ABBREV: The abbreviated version of the filename.

These predicates are available:

  - `visual-filename-abbrev--abbrev-shorter-p' ensures that an
    abbreviation is only shown if it is shorter (in the number of
    characters) than the original filename.  This is fast but
    doesn't work too good if `visual-filename-abbrev-ellipsis' is
    displayed wider than what's abbreviated (which depends on the
    font).

  - `visual-filename-abbrev--abbrev-visually-shorter-p' ensures
    that an abbreviation is only shown if it is visually shorter
    than the original filename, i.e., it takes the current font
    and, e.g., double-width unicode characters into account.
    This predicate is a bit more expensive to compute.

  - `visual-filename-abbrev--line-wider-than-window-p' allows
    abbreviations only if the line the filename is on is wider than the
    width of the window, i.e., abbreviations are only shown if the
    window is too narrow for the unabbreviated filename.  This predicate
    is best used together with one of the other predicates.  It also
    allows to relax `visual-filename-abbrev-regex' a bit to cover
    filenames without extension which can lead to too many false
    positives otherwise."
  :group 'visual-filename-abbrev
  :type '(repeat function))

(defun visual-filename-abbrev--abbreviate-p (buffer pos filename abbrev)
  "Return non-nil if FILENAME in BUFFER at POS should be shown as ABBREV.
See `visual-filename-abbrev-predicates'."
  (seq-every-p (lambda (pred)
		 (funcall pred buffer pos filename abbrev))
	       visual-filename-abbrev-predicates))

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

(defun visual-filename-abbrev--cursor-sensor (_window old-pos dir)
  (when-let ((ol (if (eq dir 'entered)
		     (visual-filename-abbrev--get-overlay (point))
		   (or (visual-filename-abbrev--get-overlay old-pos)
		       (visual-filename-abbrev--get-overlay
                        (if (> (point) old-pos)
			    (1- old-pos)
			  (1+ old-pos)))))))
    (if (eq dir 'entered)
	(when-let ((d (overlay-get ol 'display)))
	  (overlay-put ol 'visual-filename-abbrev--display-backup d)
	  (overlay-put ol 'display nil))
      (when-let ((d (overlay-get ol 'visual-filename-abbrev--display-backup)))
	(overlay-put ol 'display d)
	(overlay-put ol 'visual-filename-abbrev--display-backup nil)))))

(defun visual-filename-abbrev--place-overlays (start end)
  (goto-char start)
  (while (re-search-forward visual-filename-abbrev-regex end t)
    (let* ((m-beg (match-beginning 0))
	   (m-end (match-end 0))
	   (filename (match-string 0))
	   (abbrev (visual-filename-abbrev--get-abbrev filename)))
      (when (visual-filename-abbrev--abbreviate-p
	     (current-buffer) (point) filename abbrev)
	(let ((ol (or (when-let ((o (visual-filename-abbrev--get-overlay m-beg)))
			(move-overlay o m-beg m-end)
			o)
		      (make-overlay m-beg m-end nil t))))
	  (when visual-filename-abbrev-unabbreviate-under-point
	    (overlay-put ol 'cursor-sensor-functions
			 (list #'visual-filename-abbrev--cursor-sensor)))
	  (overlay-put ol 'visual-filename-abbrev t)
	  (overlay-put ol 'evaporate t)
	  (overlay-put ol 'help-echo filename)
	  (overlay-put ol 'display abbrev))))))

(defun visual-filename-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-filename-abbrev--place-overlays beg-line end-line)))

(defvar visual-filename-abbrev--csm-before-activation nil)
(make-variable-buffer-local 'visual-filename-abbrev--csm-before-activation)

(defvar cursor-sensor-mode)
(declare-function cursor-sensor-mode "cursor-sensor")

;;;###autoload
(define-minor-mode visual-filename-abbrev-mode
  "Visually abbreviate the directory part of filenames."
  :lighter " VFAbbr"
  (if visual-filename-abbrev-mode
      (progn
	(jit-lock-register #'visual-filename-abbrev--jit-lock)
	(require 'cursor-sensor)
	;; Remember if c-s-m has been enabled before we enable it.
	(setq visual-filename-abbrev--csm-before-activation cursor-sensor-mode)
	(cursor-sensor-mode)
	(visual-filename-abbrev--jit-lock (window-start)
					  (window-end)))
    (jit-lock-unregister #'visual-filename-abbrev--jit-lock)
    ;; Deactivate it only if it has been disabled before we started it.
    (when visual-filename-abbrev--csm-before-activation
      (cursor-sensor-mode -1))
    (visual-filename-abbrev--delete-overlays 1 (1+ (buffer-size)))))

(provide 'visual-filename-abbrev)

;; Local Variables:
;; bug-reference-url-format: "https://debbugs.gnu.org/cgi/bugreport.cgi?bug=%s"
;; End:

;;; visual-filename-abbrev.el ends here
