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: Thu, 06 Oct 2022 08:09:07 +0200 Message-ID: <87pmf51o1o.fsf@cassou.me> References: <878rm7wvib.fsf@cassou.me> <83k05qlgyw.fsf@gnu.org> 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="22809"; mail-complaints-to="usenet@ciao.gmane.io" Cc: 58071@debbugs.gnu.org To: Eli Zaretskii Original-X-From: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane-mx.org@gnu.org Thu Oct 06 08:10:31 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 1ogK5X-0005nW-ET for geb-bug-gnu-emacs@m.gmane-mx.org; Thu, 06 Oct 2022 08:10:31 +0200 Original-Received: from localhost ([::1]:34738 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1ogK5W-0005dR-18 for geb-bug-gnu-emacs@m.gmane-mx.org; Thu, 06 Oct 2022 02:10:30 -0400 Original-Received: from eggs.gnu.org ([2001:470:142:3::10]:47790) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1ogK55-0005cF-VT for bug-gnu-emacs@gnu.org; Thu, 06 Oct 2022 02:10:05 -0400 Original-Received: from debbugs.gnu.org ([209.51.188.43]:59514) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1ogK54-0001Rl-D5 for bug-gnu-emacs@gnu.org; Thu, 06 Oct 2022 02:10:03 -0400 Original-Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1ogK54-00030O-8X for bug-gnu-emacs@gnu.org; Thu, 06 Oct 2022 02:10:02 -0400 X-Loop: help-debbugs@gnu.org Resent-From: Damien Cassou Original-Sender: "Debbugs-submit" Resent-CC: bug-gnu-emacs@gnu.org Resent-Date: Thu, 06 Oct 2022 06:10:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 58071 X-GNU-PR-Package: emacs X-GNU-PR-Keywords: patch Original-Received: via spool by 58071-submit@debbugs.gnu.org id=B58071.166503656111496 (code B ref 58071); Thu, 06 Oct 2022 06:10:02 +0000 Original-Received: (at 58071) by debbugs.gnu.org; 6 Oct 2022 06:09:21 +0000 Original-Received: from localhost ([127.0.0.1]:58592 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1ogK4N-0002zJ-8y for submit@debbugs.gnu.org; Thu, 06 Oct 2022 02:09:21 -0400 Original-Received: from mail.choca.pics ([80.67.172.235]:36108) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1ogK4I-0002z8-N2 for 58071@debbugs.gnu.org; Thu, 06 Oct 2022 02:09:17 -0400 Original-Received: from localhost (localhost.localdomain [IPv6:::1]) by mail.choca.pics (Postfix) with ESMTP id 1673F18197CB7; Thu, 6 Oct 2022 08:09:13 +0200 (CEST) Original-Received: from mail.choca.pics ([IPv6:::1]) by localhost (mail.choca.pics [IPv6:::1]) (amavisd-new, port 10032) with ESMTP id jsSoYwoVMDdY; Thu, 6 Oct 2022 08:09:09 +0200 (CEST) Original-Received: from localhost (localhost.localdomain [IPv6:::1]) by mail.choca.pics (Postfix) with ESMTP id 25FF118197CB3; Thu, 6 Oct 2022 08:09:09 +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 pAorAH87bJmm; Thu, 6 Oct 2022 08:09:08 +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 52EF018195798; Thu, 6 Oct 2022 08:09:08 +0200 (CEST) In-Reply-To: <83k05qlgyw.fsf@gnu.org> 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:244598 Archived-At: --=-=-= Content-Type: text/plain Please find a new version of the files attached and my answers to your feedback below. Eli Zaretskii writes: > "jumprel" is not the best name, IMO; something like > "related-files" would be better Renamed to related-files. > what you call "recipes", i.e. descriptors of how to generate the > name of related files from a given file name, should be documented > in a single doc string Agree. Doc strings and file headers have been rewritten. The doc string of `related-files-jumpers' quickly describes all known kinds of jumpers and refer to the customization interface and the manual (to be written) for the details. I refrained from describing the full syntax of every kind of jumper in `related-files-jumpers' to keep it understandable. The customization interface of `related-file-jumpers' has received a lot of love with default values, clearer tags, documentation, and better overall presentation. > I find no documentation of how to describe alternatives -- several > alternative file names produced from a single original file name I fixed that by improving the doc strings of `related-files-jumpers', `related-files-jump', `related-files-make', `related-files-jump-or-make' and `related-files-apply'. > jumprel-recipe.el is AFAICT devoid of any recipe-related public > APIs, so I don't see how such a separation can be possible. related-files-recipe.el overrides the `related-files-apply' method. So loading this file introduces a new kind of jumper. This is the same for related-files-regexp.el. Both files are completely optional and serve as examples to implement more kinds of jumpers. > I also question the motivation: is jumprel.el really independent of > the inner workings of the recipes as implemented in > jumprel-recipe.el? I think it is and it has been designed with this in mind. As far as I know, related-files.el works perfectly with 3 kinds of jumpers whose implementation is really different: - function-based jumpers are implemented in related-files.el as a default in cl-defgeneric methods. - recipe-based jumpers are optional and implemented in related-files-recipe.el. - regexp-based jumpers are optional and implemented in related-files-regexp.el. > The interface doesn't seem to me abstract enough to justify the > separation. Would you mind explaining this part? -- Damien Cassou "Success is the ability to go from one failure to another without losing enthusiasm." --Winston Churchill --=-=-= Content-Type: text/plain Content-Disposition: attachment; filename=related-files.el ;;; related-files.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 (related-files) 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/related-files-jumper (file) ;; (let ((without-ext (file-name-sans-extension file))) ;; (list ;; (concat without-ext ".js") ;; (concat without-ext ".css")))) ;; ;; (setq related-files-jumpers (list #'my/related-files-jumper)) ;; ;; `my/related-files-jumper' is called a 'jumper. With this setup, ;; `related-files-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/related-files-jumper' has to be modified in a non-obvious way or a ;; complicated new jumper must be written and added to ;; `related-files-jumpers'; ;; ;; 2. The function `my/related-files-jumper' has to be shared with all Emacs ;; users working on the same project ;; So related-files 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/related-files-jumper' in ;; `related-files-jumpers'. This jumper lets the user go from Foo.js ;; to Foo.css. related-files 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 ;; `related-files-jumpers' and THE MANUAL (TODO) for more information. ;; ;; 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"). ;; ;; `related-files-make' 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") ;; ;; There is also an `auto-insert'-based way to fill new files and new ;; kinds of fillers can easily be implemented. See the manual for ;; more information. ;; If you want to add a new kind of jump, override `related-files-apply' and ;; optionally `related-files-get-filler', call `related-files-add-jumper-type' and ;; add a function to `related-files-jumper-safety-functions'. ;; ;; If you want to add a new kind of filler, override `related-files-fill' ;; and call `related-files-add-filler-type'. ;;; Code: (require 'subr-x) (require 'cl-lib) ;;; Customization Options (defgroup related-files nil "Facilitate navigation between the current file and related files." :group 'tools) (define-widget 'related-files-jumper 'lazy "A description of how two files relate to each other." :tag "Jumper" :type '(choice)) (define-widget 'related-files-filler 'lazy "A description of how to fill a new file." :format "%v" :type '(choice :value "")) ;;;###autoload (defvar related-files-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 'related-files-jumpers 'safe-local-variable (lambda (jumpers) (seq-every-p (lambda (jumper) (eq 'safe (run-hook-with-args-until-success 'related-files-jumper-safety-functions jumper))) jumpers))) (defcustom related-files-jumpers nil "List of jumpers to consider to go from the current file to related files. There are different kinds of jumpers: - A jumper can be a function. In this case, the function should accept the current place as argument (a filename) and should return a (possibly-empty) list of (existing and non-existing) places the user might want to go to or create from the current place. Instead of returning a list, the jumper may also just return a place. - A jumper can also be a list (regexp MATCH 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 EXPANSIONS. EXPANSION is a string that matches file names. - A jumper can also be a list (recipe [:remove-suffix REMOVE-SUFFIX] [:add-suffix ADD-SUFFIX] [:add-directory ADD-DIRECTORY] [:case-transformer TRANSFORMATION]). Such a jumper defines transformations to apply to the current file name to get related file names. A :filler keyword can also be added to the list to specify how to create a missing file. Such a jumper has the advantage that is works both ways: you can go from a file to its related files but also from any related file to the initial file and other related files. Other kinds of jumpers can be created by writing Emacs Lisp. Defining a new kind of jumper requires overriding `related-files-apply' and optionally `related-files-get-filler'. It also requires calling `related-files-add-jumper-type' and adding a function to `related-files-jumper-safety-functions'. Get more information about jumper types defined above, new jumpers and fillers through the customization interface and THE MANUAL (TODO)." :type '(repeat :tag "Jumpers" related-files-jumper) :safe (lambda (jumpers) (seq-every-p (lambda (jumper) (eq 'safe (run-hook-with-args-until-success 'related-files-jumper-safety-functions jumper))) jumpers))) ;;; Public Functions ;;;###autoload (defun related-files-jump (&optional jumpers current-place) "Let the user choose where to go from CURRENT-PLACE by asking JUMPERS. Each element of JUMPERS is asked for a list of candidates and the resulting lists are concatenated with duplicates removed. The resulting list of candidates is shown to the user so one can be selected. If the resulting list is empty, the user will get an error message with some ideas on what to configure to get candidates. If the resulting list contains only one item, this item is automatically selected. Only existing files are presented to the user. Look at `related-files-make' and `related-files-jump-or-make' if you also want to be able to create new files. If JUMPERS is not provided, use `related-files-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 `related-files-jumpers'." (interactive (list (when (numberp current-prefix-arg) (list (seq-elt related-files-jumpers current-prefix-arg))))) (related-files--jump-or-make jumpers current-place :include-existing-places t)) ;;;###autoload (defun related-files-make (&optional jumpers current-place) "Let the user choose where to go from CURRENT-PLACE by asking JUMPERS. Each element of JUMPERS is asked for a list of candidates and the resulting lists are concatenated with duplicates removed. The resulting list of candidates is shown to the user so one can be selected. If the resulting list is empty, the user will get an error message with some ideas on what to configure to get candidates. If the resulting list contains only one item, this item is automatically selected. 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 `related-files-jump' and `related-files-jump-or-make' if you also want to be able to jump to existing files. If JUMPERS is not provided, use `related-files-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 `related-files-jumpers'." (interactive (list (when (numberp current-prefix-arg) (list (seq-elt related-files-jumpers current-prefix-arg))))) (related-files--jump-or-make jumpers current-place :include-non-existing-places t)) ;;;###autoload (defun related-files-jump-or-make (&optional jumpers current-place) "Let the user choose where to go from CURRENT-PLACE by asking JUMPERS. Each element of JUMPERS is asked for a list of candidates and the resulting lists are concatenated with duplicates removed. The resulting list of candidates is shown to the user so one can be selected. If the resulting list is empty, the user will get an error message with some ideas on what to configure to get candidates. If the resulting list contains only one item, this item is automatically selected. 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 `related-files-jump' and `related-files-make' if you don't want to mix existing and non-existing files in the same list.. If JUMPERS is not provided, use `related-files-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 `related-files-jumpers'." (interactive (list (when (numberp current-prefix-arg) (list (seq-elt related-files-jumpers current-prefix-arg))))) (related-files--jump-or-make jumpers current-place :include-existing-places t :include-non-existing-places t)) ;;; Jumpers Public API (cl-defgeneric related-files-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. The default implementation allows JUMPER to be a function. The function can return either a single place or a possibly-empty list of places." (funcall jumper place)) (cl-defgeneric related-files-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 related-files-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 related-files--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 related-files. It is used to format each place in PLACES." (cond ((length= places 0) (user-error "No place to go to. Consider configuring `related-files-jumpers' or using `related-files-make'") nil) ((length= places 1) (car places)) (t (let ((initial-directory (file-name-directory initial-place))) (related-files--completing-read "Place: " places (apply-partially #'related-files--format-place initial-directory)))))) (defun related-files--act-on-place (place) "Either open or create PLACE, a filename." (if (file-exists-p place) (find-file place) (related-files--make-place place))) (defun related-files--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 related-files--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 :related-files-jumper place)) (filler (related-files-get-filler jumper))) (related-files-fill filler :jumper jumper :place place))) ;;; Fillers (cl-defmethod related-files-fill ((filler string) &allow-other-keys &rest) "Fill the current buffer with FILLER, a string." (insert filler)) (cl-defmethod related-files-fill ((_filler (eql auto-insert)) &allow-other-keys &rest) "Fill the current buffer by calling `auto-insert'." (auto-insert)) ;;; Utility Functions (cl-defun related-files--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 `related-files-jumpers'. If CURRENT-PLACE is not provided, use the function `buffer-file-name'." (let* ((jumpers (or jumpers related-files-jumpers)) (current-place (or current-place (buffer-file-name)))) (cond ((not jumpers) (user-error "No jumpers. Consider configuring `related-files-jumpers'")) ((not current-place) (user-error "Related-Files only works from file-based buffers")) (t (let ((existing-places (when include-existing-places (related-files--collect-existing-places jumpers current-place))) (non-existing-places (when include-non-existing-places (related-files--collect-non-existing-places jumpers current-place)))) (when-let* ((place (related-files--choose-place (append existing-places non-existing-places) current-place))) (related-files--act-on-place place))))))) (defun related-files--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 (related-files--call-jumpers jumpers place))) (setq places-queue (nconc places-queue new-places))))) places))) (defun related-files--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))) (related-files--call-jumpers jumpers current-place))) (defun related-files--call-jumpers (jumpers place) "Return a list of places that can be accessed from PLACE with JUMPERS." (mapcan (apply-partially #'related-files--call-jumper place) jumpers)) (defun related-files--call-jumper (place jumper) "Return a list of places that can be accessed from PLACE with JUMPER." (when-let* ((place-or-places (related-files-apply jumper place)) (places (if (proper-list-p place-or-places) place-or-places (list place-or-places)))) (related-files--attach-jumper-to-places jumper places))) (defun related-files--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 :related-files-jumper jumper)) places)) (defun related-files--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 related-files-add-jumper-type (customization-type) "Add CUSTOMIZATION-TYPE choice to `related-files-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 `related-files-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." (related-files--add-choice-to-type 'related-files-jumper customization-type)) (defun related-files-add-filler-type (customization-type) "Add CUSTOMIZATION-TYPE choice to `related-files-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 `related-files-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." (related-files--add-choice-to-type 'related-files-filler customization-type)) (defun related-files--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)))) (related-files-add-jumper-type '(function :format "%t: %v\n%h\n" :doc "Should accept a place as argument and return a list of related places.")) (related-files-add-filler-type '(string :tag "Fill with pre-defined content" :value "Replace me with a better default")) (related-files-add-filler-type '(const :tag "Use `auto-insert'" auto-insert)) (provide 'related-files) ;;; related-files.el ends here ;; LocalWords: minibuffer related-files --=-=-= Content-Type: text/plain Content-Disposition: attachment; filename=related-files-recipe.el ;;; related-files-recipe.el --- Provide a recipe DSL to define related-files 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 name recipe DSL to create related-files ;; jumpers. Such a jumper should be defined as a list starting with the ;; symbol 'recipe. ;;; Code: (require 'subr-x) (require 'map) (require 'related-files) ;;; Overrides of Public Methods (cl-defmethod related-files-apply ((jumper (head recipe)) place) "Return a list of new places built by applying recipe JUMPER to PLACE." (append (apply #'related-files-recipe--apply-filename-jumper place (cdr jumper)) (apply #'related-files-recipe--unapply-filename-jumper place (cdr jumper)))) (cl-defmethod related-files-get-filler ((jumper (head recipe))) "Return the filler of recipe JUMPER." (map-elt (cdr jumper) :filler)) ;;; Utility Functions (cl-defun related-files-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 `related-files-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* (((related-files-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 (related-files-recipe--apply-to-filename path-with-suffix (apply-partially #'related-files-recipe--apply-case-transformer case-transformer)))) (if add-directory (related-files-recipe--add-directory-to-path path-with-changed-case add-directory) (list path-with-changed-case)))) (cl-defun related-files-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 `related-files-recipe--apply-filename-jumper'. For example, ADD-SUFFIX should already be present in PLACE and will be removed from it." (when-let* (((related-files-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 (related-files-recipe--apply-to-filename path-with-suffix (apply-partially #'related-files-recipe--unapply-case-transformer case-transformer)))) (if add-directory (related-files-recipe--remove-directory-from-path path-with-changed-case add-directory) (list path-with-changed-case)))) (defun related-files-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 related-files-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 (related-files-recipe--seq-positions path-segments remove-directory))) (cl-loop for position in positions for candidate = (string-join (related-files-recipe--seq-remove-at-position path-segments position) "/") if (file-exists-p (file-name-directory candidate)) collect candidate))) (defun related-files-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 related-files-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 related-files-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)))) (related-files-recipe--apply-case-transformer untransformer string))) (defun related-files-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 related-files-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 related-files-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)))) (related-files-add-jumper-type '(cons :tag "Transformation recipe" (const :tag "" recipe) (set :tag "Transformations" (list :inline t :format "%t: %v\n%d" :tag "Remove a string from the end of the filename, e.g., \".el\"" (const :remove-suffix :tag "") (string :tag "Suffix to remove" :value ".c")) (list :inline t :format "%t: %v\n%d" :tag "Add a string at the end of the filename, e.g., \"-tests.el\"" (const :add-suffix :tag "") (string :tag "Suffix to add" :value ".h")) (list :inline t :tag "Case transformer" :format "%t: %v%h\n" :doc "Useful when a file and its related files have names with different case" (const :case-transformer :tag "") (choice :value capitalize (const :tag "Capitalize the filename" capitalize) (const :tag "Uncapitalize the filename" uncapitalize))) (list :inline t :tag "String that is added next to directory names in PLACE" :format "%t: %v\n%h\n" :doc "Useful when a related file is in a parallel file hierarchy.\nFor example, with a value of \"test\", the user could jump from\n\"/project/src/lisp/calendar/parse-time.el\" to\n\"/project/src/test/lisp/calendar/parse-time.el\" and back.\nThe directory must already exist." (const :add-directory :tag "") (string :tag "Directory name to add" :value "test")) (list :inline t :tag "Filler" :format "%t: %v\n" (const :filler :tag "") related-files-filler)))) ;;;###autoload (add-hook 'related-files-jumper-safety-functions (lambda (jumper) (when (eq (car jumper) 'recipe) 'safe))) (provide 'related-files-recipe) ;;; related-files-recipe.el ends here ;; LocalWords: tranformers el --=-=-= Content-Type: text/plain; charset=utf-8 Content-Disposition: attachment; filename=related-files-regexp.el Content-Transfer-Encoding: quoted-printable ;;; related-files-recipe.el --- Provide a recipe DSL to define related-file= s 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 related-files. ;; The code below makes it possible to create related-files 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 'related-files) (require 'map) ;;; Overrides of Public Methods (cl-defmethod related-files-apply ((jumper (head regexp)) place) "Return a list of new places built by applying regexp JUMPER to PLACE." (related-files-recipe--find-sibling-file-search place (list (cons (nth 1 jumper) (nth 2 jumper))))) (cl-defmethod related-files-get-filler ((_jumper (head regexp))) "Return nil as no filler can be associated with regexp-based jumpers." nil) ;;; Emacs 29 functions adapted (defun related-files-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 `related-files-recipe--file-expand-wildcards' instead of `f= ile-expand-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 (related-files-recipe--file-expand-wildcards e= xpansion 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 related-files-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 (related-files-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))) (related-files-add-jumper-type '(list :tag "Regexp" (const :tag "" regexp) (regexp :format "%t: %v%h" :value "\\([^/]+\\)\\.c\\'" :tag "Match" :doc "MATCH is a regular expression that should match a file name that = has a sibling.\nIt can contain sub-expressions that will be used in EXPANSI= ONS.") (repeat :tag "Expansions" (string :format "%t: %v%h" :value "\\1.h" :tag "Expansion" :doc "EXPANSION is a string that matches file names.\nIt can refer to = sub-expressions of Match using \\DIGIT.")))) ;;;###autoload (add-hook 'related-files-jumper-safety-functions (lambda (jumper) (when (eq= (car jumper) 'regexp) 'safe))) (provide 'related-files-regexp) ;;; related-files-regexp.el ends here ;; LocalWords: tranformers el --=-=-= Content-Type: text/plain Content-Disposition: attachment; filename=related-files-recipe-test.el ;;; related-files-recipe-test.el --- Tests for related-files-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 related-files-recipe.el. ;;; Code: (require 'related-files-recipe) ;;; Customization Options (ert-deftest related-files-recipe-test-jumpers-safe-values () (should (safe-local-variable-p 'related-files-jumpers '((recipe :remove-suffix ".el" add-suffix "-tests.el"))))) ;;; Utility Functions (ert-deftest related-files-recipe-test-apply-filename-jumper () (cl-letf (((symbol-function 'file-exists-p) (lambda (_) t))) (let* ((place "/emacs-src/lisp/Abbrev.el") (places (related-files-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 related-files-recipe-test-unapply-filename-jumper () (cl-letf (((symbol-function 'file-exists-p) (lambda (_) t))) (let* ((place "/emacs-src/test/lisp/abbrev-tests.el") (places (related-files-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 related-files-recipe-test-add-directory-to-path () (cl-letf (((symbol-function 'file-exists-p) (lambda (_) t))) (let ((result (related-files-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 related-files-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 (related-files-recipe--add-directory-to-path "/emacs-src/lisp/abbrev.el" "test"))) (should (equal result (list (concat existing-directory "abbrev.el")))))))) (ert-deftest related-files-recipe-test-remove-directory-from-path () (cl-letf (((symbol-function 'file-exists-p) (lambda (_) t))) (let ((result (related-files-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 related-files-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 (related-files-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 related-files-recipe-test-apply-to-filename () (should (equal (related-files-recipe--apply-to-filename "/foo/bar" #'upcase) "/foo/BAR")) (should (equal (related-files-recipe--apply-to-filename "/foo/bar/BAZ.EL" #'downcase) "/foo/bar/baz.el"))) (ert-deftest related-files-recipe-test-apply-case-transformer () (should (equal (related-files-recipe--apply-case-transformer 'capitalize "foo") "Foo")) (should (equal (related-files-recipe--apply-case-transformer 'uncapitalize "Foo") "foo")) (should (equal (related-files-recipe--apply-case-transformer nil "foo") "foo")) (should-error (related-files-recipe--apply-case-transformer 'unknown "foo"))) (ert-deftest related-files-recipe-test-unapply-case-transformer () (should (equal (related-files-recipe--unapply-case-transformer 'capitalize "Foo") "foo")) (should (equal (related-files-recipe--unapply-case-transformer 'uncapitalize "foo") "Foo")) (should (equal (related-files-recipe--unapply-case-transformer nil "foo") "foo")) (should-error (related-files-recipe--unapply-case-transformer 'unknown "foo"))) (ert-deftest related-files-recipe-test-suffix-can-be-changed-p () (should-not (related-files-recipe--suffix-can-be-changed-p "/a/b.el" ".el" "-tests.el")) (should-not (related-files-recipe--suffix-can-be-changed-p "/a/b-tests.el" "-tests.el" ".el")) (should (related-files-recipe--suffix-can-be-changed-p "/a/b-tests.el" ".el" "-tests.el")) (should (related-files-recipe--suffix-can-be-changed-p "/a/b.el" "-tests.el" ".el")) (should (related-files-recipe--suffix-can-be-changed-p "/a/b.less" ".js" ".less"))) (ert-deftest related-files-recipe-test-seq-positions () (should (equal '(0 3) (related-files-recipe--seq-positions '("a" "b" "c" "a" "d") "a"))) (should (equal '() (related-files-recipe--seq-positions '("a" "b" "c" "a" "d") "Z")))) (ert-deftest related-files-recipe-test-seq-remove-at-position () (let ((letters '(a b c d))) (should (equal '(a b d) (related-files-recipe--seq-remove-at-position letters 2))) (should (equal '(b c d) (related-files-recipe--seq-remove-at-position letters 0))) (should (equal '(a b c) (related-files-recipe--seq-remove-at-position letters 3))))) (provide 'related-files-recipe-test) ;;; related-files-recipe-test.el ends here --=-=-= Content-Type: text/plain Content-Disposition: attachment; filename=related-files-test.el ;;; related-files-test.el --- Tests for related-files -*- 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 related-files.el. ;;; Code: (require 'related-files) (require 'ert) (require 'cl-lib) (require 'seq) ;;; Customization Options (ert-deftest related-files-test-jumpers-safe-values () (should (safe-local-variable-p 'related-files-jumpers nil)) (should-not (safe-local-variable-p 'related-files-jumpers (list (lambda (place) place))))) ;;; Jumpers Public API (ert-deftest related-files-test-apply-function-jumper () (let* ((place 'place) (jumperIdentity #'identity) (jumperConst (lambda (_) place))) (should (equal (related-files-apply jumperIdentity "/foo/bar") "/foo/bar")) (should (equal (related-files-apply jumperConst "/foo/bar") place)))) ;;; Functions Manipulating Places (ert-deftest related-files-test-format-place () (cl-letf (((symbol-function 'file-exists-p) (apply-partially #'equal "/project/foo/exists.el"))) (should (equal (related-files--format-place "/project/foo/" "/project/foo/exists.el") "exists.el")) (should (equal (related-files--format-place "/project/bar/" "/project/foo/exists.el") "../foo/exists.el")) (should (equal (related-files--format-place "/project/foo/" "/project/foo/non-existing.el") "non-existing.el (create it!)")))) ;;; Utility Functions (ert-deftest related-files-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 (related-files--collect-existing-places (list jumper1) current-place) (list new-place)))))) (ert-deftest related-files-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 (related-files--collect-existing-places (list jumper1 jumper2) current-place) (list new-place)))))) (ert-deftest related-files-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 (related-files--collect-existing-places '(jumper) nil))) (ert-deftest related-files-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 (related-files--call-jumpers (list jumperAtom jumperList) "/") '("/foo" "/bar1" "/bar2"))) (should (seq-set-equal-p (related-files--call-jumpers (list jumperAtom jumperSingleton) "/") '("/foo" "/baz"))) (should (seq-set-equal-p (related-files--call-jumpers (list jumperAtom jumperNil) "/") '("/foo"))) (should (seq-set-equal-p (related-files--call-jumpers (list jumperAtom jumperIdentity) '"/") '("/foo" "/"))) (should (seq-set-equal-p (related-files--call-jumpers (list jumperAtom jumperList jumperSingleton jumperNil jumperIdentity) '"/") '("/foo" "/bar1" "/bar2" "/baz" "/"))))) (ert-deftest related-files-test-test--call-jumpers-attach-jumper-to-all-places () (let* ((jumper (lambda (_) "/foo")) (place (car (related-files--call-jumpers (list jumper) "/")))) (should (eq (get-text-property 0 :related-files-jumper place) jumper)))) (provide 'related-files-test) ;;; related-files-test.el ends here --=-=-=--