diff --git a/CHANGELOG.md b/CHANGELOG.md index 5d26281e7..18fc00105 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -8,6 +8,9 @@ ### New features +- [#2148](https://github.com/bbatsov/projectile/pull/2148): Add `projectile-switch-sibling-project` (`s-p n`), which offers only the projects related to the one you're in, rather than every project on the machine. + - Relatedness comes from `projectile-project-groups` if you've configured it, then from the owner of the upstream remote, then from the leading word of the directory name - see `projectile-sibling-project-functions`. + - The remote's owner is what relates projects whose names have nothing in common; an inferred group covering more than `projectile-sibling-max-group-share` of your projects is dropped, since "we're all under the same account" relates nothing. - [#2147](https://github.com/bbatsov/projectile/pull/2147): Add `projectile-switch-worktree` (`s-p W`), which offers the other checkouts of the current project's repository, each annotated with the branch it has checked out. - Git worktrees and separate clones of the same upstream both count as checkouts, since they're the same workflow with and without the plumbing; `projectile-worktree-functions` is where other ways of finding them plug in. - [#2138](https://github.com/bbatsov/projectile/pull/2138): Better support for OCaml, Erlang and F#. diff --git a/projectile.el b/projectile.el index d86da58b3..90451b3c1 100644 --- a/projectile.el +++ b/projectile.el @@ -1132,6 +1132,12 @@ trailing slash so that membership and removal checks compare equal regardless of how the root was originally obtained." (file-name-as-directory (abbreviate-file-name root))) +(defun projectile--directory-key (path) + "Return PATH in a spelling two references to one directory always share. +Symlink-resolved and slash-terminated, so it can be compared with `equal' +or used as a hash key regardless of how each reference was spelled." + (file-truename (file-name-as-directory path))) + (projectile-define-project-cache projectile-project-type-cache "A hashmap used to cache project type to speed up related operations.") @@ -1712,6 +1718,33 @@ just return nil." ;;; Misc utility functions +(defun projectile--collect-from-functions (functions root key-function what) + "Call each of FUNCTIONS with ROOT and collect their results. + +The lists come back concatenated in the order FUNCTIONS were given, +de-duplicated by KEY-FUNCTION, so the first function to report an item +is the one whose version of it survives and the earlier functions' +findings are offered first. Items KEY-FUNCTION returns nil for are +dropped. + +A function that signals is reported and skipped rather than taking the +whole lookup down with it; WHAT names the kind of function in that +message." + (let ((seen (make-hash-table :test 'equal)) + results) + (dolist (fn functions) + (dolist (item (condition-case err + (funcall fn root) + (error + (projectile--message "%s function %s failed: %s" + what fn (error-message-string err)) + nil))) + (when-let* ((key (funcall key-function item)) + ((not (gethash key seen)))) + (puthash key t seen) + (push item results)))) + (nreverse results))) + (defun projectile-unixy-system-p () "Check to see if unixy text utilities are installed." (seq-every-p @@ -13551,10 +13584,14 @@ overwriting each other's changes." ;; scp-like and URL spellings of one remote compare equal. ;; Equal `:remote' means separate clones of one project - the ;; hand-rolled version of worktrees, and just as common. +;; :owner the account, organization or directory that upstream hangs +;; off. Equal `:owner' means nothing about the code, but it's +;; the strongest signal there is that two projects belong to +;; one effort (see `projectile-sibling-projects'). ;; -;; Both are needed: `:repo' alone would miss separate clones entirely, and -;; `:remote' alone would miss the worktrees of a repository that doesn't -;; have a remote at all. +;; The first two are both needed: `:repo' alone would miss separate clones +;; entirely, and `:remote' alone would miss the worktrees of a repository +;; that doesn't have a remote at all. (projectile-define-project-cache projectile-repo-identity-cache "Cache of `projectile-repo-identity' results keyed by project root. @@ -13606,6 +13643,17 @@ systems are not reliably case-insensitive." (replace-regexp-in-string "\\`/+" "" (match-string 2 url)))))) (t (projectile--normalize-repo-path (expand-file-name url))))))) +(defun projectile--repo-url-owner (remote) + "Return the owner of the normalized REMOTE, or nil when it has none. + +That's everything but the last segment: the account or organization a +forge hangs the repository off, or the directory a local repository sits +in. A remote with a single path segment (`host/repo') has no owner worth +the name - the host isn't one - so it gets nil rather than something that +would put every repository on that host in one group." + (when (and remote (string-match "\\`\\(.*/.+\\)/[^/]+\\'" remote)) + (match-string 1 remote))) + ;; Everything below reads git's own files rather than running git. Identity ;; is computed for every known project when looking for the other checkouts ;; of one, and a subprocess apiece would be seconds of latency on a machine @@ -13749,8 +13797,14 @@ Results are cached in `projectile-repo-identity-cache' (cleared by ;; An identity with nothing in it says as little as no identity ;; at all, and storing it as nil keeps the callers from having ;; to test both. - (unless (or (plist-get identity :repo) (plist-get identity :remote)) - (setq identity nil)) + (if (not (or (plist-get identity :repo) (plist-get identity :remote))) + (setq identity nil) + ;; The owner falls out of the remote, so derive it here rather + ;; than in every backend. + (setq identity + (plist-put identity :owner + (projectile--repo-url-owner + (plist-get identity :remote))))) (puthash root identity projectile-repo-identity-cache) identity)))))) @@ -13881,22 +13935,13 @@ both git and the known projects report is listed once - the first function to report it wins, which is why the one that knows the most about a checkout should come first. The plists that come back carry `:path', and `:branch'/`:prunable' when whoever found them knew." - (let ((root (or project-root (projectile-acquire-root))) - (seen (make-hash-table :test 'equal)) - worktrees) - (dolist (fn projectile-worktree-functions) - (dolist (worktree (condition-case err - (funcall fn root) - (error - (projectile--message "Worktree function %s failed: %s" - fn (error-message-string err)) - nil))) - (when-let* ((path (plist-get worktree :path)) - (key (file-truename path)) - ((not (gethash key seen)))) - (puthash key t seen) - (push worktree worktrees)))) - (nreverse worktrees))) + (projectile--collect-from-functions + projectile-worktree-functions + (or project-root (projectile-acquire-root)) + (lambda (worktree) + (when-let* ((path (plist-get worktree :path))) + (projectile--directory-key path))) + "Worktree")) (defun projectile--worktree-annotation (worktree) "Return the completion annotation describing WORKTREE, or nil. @@ -13945,6 +13990,245 @@ switch. With a prefix ARG invokes `projectile-dispatch' instead." :category 'projectile-worktree))) +;;; Sibling projects +;; +;; Plenty of work spans several repositories: a library and the app using +;; it, a tool and its documentation site, the handful of packages that make +;; up one project. They're separate projects and should stay that way, but +;; moving between them shouldn't mean going through every project on the +;; machine. `projectile-switch-sibling-project' offers just the ones +;; related to the project you're in. +;; +;; Which ones those are comes from `projectile-sibling-project-functions', +;; consulted in order, from the most reliable signal to the least: +;; +;; 1. Groups you configured yourself, which are always right. +;; 2. The owner of the upstream remote - the account or organization the +;; repositories hang off. This is by far the best of the inferred +;; signals: it relates projects whose names have nothing in common, +;; which no amount of looking at directory names ever will. +;; 3. The leading word of the directory name, which is all that's left +;; for a repository with no remote at all. +;; +;; Inference is a heuristic, so it's bounded: a group covering more than +;; `projectile-sibling-max-group-share' of the known projects is dropped +;; rather than offered. A group that most of your projects belong to isn't +;; telling you anything - if everything you own lives under one account, +;; "same account" doesn't relate anything to anything. + +(defcustom projectile-project-groups nil + "Named groups of projects that belong together. + +An alist mapping a group name to the list of project directories in it. +A project may appear in several groups, and the groups of every one it +belongs to are offered together by +`projectile-switch-sibling-project'. + +This is the one signal that's never guessed, so it's consulted first. +Use it for the projects that belong together for reasons nothing about +them can reveal: + + (setq projectile-project-groups + \\='((\"editor\" . (\"~/src/editor\" \"~/src/editor-docs\")) + (\"infra\" . (\"~/src/deploy\" \"~/src/terraform\")))) + +To describe a single project's siblings from its own directory, set +`projectile-project-siblings' in its `.dir-locals.el' instead." + :group 'projectile + :type '(alist :key-type (string :tag "Group") + :value-type (repeat directory)) + :package-version '(projectile . "3.4.0")) + +(defvar projectile-project-siblings nil + "Projects to treat as siblings of the current one. +A list of project directories. Use this to describe one project's +siblings from the project itself; it should be set via .dir-locals.el. +`projectile-project-groups' is the equivalent for describing whole +groups centrally.") +(put 'projectile-project-siblings 'safe-local-variable + (lambda (value) (and (listp value) (seq-every-p #'stringp value)))) + +(defcustom projectile-sibling-max-group-share 0.25 + "How much of the known projects an inferred sibling group may cover. + +A number between 0 and 1, or nil to never discard a group. Inference +that relates most of your projects to each other has found nothing: if +every repository you own lives under one account then \"same account\" +tells you nothing, and offering that group is just +`projectile-switch-project' with extra steps. Such a group is dropped +so the next signal gets its turn. + +Groups of two always survive, and the cap doesn't apply at all until +there are `projectile--sibling-cap-min-projects' known projects to take +a share of. Configured groups (`projectile-project-groups') are never +subject to this - you meant those." + :group 'projectile + :type '(choice (const :tag "Never discard a group" nil) + (number :tag "Share of known projects")) + :package-version '(projectile . "3.4.0")) + +(defcustom projectile-sibling-project-functions + '(projectile-siblings-from-groups + projectile-siblings-from-owner + projectile-siblings-from-name) + "Functions consulted by `projectile-sibling-projects'. + +Each is called with a project root and should return a list of project +directories related to it. They're consulted in order and their results +concatenated, so the most trustworthy signal should come first; a project +found by more than one is offered once, in the position the first +function to report it put it." + :group 'projectile + :type '(repeat function) + :package-version '(projectile . "3.4.0")) + +(defconst projectile--sibling-cap-min-projects 10 + "How many known projects there must be before the share cap applies. +Below this `projectile-sibling-max-group-share' is ignored: a share of a +handful of projects measures nothing, and relating three of your four +projects to each other is a fine answer.") + +(defvar projectile--sibling-project-pool nil + "The known projects a sibling lookup is choosing from. +Bound by `projectile-sibling-projects' so that every signal function +shares one walk of the known projects and one pass of the ignore +filtering, instead of each of them paying for both.") + +(defun projectile--sibling-candidate-projects () + "Return the known projects a sibling signal may draw on." + (or projectile--sibling-project-pool + (let ((projects (projectile-known-projects))) + ;; Only filter when there's ignore configuration to apply, so the + ;; common case doesn't pay for a `file-truename' per known project. + (if (or projectile-ignored-projects + projectile-ignored-project-patterns + projectile-ignored-project-function) + (seq-remove #'projectile-ignored-project-p projects) + projects)))) + +(defun projectile--siblings-by-key (root key-function) + "Return the known projects KEY-FUNCTION gives the same answer for as ROOT. + +Nil when ROOT has no key, and nil when so many projects share it that +the answer says nothing - see `projectile-sibling-max-group-share'. This +is the shape every inferred signal takes: some property of a project +root, and everything else that has it too." + (when-let* ((key (funcall key-function root))) + (let* ((projects (projectile--sibling-candidate-projects)) + (matches (seq-filter (lambda (project) + (equal key (funcall key-function project))) + projects))) + (unless (and projectile-sibling-max-group-share + ;; A share of a handful of projects isn't a measurement + ;; of anything, and the switch list is short enough not + ;; to need narrowing, so the cap only starts applying + ;; once "most of them" means something. + (>= (length projects) projectile--sibling-cap-min-projects) + (> (length matches) + (max 2 (floor (* projectile-sibling-max-group-share + (length projects)))))) + matches)))) + +(defun projectile-siblings-from-groups (root) + "Return the projects grouped with ROOT by configuration. + +That's the groups in `projectile-project-groups' that ROOT is a member +of, plus whatever `projectile-project-siblings' names. The latter is a +buffer-local setting describing the project you're in, so it's only +consulted when that's the project being asked about. + +Configured groups are never subject to +`projectile-sibling-max-group-share': however many projects you put in a +group, you meant to." + (let ((key (projectile--directory-key root))) + (append + (when-let* ((current (ignore-errors (projectile-project-root))) + ((equal key (projectile--directory-key current)))) + projectile-project-siblings) + (seq-mapcat + #'cdr + (seq-filter (lambda (group) + (seq-some (lambda (member) + (equal key (projectile--directory-key member))) + (cdr group))) + projectile-project-groups))))) + +(defun projectile-siblings-from-owner (root) + "Return the known projects whose upstream has the same owner as ROOT\\='s. + +The account or organization a repository hangs off is the strongest hint +there is that two projects are part of one effort, and the only one that +relates projects whose names have nothing in common." + (projectile--siblings-by-key + root (lambda (project) + (plist-get (projectile-repo-identity project) :owner)))) + +(defun projectile--project-leading-token (path) + "Return the first word of PATH\\='s directory name, or nil. +Single characters aren't words worth grouping on, so they're skipped." + (seq-find (lambda (token) (>= (length token) 2)) + (split-string (downcase (file-name-nondirectory + (directory-file-name path))) + "[-_. ]+" t))) + +(defun projectile-siblings-from-name (root) + "Return the known projects whose directory name starts like ROOT\\='s. + +Only the leading word counts. Matching on any shared word instead reads +far more into a name than is there - it relates every `*-mode' to every +other, and every `docs.*' site to the rest - whereas a shared first word +is nearly always a deliberate family (`rubocop', `rubocop-ast'). + +This is the signal of last resort: it's the only one left for a +repository with no remote at all, and the only one that will ever relate +two projects belonging to different owners." + (projectile--siblings-by-key root #'projectile--project-leading-token)) + +(defun projectile-sibling-projects (&optional project-root) + "Return the projects related to PROJECT-ROOT, including itself. + +Every function in `projectile-sibling-project-functions' is consulted in +turn and their results concatenated, de-duplicated by resolved path, so +the ordering runs from the most trustworthy signal to the least. The +projects come back in the spelling the other switch commands use." + (let* ((root (or project-root (projectile-acquire-root))) + ;; Walk the known projects once for all the signal functions. + (projectile--sibling-project-pool (projectile--sibling-candidate-projects))) + (mapcar #'projectile--known-project-root + (projectile--collect-from-functions + projectile-sibling-project-functions root + #'projectile--directory-key "Sibling")))) + +;;;###autoload +(defun projectile-switch-sibling-project (&optional arg) + "Switch to a project related to the current one. + +Related means grouped with it in `projectile-project-groups', or sharing +the owner of its upstream remote, or - failing both - starting with the +same word. See `projectile-sibling-project-functions'. + +Invokes the command referenced by `projectile-switch-project-action' on +switch. With a prefix ARG invokes `projectile-dispatch' instead." + (interactive "P") + (let* ((root (projectile-acquire-root)) + (siblings (seq-remove + (lambda (project) + ;; The project we're in isn't somewhere to switch to, + ;; and a configured group can name one that has since + ;; been moved away. + (or (file-equal-p project root) + (not (file-directory-p project)))) + (projectile-sibling-projects root)))) + (unless siblings + (user-error "No projects related to %s found" + (projectile-project-name root))) + (projectile-completing-read + "Switch to sibling project: " siblings + :action (lambda (project) + (projectile-switch-project-by-name project arg)) + :category 'projectile-project))) + + ;;; Project bookmarks ;; ;; Project-scoped bookmarks on top of the built-in `bookmark.el'. There's @@ -15807,6 +16091,8 @@ Magit that don't trigger `find-file-hook'." (define-key map (kbd "k") #'projectile-kill-buffers) (define-key map (kbd "l") #'projectile-find-file-in-directory) (define-key map (kbd "m") #'projectile-dispatch) + ;; projects related to this one, in other repositories + (define-key map (kbd "n") #'projectile-switch-sibling-project) (define-key map (kbd "o") #'projectile-multi-occur) (define-key map (kbd "p") #'projectile-switch-project) (define-key map (kbd "q") #'projectile-switch-open-project) @@ -16161,6 +16447,7 @@ search/replace case-sensitive, `--word' makes it match whole words, ("p" "switch project" projectile-dispatch-switch-project) ("q" "switch open project" projectile-switch-open-project) ("W" "switch worktree" projectile-switch-worktree) + ("n" "switch sibling project" projectile-switch-sibling-project) ("A" "add known project" projectile-add-known-project) ("v" "vc" projectile-vc) ("P" "dashboard" projectile-dashboard) diff --git a/test/projectile-sibling-test.el b/test/projectile-sibling-test.el new file mode 100644 index 000000000..d05e647c8 --- /dev/null +++ b/test/projectile-sibling-test.el @@ -0,0 +1,342 @@ +;;; projectile-sibling-test.el --- Tests for sibling project switching -*- lexical-binding: t -*- + +;; Copyright © 2011-2026 Bozhidar Batsov + +;; Author: Bozhidar Batsov + +;; This file is NOT part of GNU 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 `http://www.gnu.org/licenses/'. + +;;; Commentary: + +;; Tests for `projectile-switch-sibling-project' and the signals it uses +;; to decide which projects are related to one another. + +;;; Code: + +(require 'projectile-test-helpers) + +(defun projectile-sibling-test--names (paths) + "Return the directory names of PATHS, for readable expectations." + (mapcar (lambda (path) + (file-name-nondirectory (directory-file-name path))) + paths)) + + +;;; Deriving an owner from a remote + +(describe "projectile--repo-url-owner" + (it "returns the account a forge repository hangs off" + (expect (projectile--repo-url-owner "github.com/bbatsov/projectile") + :to-equal "github.com/bbatsov")) + + (it "keeps subgroups with the owner" + (expect (projectile--repo-url-owner "gitlab.com/group/sub/proj") + :to-equal "gitlab.com/group/sub")) + + (it "returns the containing directory of a local repository" + (expect (projectile--repo-url-owner "/srv/git/repo") + :to-equal "/srv/git")) + + (it "returns nil when there's no owner, only a host and a repo" + ;; Grouping on the host would relate every repository on it. + (expect (projectile--repo-url-owner "github.com/projectile") :to-be nil)) + + (it "returns nil for no remote at all" + (expect (projectile--repo-url-owner nil) :to-be nil))) + +(describe "projectile-repo-identity" + (it "carries the owner of the remote" + (projectile-test-with-sandbox + (let ((repo (projectile-test-init-git-repo + "repo" "git@github.com:bbatsov/projectile.git"))) + (expect (plist-get (projectile-repo-identity repo) :owner) + :to-equal "github.com/bbatsov")))) + + (it "leaves the owner nil when there's no remote" + (projectile-test-with-sandbox + (let ((repo (projectile-test-init-git-repo "repo"))) + (expect (plist-get (projectile-repo-identity repo) :owner) :to-be nil))))) + + +;;; Tokenizing a project's name + +(describe "projectile--project-leading-token" + (it "takes the first word, splitting on the usual separators" + (expect (projectile--project-leading-token "/src/rubocop-ast/") + :to-equal "rubocop") + (expect (projectile--project-leading-token "/src/docs.cider.mx/") + :to-equal "docs") + (expect (projectile--project-leading-token "/src/my_cool_thing/") + :to-equal "my")) + + (it "downcases the word" + (expect (projectile--project-leading-token "/src/FsUnit/") + :to-equal "fsunit")) + + (it "skips single characters, which group nothing usefully" + (expect (projectile--project-leading-token "/src/a-project/") + :to-equal "project")) + + (it "copes with a path that has no trailing slash" + (expect (projectile--project-leading-token "/src/rubocop-ast") + :to-equal "rubocop"))) + + +;;; The signals + +(describe "projectile-siblings-from-groups" + (it "returns the members of a group the project belongs to" + (let ((projectile-project-groups + '(("editor" . ("/src/editor/" "/src/editor-docs/")) + ("infra" . ("/src/deploy/" "/src/tf/"))))) + (expect (projectile-siblings-from-groups "/src/editor/") + :to-equal '("/src/editor/" "/src/editor-docs/")))) + + (it "combines every group the project belongs to" + (let ((projectile-project-groups + '(("one" . ("/src/a/" "/src/b/")) + ("two" . ("/src/a/" "/src/c/"))))) + (expect (projectile-siblings-from-groups "/src/a/") + :to-have-same-items-as '("/src/a/" "/src/b/" "/src/a/" "/src/c/")))) + + (it "matches a member however its path is spelled" + (let ((projectile-project-groups '(("g" . ("/src/a" "/src/b/"))))) + (expect (projectile-siblings-from-groups "/src/a/") + :to-equal '("/src/a" "/src/b/")))) + + (it "returns nothing for a project in no group" + (let ((projectile-project-groups '(("g" . ("/src/a/" "/src/b/"))))) + (expect (projectile-siblings-from-groups "/src/z/") :to-be nil))) + + (it "includes what the project's own dir-locals variable names" + (let ((projectile-project-groups nil) + (projectile-project-siblings '("/src/partner/"))) + (spy-on 'projectile-project-root :and-return-value "/src/here/") + (expect (projectile-siblings-from-groups "/src/here/") + :to-equal '("/src/partner/")))) + + (it "does not attribute the current project's siblings to another root" + ;; `projectile-project-siblings' is buffer-local and describes the + ;; project you're in, so asking about a different one must not pick + ;; it up. + (let ((projectile-project-groups nil) + (projectile-project-siblings '("/src/partner/"))) + (spy-on 'projectile-project-root :and-return-value "/src/here/") + (expect (projectile-siblings-from-groups "/src/elsewhere/") :to-be nil)))) + +(describe "projectile-siblings-from-owner" + (it "relates projects whose remotes share an owner" + (projectile-test-with-sandbox + (let* ((one (projectile-test-init-git-repo + "haystack" "git@github.com:clojure-emacs/haystack.git")) + (two (projectile-test-init-git-repo + "orchard" "git@github.com:clojure-emacs/orchard.git")) + (other (projectile-test-init-git-repo + "crux" "git@github.com:bbatsov/crux.git")) + (projectile-known-projects (list one two other))) + ;; The names have nothing in common - only the owner relates them. + (expect (projectile-sibling-test--names + (projectile-siblings-from-owner one)) + :to-have-same-items-as '("haystack" "orchard"))))) + + (it "returns nothing for a project with no remote" + (projectile-test-with-sandbox + (let* ((repo (projectile-test-init-git-repo "repo")) + (projectile-known-projects (list repo))) + (expect (projectile-siblings-from-owner repo) :to-be nil))))) + +(describe "projectile-siblings-from-name" + (it "relates projects whose names start with the same word" + (let ((projectile-known-projects + '("/src/rubocop/" "/src/rubocop-ast/" "/src/rubocop-rails/" + "/src/crux/"))) + (expect (projectile-sibling-test--names + (projectile-siblings-from-name "/src/rubocop/")) + :to-have-same-items-as '("rubocop" "rubocop-ast" "rubocop-rails")))) + + (it "only looks at the leading word" + ;; `helm-projectile' shares a word with `projectile' but not the first + ;; one; matching on any shared word relates far too much. + (let ((projectile-known-projects + '("/src/projectile/" "/src/helm-projectile/" "/src/crux/"))) + (expect (projectile-sibling-test--names + (projectile-siblings-from-name "/src/projectile/")) + :to-equal '("projectile")))) + + (it "does not relate everything ending in a common word" + (let ((projectile-known-projects + '("/src/clojure-mode/" "/src/fish-mode/" "/src/adoc-mode/"))) + (expect (projectile-sibling-test--names + (projectile-siblings-from-name "/src/clojure-mode/")) + :to-equal '("clojure-mode"))))) + + +;;; The share cap + +(describe "projectile--siblings-by-key" + (defun projectile-sibling-test--numbered (count) + (mapcar (lambda (i) (format "/src/p%d/" i)) (number-sequence 1 count))) + + (defun projectile-sibling-test--bucket (members) + "Return a key function putting MEMBERS in one bucket and the rest apart." + (lambda (project) (if (member project members) "shared" project))) + + (it "drops a group covering too much of the known projects" + (let ((projectile-known-projects (projectile-sibling-test--numbered 20)) + (projectile-sibling-max-group-share 0.25)) + ;; 10 of 20 is well past a quarter, so the group says nothing. + (expect (projectile--siblings-by-key + "/src/p1/" + (projectile-sibling-test--bucket + (projectile-sibling-test--numbered 10))) + :to-be nil))) + + (it "keeps a group that stays under the share" + (let ((projectile-known-projects (projectile-sibling-test--numbered 20)) + (projectile-sibling-max-group-share 0.25)) + (expect (projectile--siblings-by-key + "/src/p1/" + (projectile-sibling-test--bucket + '("/src/p1/" "/src/p2/" "/src/p3/"))) + :to-equal '("/src/p1/" "/src/p2/" "/src/p3/")))) + + (it "does not apply the cap when there are too few projects to take a share of" + ;; Three of your four projects being related is a fine answer; the cap + ;; is there for the machine with a hundred of them. + (let ((projectile-known-projects '("/src/a/" "/src/b/" "/src/c/" "/src/d/")) + (projectile-sibling-max-group-share 0.25)) + (expect (projectile--siblings-by-key + "/src/a/" + (projectile-sibling-test--bucket '("/src/a/" "/src/b/" "/src/c/"))) + :to-equal '("/src/a/" "/src/b/" "/src/c/")))) + + (it "always allows a pair, however small the configured share" + (let ((projectile-known-projects (projectile-sibling-test--numbered 20)) + (projectile-sibling-max-group-share 0.01)) + (expect (projectile--siblings-by-key + "/src/p1/" + (projectile-sibling-test--bucket '("/src/p1/" "/src/p2/"))) + :to-equal '("/src/p1/" "/src/p2/")))) + + (it "keeps every group when the cap is disabled" + (let ((projectile-known-projects (projectile-sibling-test--numbered 20)) + (projectile-sibling-max-group-share nil)) + (expect (length (projectile--siblings-by-key "/src/p1/" (lambda (_) "all"))) + :to-equal 20))) + + (it "returns nothing when the project itself has no key" + (let ((projectile-known-projects '("/src/a/" "/src/b/"))) + (expect (projectile--siblings-by-key "/src/a/" #'ignore) :to-be nil))) + + (it "leaves out ignored projects" + (let ((projectile-known-projects '("/src/a/" "/src/b/")) + (projectile-ignored-projects '("/src/b/")) + (projectile-sibling-max-group-share nil)) + (spy-on 'projectile-ignored-project-p :and-call-fake + (lambda (p) (equal p "/src/b/"))) + (expect (projectile--siblings-by-key "/src/a/" (lambda (_) "all")) + :to-equal '("/src/a/"))))) + + +;;; Putting the signals together + +(describe "projectile-sibling-projects" + (it "offers configured groups before anything inferred" + (let ((projectile-project-groups '(("g" . ("/src/aaa/" "/src/zzz/")))) + (projectile-known-projects '("/src/aaa/" "/src/aaa-two/")) + (projectile-sibling-project-functions + '(projectile-siblings-from-groups projectile-siblings-from-name))) + ;; `zzz' is unrelated by name but configured, so it comes before the + ;; project only the name signal found. + (expect (projectile-sibling-test--names + (projectile-sibling-projects "/src/aaa/")) + :to-equal '("aaa" "zzz" "aaa-two")))) + + (it "offers a project found by two signals only once" + (let ((projectile-project-groups '(("g" . ("/src/aaa/" "/src/aaa-two/")))) + (projectile-known-projects '("/src/aaa/" "/src/aaa-two/")) + (projectile-sibling-project-functions + '(projectile-siblings-from-groups projectile-siblings-from-name))) + (expect (projectile-sibling-test--names + (projectile-sibling-projects "/src/aaa/")) + :to-equal '("aaa" "aaa-two")))) + + (it "survives a sibling function that throws" + (let ((projectile-sibling-project-functions + (list (lambda (_root) (error "boom")) + (lambda (_root) '("/src/other/"))))) + (expect (projectile-sibling-projects "/src/here/") + :to-equal '("/src/other/"))))) + + +;;; Switching + +(describe "projectile-switch-sibling-project" + (it "errors when nothing is related to the current project" + (let ((projectile-sibling-project-functions nil)) + (spy-on 'projectile-acquire-root :and-return-value "/src/lonely/") + (expect (projectile-switch-sibling-project) :to-throw 'user-error))) + + (it "does not offer the project we're already in" + (projectile-test-with-sandbox + (projectile-test-with-files + ("aaa/" "aaa-two/") + (let* ((root (file-name-as-directory (expand-file-name "aaa"))) + (projectile-known-projects + (list root (file-name-as-directory (expand-file-name "aaa-two")))) + (projectile-sibling-project-functions + '(projectile-siblings-from-name)) + offered) + (spy-on 'projectile-acquire-root :and-return-value root) + (spy-on 'projectile-completing-read :and-call-fake + (lambda (_prompt choices &rest _args) (setq offered choices) nil)) + (projectile-switch-sibling-project) + (expect (projectile-sibling-test--names offered) :to-equal '("aaa-two")))))) + + (it "does not offer a configured project that isn't there any more" + (projectile-test-with-sandbox + (projectile-test-with-files + ("here/") + (let* ((root (file-name-as-directory (expand-file-name "here"))) + (projectile-project-groups + (list (cons "g" (list root "/src/moved-away/")))) + (projectile-sibling-project-functions + '(projectile-siblings-from-groups))) + (spy-on 'projectile-acquire-root :and-return-value root) + (expect (projectile-switch-sibling-project) :to-throw 'user-error))))) + + (it "switches to the chosen project" + (projectile-test-with-sandbox + (projectile-test-with-files + ("aaa/" "aaa-two/") + (let* ((root (file-name-as-directory (expand-file-name "aaa"))) + (sibling (file-name-as-directory (expand-file-name "aaa-two"))) + (projectile-known-projects (list root sibling)) + (projectile-sibling-project-functions + '(projectile-siblings-from-name))) + (spy-on 'projectile-acquire-root :and-return-value root) + (spy-on 'projectile-switch-project-by-name) + (spy-on 'projectile-completing-read :and-call-fake + (lambda (_prompt choices &rest args) + (funcall (plist-get args :action) (car choices)))) + (projectile-switch-sibling-project) + (expect (file-truename + (car (spy-calls-args-for 'projectile-switch-project-by-name 0))) + :to-equal (file-truename sibling))))))) + +(provide 'projectile-sibling-test) + +;;; projectile-sibling-test.el ends here