From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.io!.POSTED.blaine.gmane.org!not-for-mail From: Damien Cassou Newsgroups: gmane.emacs.bugs Subject: bug#58071: 28.2; [PATCH] jumprel: A tool to find/create related files Date: Sun, 25 Sep 2022 13:20:28 +0200 Message-ID: <878rm7wvib.fsf@cassou.me> Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" Injection-Info: ciao.gmane.io; posting-host="blaine.gmane.org:116.202.254.214"; logging-data="34189"; mail-complaints-to="usenet@ciao.gmane.io" To: 58071@debbugs.gnu.org Original-X-From: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane-mx.org@gnu.org Sun Sep 25 13:22:28 2022 Return-path: Envelope-to: geb-bug-gnu-emacs@m.gmane-mx.org Original-Received: from lists.gnu.org ([209.51.188.17]) by ciao.gmane.io with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.92) (envelope-from ) id 1ocPiN-0008ho-W6 for geb-bug-gnu-emacs@m.gmane-mx.org; Sun, 25 Sep 2022 13:22:28 +0200 Original-Received: from localhost ([::1]:54296 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1ocPiM-0006vM-JR for geb-bug-gnu-emacs@m.gmane-mx.org; Sun, 25 Sep 2022 07:22:26 -0400 Original-Received: from eggs.gnu.org ([2001:470:142:3::10]:39412) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1ocPhy-0006uC-Ao for bug-gnu-emacs@gnu.org; Sun, 25 Sep 2022 07:22:06 -0400 Original-Received: from debbugs.gnu.org ([209.51.188.43]:46884) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1ocPhy-0004v9-2h for bug-gnu-emacs@gnu.org; Sun, 25 Sep 2022 07:22:02 -0400 Original-Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1ocPhx-00080p-UI for bug-gnu-emacs@gnu.org; Sun, 25 Sep 2022 07:22:01 -0400 X-Loop: help-debbugs@gnu.org Resent-From: Damien Cassou Original-Sender: "Debbugs-submit" Resent-CC: bug-gnu-emacs@gnu.org Resent-Date: Sun, 25 Sep 2022 11:22:01 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: report 58071 X-GNU-PR-Package: emacs X-GNU-PR-Keywords: patch X-Debbugs-Original-To: bug-gnu-emacs@gnu.org Original-Received: via spool by submit@debbugs.gnu.org id=B.166410487730735 (code B ref -1); Sun, 25 Sep 2022 11:22:01 +0000 Original-Received: (at submit) by debbugs.gnu.org; 25 Sep 2022 11:21:17 +0000 Original-Received: from localhost ([127.0.0.1]:45962 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1ocPhC-0007zc-Ne for submit@debbugs.gnu.org; Sun, 25 Sep 2022 07:21:17 -0400 Original-Received: from lists.gnu.org ([209.51.188.17]:37808) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1ocPh7-0007zR-TX for submit@debbugs.gnu.org; Sun, 25 Sep 2022 07:21:13 -0400 Original-Received: from eggs.gnu.org ([2001:470:142:3::10]:52562) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1ocPh7-0005w7-NG for bug-gnu-emacs@gnu.org; Sun, 25 Sep 2022 07:21:09 -0400 Original-Received: from mail.choca.pics ([80.67.172.235]:42756) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1ocPh2-0004pB-Ej for bug-gnu-emacs@gnu.org; Sun, 25 Sep 2022 07:21:09 -0400 Original-Received: from localhost (localhost.localdomain [IPv6:::1]) by mail.choca.pics (Postfix) with ESMTP id 777E2181942C4 for ; Sun, 25 Sep 2022 13:20:41 +0200 (CEST) Original-Received: from mail.choca.pics ([IPv6:::1]) by localhost (mail.choca.pics [IPv6:::1]) (amavisd-new, port 10032) with ESMTP id QDnhMjspfSsl for ; Sun, 25 Sep 2022 13:20:37 +0200 (CEST) Original-Received: from localhost (localhost.localdomain [IPv6:::1]) by mail.choca.pics (Postfix) with ESMTP id BF703181942C5 for ; Sun, 25 Sep 2022 13:20:37 +0200 (CEST) X-Virus-Scanned: amavisd-new at choca.pics Original-Received: from mail.choca.pics ([IPv6:::1]) by localhost (mail.choca.pics [IPv6:::1]) (amavisd-new, port 10026) with ESMTP id w4tJ7APtMK2N for ; Sun, 25 Sep 2022 13:20:37 +0200 (CEST) Original-Received: from localhost (153.226.95.79.rev.sfr.net [79.95.226.153]) by mail.choca.pics (Postfix) with ESMTPSA id 3C0F5181942C4 for ; Sun, 25 Sep 2022 13:20:37 +0200 (CEST) Received-SPF: pass client-ip=80.67.172.235; envelope-from=damien@cassou.me; helo=mail.choca.pics X-Spam_score_int: -18 X-Spam_score: -1.9 X-Spam_bar: - X-Spam_report: (-1.9 / 5.0 requ) BAYES_00=-1.9, SPF_HELO_NONE=0.001, SPF_PASS=-0.001 autolearn=ham autolearn_force=no X-Spam_action: no action X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: bug-gnu-emacs@gnu.org List-Id: "Bug reports for GNU Emacs, the Swiss army knife of text editors" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane-mx.org@gnu.org Original-Sender: "bug-gnu-emacs" Xref: news.gmane.io gmane.emacs.bugs:243587 Archived-At: --=-=-= Content-Type: text/plain Please find attached jumprel, a tool to find/create related files. This tool has been described (and compared with `find-file.el' and `find-sibling-file') in emacs-devel's thread "Comparison of tools to search for related files". You will find a few files attached to this email: - jumprel.el: The core of the library. This is where you will find an introductory documentation. - tests/jumprel-test.el: Corresponding tests. - jumprel-recipe.el: Support for recipe-based jumpers. This makes it easy to define powerful jumpers. - tests/jumprel-recipe-test.el: Corresponding tests. - jumprel-regexp.el: A proof-of-concept way to define regexp-based jumpers. This files provides the same kind of support as `find-sibling-file' and `find-file.el'. This file is heavily based on previous work from Lars Ingebrigtsen and others. - 0001-.dir-locals.el-Configure-jumprel-jumpers.patch: A patch for Emacs' .dir-locals.el making use of jumprel for .el and .c/.h files. Because there are already 2 mechanisms to find related files in Emacs (see above-mentioned thread), I think we should only consider integrating jumprel into Emacs core if the other 2 are somewhat deprecated (find-sibling-file hasn't been part of any release yet). Even if you don't want to include this package in Emacs core, I would really welcome feedback. -- Damien Cassou "Success is the ability to go from one failure to another without losing enthusiasm." --Winston Churchill --=-=-= Content-Type: text/x-patch Content-Disposition: attachment; filename=0001-.dir-locals.el-Configure-jumprel-jumpers.patch >From f3d6b1b4614d0bc4962404527e0960924d9722e5 Mon Sep 17 00:00:00 2001 From: Damien Cassou Date: Sun, 25 Sep 2022 13:07:18 +0200 Subject: [PATCH] * .dir-locals.el: Configure jumprel-jumpers --- .dir-locals.el | 2 ++ 1 file changed, 2 insertions(+) diff --git a/.dir-locals.el b/.dir-locals.el index 84617a7980..cced69e9c2 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -9,6 +9,7 @@ (bug-reference-url-format . "https://debbugs.gnu.org/%s") (diff-add-log-use-relative-names . t))) (c-mode . ((c-file-style . "GNU") + (jumprel-jumpers . ((recipe :remove-suffix ".c" :add-suffix ".h" :filler auto-insert))) (c-noise-macro-names . ("INLINE" "ATTRIBUTE_NO_SANITIZE_UNDEFINED" "UNINIT" "CALLBACK" "ALIGN_STACK")) (electric-quote-comment . nil) (electric-quote-string . nil) @@ -26,6 +27,7 @@ (mode . bug-reference))) (diff-mode . ((mode . whitespace))) (emacs-lisp-mode . ((indent-tabs-mode . nil) + (jumprel-jumpers . ((recipe :remove-suffix ".el" :add-suffix "-tests.el" :add-directory "test" :filler auto-insert))) (electric-quote-comment . nil) (electric-quote-string . nil) (mode . bug-reference-prog))) -- 2.36.2 --=-=-= Content-Type: text/plain Content-Disposition: attachment; filename=jumprel.el ;;; 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 --=-=-= Content-Type: text/plain Content-Disposition: attachment; filename=jumprel-recipe.el ;;; jumprel-recipe.el --- Provide a recipe DSL to define jumprel jumpers -*- 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/ ;; 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: ;; The code below defines a file-creation recipe DSL to create jumprel ;; jumpers. Such a jumper should be defined as a list starting with the ;; symbol 'recipe. Here are some examples: ;; ;; (recipe :remove-suffix ".js" :add-suffix ".css") ;; ;; The jumper above will let the user jump from MyComponent.js to ;; MyComponent.css in the same directory and back from the CSS to the ;; JS file. Sometimes, a related file is in a parallel folder ;; hierarchy. This can be specified by using the :add-directory ;; keyword: ;; ;; (recipe :remove-suffix ".el" :add-suffix "-tests.el" :add-directory "test") ;; ;; This is the typical elisp code base example where test files end ;; with "-tests.el" and are located in a "test/" directory. With such ;; a jumper, the user can jump from ;; /project/src/lisp/calendar/parse-time.el to ;; /project/src/test/lisp/calendar/parse-time-tests.el and back. ;; ;; Sometimes, capitalization between a file and its related file isn't ;; similar. In this case, the :case-transformer keyword can be used: ;; ;; (recipe :remove-suffix ".js" :add-suffix "-tests.js" :case-transformer uncapitalize) ;; ;; This makes it possible for a user to jump from /project/src/Foo.js ;; to /project/src/foo-tests.js and back. ;; ;; A filler (see jumprel's main documentation) can be specified with ;; the :filler keyword: ;; ;; (recipe :remove-suffix ".js" :add-suffix ".css" :filler auto-insert) ;; ;; This will call `auto-insert' on newly created files. See jumprel's ;; main documentation for the syntax of other kinds of fillers. ;;; Code: (require 'subr-x) (require 'map) (require 'jumprel) ;;; Overrides of Public Methods (cl-defmethod jumprel-apply ((jumper (head recipe)) place) "Return a list of new places built by applying recipe JUMPER to PLACE." (append (apply #'jumprel-recipe--apply-filename-jumper place (cdr jumper)) (apply #'jumprel-recipe--unapply-filename-jumper place (cdr jumper)))) (cl-defmethod jumprel-get-filler ((jumper (head recipe))) "Return the filler of recipe JUMPER." (map-elt (cdr jumper) :filler)) ;;; Utility Functions (cl-defun jumprel-recipe--apply-filename-jumper (place &key (remove-suffix "") (add-suffix "") case-transformer add-directory &allow-other-keys) "Return places built after applying some modifications to PLACE. Modifications are applied in the order below. REMOVE-SUFFIX is a string (e.g., \".el\") that PLACE should end with and that is going to be removed from it. ADD-SUFFIX is a string (e.g., \"-tests.el\") that will be added at the end. CASE-TRANSFORMER is one of the kind of tranformers defined by `jumprel-recipe--apply-case-transformer' and is used to change the case of the filename. ADD-DIRECTORY is a string (e.g., \"test\") that is added next to directory names in PLACE." (when-let* (((jumprel-recipe--suffix-can-be-changed-p place add-suffix remove-suffix)) (path-without-suffix (substring place 0 (- (length remove-suffix)))) (path-with-suffix (concat path-without-suffix add-suffix)) (path-with-changed-case (jumprel-recipe--apply-to-filename path-with-suffix (apply-partially #'jumprel-recipe--apply-case-transformer case-transformer)))) (if add-directory (jumprel-recipe--add-directory-to-path path-with-changed-case add-directory) (list path-with-changed-case)))) (cl-defun jumprel-recipe--unapply-filename-jumper (place &key (add-suffix "") (remove-suffix "") case-transformer add-directory &allow-other-keys) "Return places built after un-applying some modifications to PLACE. The meaning of ADD-SUFFIX, REMOVE-SUFFIX, CASE-TRANSFORMER and ADD-DIRECTORY is the opposite of the one of `jumprel-recipe--apply-filename-jumper'. For example, ADD-SUFFIX should already be present in PLACE and will be removed from it." (when-let* (((jumprel-recipe--suffix-can-be-changed-p place remove-suffix add-suffix)) (path-without-suffix (substring place 0 (- (length add-suffix)))) (path-with-suffix (concat path-without-suffix remove-suffix)) (path-with-changed-case (jumprel-recipe--apply-to-filename path-with-suffix (apply-partially #'jumprel-recipe--unapply-case-transformer case-transformer)))) (if add-directory (jumprel-recipe--remove-directory-from-path path-with-changed-case add-directory) (list path-with-changed-case)))) (defun jumprel-recipe--add-directory-to-path (file add-directory) "Return the paths to files looking like FILE but with ADD-DIRECTORY inside it. The file-system is searched for existing directories but the returned paths don't have to exist." (cl-labels ((parent-directory (directory) (file-name-directory (directory-file-name directory))) (root-p (directory) (string= directory (parent-directory directory)))) (cl-loop for current-directory = (file-name-directory file) then (parent-directory current-directory) for candidate = (expand-file-name (substring file (length (expand-file-name current-directory))) (expand-file-name add-directory current-directory)) if (file-exists-p (file-name-directory candidate)) collect candidate into result if (root-p current-directory) return result))) (defun jumprel-recipe--remove-directory-from-path (file remove-directory) "Return the paths to files looking like FILE but with REMOVE-DIRECTORY removed. The file-system is searched for existing directories but the returned paths don't have to exist." (when-let* ((path-segments (split-string file "/")) (positions (jumprel-recipe--seq-positions path-segments remove-directory))) (cl-loop for position in positions for candidate = (string-join (jumprel-recipe--seq-remove-at-position path-segments position) "/") if (file-exists-p (file-name-directory candidate)) collect candidate))) (defun jumprel-recipe--apply-to-filename (path fn) "Apply FN to the filename part of PATH." (let* ((filename (file-name-nondirectory path)) (directory (file-name-directory path))) (expand-file-name (funcall fn filename) directory))) (defun jumprel-recipe--apply-case-transformer (transformer string) "Return the result of applying TRANFORMER to STRING. TRANSFORMER should be either nil, 'capitalize or 'uncapitalize. If nil, this function just returns STRING." (cl-case transformer (capitalize (concat (upcase (substring string 0 1)) (substring string 1))) (uncapitalize (concat (downcase (substring string 0 1)) (substring string 1))) (t (if transformer (user-error "Unknown transformer %s" transformer) string)))) (defun jumprel-recipe--unapply-case-transformer (transformer string) "Return the result of un-applying TRANFORMER to STRING. TRANSFORMER should be either nil, 'capitalize or 'uncapitalize. If nil, this function just returns STRING." (let ((untransformer (cl-case transformer (capitalize 'uncapitalize) (uncapitalize 'capitalize) (t transformer)))) (jumprel-recipe--apply-case-transformer untransformer string))) (defun jumprel-recipe--suffix-can-be-changed-p (path add-suffix remove-suffix) "Return nil if REMOVE-SUFFIX cannot be replaced with ADD-SUFFIX in PATH. The function also returns nil if ADD-SUFFIX is already present in PATH. This avoids adding the same suffix again. For example, the function returns nil if -tests.el is added to /project/foo-tests.el to avoid getting /project/foo-tests-tests.el as candidate." (and (string-suffix-p remove-suffix path) (or (not (string-suffix-p add-suffix path)) (string-suffix-p add-suffix remove-suffix)))) ;; NOTE: This is in Emacs 29 already under the name `seq-positions' (defun jumprel-recipe--seq-positions (seq elt &optional testfn) "Return the positions of ELT in SEQ. Equality is defined by TESTFN if non-nil or by `equal' if nil." (cl-loop for i from 0 below (length seq) if (funcall (or testfn #'equal) (nth i seq) elt) collect i)) ;; NOTE: This is in Emacs 29 already under the name `seq-remove-at-position' (defun jumprel-recipe--seq-remove-at-position (seq position) "Return a copy of SEQ where the element at POSITION got removed." (append (cl-subseq seq 0 position) (cl-subseq seq (1+ position)))) (jumprel-add-jumper-type '(cons :tag "Recipe" (const :tag "" recipe) (set :tag "Transformations" (list :inline t :tag "Remove suffix" (const :remove-suffix) string) (list :inline t :tag "Add suffix" (const :add-suffix) string) (list :inline t :tag "Case transformer" (const :case-transformer) (choice :value capitalize (const :tag "Capitalize" capitalize) (const :tag "Uncapitalize" uncapitalize))) (list :inline t :tag "Add directory" (const :add-directory) string) (list :inline t :tag "Filler" (const :filler) jumprel-filler)))) ;;;###autoload (add-hook 'jumprel-jumper-safety-functions (lambda (jumper) (when (eq (car jumper) 'recipe) 'safe))) (provide 'jumprel-recipe) ;;; jumprel-recipe.el ends here ;; LocalWords: tranformers el --=-=-= Content-Type: text/plain; charset=utf-8 Content-Disposition: attachment; filename=jumprel-regexp.el Content-Transfer-Encoding: quoted-printable ;;; jumprel-recipe.el --- Provide a recipe DSL to define jumprel jumpers -= *- lexical-binding: t; -*- ;; Copyright (C) 2022 Damien Cassou ;; Author: Damien Cassou ;; Version: 0.1.0 ;; Package-Requires: ((emacs "29.1")) ;; Created: 25 Sep 2022 ;; URL: https://www.gnu.org/software/emacs/ ;; 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: ;; NOTE The code and documentation below is heavily copy/pasted from ;; `find-sibling-rules' and `find-sibling-file' by Lars Ingebrigtsen ;; . TODO: This NOTE should probably be deleted if we ;; decide to replace `find-sibling-file' with jumprel. ;; The code below makes it possible to create jumprel jumpers from ;; regular expressions. Such a jumper should be defined as a list ;; starting with the symbol 'regexp followed by two strings MATCH and ;; EXPANSION. MATCH is a regular expression that should match a file ;; name that has a sibling. It can contain sub-expressions that will ;; be used in EXPANSION. ;; EXPANSION is a string that matches file names. For instance, to ;; define ".h" files as siblings of any ".c", you could say: ;; ;; (regexp "\\([^/]+\\)\\.c\\'" "\\1.h") ;; MATCH and EXPANSION can also be fuller paths. For instance, if ;; you want to define other versions of a project as being sibling ;; files, you could say something like: ;; ;; (regexp "src/emacs/[^/]+/\\(.*\\)\\'" "src/emacs/.*/\\1\\'") ;; In this example, if you=E2=80=99re in src/emacs/emacs-27/lisp/abbrev.el, ;; and an src/emacs/emacs-28/lisp/abbrev.el file exists, it=E2=80=99s now ;; defined as a sibling. ;; Regexp-based jumpers as defined here do not support fillers. ;;; Code: (require 'jumprel) (require 'map) ;;; Overrides of Public Methods (cl-defmethod jumprel-apply ((jumper (head regexp)) place) "Return a list of new places built by applying regexp JUMPER to PLACE." (jumprel-recipe--find-sibling-file-search place (list (list (nth 1 jumper) (nth 2 jumper))))) (cl-defmethod jumprel-get-filler ((_jumper (head regexp))) "Return nil as no filler can be associated with regexp-based jumpers." nil) ;;; Emacs 29 functions adapted (defun jumprel-recipe--find-sibling-file-search (file rules) ;; Same as `find-sibling-file-search' in Emacs 29 except that ;; ;; - `rules' is a mandatory parameter; ;; ;; - it calls `jumprel-recipe--file-expand-wildcards' instead of `file-ex= pand-wildcards'. "Return a list of FILE's \"siblings\" RULES should be a list on the form defined by `find-sibling-rules' (which see), and if nil, defaults to `find-sibling-rules'." (let ((results nil)) (pcase-dolist (`(,match . ,expansions) rules) ;; Go through the list and find matches. (when (string-match match file) (let ((match-data (match-data))) (dolist (expansion expansions) (let ((start 0)) ;; Expand \\1 forms in the expansions. (while (string-match "\\\\\\([&0-9]+\\)" expansion start) (let ((index (string-to-number (match-string 1 expansion)))) (setq start (match-end 0) expansion (replace-match (substring file (elt match-data (* index 2)) (elt match-data (1+ (* index 2)))) t t expansion))))) ;; Then see which files we have that are matching. (And ;; expand from the end of the file's match, since we might ;; be doing a relative match.) (let ((default-directory (substring file 0 (car match-data)))) ;; Keep the first matches first. (setq results (nconc results (mapcar #'expand-file-name (jumprel-recipe--file-expand-wildcards expansi= on nil t))))))))) ;; Delete the file itself (in case it matched), and remove ;; duplicates, in case we have several expansions and some match ;; the same subsets of files. (delete file (delete-dups results)))) (defun jumprel-recipe--file-expand-wildcards (pattern &optional full regexp) ;; Same as `file-expand-wildcards' in Emacs 29 "Expand (a.k.a. \"glob\") file-name wildcard pattern PATTERN. This returns a list of file names that match PATTERN. The returned list of file names is sorted in the `string<' order. PATTERN is, by default, a \"glob\"/wildcard string, e.g., \"/tmp/*.png\" or \"/*/*/foo.png\", but can also be a regular expression if the optional REGEXP parameter is non-nil. In any case, the matches are applied per sub-directory, so a match can't span a parent/sub directory, which means that a regexp bit can't contain the \"/\" character. The returned list of file names is sorted in the `string<' order. If PATTERN is written as an absolute file name, the expansions in the returned list are also absolute. If PATTERN is written as a relative file name, it is interpreted relative to the current `default-directory'. The file names returned are normally also relative to the current default directory. However, if FULL is non-nil, they are absolute." (save-match-data (let* ((nondir (file-name-nondirectory pattern)) (dirpart (file-name-directory pattern)) ;; A list of all dirs that DIRPART specifies. ;; This can be more than one dir ;; if DIRPART contains wildcards. (dirs (if (and dirpart (string-match "[[*?]" (file-local-name dirpart))) (mapcar 'file-name-as-directory (jumprel-recipe--file-expand-wildcards (directory-file-name dirpart) nil regexp)) (list dirpart))) contents) (dolist (dir dirs) (when (or (null dir) ; Possible if DIRPART is not wild. (file-accessible-directory-p dir)) (let ((this-dir-contents ;; Filter out "." and ".." (delq nil (mapcar (lambda (name) (unless (string-match "\\`\\.\\.?\\'" (file-name-nondirect= ory name)) name)) (directory-files (or dir ".") full (if regexp ;; We're matching each file name ;; element separately. (concat "\\`" nondir "\\'") (wildcard-to-regexp nondir))))))) (setq contents (nconc (if (and dir (not full)) (mapcar (lambda (name) (concat dir name)) this-dir-contents) this-dir-contents) contents))))) contents))) (jumprel-add-jumper-type '(list :tag "Regexp" (const :tag "" regexp) (regexp :tag "match") (regexp :tag "expansion") (set :tag "" (list :inline t :tag "Filler" (const :filler) jumprel-filler)))) ;;;###autoload (add-hook 'jumprel-jumper-safety-functions (lambda (jumper) (when (eq (car = jumper) 'regexp) 'safe))) (provide 'jumprel-regexp) ;;; jumprel-regexp.el ends here ;; LocalWords: tranformers el --=-=-= Content-Type: text/plain Content-Disposition: attachment; filename=jumprel-recipe-test.el ;;; jumprel-recipe-test.el --- Tests for jumprel-recipe -*- 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/ ;; 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: ;; Tests for jumprel-recipe.el. ;;; Code: (require 'jumprel-recipe) ;;; Customization Options (ert-deftest jumprel-recipe-test-jumpers-safe-values () (should (safe-local-variable-p 'jumprel-jumpers '((recipe :remove-suffix ".el" add-suffix "-tests.el"))))) ;;; Utility Functions (ert-deftest jumprel-recipe-test-apply-filename-jumper () (cl-letf (((symbol-function 'file-exists-p) (lambda (_) t))) (let* ((place "/emacs-src/lisp/Abbrev.el") (places (jumprel-recipe--apply-filename-jumper place :remove-suffix ".el" :add-suffix "-tests.el" :case-transformer 'uncapitalize :add-directory "test" :filler 'foo))) (should (seq-set-equal-p places '("/test/emacs-src/lisp/abbrev-tests.el" "/emacs-src/test/lisp/abbrev-tests.el" "/emacs-src/lisp/test/abbrev-tests.el")))))) (ert-deftest jumprel-recipe-test-unapply-filename-jumper () (cl-letf (((symbol-function 'file-exists-p) (lambda (_) t))) (let* ((place "/emacs-src/test/lisp/abbrev-tests.el") (places (jumprel-recipe--unapply-filename-jumper place :remove-suffix ".el" :add-suffix "-tests.el" :case-transformer 'uncapitalize :add-directory "test" :filler 'foo))) (should (seq-set-equal-p places '("/emacs-src/lisp/Abbrev.el")))))) (ert-deftest jumprel-recipe-test-add-directory-to-path () (cl-letf (((symbol-function 'file-exists-p) (lambda (_) t))) (let ((result (jumprel-recipe--add-directory-to-path "/emacs-src/lisp/abbrev.el" "test"))) (should (seq-set-equal-p result '("/test/emacs-src/lisp/abbrev.el" "/emacs-src/test/lisp/abbrev.el" "/emacs-src/lisp/test/abbrev.el")))))) (ert-deftest jumprel-recipe-test-add-directory-to-path-filter-non-existing-directories () "To reduce the number of candidates, the directories must already exist." (let ((existing-directory "/emacs-src/test/lisp/")) (cl-letf (((symbol-function 'file-exists-p) (apply-partially #'string= existing-directory))) (let ((result (jumprel-recipe--add-directory-to-path "/emacs-src/lisp/abbrev.el" "test"))) (should (equal result (list (concat existing-directory "abbrev.el")))))))) (ert-deftest jumprel-recipe-test-remove-directory-from-path () (cl-letf (((symbol-function 'file-exists-p) (lambda (_) t))) (let ((result (jumprel-recipe--remove-directory-from-path "/test/emacs-src/test/lisp/test/abbrev-tests.el" "test"))) (should (seq-set-equal-p result '("/emacs-src/test/lisp/test/abbrev-tests.el" "/test/emacs-src/lisp/test/abbrev-tests.el" "/test/emacs-src/test/lisp/abbrev-tests.el")))))) (ert-deftest jumprel-recipe-test-remove-directory-from-path-filter-non-existing-directories () "To reduce the number of candidates, the directories must already exist." (let ((existing-directory "/test/emacs-src/lisp/test/")) (cl-letf (((symbol-function 'file-exists-p) (apply-partially #'string= existing-directory))) (let ((result (jumprel-recipe--remove-directory-from-path "/test/emacs-src/test/lisp/test/abbrev-tests.el" "test"))) (should (equal result (list (concat existing-directory "abbrev-tests.el")))))))) (ert-deftest jumprel-recipe-test-apply-to-filename () (should (equal (jumprel-recipe--apply-to-filename "/foo/bar" #'upcase) "/foo/BAR")) (should (equal (jumprel-recipe--apply-to-filename "/foo/bar/BAZ.EL" #'downcase) "/foo/bar/baz.el"))) (ert-deftest jumprel-recipe-test-apply-case-transformer () (should (equal (jumprel-recipe--apply-case-transformer 'capitalize "foo") "Foo")) (should (equal (jumprel-recipe--apply-case-transformer 'uncapitalize "Foo") "foo")) (should (equal (jumprel-recipe--apply-case-transformer nil "foo") "foo")) (should-error (jumprel-recipe--apply-case-transformer 'unknown "foo"))) (ert-deftest jumprel-recipe-test-unapply-case-transformer () (should (equal (jumprel-recipe--unapply-case-transformer 'capitalize "Foo") "foo")) (should (equal (jumprel-recipe--unapply-case-transformer 'uncapitalize "foo") "Foo")) (should (equal (jumprel-recipe--unapply-case-transformer nil "foo") "foo")) (should-error (jumprel-recipe--unapply-case-transformer 'unknown "foo"))) (ert-deftest jumprel-recipe-test-suffix-can-be-changed-p () (should-not (jumprel-recipe--suffix-can-be-changed-p "/a/b.el" ".el" "-tests.el")) (should-not (jumprel-recipe--suffix-can-be-changed-p "/a/b-tests.el" "-tests.el" ".el")) (should (jumprel-recipe--suffix-can-be-changed-p "/a/b-tests.el" ".el" "-tests.el")) (should (jumprel-recipe--suffix-can-be-changed-p "/a/b.el" "-tests.el" ".el")) (should (jumprel-recipe--suffix-can-be-changed-p "/a/b.less" ".js" ".less"))) (ert-deftest jumprel-recipe-test-seq-positions () (should (equal '(0 3) (jumprel-recipe--seq-positions '("a" "b" "c" "a" "d") "a"))) (should (equal '() (jumprel-recipe--seq-positions '("a" "b" "c" "a" "d") "Z")))) (ert-deftest jumprel-recipe-test-seq-remove-at-position () (let ((letters '(a b c d))) (should (equal '(a b d) (jumprel-recipe--seq-remove-at-position letters 2))) (should (equal '(b c d) (jumprel-recipe--seq-remove-at-position letters 0))) (should (equal '(a b c) (jumprel-recipe--seq-remove-at-position letters 3))))) (provide 'jumprel-recipe-test) ;;; jumprel-recipe-test.el ends here --=-=-= Content-Type: text/plain Content-Disposition: attachment; filename=jumprel-test.el ;;; jumprel-test.el --- Tests for jumprel -*- 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/ ;; 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: ;; Tests for jumprel.el. ;;; Code: (require 'jumprel) (require 'ert) (require 'cl-lib) (require 'seq) ;;; Customization Options (ert-deftest jumprel-test-jumpers-safe-values () (should (safe-local-variable-p 'jumprel-jumpers nil)) (should-not (safe-local-variable-p 'jumprel-jumpers (list (lambda (place) place))))) ;;; Jumpers Public API (ert-deftest jumprel-test-apply-function-jumper () (let* ((place 'place) (jumperIdentity #'identity) (jumperConst (lambda (_) place))) (should (equal (jumprel-apply jumperIdentity "/foo/bar") "/foo/bar")) (should (equal (jumprel-apply jumperConst "/foo/bar") place)))) ;;; Functions Manipulating Places (ert-deftest jumprel-test-format-place () (cl-letf (((symbol-function 'file-exists-p) (apply-partially #'equal "/project/foo/exists.el"))) (should (equal (jumprel--format-place "/project/foo/" "/project/foo/exists.el") "exists.el")) (should (equal (jumprel--format-place "/project/bar/" "/project/foo/exists.el") "../foo/exists.el")) (should (equal (jumprel--format-place "/project/foo/" "/project/foo/non-existing.el") "non-existing.el (create it!)")))) ;;; Utility Functions (ert-deftest jumprel-test-collect-existing-places-does-not-return-current-place () (cl-letf (((symbol-function 'file-exists-p) (apply-partially #'seq-contains-p '("/bar" "/foo")))) (let* ((current-place "/bar") (new-place "/foo") (jumper1 (lambda (_) new-place))) (should (equal (jumprel--collect-existing-places (list jumper1) current-place) (list new-place)))))) (ert-deftest jumprel-test-collect-existing-places-returns-uniq-results () "If 2 jumpers produce the same place, the place should only appear once." (cl-letf (((symbol-function 'file-exists-p) (apply-partially #'seq-contains-p '("/bar" "/foo")))) (let* ((current-place "/bar") (new-place "/foo") (jumper1 (lambda (_) new-place)) (jumper2 (lambda (_) new-place))) (should (seq-set-equal-p (jumprel--collect-existing-places (list jumper1 jumper2) current-place) (list new-place)))))) (ert-deftest jumprel-test-collect-existing-places-returns-no-place-when-no-current-place () "If there is no current place, there shouldn't be any destination place." (should-not (jumprel--collect-existing-places '(jumper) nil))) (ert-deftest jumprel-test-call-jumpers () (let* ((jumperAtom (lambda (_) "/foo")) (jumperList (lambda (_) (list "/bar1" "/bar2"))) (jumperSingleton (lambda (_) (list "/baz"))) (jumperNil (lambda (_))) (jumperIdentity #'identity)) (should (seq-set-equal-p (jumprel--call-jumpers (list jumperAtom jumperList) "/") '("/foo" "/bar1" "/bar2"))) (should (seq-set-equal-p (jumprel--call-jumpers (list jumperAtom jumperSingleton) "/") '("/foo" "/baz"))) (should (seq-set-equal-p (jumprel--call-jumpers (list jumperAtom jumperNil) "/") '("/foo"))) (should (seq-set-equal-p (jumprel--call-jumpers (list jumperAtom jumperIdentity) '"/") '("/foo" "/"))) (should (seq-set-equal-p (jumprel--call-jumpers (list jumperAtom jumperList jumperSingleton jumperNil jumperIdentity) '"/") '("/foo" "/bar1" "/bar2" "/baz" "/"))))) (ert-deftest jumprel-test-test--call-jumpers-attach-jumper-to-all-places () (let* ((jumper (lambda (_) "/foo")) (place (car (jumprel--call-jumpers (list jumper) "/")))) (should (eq (get-text-property 0 :jumprel-jumper place) jumper)))) (provide 'jumprel-test) ;;; jumprel-test.el ends here --=-=-=--