;;; jumprel.el --- Easily find files related to the current one -*- lexical-binding: t; -*- ;; Copyright (C) 2022 Damien Cassou ;; Author: Damien Cassou ;; Version: 0.1.0 ;; Package-Requires: ((emacs "28.2")) ;; Created: 25 Sep 2022 ;; URL: https://www.gnu.org/software/emacs/ ;; Author: Damien Cassou ;; Keywords: tools ;; 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 . ;;; Commentary: ;; Thousands times a day you want to jump from a file to its test file ;; (or to its CSS file, or to its header file, or any other related ;; file) and just as many times you want to go back to the initial ;; file. JUMPing to RELated (jumprel) files is what this package is ;; about. ;; The question is: how does a user specify that a file is related to ;; a set of other files? One way is to create a function that takes a ;; file as argument and returns a list of related filenames: ;; ;; (defun my/jumprel-jumper (file) ;; (let ((without-ext (file-name-sans-extension file))) ;; (list ;; (concat without-ext ".js") ;; (concat without-ext ".css")))) ;; ;; (setq jumprel-jumpers (list #'my/jumprel-jumper)) ;; ;; `my/jumprel-jumper' is called a 'jumper. With this setup, ;; `jumprel-jump' will let the user jump from Foo.js to Foo.css and ;; back. ;; ;; This is working good but has several limitations: ;; ;; 1. If Foo.css is not in the same directory as Foo.js or if you want ;; to include test files which end with "-tests.js", ;; `my/jumprel-jumper' has to be modified in a non-obvious way or a ;; complicated new jumper must be written and added to ;; `jumprel-jumpers'; ;; ;; 2. The function `my/jumprel-jumper' has to be shared with all Emacs ;; users working on the same project ;; So jumprel recommends another approach that is less powerful but ;; much simpler. Here is another way to define the same jumper: ;; ;; (recipe :remove-suffix ".js" :add-suffix ".css") ;; ;; This list must replace `my/jumprel-jumper' in `jumprel-jumpers'. ;; This jumper lets the user go from Foo.js to Foo.css. jumprel will ;; automatically inverse the meaning of :remove-suffix and :add-suffix ;; arguments so the user can also go from Foo.css to Foo.js with this ;; jumper. See `jumprel-recipe.el' for more powerful examples. ;; ;; This kind of jumper can easily be shared with the members of a team ;; through a .dir-locals.el file. See (info "(Emacs) Directory Variables"). ;; ;; jumprel also makes it easy to create a related file and fill it ;; with some content. If the content is always the same, a string can ;; be used to specify it: ;; ;; (recipe :remove-suffix ".js" :add-suffix ".css" :filler "Fill the CSS file") ;; (recipe :remove-suffix ".js" :add-suffix ".css" :filler "Fill the CSS file") ;; ;; This is rather limited though. Another solution is to use the ;; 'auto-insert filler: ;; ;; (recipe :remove-suffix ".el" :add-suffix "-test.el" :filler auto-insert) ;; ;; This will execute `auto-insert' in the new file. New kinds of ;; filler can easily be implemented by overriding `jumprel-fill'. For ;; example, if you are using the popular `yasnippet' package (not part ;; of Emacs), you can ;; ;; (cl-defmethod jumprel-fill ((filler (head yasnippet)) &allow-other-keys &rest) ;; (when-let* ((snippet (map-elt (cdr filler) :name))) ;; (yas-expand-snippet (yas-lookup-snippet snippet major-mode)))) ;; ;; Which means the user can now specify a yasnippet snippet in their ;; `.dir-locals.el' file: ;; ;; (recipe :remove-suffix ".js" :add-suffix ".spec.js" :filler (yasnippet :name "spec")) ;; ;; This will execute `yasnippet' in the new file with the "spec" ;; snippet. ;; If you want to add a new kind of jump, override `jumprel-apply' and ;; optionally `jumprel-get-filler', call `jumprel-add-jumper-type' and ;; add a function to `jumprel-jumper-safety-functions'. ;; ;; If you want to add a new kind of filler, override `jumprel-fill' ;; and call `jumprel-add-filler-type'. ;;; Code: (require 'subr-x) (require 'cl-lib) ;;; Customization Options (defgroup jumprel nil "Facilitate navigation between the current file and related files." :group 'tools) (define-widget 'jumprel-jumper 'lazy "A description of how two files relate to each other." :tag "Jumper" :type '(choice)) (define-widget 'jumprel-filler 'lazy "A description of how to fill a new file." :tag "Filler" :type '(choice)) ;;;###autoload (defvar jumprel-jumper-safety-functions nil "Functions checking if a given jumper is safe or not. Each function should take a jumper as argument and should return either nil, 'safe or 'unsafe. Nil must be returned if the function doesn't know if the jumper is safe. The first function returning non-nil will determine the safety of the jumper and other functions won't be executed.") ;;;###autoload (put 'jumprel-jumpers 'safe-local-variable (lambda (jumpers) (seq-every-p (lambda (jumper) (eq 'safe (run-hook-with-args-until-success 'jumprel-jumper-safety-functions jumper))) jumpers))) (defcustom jumprel-jumpers nil "List of jumpers to consider to go from the current file to related files. A jumper is basically a function taking the current place as argument (a filename) and returning a list of (existing and non-existing) places the user might want to go to from the current place. There are different ways to specify a jumper. Look at the `customize' interface of this variable for more information." :type '(repeat jumprel-jumper) :safe (lambda (jumpers) (seq-every-p (lambda (jumper) (eq 'safe (run-hook-with-args-until-success 'jumprel-jumper-safety-functions jumper))) jumpers))) ;;; Public Functions ;;;###autoload (defun jumprel-jump (&optional jumpers current-place) "Let the user choose where to go from CURRENT-PLACE by asking JUMPERS. Only existing files are presented to the user. Look at `jumprel-make' and `jumprel-jump-or-make' if you also want to be able to create new files. If JUMPERS is not provided, use `jumprel-jumpers'. If CURRENT-PLACE is not provided, use the function `buffer-file-name'. Interactively, a numeric prefix argument selects the jumper at the specified position (zero-based index) in `jumprel-jumpers'." (interactive (list (when (numberp current-prefix-arg) (list (seq-elt jumprel-jumpers current-prefix-arg))))) (jumprel--jump-or-make jumpers current-place :include-existing-places t)) ;;;###autoload (defun jumprel-make (&optional jumpers current-place) "Let the user choose where to go from CURRENT-PLACE by asking JUMPERS. Only non-existing files are presented to the user so the user can easily create them. This is useful to create a test file for the current file for example. Look at `jumprel-jump' and `jumprel-jump-or-make' if you also want to be able to jump to existing files. If JUMPERS is not provided, use `jumprel-jumpers'. If CURRENT-PLACE is not provided, use the function `buffer-file-name'. Interactively, a numeric prefix argument selects the jumper at the specified position (zero-based index) in `jumprel-jumpers'." (interactive (list (when (numberp current-prefix-arg) (list (seq-elt jumprel-jumpers current-prefix-arg))))) (jumprel--jump-or-make jumpers current-place :include-non-existing-places t)) ;;;###autoload (defun jumprel-jump-or-make (&optional jumpers current-place) "Let the user choose where to go from CURRENT-PLACE by asking JUMPERS. Both existing and non-existing files are presented to the user so the user can easily jump to existing files or create missing ones. Look at `jumprel-jump' and `jumprel-make' if you don't want to mix existing and non-existing files in the same list.. If JUMPERS is not provided, use `jumprel-jumpers'. If CURRENT-PLACE is not provided, use the function `buffer-file-name'. Interactively, a numeric prefix argument selects the jumper at the specified position (zero-based index) in `jumprel-jumpers'." (interactive (list (when (numberp current-prefix-arg) (list (seq-elt jumprel-jumpers current-prefix-arg))))) (jumprel--jump-or-make jumpers current-place :include-existing-places t :include-non-existing-places t)) ;;; Jumpers Public API (cl-defgeneric jumprel-apply (jumper place) "Apply JUMPER to PLACE and return related places or nil. PLACE is a filename and the result must be a possibly-empty list of filenames." (funcall jumper place)) (cl-defgeneric jumprel-get-filler (jumper) "Return a filler associated with JUMPER. There is no filler associated to a function-based jumper but other kinds of jumpers may be able to specify a filler.") ;;; Filler Public API (cl-defgeneric jumprel-fill (filler &allow-other-keys &rest) "Use FILLER to fill the current buffer with some content. The current buffer is empty when this function is called. Beyond the filler, this function is called with the :jumper and :place keyword arguments.") ;;; Functions Manipulating Places (defun jumprel--choose-place (places initial-place) "Let the user pick one of PLACES and return it. PLACES is a list of filenames and INITIAL-PLACE is a filename. INITIAL-PLACE is the place that was current when the user started jumprel. It is used to format each place in PLACES." (cond ((length= places 0) (user-error "No place to go to. Consider configuring `jumprel-jumpers' or using `jumprel-make'") nil) ((length= places 1) (car places)) (t (let ((initial-directory (file-name-directory initial-place))) (jumprel--completing-read "Place: " places (apply-partially #'jumprel--format-place initial-directory)))))) (defun jumprel--act-on-place (place) "Either open or create PLACE, a filename." (if (file-exists-p place) (find-file place) (jumprel--make-place place))) (defun jumprel--format-place (initial-directory place) "Return a string representing PLACE. INITIAL-DIRECTORY is used to format PLACE relatively. If PLACE doesn't exist, append \"(create it!)\" to the return value." (when-let* ((relative-name (file-relative-name place initial-directory))) (if (file-exists-p place) relative-name (format "%s (create it!)" relative-name)))) (defun jumprel--make-place (place) "Create the file at PLACE. If a jumper is attached to PLACE and if this jumper has a filler, use the filler to populate the new file with initial content." (find-file place) (when-let* ((jumper (get-text-property 0 :jumprel-jumper place)) (filler (jumprel-get-filler jumper))) (jumprel-fill filler :jumper jumper :place place))) ;;; Fillers (cl-defmethod jumprel-fill ((filler string) &allow-other-keys &rest) "Fill the current buffer with FILLER, a string." (insert filler)) (cl-defmethod jumprel-fill ((_filler (eql auto-insert)) &allow-other-keys &rest) "Fill the current buffer by calling `auto-insert'." (auto-insert)) ;;; Utility Functions (cl-defun jumprel--jump-or-make (jumpers current-place &key include-existing-places include-non-existing-places) "Let the user choose where to go from CURRENT-PLACE by asking JUMPERS. Existing files are presented to the user if INCLUDE-EXISTING-PLACES is non-nil. Non-existing files are presented to the user if INCLUDE-NON-EXISTING-PLACES is non-nil. If JUMPERS is not provided, use `jumprel-jumpers'. If CURRENT-PLACE is not provided, use the function `buffer-file-name'." (let* ((jumpers (or jumpers jumprel-jumpers)) (current-place (or current-place (buffer-file-name)))) (cond ((not jumpers) (user-error "No jumpers. Consider configuring `jumprel-jumpers'")) ((not current-place) (user-error "Jumprel only works from file-based buffers")) (t (let ((existing-places (when include-existing-places (jumprel--collect-existing-places jumpers current-place))) (non-existing-places (when include-non-existing-places (jumprel--collect-non-existing-places jumpers current-place)))) (when-let* ((place (jumprel--choose-place (append existing-places non-existing-places) current-place))) (jumprel--act-on-place place))))))) (defun jumprel--collect-existing-places (jumpers current-place) "Return a list of places that can be accessed from CURRENT-PLACE with JUMPERS. Each jumper in JUMPERS is not only called with CURRENT-PLACE as argument but also with all places generated by other jumpers, recursively. Only existing places are considered and returned. The returned value doesn't contain CURRENT-PLACE." (when current-place (let* ((places nil) (places-queue (list current-place))) (while places-queue (when-let* ((place (pop places-queue)) ((file-exists-p place)) ((not (seq-contains-p places place)))) (unless (equal place current-place) (push place places)) (let ((new-places (jumprel--call-jumpers jumpers place))) (setq places-queue (nconc places-queue new-places))))) places))) (defun jumprel--collect-non-existing-places (jumpers current-place) "Return a list of places that can be accessed from CURRENT-PLACE with JUMPERS. Only non-existing places are considered and returned. The returned value doesn't contain CURRENT-PLACE." (cl-delete-if (lambda (place) (or (equal place current-place) (file-exists-p place))) (jumprel--call-jumpers jumpers current-place))) (defun jumprel--call-jumpers (jumpers place) "Return a list of places that can be accessed from PLACE with JUMPERS." (mapcan (apply-partially #'jumprel--call-jumper place) jumpers)) (defun jumprel--call-jumper (place jumper) "Return a list of places that can be accessed from PLACE with JUMPER." (when-let* ((place-or-places (jumprel-apply jumper place)) (places (if (proper-list-p place-or-places) place-or-places (list place-or-places)))) (jumprel--attach-jumper-to-places jumper places))) (defun jumprel--attach-jumper-to-places (jumper places) "Return PLACES with JUMPER attached to each. Each item of the return value remembers it was created with JUMPER." (mapcar (lambda (place) (propertize place :jumprel-jumper jumper)) places)) (defun jumprel--completing-read (prompt entities formatter) "Display PROMPT and let the user choose one of ENTITIES in the minibuffer. Format each entity with FORMATTER before presenting it to the user." (let* ((entity-string-to-entity (make-hash-table :test 'equal :size (length entities))) (entity-strings (mapcar formatter entities))) (cl-loop for entity in entities for entity-string in entity-strings do (puthash entity-string entity entity-string-to-entity)) (when-let* ((entity-string (completing-read prompt entity-strings nil t))) (gethash entity-string entity-string-to-entity)))) (defun jumprel-add-jumper-type (customization-type) "Add CUSTOMIZATION-TYPE choice to `jumprel-jumper' widget. This function should be called when creating a new kind of jumper to add an alternative customization type to the `customize' interface of `jumprel-jumpers'. CUSTOMIZATION-TYPE describes what the new kind of jumper should look like and should contain the same kind of data as the :type argument of `defcustom'. See Info node `(elisp) Customization Types' for more information." (jumprel--add-choice-to-type 'jumprel-jumper customization-type)) (defun jumprel-add-filler-type (customization-type) "Add CUSTOMIZATION-TYPE choice to `jumprel-filler' widget. This function should be called when creating a new kind of filler to add an alternative customization type to the `customize' interface of `jumprel-jumpers'. CUSTOMIZATION-TYPE describes what the new kind of filler should look like and should contain the same kind of data as the :type argument of `defcustom'. See Info node `(elisp) Customization Types' for more information." (jumprel--add-choice-to-type 'jumprel-filler customization-type)) (defun jumprel--add-choice-to-type (widget-symbol customization-type) "Add CUSTOMIZATION-TYPE to the choice type of WIDGET-SYMBOL. CUSTOMIZATION-TYPE is only added if absent from the type alternatives." (when-let* ((widget (get widget-symbol 'widget-type)) (choice (widget-get widget :type)) ((not (seq-contains-p (cdr choice) customization-type)))) (widget-put widget :type `(,@choice ,customization-type)))) (jumprel-add-jumper-type 'function) (jumprel-add-filler-type '(string :tag "Fill with pre-defined content")) (jumprel-add-filler-type '(const :tag "Use `auto-insert'" auto-insert)) (provide 'jumprel) ;;; jumprel.el ends here ;; LocalWords: minibuffer jumprel