Integrated repository, worktree, git stacker, and project manager
Add integrations/{emacs,systemd}: pm Emacs package and user units
Combines the previously separate extensions/emacs add, README path
fix, and extensions/systemd add into a single integrations/* layout —
mirroring emacs-config's integrations/ convention.
integrations/emacs/ ships the pm.el package (project.el backend,
magit-style transients, 21 ERT tests).
integrations/systemd/ ships pm-repo-mgmt.{service,timer} for keeping
the canonical repo store warm.
Wired into `make check` via the existing test-emacs target.
Jordan Isaacs
(Apr 27, 2026, 6:42 AM UTC)
dcfd31b3
b3df4623
+1762
-2
+7
-2
Makefile
+7
-2
Makefile
···
1
-
.PHONY: check lint typecheck test fmt
1
+
.PHONY: check lint typecheck test test-emacs fmt
2
2
3
-
check: lint typecheck test
3
+
check: lint typecheck test test-emacs
4
4
5
5
lint:
6
6
uv run ruff check src tests
···
10
10
11
11
test:
12
12
uv run pytest
13
+
14
+
test-emacs:
15
+
cd integrations/emacs && \
16
+
emacs -Q -batch -L . -l ert -l pm-tests.el \
17
+
-f ert-run-tests-batch-and-exit
13
18
14
19
fmt:
15
20
uv run ruff format src tests
+134
integrations/emacs/README.md
+134
integrations/emacs/README.md
···
1
+
# pm.el — Emacs integration for `pm`
2
+
3
+
Drives the `pm` CLI from inside Emacs. Recognizes pm containers
4
+
(`~/.projects/<name>/`) as first-class `project.el` projects, exposes
5
+
two magit-style transients — `pm-dispatch` (global, `C-x p P`) and
6
+
`pm-project-dispatch` (current project, `C-x p .`) — and treats every
7
+
git worktree under a container as a "subproject" of that container.
8
+
9
+
## Requirements
10
+
11
+
- Emacs 28.1 or newer (built-in `transient`, `cl-defmethod`).
12
+
- `pm` on `$PATH`.
13
+
14
+
## Install
15
+
16
+
The package is shipped from this repo. Add a `use-package` block to your
17
+
Emacs config pointing at the directory:
18
+
19
+
```elisp
20
+
(use-package pm
21
+
:load-path "~/.repos/project-manager/integrations/emacs/"
22
+
:commands (pm-dispatch pm-project-dispatch pm-refresh
23
+
pm--project-finder pm-jump-parent pm-jump-sibling)
24
+
:init
25
+
(with-eval-after-load 'project
26
+
(add-hook 'project-find-functions #'pm--project-finder)
27
+
(add-to-list 'project-switch-commands
28
+
'(pm-project-dispatch "PM" ?P) t))
29
+
(global-set-key (kbd "C-x p P") #'pm-dispatch)
30
+
(global-set-key (kbd "C-x p .") #'pm-project-dispatch)
31
+
(add-hook 'after-init-hook
32
+
(lambda () (run-with-idle-timer 0.5 nil #'pm-refresh))))
33
+
```
34
+
35
+
Adjust `:load-path` if the repo lives elsewhere.
36
+
37
+
## Usage
38
+
39
+
### `C-x p P` — global pm
40
+
41
+
| Group | Key | Command |
42
+
| ------- | --- | ------------------------------------------------------- |
43
+
| Create | `c` | new project |
44
+
| | `+` | mint a pool slot |
45
+
| Inspect | `l` | list projects (tabulated) |
46
+
| | `o` | list pool |
47
+
| | `R` | list canonical repos |
48
+
| Switch | `p` | switch to a project |
49
+
| System | `g` | refresh |
50
+
| | `F` | pull all canonical repos |
51
+
| Project | `.` | enter `pm-project-dispatch` (only shown in a pm tree) |
52
+
53
+
### `C-x p .` — current pm project
54
+
55
+
Header shows `pm: <container>` (or `<container>/<alias>` from inside a
56
+
worktree). If invoked outside any pm tree, prompts for a project and
57
+
re-enters bound to it. Use a prefix arg (`C-u C-x p .`) to force a
58
+
prompt even when in a pm tree.
59
+
60
+
| Group | Key | Toggle / Command |
61
+
| --------- | ---- | ----------------------------------------- |
62
+
| Arguments | `-A` | `--all` (batch wt ops) |
63
+
| | `-n` | `--no-branch` (attach skips branch restore) |
64
+
| | `-d` | `--dry-run` (detach simulation) |
65
+
| Inspect | `s` | status |
66
+
| Worktrees | `n` | new |
67
+
| | `a` | attach |
68
+
| | `D` | detach |
69
+
| | `X` | delete worktree |
70
+
| Navigate | `p` | parent (when inside a worktree) |
71
+
| | `j` | sibling (when ≥ 1 sibling exists) |
72
+
| Danger | `K` | delete project |
73
+
| System | `g` | refresh |
74
+
| | `<` | back to global pm |
75
+
76
+
The `[Navigate]` group hides at the container level (no parent /
77
+
sibling there). After `j` lands you in a sibling worktree, use the
78
+
standard `C-x p f` for find-file — there's no dedicated find-file-in-sibling.
79
+
80
+
Suffix descriptions live-update as you toggle infix args, so e.g. with
81
+
`-A` enabled, the `D` line reads `detach (all)` and skips the
82
+
worktree prompt.
83
+
84
+
Every `pm` invocation is async; non-zero exits surface via
85
+
`display-warning` and a kept `*pm: <verb>*` buffer for inspection.
86
+
87
+
### Subproject naming
88
+
89
+
`project-name` is advised so any `vc/Git` project rooted under
90
+
`pm-projects-dir/<container>/<alias>/` (or its resolved slot path)
91
+
displays as `<container>/<alias>`. The modeline,
92
+
`consult-project-buffer`, and any other consumer of `project-name`
93
+
pick this up automatically. Containers themselves still display as
94
+
just `<container>`.
95
+
96
+
The advice uses the worktree alias from the symlink path (the name
97
+
you gave with `--wt mywt:repo`), not the underlying repo name.
98
+
99
+
### Federation
100
+
101
+
When you switch to a container (e.g. `C-x p p emacs-daemon`),
102
+
`project-find-file` enumerates files across every attached worktree,
103
+
prefixed by alias (`emacs/init.el`, `kms/cmd/main.go`, ...). Set
104
+
`pm-include-files-from-worktrees` to nil to fall back to listing only
105
+
top-level container entries.
106
+
107
+
## Configuration
108
+
109
+
| Custom | Default | Purpose |
110
+
| ----------------------------------- | --------------------------------- | ---------------------------------------- |
111
+
| `pm-executable` | `"pm"` | Resolved via `executable-find` on first use. |
112
+
| `pm-projects-dir` | `"~/.projects/"` | Container root. |
113
+
| `pm-confirm-destructive` | `t` | Prompt before destructive ops. |
114
+
| `pm-include-files-from-worktrees` | `t` | Federate `project-files` across worktrees. |
115
+
116
+
## Tests
117
+
118
+
```sh
119
+
emacs -Q -batch -L . -l ert -l pm-tests.el -f ert-run-tests-batch-and-exit
120
+
```
121
+
122
+
All tests are hermetic — `pm` is not invoked.
123
+
124
+
## Notes on `twist.nix`
125
+
126
+
A `:load-path` `use-package` is invisible to twist's package
127
+
autodetection (no MELPA recipe needed). If you want the package built
128
+
into a nix-pinned Emacs, add a recipe at `recipes/pm` pointing at the
129
+
local source path; otherwise the `:load-path` form just works.
130
+
131
+
## Stacker
132
+
133
+
Stacker commands are deliberately omitted. Run them from the shell
134
+
(`pm stacker ...`) or send a PR adding a `pm-stacker.el` module.
+101
integrations/emacs/pm-commands.el
+101
integrations/emacs/pm-commands.el
···
1
+
;;; pm-commands.el --- Low-level wrappers for pm CLI verbs -*- lexical-binding: t -*-
2
+
3
+
;;; Commentary:
4
+
5
+
;; Thin async wrappers around `pm <verb> --json'. Each function
6
+
;; takes its arguments and a callback that receives the parsed JSON.
7
+
;; The callback is invoked only on successful (exit 0) completion;
8
+
;; non-zero results surface via `pm--surface-error' from pm-process.
9
+
10
+
;;; Code:
11
+
12
+
(require 'pm-process)
13
+
14
+
(defun pm--strs (&rest parts)
15
+
"Build an argv list, dropping nil and flattening lists."
16
+
(let (out)
17
+
(dolist (p parts)
18
+
(cond
19
+
((null p) nil)
20
+
((listp p) (dolist (x p) (when x (push x out))))
21
+
(t (push p out))))
22
+
(nreverse out)))
23
+
24
+
;;;; project
25
+
26
+
(defun pm--project-ls (cb)
27
+
(pm--run-async '("project" "ls" "--json") cb))
28
+
29
+
(defun pm--project-status (name cb)
30
+
(pm--run-async (pm--strs "project" "status" name "--json") cb))
31
+
32
+
(defun pm--project-create (name spec cb)
33
+
(pm--run-async
34
+
(pm--strs "project" "create" name
35
+
(and spec (list "--wt" spec))
36
+
"--json")
37
+
cb :tag 'create))
38
+
39
+
(defun pm--project-delete (name repos cb)
40
+
(pm--run-async
41
+
(pm--strs "project" "delete" name
42
+
(and repos (list "--repos" repos))
43
+
"--json")
44
+
cb :tag 'delete))
45
+
46
+
;;;; project wt
47
+
48
+
(defun pm--wt-create (name spec cb)
49
+
(pm--run-async
50
+
(pm--strs "project" "wt" "create" name "--wt" spec "--json")
51
+
cb :tag 'wt-create))
52
+
53
+
(defun pm--wt-attach (name wts all no-branch cb)
54
+
(pm--run-async
55
+
(pm--strs "project" "wt" "attach" name
56
+
(cond (all '("--all"))
57
+
(wts (list "--wt" wts)))
58
+
(and no-branch '("--no-branch"))
59
+
"--json")
60
+
cb :tag 'wt-attach))
61
+
62
+
(defun pm--wt-detach (name wts all dry-run cb)
63
+
(pm--run-async
64
+
(pm--strs "project" "wt" "detach" name
65
+
(cond (all '("--all"))
66
+
(wts (list "--wt" wts)))
67
+
(and dry-run '("--dry-run"))
68
+
"--json")
69
+
cb :tag 'wt-detach))
70
+
71
+
(defun pm--wt-delete (name wts all cb)
72
+
(pm--run-async
73
+
(pm--strs "project" "wt" "delete" name
74
+
(cond (all '("--all"))
75
+
(wts (list "--wt" wts)))
76
+
"--json")
77
+
cb :tag 'wt-delete))
78
+
79
+
;;;; pool
80
+
81
+
(defun pm--pool-ls (repo cb)
82
+
(pm--run-async (pm--strs "pool" "ls" repo "--json") cb))
83
+
84
+
(defun pm--pool-add (repo cb)
85
+
(pm--run-async (pm--strs "pool" "add" repo "--json") cb :tag 'pool-add))
86
+
87
+
;;;; repo
88
+
89
+
(defun pm--repo-ls (offline cb)
90
+
(pm--run-async
91
+
(pm--strs "repo" "ls" (and offline '("--offline")) "--json")
92
+
cb))
93
+
94
+
(defun pm--repo-pull (repo cb)
95
+
(pm--run-async
96
+
(pm--strs "repo" "pull" (and repo (list "--repo" repo)) "--json")
97
+
cb :tag 'repo-pull))
98
+
99
+
(provide 'pm-commands)
100
+
101
+
;;; pm-commands.el ends here
+125
integrations/emacs/pm-process.el
+125
integrations/emacs/pm-process.el
···
1
+
;;; pm-process.el --- Async runner for pm CLI -*- lexical-binding: t -*-
2
+
3
+
;;; Commentary:
4
+
5
+
;; Async invocation of the `pm' CLI with --json output. All shellouts
6
+
;; go through `pm--run-async'; success delivers a parsed alist to the
7
+
;; caller, failure surfaces stderr via `display-warning' and a kept
8
+
;; buffer. An in-flight registry serializes mutating ops so transient
9
+
;; suffixes can disable themselves while a call is pending.
10
+
11
+
;;; Code:
12
+
13
+
(require 'cl-lib)
14
+
(require 'subr-x)
15
+
16
+
(defvar pm-executable)
17
+
18
+
(defvar pm--executable-cache nil
19
+
"Cached resolved path to the `pm' binary.")
20
+
21
+
(defvar pm--inflight nil
22
+
"Alist of (TAG . PROCESS) for pm calls in flight.
23
+
TAG is a symbol like `create' or `delete'; predicates use it to
24
+
gate transient suffixes during mutating ops.")
25
+
26
+
(defun pm--executable ()
27
+
"Return the absolute path to the `pm' binary, resolving lazily."
28
+
(or pm--executable-cache
29
+
(setq pm--executable-cache
30
+
(or (executable-find pm-executable)
31
+
(user-error "pm: executable %S not found on exec-path"
32
+
pm-executable)))))
33
+
34
+
(defun pm--verb-tag (args)
35
+
"Build a short tag like `project-status' from ARGS for buffer naming."
36
+
(mapconcat #'identity (seq-take args 2) "-"))
37
+
38
+
(defun pm--out-buffer (verb)
39
+
"Return (or create) the stdout buffer for VERB."
40
+
(get-buffer-create (format " *pm-out: %s*" verb)))
41
+
42
+
(defun pm--err-buffer (verb)
43
+
"Return (or create) the stderr buffer for VERB."
44
+
(get-buffer-create (format "*pm: %s*" verb)))
45
+
46
+
(defun pm--surface-error (verb err-buf exit-code)
47
+
"Surface a non-zero pm result for VERB from ERR-BUF with EXIT-CODE."
48
+
(let ((summary (with-current-buffer err-buf
49
+
(goto-char (point-min))
50
+
(if (re-search-forward "^pm: \\(.*\\)$" nil t)
51
+
(match-string 1)
52
+
(string-trim
53
+
(buffer-substring-no-properties
54
+
(point-min) (min (point-max) 200)))))))
55
+
(display-warning
56
+
'pm
57
+
(format "[%s] exit %d: %s" verb exit-code
58
+
(if (string-empty-p summary) "<no stderr>" summary))
59
+
:warning)))
60
+
61
+
(defun pm--parse-json (out-buf)
62
+
"Parse JSON in OUT-BUF. Returns a Lisp value or nil on empty input."
63
+
(with-current-buffer out-buf
64
+
(goto-char (point-min))
65
+
(when (re-search-forward "[^[:space:]]" nil t)
66
+
(goto-char (point-min))
67
+
(json-parse-buffer :object-type 'alist
68
+
:array-type 'list
69
+
:null-object nil
70
+
:false-object nil))))
71
+
72
+
(cl-defun pm--run-async (args on-success
73
+
&key on-error tag input)
74
+
"Invoke `pm' with ARGS asynchronously, calling ON-SUCCESS with parsed JSON.
75
+
76
+
ARGS is a list of strings (do not include the executable). On exit 0,
77
+
ON-SUCCESS is called with the parsed JSON value (alist / list / nil).
78
+
On non-zero, ON-ERROR is called with (verb err-buffer exit-code) — or
79
+
`pm--surface-error' if ON-ERROR is omitted.
80
+
81
+
:TAG, when provided, registers the process in `pm--inflight' under that
82
+
symbol while running; predicates can use `pm--inflight-p' to gate UI.
83
+
:INPUT is an optional string written to the process's stdin."
84
+
(let* ((bin (pm--executable))
85
+
(verb (pm--verb-tag args))
86
+
(out-buf (pm--out-buffer verb))
87
+
(err-buf (pm--err-buffer verb)))
88
+
(with-current-buffer out-buf (erase-buffer))
89
+
(with-current-buffer err-buf (erase-buffer))
90
+
(let* ((proc
91
+
(make-process
92
+
:name (format "pm-%s" verb)
93
+
:buffer out-buf
94
+
:stderr err-buf
95
+
:command (cons bin args)
96
+
:noquery t
97
+
:sentinel
98
+
(lambda (proc _event)
99
+
(when (memq (process-status proc) '(exit signal))
100
+
(when tag
101
+
(setq pm--inflight (assq-delete-all tag pm--inflight)))
102
+
(let ((code (process-exit-status proc)))
103
+
(if (zerop code)
104
+
(condition-case err
105
+
(funcall on-success (pm--parse-json out-buf))
106
+
(error
107
+
(display-warning
108
+
'pm (format "[%s] callback error: %S" verb err)
109
+
:error)))
110
+
(funcall (or on-error #'pm--surface-error)
111
+
verb err-buf code))))))))
112
+
(when tag
113
+
(push (cons tag proc) pm--inflight))
114
+
(when input
115
+
(process-send-string proc input)
116
+
(process-send-eof proc))
117
+
proc)))
118
+
119
+
(defun pm--inflight-p (tag)
120
+
"Return non-nil if a call tagged TAG is currently in flight."
121
+
(and (assq tag pm--inflight) t))
122
+
123
+
(provide 'pm-process)
124
+
125
+
;;; pm-process.el ends here
+262
integrations/emacs/pm-project.el
+262
integrations/emacs/pm-project.el
···
1
+
;;; pm-project.el --- project.el integration for pm -*- lexical-binding: t -*-
2
+
3
+
;;; Commentary:
4
+
5
+
;; A `project.el' backend (`'pm') that recognizes pm containers (dirs
6
+
;; with `.pm.db' under `pm-projects-dir') as projects. The backend
7
+
;; federates `project-files' across attached worktrees so
8
+
;; `project-find-file' from the container sees the entire working set.
9
+
;; A `:around' advice on `project-name' renders worktree buffers as
10
+
;; `<container>/<wt-alias>' so the parent is visible everywhere a
11
+
;; project name is shown (modeline, consult-project-buffer, etc.).
12
+
;; Helpers and interactive commands implement parent/sibling
13
+
;; navigation between subprojects of the same pm container.
14
+
15
+
;;; Code:
16
+
17
+
(require 'cl-lib)
18
+
(require 'subr-x)
19
+
(require 'project)
20
+
(require 'pm-process)
21
+
(require 'pm-commands)
22
+
23
+
(defvar pm-projects-dir)
24
+
(defvar pm-include-files-from-worktrees)
25
+
26
+
(defvar pm--known-projects nil
27
+
"Alist (CONTAINER . PLIST) of pm projects known to Emacs.
28
+
PLIST has at least :worktrees, a list of alists straight from
29
+
`pm project ls --json' rows. Populated by `pm-refresh'.")
30
+
31
+
(defvar pm--slot-to-display nil
32
+
"Alist (RESOLVED-SLOT-PATH . \"container/alias\") for advice lookup.
33
+
Filled at refresh time so `project-name' advice can attribute
34
+
buffers visited via the resolved (truename) worktree path.")
35
+
36
+
;;;; Path utilities
37
+
38
+
(defun pm--projects-root ()
39
+
(file-name-as-directory (expand-file-name pm-projects-dir)))
40
+
41
+
(defun pm--under-projects-p (path)
42
+
(string-prefix-p (pm--projects-root)
43
+
(file-name-as-directory (expand-file-name path))))
44
+
45
+
(defun pm--container-of (path)
46
+
"Return the pm container directory containing PATH, or nil."
47
+
(let* ((expanded (file-name-as-directory
48
+
(expand-file-name (or path default-directory))))
49
+
(root (pm--projects-root)))
50
+
(when (string-prefix-p root expanded)
51
+
(let* ((rel (substring expanded (length root)))
52
+
(name (car (split-string rel "/" t))))
53
+
(when (and name
54
+
(file-exists-p
55
+
(expand-file-name (concat name "/.pm.db") root)))
56
+
(file-name-as-directory (expand-file-name name root)))))))
57
+
58
+
(defun pm--worktree-alias-of (path)
59
+
"Return the worktree alias for PATH if under a container, else nil."
60
+
(let* ((expanded (file-name-as-directory
61
+
(expand-file-name (or path default-directory))))
62
+
(root (pm--projects-root)))
63
+
(when (string-prefix-p root expanded)
64
+
(let* ((rel (substring expanded (length root)))
65
+
(parts (split-string rel "/" t)))
66
+
(when (>= (length parts) 2)
67
+
(cadr parts))))))
68
+
69
+
(defun pm--worktree-aliases-in (container)
70
+
"Return symlink names directly under CONTAINER (worktree aliases)."
71
+
(let (aliases)
72
+
(when (file-directory-p container)
73
+
(dolist (entry (directory-files container nil "^[^.]" t))
74
+
(let ((path (expand-file-name entry container)))
75
+
(when (file-symlink-p path)
76
+
(push entry aliases)))))
77
+
(nreverse aliases)))
78
+
79
+
(defun pm--siblings-of (container current-alias)
80
+
"Worktree aliases in CONTAINER excluding CURRENT-ALIAS."
81
+
(let ((cached (plist-get (cdr (assoc container pm--known-projects))
82
+
:worktrees)))
83
+
(cl-remove current-alias
84
+
(if cached
85
+
(mapcar (lambda (row) (alist-get 'wt row)) cached)
86
+
(pm--worktree-aliases-in container))
87
+
:test #'equal)))
88
+
89
+
;;;; project.el backend
90
+
91
+
;;;###autoload
92
+
(defun pm--project-finder (dir)
93
+
"Recognize DIR as a pm container if it holds a `.pm.db'.
94
+
95
+
Only claims when DIR is the container directory itself; deeper
96
+
paths (inside a worktree symlink) are left to `project-try-vc' so
97
+
git remains the project authority for files inside a worktree."
98
+
(let* ((expanded (file-name-as-directory (expand-file-name dir))))
99
+
(when (and (pm--under-projects-p expanded)
100
+
(file-exists-p (expand-file-name ".pm.db" expanded)))
101
+
(cons 'pm expanded))))
102
+
103
+
(cl-defmethod project-root ((project (head pm)))
104
+
(cdr project))
105
+
106
+
(cl-defmethod project-name ((project (head pm)))
107
+
(file-name-nondirectory (directory-file-name (cdr project))))
108
+
109
+
(cl-defmethod project-files ((project (head pm)) &optional dirs)
110
+
(ignore dirs)
111
+
(let ((root (cdr project)))
112
+
(if (not pm-include-files-from-worktrees)
113
+
(cl-remove-if
114
+
(lambda (f) (string-suffix-p "/.pm.db" f))
115
+
(directory-files root t "^[^.]" t))
116
+
(let (out)
117
+
(dolist (alias (pm--worktree-aliases-in root))
118
+
(let* ((symlink (expand-file-name alias root))
119
+
(target (ignore-errors (file-truename symlink))))
120
+
(when (and target (file-directory-p target))
121
+
(let ((sub-proj (project-current nil target)))
122
+
(when sub-proj
123
+
(let ((sub-files (ignore-errors (project-files sub-proj))))
124
+
(dolist (f sub-files)
125
+
(push (concat (file-name-as-directory symlink)
126
+
(file-relative-name f target))
127
+
out))))))))
128
+
(nreverse out)))))
129
+
130
+
;;;; project-name advice (Pattern 3)
131
+
132
+
(defun pm--display-name-from-root (root)
133
+
"Return `<container>/<alias>' if ROOT is a worktree, else nil.
134
+
135
+
ROOT may be the symlink path under `pm-projects-dir' or the
136
+
resolved slot path. Container roots (parent of an alias) return
137
+
nil so the bare container name from `project-name' is preserved.
138
+
Falls back to the slot-path cache when ROOT looks like
139
+
`<projects-dir>/<x>/...' but `<x>' has no `.pm.db' (e.g. when the
140
+
worktree pool itself happens to be nested under `pm-projects-dir')."
141
+
(let* ((expanded (file-name-as-directory (expand-file-name root)))
142
+
(projects-root (pm--projects-root))
143
+
(cached (cdr (assoc expanded pm--slot-to-display))))
144
+
(or
145
+
(and (string-prefix-p projects-root expanded)
146
+
(let* ((rel (substring expanded (length projects-root)))
147
+
(parts (split-string rel "/" t)))
148
+
(and (>= (length parts) 2)
149
+
(file-exists-p
150
+
(expand-file-name (concat (car parts) "/.pm.db")
151
+
projects-root))
152
+
(concat (car parts) "/" (cadr parts)))))
153
+
cached)))
154
+
155
+
(defun pm--name-advice (orig project)
156
+
"Render worktree projects as `<container>/<alias>'."
157
+
(or (and project
158
+
(not (eq (car-safe project) 'pm))
159
+
(let ((root (ignore-errors (project-root project))))
160
+
(and root (pm--display-name-from-root root))))
161
+
(funcall orig project)))
162
+
163
+
(unless (advice-member-p #'pm--name-advice 'project-name)
164
+
(advice-add 'project-name :around #'pm--name-advice))
165
+
166
+
;;;; Refresh / reconcile
167
+
168
+
(defun pm--register-container (container)
169
+
"Add CONTAINER to `project--list' as a pm project."
170
+
(project-remember-project (cons 'pm container)))
171
+
172
+
(defun pm--forget-container (container)
173
+
"Drop CONTAINER from `project--list' and the cache."
174
+
(project-forget-project container)
175
+
(setq pm--known-projects
176
+
(assoc-delete-all container pm--known-projects)))
177
+
178
+
(defun pm--reconcile (rows)
179
+
"Reconcile cache + `project--list' against ROWS from `pm project ls'."
180
+
(let (new-known new-slot containers)
181
+
(dolist (row rows)
182
+
(let* ((name (alist-get 'project row))
183
+
(worktrees (alist-get 'worktrees row))
184
+
(container (file-name-as-directory
185
+
(expand-file-name name pm-projects-dir))))
186
+
(push container containers)
187
+
(push (cons container (list :worktrees worktrees)) new-known)
188
+
(dolist (wt worktrees)
189
+
(let* ((alias (alist-get 'wt wt))
190
+
(symlink (expand-file-name alias container))
191
+
(target (and (file-symlink-p symlink)
192
+
(ignore-errors (file-truename symlink)))))
193
+
(when (and target (file-directory-p target))
194
+
(push (cons (file-name-as-directory target)
195
+
(concat name "/" alias))
196
+
new-slot))))))
197
+
(setq pm--known-projects (nreverse new-known))
198
+
(setq pm--slot-to-display (nreverse new-slot))
199
+
(dolist (c containers)
200
+
(pm--register-container c))
201
+
(when (and (boundp 'project--list) (listp project--list))
202
+
(let ((live (mapcar #'identity containers))
203
+
(root (pm--projects-root)))
204
+
(dolist (entry (copy-sequence project--list))
205
+
(let ((path (and (consp entry) (car entry))))
206
+
(when (and (stringp path)
207
+
(string-prefix-p root path)
208
+
(not (member path live)))
209
+
(project-forget-project path))))))
210
+
(when (fboundp 'project--write-project-list)
211
+
(project--write-project-list))
212
+
containers))
213
+
214
+
;;;###autoload
215
+
(defun pm-refresh (&optional callback)
216
+
"Re-sync pm projects with `project.el's known list.
217
+
218
+
Runs `pm project ls --json' asynchronously; on success reconciles
219
+
`project--list' and the local cache. CALLBACK, if given, is
220
+
called with the list of container paths after reconciliation."
221
+
(interactive)
222
+
(pm--project-ls
223
+
(lambda (rows)
224
+
(let ((containers (pm--reconcile rows)))
225
+
(when callback (funcall callback containers))
226
+
(when (called-interactively-p 'any)
227
+
(message "pm: %d project%s refreshed"
228
+
(length containers)
229
+
(if (= 1 (length containers)) "" "s")))))))
230
+
231
+
;;;; Subproject navigation (Pattern 2)
232
+
233
+
;;;###autoload
234
+
(defun pm-jump-parent ()
235
+
"From a worktree buffer, switch to the parent pm container project."
236
+
(interactive)
237
+
(let ((container (pm--container-of default-directory)))
238
+
(unless container
239
+
(user-error "Not inside a pm-managed worktree"))
240
+
(project-switch-project container)))
241
+
242
+
(defun pm--read-sibling (prompt)
243
+
(let* ((container (or (pm--container-of default-directory)
244
+
(user-error "Not inside a pm-managed worktree")))
245
+
(current (pm--worktree-alias-of default-directory))
246
+
(siblings (pm--siblings-of container current)))
247
+
(unless siblings
248
+
(user-error "No sibling worktrees in %s"
249
+
(file-name-nondirectory (directory-file-name container))))
250
+
(let ((choice (completing-read prompt siblings nil t)))
251
+
(cons container choice))))
252
+
253
+
;;;###autoload
254
+
(defun pm-jump-sibling ()
255
+
"Switch to a sibling worktree of the current pm container."
256
+
(interactive)
257
+
(pcase-let ((`(,container . ,alias) (pm--read-sibling "Sibling worktree: ")))
258
+
(project-switch-project (expand-file-name alias container))))
259
+
260
+
(provide 'pm-project)
261
+
262
+
;;; pm-project.el ends here
+304
integrations/emacs/pm-tests.el
+304
integrations/emacs/pm-tests.el
···
1
+
;;; pm-tests.el --- ERT tests for pm.el -*- lexical-binding: t -*-
2
+
3
+
;;; Commentary:
4
+
5
+
;; Run with:
6
+
;; emacs -Q -batch -L . -l ert -l pm-tests.el \
7
+
;; -f ert-run-tests-batch-and-exit
8
+
;;
9
+
;; All tests are hermetic — `pm--run-async' is mocked so no real `pm'
10
+
;; binary is invoked.
11
+
12
+
;;; Code:
13
+
14
+
(require 'ert)
15
+
(require 'cl-lib)
16
+
(let ((dir (file-name-directory (or load-file-name buffer-file-name))))
17
+
(add-to-list 'load-path dir))
18
+
(require 'pm)
19
+
(require 'pm-process)
20
+
(require 'pm-project)
21
+
(require 'pm-commands)
22
+
(require 'pm-ui)
23
+
(require 'pm-transient)
24
+
25
+
(defmacro pm-test--with-fixture (var &rest body)
26
+
"Bind VAR to a temp pm-projects-dir and evaluate BODY.
27
+
The temp tree contains two containers, `alpha' (worktrees a, b) and
28
+
`beta' (worktree main). Each worktree symlink points to a fake git
29
+
checkout dir under <tmp>/pool/<repo>/<uuid>."
30
+
(declare (indent 1))
31
+
`(let* ((,var (file-name-as-directory (make-temp-file "pm-test-" t)))
32
+
(pool (file-name-as-directory (concat ,var "pool/")))
33
+
(pm-projects-dir ,var)
34
+
(pm-include-files-from-worktrees t))
35
+
(unwind-protect
36
+
(progn
37
+
(make-directory (concat pool "repo1/uuid-a") t)
38
+
(make-directory (concat pool "repo1/uuid-b") t)
39
+
(make-directory (concat pool "repo2/uuid-m") t)
40
+
(dolist (slot '("repo1/uuid-a" "repo1/uuid-b" "repo2/uuid-m"))
41
+
(write-region "" nil (concat pool slot "/.git")))
42
+
(make-directory (concat ,var "alpha/") t)
43
+
(write-region "" nil (concat ,var "alpha/.pm.db"))
44
+
(make-symbolic-link (concat pool "repo1/uuid-a")
45
+
(concat ,var "alpha/a"))
46
+
(make-symbolic-link (concat pool "repo1/uuid-b")
47
+
(concat ,var "alpha/b"))
48
+
(make-directory (concat ,var "beta/") t)
49
+
(write-region "" nil (concat ,var "beta/.pm.db"))
50
+
(make-symbolic-link (concat pool "repo2/uuid-m")
51
+
(concat ,var "beta/main"))
52
+
,@body)
53
+
(delete-directory ,var t))))
54
+
55
+
(ert-deftest pm-test--project-finder-recognizes-container ()
56
+
(pm-test--with-fixture root
57
+
(let ((proj (pm--project-finder (concat root "alpha/"))))
58
+
(should (eq (car proj) 'pm))
59
+
(should (string= (cdr proj)
60
+
(file-name-as-directory (concat root "alpha")))))))
61
+
62
+
(ert-deftest pm-test--project-finder-rejects-non-container ()
63
+
(pm-test--with-fixture root
64
+
(should (null (pm--project-finder (concat root "alpha/a/"))))
65
+
(should (null (pm--project-finder root)))))
66
+
67
+
(ert-deftest pm-test--project-name-from-container ()
68
+
(pm-test--with-fixture root
69
+
(let ((proj (cons 'pm (file-name-as-directory (concat root "alpha")))))
70
+
(should (string= (project-name proj) "alpha")))))
71
+
72
+
(ert-deftest pm-test--container-of-walks-up ()
73
+
(pm-test--with-fixture root
74
+
(should (string= (pm--container-of (concat root "alpha/a/some/sub/"))
75
+
(file-name-as-directory (concat root "alpha"))))
76
+
(should (string= (pm--container-of (concat root "beta/main/"))
77
+
(file-name-as-directory (concat root "beta"))))))
78
+
79
+
(ert-deftest pm-test--container-of-returns-nil-outside ()
80
+
(pm-test--with-fixture root
81
+
(should (null (pm--container-of "/tmp/")))))
82
+
83
+
(ert-deftest pm-test--worktree-alias-of ()
84
+
(pm-test--with-fixture root
85
+
(should (string= (pm--worktree-alias-of (concat root "alpha/a/x/y"))
86
+
"a"))
87
+
(should (string= (pm--worktree-alias-of (concat root "beta/main"))
88
+
"main"))
89
+
(should (null (pm--worktree-alias-of (concat root "alpha/"))))))
90
+
91
+
(ert-deftest pm-test--worktree-aliases-in ()
92
+
(pm-test--with-fixture root
93
+
(should (equal (sort (pm--worktree-aliases-in
94
+
(concat root "alpha/"))
95
+
#'string<)
96
+
'("a" "b")))))
97
+
98
+
(ert-deftest pm-test--siblings-of-excludes-self ()
99
+
(pm-test--with-fixture root
100
+
(let ((pm--known-projects nil))
101
+
(should (equal (pm--siblings-of
102
+
(file-name-as-directory (concat root "alpha"))
103
+
"a")
104
+
'("b")))
105
+
(should (null (pm--siblings-of
106
+
(file-name-as-directory (concat root "beta"))
107
+
"main"))))))
108
+
109
+
(ert-deftest pm-test--display-name-from-symlink-path ()
110
+
(pm-test--with-fixture root
111
+
(should (string= (pm--display-name-from-root
112
+
(concat root "alpha/a/"))
113
+
"alpha/a"))
114
+
(should (null (pm--display-name-from-root (concat root "alpha/"))))))
115
+
116
+
(ert-deftest pm-test--display-name-from-slot-path ()
117
+
(pm-test--with-fixture root
118
+
(let ((pm--slot-to-display
119
+
(list (cons (file-name-as-directory
120
+
(concat root "pool/repo1/uuid-a"))
121
+
"alpha/a"))))
122
+
(should (string= (pm--display-name-from-root
123
+
(concat root "pool/repo1/uuid-a/"))
124
+
"alpha/a")))))
125
+
126
+
(ert-deftest pm-test--name-advice-passes-through-non-pm ()
127
+
(pm-test--with-fixture root
128
+
(let ((pm--slot-to-display nil))
129
+
(cl-letf (((symbol-function 'project-root)
130
+
(lambda (_) "/tmp/unrelated/")))
131
+
(should (string= (pm--name-advice (lambda (_) "unrelated") '(vc Git "/tmp/unrelated/"))
132
+
"unrelated"))))))
133
+
134
+
(ert-deftest pm-test--name-advice-renders-alias ()
135
+
(pm-test--with-fixture root
136
+
(cl-letf (((symbol-function 'project-root)
137
+
(lambda (_) (concat root "alpha/a/"))))
138
+
(should (string= (pm--name-advice (lambda (_) "uuid-a")
139
+
'(vc Git "/whatever"))
140
+
"alpha/a")))))
141
+
142
+
(ert-deftest pm-test--reconcile-populates-cache ()
143
+
(pm-test--with-fixture root
144
+
(let ((rows '(((project . "alpha")
145
+
(worktrees . (((wt . "a") (repo . "repo1")
146
+
(branch . "main") (status . "attached"))
147
+
((wt . "b") (repo . "repo1")
148
+
(branch . "feat") (status . "attached")))))
149
+
((project . "beta")
150
+
(worktrees . (((wt . "main") (repo . "repo2")
151
+
(branch . "trunk") (status . "attached")))))))
152
+
(project--list nil)
153
+
(pm--known-projects nil)
154
+
(pm--slot-to-display nil))
155
+
(cl-letf (((symbol-function 'project-remember-project)
156
+
(lambda (pr &optional _no-write)
157
+
(push (list (project-root pr)) project--list)))
158
+
((symbol-function 'project-forget-project) #'ignore)
159
+
((symbol-function 'project--write-project-list) #'ignore))
160
+
(let ((containers (pm--reconcile rows)))
161
+
(should (= 2 (length containers)))
162
+
(should (assoc (file-name-as-directory (concat root "alpha"))
163
+
pm--known-projects))
164
+
(should (assoc (file-name-as-directory (concat root "beta"))
165
+
pm--known-projects))
166
+
(should (= 3 (length pm--slot-to-display))))))))
167
+
168
+
(ert-deftest pm-test--build-spec-with-aliases ()
169
+
(cl-letf (((symbol-function 'read-string)
170
+
(lambda (prompt &rest _)
171
+
(cond
172
+
((string-match-p "Alias for repo1" prompt) "")
173
+
((string-match-p "Alias for repo2" prompt) "feature")
174
+
(t "")))))
175
+
(should (string= (pm--build-spec '("repo1" "repo2"))
176
+
"repo1,feature:repo2"))))
177
+
178
+
(ert-deftest pm-test--strs-flattens-and-drops-nil ()
179
+
(should (equal (pm--strs "a" nil "b" '("c" "d") nil "e")
180
+
'("a" "b" "c" "d" "e")))
181
+
(should (equal (pm--strs '("--all"))
182
+
'("--all"))))
183
+
184
+
;;;; Cross-project entry to pm-project-dispatch
185
+
;;
186
+
;; The bound project is communicated to the transient via `:scope', not
187
+
;; via `default-directory': the latter unwinds the moment the entry
188
+
;; function returns and is gone by the time the user presses a suffix
189
+
;; key. These tests capture the `:scope' that `transient-setup' is
190
+
;; called with to verify the entry function picks the right project
191
+
;; under each scenario.
192
+
193
+
(defmacro pm-test--capture-dispatch-scope (&rest body)
194
+
"Run BODY with `transient-setup' stubbed to capture the :scope arg.
195
+
Returns the captured scope (path string) or nil."
196
+
`(let (captured)
197
+
(cl-letf (((symbol-function 'transient-setup)
198
+
(lambda (&rest args)
199
+
(setq captured
200
+
(plist-get (cdddr args) :scope)))))
201
+
,@body
202
+
captured)))
203
+
204
+
(ert-deftest pm-test--project-dispatch-scope-is-current-project ()
205
+
"Inside project A with no prefix arg, scope resolves to A."
206
+
(pm-test--with-fixture root
207
+
(let* ((default-directory (concat root "alpha/a/"))
208
+
(scope (pm-test--capture-dispatch-scope
209
+
(call-interactively #'pm-project-dispatch))))
210
+
(should scope)
211
+
(should (string= (pm--container-name scope) "alpha")))))
212
+
213
+
(ert-deftest pm-test--project-dispatch-scope-prefix-arg-prompts ()
214
+
"Inside project A with prefix arg, scope is the chosen project (B)."
215
+
(pm-test--with-fixture root
216
+
(cl-letf (((symbol-function 'pm--read-project)
217
+
(lambda (&rest _) "beta")))
218
+
(let* ((default-directory (concat root "alpha/a/"))
219
+
(scope (pm-test--capture-dispatch-scope
220
+
(let ((current-prefix-arg '(4)))
221
+
(call-interactively #'pm-project-dispatch)))))
222
+
(should scope)
223
+
(should (string= (file-name-as-directory scope)
224
+
(file-name-as-directory (concat root "beta"))))))))
225
+
226
+
(ert-deftest pm-test--project-dispatch-scope-from-outside-prompts ()
227
+
"From a path not under pm-projects-dir, scope is the prompted project."
228
+
(pm-test--with-fixture root
229
+
(cl-letf (((symbol-function 'pm--read-project)
230
+
(lambda (&rest _) "beta")))
231
+
(let* ((default-directory "/tmp/")
232
+
(scope (pm-test--capture-dispatch-scope
233
+
(call-interactively #'pm-project-dispatch))))
234
+
(should scope)
235
+
(should (string= (file-name-as-directory scope)
236
+
(file-name-as-directory (concat root "beta"))))))))
237
+
238
+
(ert-deftest pm-test--project-dispatch-honors-project-switch-override ()
239
+
"Regression: `C-x p p <B> P' from outside any pm tree must scope to B.
240
+
241
+
In Emacs 28+, `project-switch-project' does NOT rebind
242
+
`default-directory' — it sets `project-current-directory-override'
243
+
buffer-locally and calls the chosen command. The entry function
244
+
must therefore read the override; otherwise it falls back to the
245
+
original buffer's directory (which has no pm container) and
246
+
either prompts again or scopes to the wrong place."
247
+
(pm-test--with-fixture root
248
+
(let* ((default-directory "/tmp/")
249
+
(project-current-directory-override
250
+
(concat root "beta/"))
251
+
(scope (pm-test--capture-dispatch-scope
252
+
(call-interactively #'pm-project-dispatch))))
253
+
(should scope)
254
+
(should (string= (file-name-as-directory scope)
255
+
(file-name-as-directory (concat root "beta")))))))
256
+
257
+
(ert-deftest pm-test--project-dispatch-override-wins-over-current-buffer ()
258
+
"From a buffer in project A, `C-x p p <B> P' must scope to B (not A).
259
+
260
+
When `project-current-directory-override' is set (the user just
261
+
explicitly chose B via `C-x p p'), it must take precedence over
262
+
the buffer's own pm context."
263
+
(pm-test--with-fixture root
264
+
(let* ((default-directory (concat root "alpha/a/"))
265
+
(project-current-directory-override
266
+
(concat root "beta/"))
267
+
(scope (pm-test--capture-dispatch-scope
268
+
(call-interactively #'pm-project-dispatch))))
269
+
(should scope)
270
+
(should (string= (file-name-as-directory scope)
271
+
(file-name-as-directory (concat root "beta")))))))
272
+
273
+
(ert-deftest pm-test--project-dispatch-suffix-survives-let-unwind ()
274
+
"Regression: scope persists after the entry function's locals unwind.
275
+
276
+
Reproduces the bug where `C-x p p <project-B> P' (from project A)
277
+
ran a status suffix that targeted A: the entry function let-bound
278
+
`default-directory' but `transient-setup' returns immediately, so by
279
+
the time the user presses a suffix key the let has unwound. Fix is
280
+
to pass the project as :scope, which the prefix object retains.
281
+
282
+
To make the test airtight, we simulate the unwind by capturing the
283
+
scope inside the stub then re-resolving the container *outside* any
284
+
let bindings — `default-directory' has reverted to the original
285
+
buffer-level value and only :scope can carry the answer."
286
+
(pm-test--with-fixture root
287
+
(cl-letf (((symbol-function 'pm--read-project)
288
+
(lambda (&rest _) "beta")))
289
+
(let* ((default-directory (concat root "alpha/a/"))
290
+
captured-scope)
291
+
(cl-letf (((symbol-function 'transient-setup)
292
+
(lambda (&rest args)
293
+
(setq captured-scope (plist-get (cdddr args) :scope)))))
294
+
(let ((current-prefix-arg '(4)))
295
+
(call-interactively #'pm-project-dispatch)))
296
+
;; default-directory has reverted to alpha/a/ here; only the
297
+
;; explicit scope can identify the bound project.
298
+
(should captured-scope)
299
+
(should (string= (file-name-as-directory captured-scope)
300
+
(file-name-as-directory (concat root "beta"))))))))
301
+
302
+
(provide 'pm-tests)
303
+
304
+
;;; pm-tests.el ends here
+285
integrations/emacs/pm-transient.el
+285
integrations/emacs/pm-transient.el
···
1
+
;;; pm-transient.el --- Transient menus for pm -*- lexical-binding: t -*-
2
+
3
+
;;; Commentary:
4
+
5
+
;; Two magit-style transients:
6
+
;;
7
+
;; - `pm-dispatch' (global, `C-x p P') — verbs that don't need a
8
+
;; current project: create / list / switch / refresh, plus pool and
9
+
;; repo verbs. A `[Project]' group with a single `.' suffix appears
10
+
;; only when the buffer is inside a pm tree, and enters
11
+
;; `pm-project-dispatch'.
12
+
;;
13
+
;; - `pm-project-dispatch' (project, `C-x p .') — verbs scoped to a
14
+
;; single pm project, derived from `default-directory' (prompts if
15
+
;; invoked outside any pm tree). Header shows
16
+
;; `pm: <container>[/<alias>]'. Persistent infix args
17
+
;; (`-A --all', `-n --no-branch', `-d --dry-run') drive the wt
18
+
;; action suffixes; descriptions live-update to reflect toggles.
19
+
20
+
;;; Code:
21
+
22
+
(require 'transient)
23
+
(require 'pm-process)
24
+
(require 'pm-project)
25
+
(require 'pm-ui)
26
+
(require 'pm-commands)
27
+
28
+
(defvar pm-projects-dir)
29
+
(defvar pm-confirm-destructive)
30
+
31
+
;;;; Buffer-level predicates (used by `pm-dispatch')
32
+
33
+
(defun pm--in-pm-tree-p ()
34
+
"Non-nil when `default-directory' is inside any pm container."
35
+
(and (pm--container-of default-directory) t))
36
+
37
+
(defun pm--no-create-inflight ()
38
+
(not (pm--inflight-p 'create)))
39
+
40
+
;;;; Scope-level helpers (used by `pm-project-dispatch')
41
+
;;
42
+
;; The bound project travels through the transient via `:scope', not
43
+
;; via `default-directory': the entry function's let-binding unwinds
44
+
;; the moment `transient-setup' returns, well before any suffix key is
45
+
;; pressed. Header / predicates / suffix bodies must therefore read
46
+
;; `(transient-scope)' — not the buffer's `default-directory' — when
47
+
;; computing what project they're acting on.
48
+
49
+
(defun pm--ds-path ()
50
+
"Return the path bound to the current project dispatch, or nil."
51
+
(transient-scope))
52
+
53
+
(defun pm--ds-container ()
54
+
(when-let ((p (pm--ds-path))) (pm--container-of p)))
55
+
56
+
(defun pm--ds-container-name ()
57
+
(when-let ((c (pm--ds-container)))
58
+
(file-name-nondirectory (directory-file-name c))))
59
+
60
+
(defun pm--ds-alias ()
61
+
(when-let ((p (pm--ds-path))) (pm--worktree-alias-of p)))
62
+
63
+
(defun pm--ds-inside-worktree-p ()
64
+
(and (pm--ds-container) (pm--ds-alias) t))
65
+
66
+
(defun pm--ds-has-siblings-p ()
67
+
(when-let* ((c (pm--ds-container))
68
+
(a (pm--ds-alias)))
69
+
(consp (pm--siblings-of c a))))
70
+
71
+
(defun pm--container-name (dir)
72
+
"Return the bare container name for DIR, or nil."
73
+
(when-let ((c (pm--container-of dir)))
74
+
(file-name-nondirectory (directory-file-name c))))
75
+
76
+
(defun pm--dispatch-header ()
77
+
(format "pm: %s%s"
78
+
(or (pm--ds-container-name) "?")
79
+
(if-let ((a (pm--ds-alias))) (format "/%s" a) "")))
80
+
81
+
;;;; Project-dispatch suffixes (read infix args)
82
+
83
+
(defun pm--dispatch-args ()
84
+
(transient-args 'pm--project-dispatch-menu))
85
+
86
+
(defun pm--decorate-desc (base &rest tags)
87
+
"Return BASE description plus parenthetical TAGS that are non-nil."
88
+
(let ((extra (delq nil tags)))
89
+
(if extra (format "%s (%s)" base (mapconcat #'identity extra " "))
90
+
base)))
91
+
92
+
(transient-define-suffix pm-project-dispatch--status ()
93
+
"Show status of the bound project."
94
+
:description "status"
95
+
(interactive)
96
+
(pm-project-status (pm--ds-container-name)))
97
+
98
+
(transient-define-suffix pm-project-dispatch--wt-create ()
99
+
"Add a worktree to the bound project."
100
+
:description "new"
101
+
(interactive)
102
+
(pm-wt-create (pm--ds-container-name)))
103
+
104
+
(transient-define-suffix pm-project-dispatch--wt-attach ()
105
+
"Attach worktrees in the bound project, honoring infix args."
106
+
:description
107
+
(lambda ()
108
+
(let ((args (pm--dispatch-args)))
109
+
(pm--decorate-desc "attach"
110
+
(and (member "--all" args) "all")
111
+
(and (member "--no-branch" args) "no-branch"))))
112
+
(interactive)
113
+
(let* ((args (pm--dispatch-args))
114
+
(all (and (member "--all" args) t))
115
+
(no-branch (and (member "--no-branch" args) t))
116
+
(name (pm--ds-container-name))
117
+
(wts (unless all
118
+
(mapconcat #'identity
119
+
(pm--read-worktrees-multi
120
+
"Attach which: " name)
121
+
","))))
122
+
(pm--wt-attach name wts all no-branch
123
+
(lambda (_)
124
+
(pm-refresh
125
+
(lambda (_) (message "pm: attached")))))))
126
+
127
+
(transient-define-suffix pm-project-dispatch--wt-detach ()
128
+
"Detach worktrees in the bound project, honoring infix args."
129
+
:description
130
+
(lambda ()
131
+
(let ((args (pm--dispatch-args)))
132
+
(pm--decorate-desc "detach"
133
+
(and (member "--all" args) "all")
134
+
(and (member "--dry-run" args) "dry"))))
135
+
(interactive)
136
+
(let* ((args (pm--dispatch-args))
137
+
(all (and (member "--all" args) t))
138
+
(dry-run (and (member "--dry-run" args) t))
139
+
(name (pm--ds-container-name))
140
+
(wts (unless all
141
+
(mapconcat #'identity
142
+
(pm--read-worktrees-multi
143
+
"Detach which: " name)
144
+
","))))
145
+
(when (or dry-run
146
+
(pm--maybe-confirm
147
+
(format "Detach %s in %s? "
148
+
(if all "all worktrees" wts) name)))
149
+
(pm--wt-detach name wts all dry-run
150
+
(lambda (_)
151
+
(pm-refresh
152
+
(lambda (_)
153
+
(message "pm: %s"
154
+
(if dry-run "detach (dry-run)" "detached")))))))))
155
+
156
+
(transient-define-suffix pm-project-dispatch--wt-delete ()
157
+
"Delete worktrees from the bound project, honoring infix args."
158
+
:description
159
+
(lambda ()
160
+
(let ((args (pm--dispatch-args)))
161
+
(pm--decorate-desc "delete" (and (member "--all" args) "all"))))
162
+
(interactive)
163
+
(let* ((args (pm--dispatch-args))
164
+
(all (and (member "--all" args) t))
165
+
(name (pm--ds-container-name))
166
+
(wts (unless all
167
+
(mapconcat #'identity
168
+
(pm--read-worktrees-multi
169
+
"Delete which: " name)
170
+
","))))
171
+
(when (pm--maybe-confirm
172
+
(format "Permanently delete %s in %s? "
173
+
(if all "all worktrees" wts) name))
174
+
(pm--wt-delete name wts all
175
+
(lambda (_)
176
+
(pm-refresh
177
+
(lambda (_) (message "pm: deleted"))))))))
178
+
179
+
(transient-define-suffix pm-project-dispatch--delete ()
180
+
"Delete the bound project."
181
+
:description "delete project"
182
+
(interactive)
183
+
(pm-project-delete (pm--ds-container-name)))
184
+
185
+
(transient-define-suffix pm-project-dispatch--jump-parent ()
186
+
"Switch to the bound project's container."
187
+
:description "parent"
188
+
(interactive)
189
+
(let ((default-directory (or (pm--ds-path) default-directory)))
190
+
(call-interactively #'pm-jump-parent)))
191
+
192
+
(transient-define-suffix pm-project-dispatch--jump-sibling ()
193
+
"Switch to a sibling worktree of the bound project."
194
+
:description "sibling"
195
+
(interactive)
196
+
(let ((default-directory (or (pm--ds-path) default-directory)))
197
+
(call-interactively #'pm-jump-sibling)))
198
+
199
+
;;;; Project dispatch (the prefix)
200
+
201
+
(transient-define-prefix pm--project-dispatch-menu ()
202
+
"pm: act on the bound pm project."
203
+
[:description pm--dispatch-header
204
+
["Arguments"
205
+
("-A" "All worktrees" "--all")
206
+
("-n" "Skip branch restore" "--no-branch")
207
+
("-d" "Dry run" "--dry-run")]]
208
+
[["Inspect"
209
+
("s" pm-project-dispatch--status)]
210
+
["Worktrees"
211
+
("n" pm-project-dispatch--wt-create)
212
+
("a" pm-project-dispatch--wt-attach)
213
+
("D" pm-project-dispatch--wt-detach)
214
+
("X" pm-project-dispatch--wt-delete)]
215
+
["Navigate"
216
+
:if pm--ds-inside-worktree-p
217
+
("p" pm-project-dispatch--jump-parent)
218
+
("j" pm-project-dispatch--jump-sibling :if pm--ds-has-siblings-p)]]
219
+
[["Danger"
220
+
("K" pm-project-dispatch--delete)]
221
+
["System"
222
+
("g" "refresh" pm-refresh)
223
+
("<" "global pm" pm-dispatch)]])
224
+
225
+
;; The bound project travels via `:scope' rather than `default-directory'
226
+
;; — `transient-setup' returns immediately, and any `let' around the
227
+
;; entry call would unwind before the user pressed a suffix key.
228
+
;;
229
+
;; Resolution order:
230
+
;; 1. With prefix ARG, always prompt.
231
+
;; 2. Else, honor `project-current-directory-override' if set — that's
232
+
;; how `project-switch-project' (Emacs 28+) communicates the
233
+
;; just-selected project to its post-switch command. It does NOT
234
+
;; rebind `default-directory'.
235
+
;; 3. Else, if the buffer's `default-directory' is inside a pm tree,
236
+
;; use that tree.
237
+
;; 4. Else, prompt.
238
+
;;;###autoload
239
+
(defun pm-project-dispatch (&optional arg)
240
+
"Open `pm-project-dispatch' on the current pm project.
241
+
With prefix ARG, prompt for a project even when one is contextually
242
+
available."
243
+
(interactive "P")
244
+
(let* ((override (bound-and-true-p project-current-directory-override))
245
+
(path
246
+
(cond
247
+
(arg
248
+
(file-name-as-directory
249
+
(expand-file-name (pm--read-project "Project: ")
250
+
pm-projects-dir)))
251
+
((and override (pm--container-of override))
252
+
(file-name-as-directory (expand-file-name override)))
253
+
((pm--container-of default-directory)
254
+
default-directory)
255
+
(t
256
+
(file-name-as-directory
257
+
(expand-file-name (pm--read-project "Project: ")
258
+
pm-projects-dir))))))
259
+
(transient-setup 'pm--project-dispatch-menu nil nil :scope path)))
260
+
261
+
;;;; Global dispatch
262
+
263
+
;;;###autoload (autoload 'pm-dispatch "pm-transient" nil t)
264
+
(transient-define-prefix pm-dispatch ()
265
+
"pm: global commands."
266
+
["pm"
267
+
["Create"
268
+
("c" "project" pm-project-create :if pm--no-create-inflight)
269
+
("+" "pool slot" pm-pool-add)]
270
+
["Inspect"
271
+
("l" "projects" pm-project-list)
272
+
("o" "pool" pm-pool-list)
273
+
("R" "repos" pm-repo-list)]
274
+
["Switch"
275
+
("p" "project" pm-project-switch)]
276
+
["System"
277
+
("g" "refresh" pm-refresh)
278
+
("F" "pull repos" pm-repo-pull)]
279
+
["Project"
280
+
:if pm--in-pm-tree-p
281
+
("." "current project →" pm-project-dispatch)]])
282
+
283
+
(provide 'pm-transient)
284
+
285
+
;;; pm-transient.el ends here
+408
integrations/emacs/pm-ui.el
+408
integrations/emacs/pm-ui.el
···
1
+
;;; pm-ui.el --- Interactive entrypoints for pm -*- lexical-binding: t -*-
2
+
3
+
;;; Commentary:
4
+
5
+
;; Interactive UI built on the low-level wrappers in `pm-commands' and
6
+
;; the project.el integration in `pm-project'. Functions here are the
7
+
;; suffix bodies for `pm-transient'.
8
+
9
+
;;; Code:
10
+
11
+
(require 'cl-lib)
12
+
(require 'subr-x)
13
+
(require 'project)
14
+
(require 'pm-process)
15
+
(require 'pm-commands)
16
+
(require 'pm-project)
17
+
18
+
(defvar pm-projects-dir)
19
+
(defvar pm-confirm-destructive)
20
+
21
+
;;;; Prompt helpers
22
+
23
+
(defun pm--scan-containers ()
24
+
"Filesystem fallback: containers under `pm-projects-dir' with `.pm.db'."
25
+
(when (file-directory-p pm-projects-dir)
26
+
(cl-remove-if-not
27
+
(lambda (name)
28
+
(file-exists-p (expand-file-name (concat name "/.pm.db")
29
+
pm-projects-dir)))
30
+
(directory-files pm-projects-dir nil "^[^.]"))))
31
+
32
+
(defun pm--cached-project-names ()
33
+
(mapcar (lambda (entry)
34
+
(file-name-nondirectory (directory-file-name (car entry))))
35
+
pm--known-projects))
36
+
37
+
(defun pm--read-project (prompt &optional default)
38
+
(let ((candidates (or (pm--cached-project-names) (pm--scan-containers))))
39
+
(unless candidates
40
+
(user-error "No pm projects under %s" pm-projects-dir))
41
+
(completing-read prompt candidates nil t nil nil default)))
42
+
43
+
(defun pm--read-worktree (prompt name)
44
+
"Prompt for a worktree alias inside project NAME."
45
+
(let* ((entry (assoc (file-name-as-directory
46
+
(expand-file-name name pm-projects-dir))
47
+
pm--known-projects))
48
+
(worktrees (plist-get (cdr entry) :worktrees))
49
+
(candidates
50
+
(or (mapcar (lambda (w) (alist-get 'wt w)) worktrees)
51
+
(pm--worktree-aliases-in
52
+
(file-name-as-directory
53
+
(expand-file-name name pm-projects-dir))))))
54
+
(unless candidates
55
+
(user-error "No worktrees in project %s" name))
56
+
(completing-read prompt candidates nil t)))
57
+
58
+
(defun pm--read-worktrees-multi (prompt name)
59
+
(completing-read-multiple
60
+
prompt
61
+
(let* ((entry (assoc (file-name-as-directory
62
+
(expand-file-name name pm-projects-dir))
63
+
pm--known-projects))
64
+
(worktrees (plist-get (cdr entry) :worktrees)))
65
+
(or (mapcar (lambda (w) (alist-get 'wt w)) worktrees)
66
+
(pm--worktree-aliases-in
67
+
(file-name-as-directory
68
+
(expand-file-name name pm-projects-dir)))))
69
+
nil t))
70
+
71
+
(defun pm--maybe-confirm (prompt)
72
+
"Return non-nil if action should proceed; honors `pm-confirm-destructive'."
73
+
(or (not pm-confirm-destructive) (yes-or-no-p prompt)))
74
+
75
+
;;;; Project lifecycle
76
+
77
+
(defun pm--build-spec (repos)
78
+
"Prompt for an optional alias per repo in REPOS; return spec string."
79
+
(let ((parts
80
+
(mapcar
81
+
(lambda (repo)
82
+
(let ((alias (read-string
83
+
(format "Alias for %s (RET = none): " repo))))
84
+
(if (string-empty-p alias) repo
85
+
(concat alias ":" repo))))
86
+
repos)))
87
+
(mapconcat #'identity parts ",")))
88
+
89
+
;;;###autoload
90
+
(defun pm-project-create ()
91
+
"Create a new pm project, attaching one or more worktrees."
92
+
(interactive)
93
+
(let ((name (read-string "New project name: ")))
94
+
(when (string-empty-p name) (user-error "Aborted"))
95
+
(pm--repo-ls
96
+
nil
97
+
(lambda (repos)
98
+
(let* ((repo-names (mapcar (lambda (r) (alist-get 'repo r)) repos))
99
+
(chosen (completing-read-multiple
100
+
"Worktrees (pick repos, comma-sep): "
101
+
repo-names nil t)))
102
+
(when (null chosen)
103
+
(user-error "Aborted: at least one worktree required"))
104
+
(let ((spec (pm--build-spec chosen)))
105
+
(pm--project-create
106
+
name spec
107
+
(lambda (rows)
108
+
(let ((container (file-name-as-directory
109
+
(expand-file-name name pm-projects-dir))))
110
+
(pm-refresh
111
+
(lambda (_)
112
+
(let ((aliases (mapcar (lambda (r) (alist-get 'wt r)) rows)))
113
+
(message "pm: created %s [%s]"
114
+
name (mapconcat #'identity aliases ", "))
115
+
(when (and aliases
116
+
(y-or-n-p
117
+
(format "Switch into %s/%s? "
118
+
name (car aliases))))
119
+
(project-switch-project
120
+
(expand-file-name (car aliases) container)))))))))))))))
121
+
122
+
;;;###autoload
123
+
(defun pm-project-delete (name)
124
+
"Delete pm project NAME (and all its worktrees)."
125
+
(interactive (list (pm--read-project "Delete project: ")))
126
+
(when (pm--maybe-confirm
127
+
(format "Really delete pm project %s and all its worktrees? " name))
128
+
(pm--project-delete
129
+
name nil
130
+
(lambda (_)
131
+
(pm--forget-container
132
+
(file-name-as-directory (expand-file-name name pm-projects-dir)))
133
+
(message "pm: deleted %s" name)))))
134
+
135
+
;;;###autoload
136
+
(defun pm-project-switch (name)
137
+
"Switch into pm project NAME."
138
+
(interactive (list (pm--read-project "Switch to project: ")))
139
+
(project-switch-project
140
+
(file-name-as-directory (expand-file-name name pm-projects-dir))))
141
+
142
+
;;;; Status buffer
143
+
144
+
(defun pm--render-status (name data)
145
+
(insert (propertize (format "pm project status: %s\n\n" name)
146
+
'face 'bold))
147
+
(let ((sections '((worktrees . "Worktrees")
148
+
(prs . "Pull requests")
149
+
(sessions . "Recent agent sessions"))))
150
+
(dolist (sec sections)
151
+
(let ((rows (alist-get (car sec) data)))
152
+
(insert (propertize (format "%s\n" (cdr sec))
153
+
'face '(:weight bold)))
154
+
(if (null rows)
155
+
(insert " (none)\n\n")
156
+
(dolist (row rows)
157
+
(insert " ")
158
+
(insert (mapconcat
159
+
(lambda (cell)
160
+
(format "%s=%s" (car cell)
161
+
(or (cdr cell) "—")))
162
+
row " "))
163
+
(insert "\n"))
164
+
(insert "\n"))))))
165
+
166
+
;;;###autoload
167
+
(defun pm-project-status (name)
168
+
"Show `pm project status NAME' in a popup buffer."
169
+
(interactive (list (pm--read-project "Status of: ")))
170
+
(pm--project-status
171
+
name
172
+
(lambda (data)
173
+
(let ((buf (get-buffer-create (format "*pm-status: %s*" name))))
174
+
(with-current-buffer buf
175
+
(let ((inhibit-read-only t))
176
+
(erase-buffer)
177
+
(pm--render-status name data))
178
+
(goto-char (point-min))
179
+
(special-mode))
180
+
(pop-to-buffer buf)))))
181
+
182
+
;;;; Project list (tabulated)
183
+
184
+
(defvar pm-list-mode-map
185
+
(let ((map (make-sparse-keymap)))
186
+
(define-key map (kbd "RET") #'pm-list-switch)
187
+
(define-key map (kbd "s") #'pm-list-status)
188
+
(define-key map (kbd "D") #'pm-list-delete)
189
+
map))
190
+
191
+
(define-derived-mode pm-list-mode tabulated-list-mode "pm-list"
192
+
"Tabulated list of pm projects × worktrees."
193
+
(setq tabulated-list-format
194
+
[("Project" 24 t)
195
+
("Worktree" 16 t)
196
+
("Repo" 20 t)
197
+
("Branch" 30 t)
198
+
("Status" 10 t)])
199
+
(setq tabulated-list-padding 1)
200
+
(tabulated-list-init-header)
201
+
(add-hook 'tabulated-list-revert-hook
202
+
(lambda () (pm--list-populate)) nil t))
203
+
204
+
(defun pm--list-populate ()
205
+
(pm--project-ls
206
+
(lambda (rows)
207
+
(let (entries)
208
+
(dolist (row rows)
209
+
(let ((project (alist-get 'project row)))
210
+
(dolist (wt (alist-get 'worktrees row))
211
+
(push (list (cons project (alist-get 'wt wt))
212
+
(vector project
213
+
(or (alist-get 'wt wt) "")
214
+
(or (alist-get 'repo wt) "")
215
+
(or (alist-get 'branch wt) "")
216
+
(or (alist-get 'status wt) "")))
217
+
entries))))
218
+
(with-current-buffer (get-buffer-create "*pm-list*")
219
+
(let ((inhibit-read-only t))
220
+
(setq tabulated-list-entries (nreverse entries))
221
+
(tabulated-list-print t)))))))
222
+
223
+
;;;###autoload
224
+
(defun pm-project-list ()
225
+
"List pm projects and worktrees in a tabulated buffer."
226
+
(interactive)
227
+
(let ((buf (get-buffer-create "*pm-list*")))
228
+
(with-current-buffer buf
229
+
(pm-list-mode)
230
+
(pm--list-populate))
231
+
(pop-to-buffer buf)))
232
+
233
+
(defun pm-list-current-project ()
234
+
(car (tabulated-list-get-id)))
235
+
236
+
(defun pm-list-current-worktree ()
237
+
(cdr (tabulated-list-get-id)))
238
+
239
+
(defun pm-list-switch ()
240
+
(interactive)
241
+
(when-let ((name (pm-list-current-project)))
242
+
(pm-project-switch name)))
243
+
244
+
(defun pm-list-status ()
245
+
(interactive)
246
+
(when-let ((name (pm-list-current-project)))
247
+
(pm-project-status name)))
248
+
249
+
(defun pm-list-delete ()
250
+
(interactive)
251
+
(when-let ((name (pm-list-current-project)))
252
+
(pm-project-delete name)))
253
+
254
+
;;;; Worktree commands
255
+
256
+
;;;###autoload
257
+
(defun pm-wt-create (name)
258
+
"Add a worktree to project NAME."
259
+
(interactive (list (pm--read-project "Add worktree to: ")))
260
+
(pm--repo-ls
261
+
nil
262
+
(lambda (repos)
263
+
(let* ((repo-names (mapcar (lambda (r) (alist-get 'repo r)) repos))
264
+
(chosen (completing-read-multiple
265
+
"Worktrees (repos, comma-sep): " repo-names nil t)))
266
+
(when (null chosen) (user-error "Aborted"))
267
+
(let ((spec (pm--build-spec chosen)))
268
+
(pm--wt-create
269
+
name spec
270
+
(lambda (_)
271
+
(pm-refresh
272
+
(lambda (_) (message "pm: added wt(s) to %s" name))))))))))
273
+
274
+
(defun pm--wt-action (action verb name)
275
+
"Common skeleton for attach/detach/delete on worktrees in NAME.
276
+
ACTION is the wrapper symbol; VERB is the user-visible name."
277
+
(let* ((all (y-or-n-p (format "%s ALL worktrees in %s? " verb name)))
278
+
(wts (unless all
279
+
(mapconcat #'identity
280
+
(pm--read-worktrees-multi
281
+
(format "%s which worktrees: " verb) name)
282
+
","))))
283
+
(when (and (member verb '("Detach" "Delete"))
284
+
(not (pm--maybe-confirm
285
+
(format "%s %s in %s? "
286
+
verb (if all "all worktrees" wts) name))))
287
+
(user-error "Aborted"))
288
+
(cond
289
+
((eq action 'attach) (pm--wt-attach name wts all nil
290
+
(lambda (_)
291
+
(pm-refresh
292
+
(lambda (_) (message "pm: attached"))))))
293
+
((eq action 'detach) (pm--wt-detach name wts all nil
294
+
(lambda (_)
295
+
(pm-refresh
296
+
(lambda (_) (message "pm: detached"))))))
297
+
((eq action 'delete) (pm--wt-delete name wts all
298
+
(lambda (_)
299
+
(pm-refresh
300
+
(lambda (_) (message "pm: deleted"))))))
301
+
((eq action 'create) (error "Use pm-wt-create directly")))))
302
+
303
+
;;;###autoload
304
+
(defun pm-wt-attach (name)
305
+
(interactive (list (pm--read-project "Attach worktrees in: ")))
306
+
(pm--wt-action 'attach "Attach" name))
307
+
308
+
;;;###autoload
309
+
(defun pm-wt-detach (name)
310
+
(interactive (list (pm--read-project "Detach worktrees in: ")))
311
+
(pm--wt-action 'detach "Detach" name))
312
+
313
+
;;;###autoload
314
+
(defun pm-wt-delete (name)
315
+
(interactive (list (pm--read-project "Delete worktrees in: ")))
316
+
(pm--wt-action 'delete "Delete" name))
317
+
318
+
;;;; Pool
319
+
320
+
;;;###autoload
321
+
(defun pm-pool-list (&optional repo)
322
+
"Show pool slots; optionally filtered by REPO."
323
+
(interactive (list (when current-prefix-arg
324
+
(read-string "Repo (empty = all): "))))
325
+
(pm--pool-ls
326
+
(and repo (not (string-empty-p repo)) repo)
327
+
(lambda (data)
328
+
(pm--show-tabulated
329
+
"*pm-pool*"
330
+
[("Repo" 20 t) ("UUID" 38 t) ("Claim" 16 t) ("Path" 60 t)]
331
+
(mapcan
332
+
(lambda (group)
333
+
(mapcar
334
+
(lambda (slot)
335
+
(list nil (vector (or (alist-get 'repo group) "")
336
+
(or (alist-get 'uuid slot) "")
337
+
(or (alist-get 'claim slot) "")
338
+
(or (alist-get 'path slot) ""))))
339
+
(alist-get 'slots group)))
340
+
data)))))
341
+
342
+
;;;###autoload
343
+
(defun pm-pool-add (repo)
344
+
"Mint a new pool slot for REPO."
345
+
(interactive (list (read-string "Repo to mint slot for: ")))
346
+
(when (string-empty-p repo) (user-error "Aborted"))
347
+
(pm--pool-add
348
+
repo
349
+
(lambda (rows)
350
+
(message "pm: minted slot(s) %s"
351
+
(mapconcat (lambda (r) (or (alist-get 'uuid r) "?"))
352
+
rows ", ")))))
353
+
354
+
;;;; Repo
355
+
356
+
;;;###autoload
357
+
(defun pm-repo-list (&optional offline)
358
+
"List canonical repos; with prefix arg, OFFLINE (skip fetch)."
359
+
(interactive "P")
360
+
(pm--repo-ls
361
+
offline
362
+
(lambda (rows)
363
+
(pm--show-tabulated
364
+
"*pm-repos*"
365
+
[("Repo" 20 t) ("Branch" 24 t) ("Dirty" 6 t) ("Ahead" 6 t)
366
+
("Behind" 6 t) ("Submods" 10 t)]
367
+
(mapcar
368
+
(lambda (r)
369
+
(list nil (vector (or (alist-get 'repo r) "")
370
+
(or (alist-get 'branch r) "")
371
+
(if (alist-get 'dirty r) "yes" "no")
372
+
(format "%s" (or (alist-get 'ahead r) 0))
373
+
(format "%s" (or (alist-get 'behind r) 0))
374
+
(or (alist-get 'submodules r) ""))))
375
+
rows)))))
376
+
377
+
;;;###autoload
378
+
(defun pm-repo-pull (&optional repo)
379
+
"Fetch all canonical repos; with prefix arg, prompt for one REPO."
380
+
(interactive (list (when current-prefix-arg
381
+
(read-string "Repo to pull: "))))
382
+
(message "pm: pulling%s..." (if repo (format " %s" repo) " all repos"))
383
+
(pm--repo-pull
384
+
(and repo (not (string-empty-p repo)) repo)
385
+
(lambda (_) (message "pm: pull complete"))))
386
+
387
+
;;;; Generic tabulated buffer helper
388
+
389
+
(defvar-local pm--tabulated-format nil)
390
+
391
+
(define-derived-mode pm-tabulated-mode tabulated-list-mode "pm"
392
+
"Generic tabulated buffer for pm output."
393
+
(tabulated-list-init-header))
394
+
395
+
(defun pm--show-tabulated (buffer-name format entries)
396
+
(let ((buf (get-buffer-create buffer-name)))
397
+
(with-current-buffer buf
398
+
(pm-tabulated-mode)
399
+
(setq tabulated-list-format format)
400
+
(setq pm--tabulated-format format)
401
+
(tabulated-list-init-header)
402
+
(setq tabulated-list-entries entries)
403
+
(tabulated-list-print t))
404
+
(pop-to-buffer buf)))
405
+
406
+
(provide 'pm-ui)
407
+
408
+
;;; pm-ui.el ends here
+80
integrations/emacs/pm.el
+80
integrations/emacs/pm.el
···
1
+
;;; pm.el --- Emacs integration for pm CLI -*- lexical-binding: t -*-
2
+
3
+
;; Author: Jordan Isaacs
4
+
;; Version: 0.1.0
5
+
;; Package-Requires: ((emacs "28.1") (transient "0.4"))
6
+
;; Keywords: tools, vc
7
+
8
+
;;; Commentary:
9
+
10
+
;; Drives the `pm' CLI (project_manager: a pool of git worktrees bound
11
+
;; to named projects via symlinks) from inside Emacs. Recognizes pm
12
+
;; containers as `project.el' projects via a custom backend keyed on
13
+
;; the `.pm.db' marker, auto-registers them so they appear in
14
+
;; `C-x p p', and exposes a transient menu (`pm-transient') for
15
+
;; project / worktree / pool / repo verbs. Each worktree under a
16
+
;; container is treated as a "subproject": container `project-files'
17
+
;; federates across worktrees, the transient has a Subproject group
18
+
;; for parent / sibling navigation, and `project-name' is advised to
19
+
;; render worktree buffers as `<container>/<wt-alias>'.
20
+
21
+
;;; Code:
22
+
23
+
(require 'cl-lib)
24
+
25
+
(defgroup pm nil
26
+
"Emacs integration for the pm (project_manager) CLI."
27
+
:group 'tools
28
+
:prefix "pm-")
29
+
30
+
(defcustom pm-executable "pm"
31
+
"Path or name of the `pm' executable.
32
+
Resolved via `executable-find' on first use."
33
+
:type 'string
34
+
:group 'pm)
35
+
36
+
(defcustom pm-projects-dir (expand-file-name "~/.projects/")
37
+
"Root directory under which pm projects (containers) live.
38
+
Each container is `<pm-projects-dir>/<name>/' and contains a
39
+
`.pm.db' file plus one symlink per attached worktree."
40
+
:type 'directory
41
+
:group 'pm)
42
+
43
+
(defcustom pm-confirm-destructive t
44
+
"When non-nil, confirm destructive pm operations.
45
+
Applies to `project delete', `wt detach --all', `wt delete', etc."
46
+
:type 'boolean
47
+
:group 'pm)
48
+
49
+
(defcustom pm-include-files-from-worktrees t
50
+
"When non-nil, container `project-files' federates across worktrees.
51
+
Each entry is prefixed with the worktree alias (e.g. `emacs/init.el').
52
+
Set to nil to list only top-level container entries (cheaper for
53
+
containers with many large worktrees)."
54
+
:type 'boolean
55
+
:group 'pm)
56
+
57
+
(require 'pm-process)
58
+
(require 'pm-project)
59
+
(require 'pm-commands)
60
+
61
+
;; pm-ui and pm-transient are loaded on demand via autoloads.
62
+
(autoload 'pm-dispatch "pm-transient" nil t)
63
+
(autoload 'pm-project-dispatch "pm-transient" nil t)
64
+
(autoload 'pm-project-create "pm-ui" nil t)
65
+
(autoload 'pm-project-status "pm-ui" nil t)
66
+
(autoload 'pm-project-list "pm-ui" nil t)
67
+
(autoload 'pm-project-delete "pm-ui" nil t)
68
+
(autoload 'pm-project-switch "pm-ui" nil t)
69
+
(autoload 'pm-wt-create "pm-ui" nil t)
70
+
(autoload 'pm-wt-attach "pm-ui" nil t)
71
+
(autoload 'pm-wt-detach "pm-ui" nil t)
72
+
(autoload 'pm-wt-delete "pm-ui" nil t)
73
+
(autoload 'pm-pool-list "pm-ui" nil t)
74
+
(autoload 'pm-pool-add "pm-ui" nil t)
75
+
(autoload 'pm-repo-list "pm-ui" nil t)
76
+
(autoload 'pm-repo-pull "pm-ui" nil t)
77
+
78
+
(provide 'pm)
79
+
80
+
;;; pm.el ends here
+36
integrations/systemd/README.md
+36
integrations/systemd/README.md
···
1
+
# pm — systemd user units
2
+
3
+
Two oneshot/timer units that keep the canonical-repo store warm and
4
+
its pinned branches up to date.
5
+
6
+
| File | Role |
7
+
| -------------------------- | ------------------------------------------------------------------- |
8
+
| `pm-repo-mgmt.service` | Runs `pm repo pull` + `pm repo maintenance` (fetch, ff-only, gc). |
9
+
| `pm-repo-mgmt.timer` | Fires the service 15s after boot and every 15 minutes thereafter. |
10
+
11
+
The service uses `%h` so it works for any user; it expects `pm` at
12
+
`~/.local/bin/pm` — adjust `ExecStart=` if your install lives elsewhere.
13
+
14
+
## Install
15
+
16
+
```sh
17
+
ln -sf "$PWD"/pm-repo-mgmt.service ~/.config/systemd/user/
18
+
ln -sf "$PWD"/pm-repo-mgmt.timer ~/.config/systemd/user/
19
+
systemctl --user daemon-reload
20
+
systemctl --user enable --now pm-repo-mgmt.timer
21
+
```
22
+
23
+
Verify:
24
+
25
+
```sh
26
+
systemctl --user list-timers pm-repo-mgmt.timer
27
+
journalctl --user -u pm-repo-mgmt.service -n 20
28
+
```
29
+
30
+
## Uninstall
31
+
32
+
```sh
33
+
systemctl --user disable --now pm-repo-mgmt.timer
34
+
rm ~/.config/systemd/user/pm-repo-mgmt.{service,timer}
35
+
systemctl --user daemon-reload
36
+
```
+9
integrations/systemd/pm-repo-mgmt.service
+9
integrations/systemd/pm-repo-mgmt.service