path: root/breadcrumb.el

;;; breadcrumb.el --- project and imenu-based breadcrumb paths   -*- lexical-binding: t; -*-

;; Copyright (C) 2023  Free Software Foundation, Inc.

;; Author: João Távora <joaotavora@gmail.com>
;; Package-Requires: ((emacs "28.1") (project "0.9.8"))
;; Version: 1.0.1
;; Keywords:

;; This program 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.

;; This program 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 this program.  If not, see <https://www.gnu.org/licenses/>.

;;; Commentary:
;;
;;;; Usage:
;;
;; Breadcrumbs are sequences of short strings indicating where you
;; are in some big tree-like maze.
;;
;; To craft these strings, this library uses the maps provided by
;; project.el and Imenu, respectively.  Project breadcrumbs shows you
;; the current buffer's path in a large project.  Imenu breadcrumbs
;; show the current position of point in the buffer's nested
;; structure of programming constructs (for example, a specific
;; functions within multiple C++ nested namespaces).
;;
;; To use this library:
;;
;; * `M-x breadcrumb-mode` is a global mode.  Will try to turn itself
;;   on conservatively and only if there's a project.
;;
;; * `M-x breadcrumb-local-mode` is a buffer-local minor mode, if you
;;    don't want the default heuristics for turning it on everywhere.
;;
;; * Manually put the mode-line constructs
;;
;;     (:eval (breadcrumb-imenu-crumbs))
;;
;;   and
;;
;;     (:eval (breadcrumb-project-crumbs))
;;
;;  in your settings of the `mode-line-format' or
;;  `header-line-format' variables.
;;
;; The shape and size of each breadcrumb groups may be tweaked via
;; `breadcrumb-imenu-max-length', `breadcrumb-project-max-length',
;; `breadcrumb-imenu-crumb-separator', and
;; `breadcrumb-project-crumb-separator'.
;;
;; The structure each the breadcrumbs varies depending on whether
;; either project.el and imenu.el (or both) can do useful things for
;; your buffer.
;;
;; For Project breadcrumbs, this depends on whether project.el's
;; `project-current' can guess what project the current buffer
;; belongs to.
;;
;; For Imenu breadcrumbs, this varies.  Depending on the major-mode
;; author's taste, the Imenu tree (in variable `imenu--index-alist')
;; may have different structure.  Sometimes, minor mode also tweak
;; the Imenu tree in useful ways.  For example, with recent Eglot (I
;; think Eglot 1.14+), managed buffers get extra region info added to
;; it, which makes Breadcrumb show "richer" paths.
;;
;;;; Implementation notes:
;;
;; This _should_ be faster than which-func.el due some caching
;; strategies.  One of these strategies occurs in `bc--ipath-alist',
;; which takes care not to over-call `imenu--make-index-alist', which
;; could be slow (in fact very slow if an external process needs to
;; be contacted).  The variable `breadcrumb-idle-delay' controls
;; that.  Another cache occurs in `bc--ipath-plain-cache' second is
;; just a simple "space-for-speed" cache.
;;
;; Breadcrumb uses the double-dashed Imenu symbols
;; `imenu--index-alist' and `imenu--make-index-alist'.  There's
;; really no official API here.  It's arguable that, despite the
;; name, these aren't really internal symbols (the much older
;; which-func.el library makes liberal use of them, for example).
;;
;;;; Todo:
;;
;; Make more clicky buttons in the headerline to do whatever
;;

;;; Code:
(require 'cl-lib)
(require 'imenu)
(require 'project)


;;;; Customization options
;;

(defgroup breadcrumb nil
  "One-liner indication of where you are in the maze."
  :prefix "breadcrumb-"
  :group 'convenience)

(defcustom bc-project-max-length 0.3
  "Soft cutoff for `breadcrumb-project-crumbs'.
If a fixnum, it's a absolute number of characters.  If a float, a
percentage of `window-width'."
  :type '(choice (natnum :tag "Number of characters")
                 (float  :tag "Percent of window's width")))

(defcustom bc-project-crumb-separator "/"
  "Separator for `breadcrumb-project-crumbs'." :type 'string)

(defcustom bc-imenu-max-length 0.3
  "Soft cutoff for `breadcrumb-imenu-crumbs'.
If a fixnum, it's a absolute number of characters.  If a float, a
percentage of `window-width'."
  :type '(choice (natnum :tag "Number of characters")
                 (float  :tag "Percent of window's width")))

(defcustom bc-imenu-crumb-separator " > "
  "Separator for `breadcrumb-project-crumbs'." :type 'string)

(defface bc-face '((t (:inherit shadow)))
  "Base face for all breadcrumb things.")

(defface bc-imenu-crumbs-face '((t (:inherit bc-face)))
  "Face for imenu crumbs in the breadcrumb imenu path.")

(defface bc-imenu-leaf-face '((t (:inherit (font-lock-function-name-face
                                            bc-imenu-crumbs-face))))
  "Face for imenu leaf crumbs in the breadcrumb imenu path.")

(defface bc-project-crumbs-face '((t (:inherit bc-face)))
  "Face for project crumbs in the breadcrumb project path.")

(defface bc-project-base-face '((t (:inherit bc-project-crumbs-face)))
  "Face for project base in the breadcrumb project path.")

(defface bc-project-leaf-face '((t (:inherit (mode-line-buffer-id))))
  "Face for the project leaf crumb in breadcrumb project path.")


;;;; "ipath" management logic and imenu interoperation
;;
(cl-defun bc--bisect (a x &key (from 0) (to (length a)) key from-end)
  "Compute index to insert X in sequence A, keeping it sorted.
If X already in A, the resulting index is the leftmost such
index, unless FROM-END is t.  KEY is as usual in other CL land."
  (cl-macrolet ((search (from-end key)
                  `(cl-loop while (< from to)
                            for mid = (/ (+ from to) 2)
                            for p1 = (elt a mid)
                            for p2 = ,(if key `(funcall key p1) `p1)
                            if (,(if from-end '< '<=) x p2)
                            do (setq to mid) else do (setq from (1+ mid))
                            finally return from)))
    (if from-end (if key (search t key) (search t nil))
      (if key (search nil key) (search nil nil)))))

(defun bc--ipath-rich (index-alist pos)
  "Compute ipath for rich `imenu--index-alist' structures.
These structures have a `breadcrumb-region' property on every
node."
  (cl-labels
      ((search (nodes &optional ipath)
         (cl-loop
          for n in nodes
          for reg = (get-text-property 0 'breadcrumb-region (car n))
          when (<= (car reg) pos (cdr reg))
          return (search (cdr n) (cons
                                  (propertize (car n)
                                              'breadcrumb-siblings nodes
                                              'breadcrumb-parent (car ipath))
                                  ipath))
          finally (cl-return ipath))))
    (nreverse (search index-alist))))

(defvar-local bc--ipath-plain-cache nil
  "A cache for `breadcrumb--ipath-plain'.")

(defun bc--ipath-plain (index-alist pos)
  "Compute ipath for plain `imenu--index-alist' structures.
These structures don't have a `breadcrumb-region' property on."
  (cl-labels ((dfs (n &optional ipath siblings)
                (setq ipath (cons (car n) ipath))
                (if (consp (cdr n))
                    (mapc (lambda (n2) (dfs n2 ipath (cdr n))) (cdr n))
                  ;; FIXME: we convert markers to points via the `+'
                  ;; down there.  But for siblings, no such conversion
                  ;; happens, they might still point to invalid
                  ;; markers.  Not worth doing another tree traversal
                  ;; for that IMO, and siblings seems to be unused
                  ;; anyway (github#22)
                  (put-text-property 0 1 'breadcrumb-siblings (cdr siblings) (car ipath))
                  (setq bc--ipath-plain-cache
                        (vconcat bc--ipath-plain-cache
                                 `[,(cons
                                     ;; See github#17 and docstring of
                                     ;; `imenu--index-alist' for the
                                     ;; "overlay" edge case.
                                     (cl-etypecase (cdr n)
                                       (number (cdr n))
                                       (marker (+ (cdr n) 0))
                                       (overlay (overlay-start (cdr n))))
                                     ipath)])))))
    (unless bc--ipath-plain-cache
      (mapc (lambda (i) (dfs i nil index-alist)) index-alist)
      (setq bc--ipath-plain-cache (cl-sort bc--ipath-plain-cache #'< :key #'car)))
    (unless (< pos (car (aref bc--ipath-plain-cache 0)))
      (let ((res (bc--bisect bc--ipath-plain-cache pos :key #'car :from-end t)))
        (unless (zerop res) (reverse (cdr (elt bc--ipath-plain-cache (1- res)))))))))

(defun bc-ipath (index-alist pos)
  "Get breadcrumb for position POS given INDEX-ALIST."
  (if (get-text-property 0 'breadcrumb-region (caar index-alist))
      (bc--ipath-rich index-alist pos)
    (bc--ipath-plain index-alist pos)))

(defvar bc-idle-time 1
  "Control idle time before requesting new breadcrumbs.")

(defvar-local bc--idle-timer nil
  "Timer used by `breadcrumb--ipath-alist'.")

(defvar-local bc--last-update-tick 0
  "Last time `breadcrumb--ipath-alist' asked for an update.")

(defun bc--ipath-alist ()
  "Return `imenu--index-alist', maybe arrange for its update."
  ;; Be mindful of indirect buffers (github#31)
  (let ((buf (or (buffer-base-buffer) (current-buffer))))
    (with-current-buffer buf
      (unless (= (buffer-chars-modified-tick) bc--last-update-tick)
        (setq bc--last-update-tick (buffer-chars-modified-tick))
        (when bc--idle-timer (cancel-timer bc--idle-timer))
        (setq bc--idle-timer
              (run-with-idle-timer
               bc-idle-time nil
               (lambda ()
                 (when (buffer-live-p buf)
                   (with-current-buffer buf
                     (setq bc--last-update-tick (buffer-chars-modified-tick))
                     (let ((non-essential t)
                           (imenu-auto-rescan t))
                       (ignore-errors
                         (imenu--make-index-alist t))
                       (setq bc--ipath-plain-cache nil)
                       ;; no point is taxing the mode-line machinery now
                       ;; if the buffer isn't showing anywhere.
                       (when (get-buffer-window buf t)
                         (force-mode-line-update t)))))))))
      imenu--index-alist)))


;;;; Higher-level functions
;;

;; FIXME: Why do I need to put these key definitiosn in special
;; variables?
(defvar bc--header-line-key [header-line mouse-1])
(defvar bc--mode-line-key [mode-line mouse-1])

(defun bc--length (len)
  "Interpret LEN using `window-width' and return a number."
  (cond ((floatp len) (* (window-width) len))
        (t len)))

(defun bc--format-ipath-node (p more)
  (let* ((l (lambda (&rest _event)
              (interactive)
              ;; TODO: This is a bit inadequate if the user is
              ;; clicking the mode or header lines, but 'event' seems
              ;; to be missing in these cases.  We would to
              ;; conveniently visit places near the node `p' via the
              ;; mouse
              (breadcrumb-jump))))
    (propertize
     p 'mouse-face 'header-line-highlight
     'face (if more 'bc-imenu-crumbs-face 'bc-imenu-leaf-face)
     'bc-dont-shorten (null more)
     'help-echo (format "mouse-1: Go places near %s" p)
     'keymap
     (let ((m (make-sparse-keymap)))
       (define-key m bc--header-line-key l)
       (define-key m bc--mode-line-key l)
       m))))

;;;###autoload
(defun breadcrumb-imenu-crumbs ()
  "Describe point inside the Imenu tree of current file."
  (when-let* ((alist (bc--ipath-alist)))
    (when (cl-some #'identity alist)
      (bc--summarize
       (cl-loop
        for (p . more) on (bc-ipath alist (point))
        collect (bc--format-ipath-node (string-trim p) more))
       (bc--length bc-imenu-max-length)
       (propertize bc-imenu-crumb-separator
                   'face 'bc-face)))))

(defun bc--summarize (crumbs cutoff separator)
  "Return a string that summarizes CRUMBS, a list of strings.
\"Summarization\" consists of truncating some CRUMBS to 1 character.
Rightmost members of CRUMBS are summarized last.  Members with a non-nil
`breadcrumb-dont-shorten' property are never truncated.  Aim for a
return string that is at most CUTOFF characters long.  Join the crumbs
with SEPARATOR."
  (let ((rcrumbs
         (cl-loop
          for available = (- cutoff used)
          for (c . more) on (reverse crumbs)
          for seplen = (if more (length separator) 0)
          for shorten-p = (unless (get-text-property 0 'bc-dont-shorten c)
                            (> (+ (length c) seplen) available))
          for toadd = (if shorten-p (substring c 0 1) c)
          sum (+ (length toadd) seplen) into used
          collect toadd)))
    (string-join (reverse rcrumbs) separator)))

(defun bc--format-project-node (p more root path)
  "Helper for `bc--project-crumbs-1'.
Formats path crumb P given optional MORE nodes.  ROOT is the
default directory of P's project.  PATH is the path of P relative
to ROOT."
  (let ((l (lambda (&rest _event)
             (interactive)
             ;; TODO: See similar TODO in `bc--format-ipath-node'.
             (find-file (file-name-directory (expand-file-name path root))))))
    (propertize p 'face
                (if more 'bc-project-crumbs-face 'bc-project-leaf-face)
                'bc-dont-shorten (null more)
                'mouse-face 'header-line-highlight
                'help-echo (format "mouse-1: Go places near %s%s" root path)
                'keymap
                (let ((m (make-sparse-keymap)))
                  (define-key m bc--header-line-key l)
                  (define-key m bc--mode-line-key l)
                  m))))

(defvar-local bc--cached-project-root nil
  ;; This is a fairly "dumb" cache, but hopefully good enough for most
  ;; cases.  A better smarter cache that could realize when certain
  ;; project things happened would live in project.el which has much
  ;; more project-smarts, but that's apparently very hard, so do it
  ;; here (github#18)
  "Cache the expensive `project-root' call.")

(defun bc--project-crumbs-1 (bfn)
  "Helper for `breadcrumb-project-crumbs'.
Given BFN, the `buffer-file-name', produce a list of
propertized crumbs."
  (cl-loop
   with project = (project-current)
   with root = (if project (or bc--cached-project-root
                               (setq bc--cached-project-root
                                     (project-root project)))
                 default-directory)
   with pname = (if project (project-name project)
                  (file-name-nondirectory (directory-file-name root)))
   with relname = (file-relative-name (or bfn default-directory)
                                      root)
   for (s . more) on (split-string relname "/")
   concat s into upto
   when more concat "/" into upto
   collect (bc--format-project-node s more root upto) into retval
   finally
   (cl-return
    (if root
        (cons (propertize pname
                          'bc-dont-shorten t
                          'face 'bc-project-base-face)
              retval)
      retval))))

;;;###autoload
(cl-defun breadcrumb-project-crumbs ()
  "Describing the current file inside project."
  (bc--summarize
   (if buffer-file-name (bc--project-crumbs-1 buffer-file-name)
     (list (propertize (buffer-name)
                       'face 'bc-project-leaf-face
                       'bc-dont-shorten t)))
   (bc--length bc-project-max-length)
   (propertize bc-project-crumb-separator
               'face 'bc-project-crumbs-face)))

(defun bc--header-line ()
  "Helper for `breadcrumb-headerline-mode'."
  (let ((x (cl-remove-if
            #'seq-empty-p (mapcar #'funcall
                                  '(bc-project-crumbs bc-imenu-crumbs)))))
    (mapconcat #'identity x (propertize " : " 'face 'bc-face))))

;;;###autoload
(define-minor-mode breadcrumb-local-mode
  "Header lines with breadcrumbs."
  :init-value nil
  (if bc-local-mode (add-to-list 'header-line-format '(:eval (bc--header-line)))
    (setq header-line-format (delete '(:eval (bc--header-line)) header-line-format))))

(defun bc--turn-on-local-mode-on-behalf-of-global-mode ()
  (unless (or (minibufferp)
              (not (buffer-file-name))
              (null (bc-project-crumbs)))
    (bc-local-mode 1)))

;;;###autoload
(define-globalized-minor-mode breadcrumb-mode bc-local-mode
  bc--turn-on-local-mode-on-behalf-of-global-mode)

(require 'pulse)
(defun bc--goto (window pos)
  "Helper for `breadcrumb-jump'."
  (with-selected-window window
    (with-current-buffer (window-buffer)
      (push-mark)
      (goto-char pos)
      (let ((pulse-delay 0.05) (pulse-flag t))
        (pulse-momentary-highlight-region (line-beginning-position) (line-end-position))))))

;;;###autoload
(defun breadcrumb-jump ()
  "Like \\[execute-extended-command] `imenu', but breadcrumb-powered."
  (interactive)
  (let (cands choice)
    (cl-labels
        ((fmt (strs)
           (mapconcat #'identity strs " > "))
         (dfs (nodes &optional ipath)
           (cl-loop
            for n in nodes
            for newpath = (cons (car n) ipath)
            for pos = (or (car (get-text-property 0 'breadcrumb-region (car n)))
                          (and (number-or-marker-p (cdr n)) (cdr n)))
            when pos do (push (cons (fmt (reverse newpath)) pos)
                              cands)
            do (dfs (cdr n) newpath))))
      (imenu--make-index-alist)
      (dfs imenu--index-alist)
      (unless cands (user-error "Sorry, no breadcrumb items to jump to"))
      (setq choice (cdr (assoc (completing-read "Index item? " cands nil t)
                               cands #'string=)))
      (push-mark)
      (bc--goto (selected-window) choice))))


;;;; Opinionated mode line
;;

;;;###autoload
(defcustom breadcrumb-opinionated-mlf
  '("%e"
    mode-line-modified
    (:eval (bc-project-crumbs))
    " "
    (:propertize " " face default)
    " "
    (:eval (bc-imenu-crumbs))
    " "
    mode-line-format-right-align
    (vc-mode vc-mode)
    "  "
    mode-line-modes
    mode-line-misc-info
    " %p%   %l:%c"
    (:eval (format-time-string "  %H:%M")))
  "A `mode-line-format' with breadcrumb project and imenu crumbs.
Replaces `mode-line-buffer-identification' with the output of
`breadcrumb-project-crumbs' and `breadcrumb-imenu-crumbs'."
  :type '(repeat sexp))

(defcustom bc-opinionated-diminished-modes
  '(yas-minor-mode eldoc-mode company-mode whitespace-mode
    which-key-mode)
  "Minor modes whose lighters are hidden by `breadcrumb-opinionated-mode'."
  :type '(repeat symbol))

(defvar bc--saved-mlf)
(defvar bc--saved-lighters nil)

(defun bc--diminish (mode)
  (when-let* ((cell (assq mode minor-mode-alist)))
    (push (cons mode (cadr cell)) bc--saved-lighters)
    (setcar (cdr cell) "")))

;;;###autoload
(define-minor-mode breadcrumb-opinionated-mode
  "Global minor mode installing an opinionated breadcrumb mode line.
On activation, saves the current `mode-line-format' default and replaces
it with `breadcrumb-opinionated-mlf'."
  :global t
  (cond
   (bc-opinionated-mode
    (unless (boundp 'bc--saved-mlf) (setq bc--saved-mlf (default-value 'mode-line-format)))
    (setq-default mode-line-format bc-opinionated-mlf)
    (mapc #'bc--diminish bc-opinionated-diminished-modes)
    (advice-add 'add-minor-mode :after
                (lambda (toggle &rest _)
                  (when (memq toggle bc-opinionated-diminished-modes)
                    (bc--diminish toggle)))
                '((name . bc--do-diminish-advice))))
   (t
    (setq-default mode-line-format bc--saved-mlf)
    (advice-remove 'add-minor-mode 'bc--do-diminish-advice)
    (dolist (saved bc--saved-lighters)
      (when-let* ((cell (assq (car saved) minor-mode-alist)))
        (setcar (cdr cell) (cdr saved))))
    (setq bc--saved-lighters nil)
    (makunbound 'bc--saved-mlf))))

(advice-add 'mode--line-format-right-align :filter-return
            (lambda (r)
              (when bc-opinionated-mode
                (propertize r 'face 'default)))
            '((name . bc-opinionated-mlf)))

(provide 'breadcrumb)
;;;###autoload (register-definition-prefixes "breadcrumb" '("breadcrumb-"))

;; Local Variables:
;; read-symbol-shorthands: (("bc-" . "breadcrumb-"))
;; autoload-compute-prefixes: nil
;; End:

;;; breadcrumb.el ends here