-
Notifications
You must be signed in to change notification settings - Fork 1
/
disproject.el
1484 lines (1259 loc) · 59.4 KB
/
disproject.el
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
;;; disproject.el --- Dispatch project commands with Transient -*- lexical-binding: t; -*-
;; Copyright (C) 2024 aurtzy
;; Copyright (C) 2008-2023 The Magit Project Contributors
;; Copyright (C) 1985-1987, 1992-2024 Free Software Foundation, Inc.
;; Author: aurtzy <[email protected]>
;; URL: https://github.com/aurtzy/disproject
;; Keywords: convenience, files, vc
;; Version: 1.3.1
;; Package-Requires: ((emacs "29.4") (transient "0.8.0"))
;; 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 <https://www.gnu.org/licenses/>.
;;; Commentary:
;; Disproject implements Transient menus for dispatching project-related
;; commands on top of the `project.el' library. It aims to provide a more
;; featureful version of the `project-switch-project' command, which it is
;; inspired by. Those who are familiar with Projectile may also find
;; similarities to `projectile-commander'.
;;; Code:
(require 'cl-extra)
(require 'eieio)
(require 'grep)
(require 'pcase)
(require 'map)
(require 'project)
(require 'transient)
;;;
;;; Customizable variables.
;;;
(defgroup disproject nil
"Transient interface for managing and interacting with projects."
:group 'convenience
:group 'project)
(defgroup disproject-commands nil
"Customizable Disproject main dispatch commands.
See documentation on `disproject-with-environment' for the
variables it sets according to the menu settings. These must be
respected (when relevant) by commands. For example, a command
will not always run in the project root directory if it does not
respect `default-directory' or
`project-current-directory-override', which the macro sets."
:group 'disproject)
(defvar disproject-prefix--transient-commands nil
"Disproject transient prefix commands.
This is a list of prefix commands that use and permit sharing a
`disproject-scope' instance as a scope value. Prefixes which use
`disproject-prefix' or a child type are automatically added to
this list via `initialize-instance'.")
;;;; Custom variables.
(defcustom disproject-custom-allowed-suffixes '()
"Allowed values for `disproject-custom-suffixes'."
:risky t
:group 'disproject
:type '(alist :key-type (string :tag "Project path")
:value-type (repeat (sexp :tag "Custom suffix"))))
(defcustom disproject-custom-suffixes '(("c" "Make"
:command-type compile
:command "make -k"
:identifier "make"))
"Commands for the `disproject-custom-dispatch' prefix.
The custom dispatch was initially designed for suites of
compilation commands, but it is flexible enough to be used for
any custom command designated for a particular project, like
starting servers or updates.
The value should be a list of transient-like specification
entries (KEY DESCRIPTION {PROPERTY VALUE} ...).
KEY is the key-bind that will be used in the Transient menu. Key
sequences starting with alphanumeric characters (regexp
\"[a-zA-Z0-9]\") are reserved for the user.
DESCRIPTION is used as the Transient command description.
The following properties are required:
`:command' is an s-expression which is evaluated and used
depending on the command type `:command-type'.
`:command-type' is a symbol that specifies what to do with the
value of `:command'. It can be any of the following keys:
bare-call: the value is called as an interactive function from
the current buffer. This is the only command type that is not
automatically run in the environment provided by
`disproject-with-environment'.
call: the value will be called as an interactive function.
compile: the value of `:command' should be a string or an
interactive function that returns a string that will be passed
to `compile' as the shell command to run.
run: the value of `:command' should be a string or an
interactive function returning a string, which will be passed
to `async-shell-command'.
When using the \\='bare-call or \\='call command types, consider
using the variable `disproject-process-buffer-name' (available
when evaluating `:command') as the buffer name for processes to
enable tracking e.g. process state.
Some optional properties may be set as well:
`:identifier' is used as part of the buffer name, and should be
unique to the command. `disproject-process-buffer-name' is
applied to the value (or first word in the description if not
specified) to get the buffer name. Users may choose to set the
same identifier for multiple commands to mark them as
incompatible (only one can run at a given time). This relies on
commands like `compile' which notify the user that a buffer with
the same name already has a process running.
To illustrate usage of `disproject-custom-suffixes', for
example, the following may be used as a dir-locals.el value for
some project to add \"make -k\" and \"guile --help\" as compile
commands and some custom `find-file' call commands:
((\"m\" \"Make\"
:command-type compile
:command \"echo Running make...; make -k\"
:identifier \"make\")
(\"h\" \"Get help from a program (if it supports --help)\"
:command-type compile
:command (lambda (program)
(interactive \"sProgram: \")
(concat program \" --help\"))
:identifier \"guile-help\")
(\"r\" \"Sleep for a couple of seconds\"
:command-type run
:command \"echo Sleeping... && sleep 5 && echo Done sleeping.\")
(\"f\" \"Find a file\"
:command-type call
:command #\\='find-file)
(\"F\" \"Announce the finding a file\"
:command-type call
:command (lambda ()
(interactive)
(message \"FINDING A FILE!\")
(call-interactively #\\='find-file))))
This variable is marked safe due to various reasons discussed in
`disproject-custom--suffixes-allowed?'. Prompts are deferred to
the mentioned function, called when setting up the custom
dispatch menu. Non-default values must still be explicitly
allowed by the user - this may be unsafe if unconditionally
evaluated."
:type '(repeat (list (string :tag "Key bind")
(string :tag "Description")
(plist :inline t
:tag "Properties"
:key-type (choice (const :command-type)
(const :command)
(const :identifier)))))
:group 'disproject)
;;;###autoload(put 'disproject-custom-suffixes 'safe-local-variable #'always)
;;;;; Customizable Disproject commands.
(defcustom disproject-find-dir-command #'project-find-dir
"Command to find a directory in a project.
This is called whenever the function `disproject-find-dir' is
invoked."
:type 'function
:group 'disproject
:group 'disproject-commands)
(defcustom disproject-find-file-command #'project-find-file
"Command used for opening a file in a project.
This is called whenever the function `disproject-find-file' is
invoked."
:type 'function
:group 'disproject
:group 'disproject-commands)
(defcustom disproject-find-line-command #'disproject-default-find-line
"Command to find line occurrences in a project's open buffers.
This is called whenever the function `disproject-find-line' is
invoked."
:type 'function
:group 'disproject
:group 'disproject-commands)
(defcustom disproject-find-regexp-command #'project-find-regexp
"Command used for finding regexp matches in a project.
This is called whenever the function `disproject-find-regexp' is
invoked."
:type 'function
:group 'disproject
:group 'disproject-commands)
(defcustom disproject-or-external-find-file-command
#'project-or-external-find-file
"Command used to find a file in a project or its external roots.
This is called whenever the function
`disproject-or-external-find-file' is invoked."
:type 'function
:group 'disproject
:group 'disproject-commands)
(defcustom disproject-or-external-find-regexp-command
#'project-or-external-find-regexp
"Command used to find regexp matches in a project or its external roots.
This is called whenever the function
`disproject-or-external-find-file' is invoked."
:type 'function
:group 'disproject
:group 'disproject-commands)
(defcustom disproject-shell-command #'project-eshell
"Command used for opening a shell in a project.
This is called whenever the function `disproject-shell-command'
is invoked."
:type 'function
:group 'disproject
:group 'disproject-commands)
(defcustom disproject-switch-to-buffer-command #'project-switch-to-buffer
"Command used for switching project buffers.
This is called whenever the function
`disproject-switch-to-buffer' is invoked."
:type 'function
:group 'disproject
:group 'disproject-commands)
(defcustom disproject-vc-status-commands '((Git . magit-status)
(nil . project-vc-dir))
"Alist of entries denoting a VC backend and an associated status command.
BACKEND is a VC backend; see `project-vc-backend-markers-alist'
for recognized keys. COMMAND is a symbol or function that is
called interactively when the suffix is invoked.
In certain cases, COMMAND may be unbound, or an entry for a
selected project's backend is not present. In both of these
cases, the entry with a nil backend will be used instead as a
fallback. A fallback should always be specified.
This is used in the command `disproject-vc-status'."
:type 'alist
:group 'disproject
:group 'disproject-commands)
;;;; Default commands.
(defun disproject-default-find-line (regexp)
"Find matching line in buffers associated with the current project.
REGEXP is a regular expression used to search for occurrences.
This uses `multi-occur' under the hood."
(interactive (list (project--read-regexp)))
(if-let* ((project (project-current)))
(multi-occur (project-buffers project) regexp)
(error "No project in current directory: %s" default-directory)))
;;;; Transient groups.
;; Evaluate at compile-time so `transient-define-prefix' can find definitions.
(eval-and-compile
(defconst disproject--selected-project-header-group
[:description disproject--selected-project-description ""]
"Header for transient prefixes to display the currently selected project."))
;;;
;;; Prefix handling.
;;;
(defun disproject--assert-type (variable value)
"Assert that VALUE matches the type for custom VARIABLE.
A nil value is returned and a warning is signaled if VALUE does
not match the type. Otherwise, this function returns a non-nil
value."
(let ((type (get variable 'custom-type)))
(if (widget-apply (widget-convert type) :match value)
t
;; The rest of the menu should still be usable if a customizable variable
;; type is invalid, so only warn user about invalid types.
(display-warning
'disproject
(format-message "Value: `%S'\nDoes not match type: %s" value type))
nil)))
(defun disproject-custom--suffixes-allowed? (project custom-suffixes)
"Return non-nil if CUSTOM-SUFFIXES for PROJECT has been allowed.
CUSTOM-SUFFIXES should follow the specifications from
`disproject-custom-suffixes'. PROJECT is the project context in
which the suffixes will be checked.
If CUSTOM-SUFFIXES has not been marked as allowed, a prompt will
be made to temporarily or permanently do so.
Due to the tendency for `disproject-custom-suffixes' to be
tweaked or customized, we use this function with limited history
saving to determine if the suffixes are allowed in order to
prevent `safe-local-variable-values' from increasing drastically
in size.
This does not check other projects, because commands may behave
differently depending on the project (e.g. what \"make\" does for
one project can do something else for another).
Saved history of allowed suffixes is currently not implemented.
Only the most recent custom suffixes (i.e. currently used) are
saved."
;; TODO: Add some form of saved history; the
;; `disproject-custom-allowed-suffixes' alist value is a list type to allow
;; for this. This implementation only saves a single custom-suffixes element
;; to the list at the moment.
(let* ((root-directory (project-root project))
(project-suffixes-list (alist-get root-directory
disproject-custom-allowed-suffixes
nil nil #'equal)))
(or (seq-some (lambda (suffixes)
(equal suffixes custom-suffixes))
project-suffixes-list)
(let* ((buf (get-buffer-create "*Custom Suffixes*")))
(with-current-buffer buf
(erase-buffer)
(insert "\
This project has modified local custom suffixes, which may be risky.
Allow the custom suffixes? You can type
y -- to allow the custom suffixes.
n -- to ignore them and use the default custom suffixes.
! -- to permanently allow the custom suffixes."
"\n\n")
;; TODO: Replace this pretty print with a custom one to give a more
;; uniform layout (e.g. new line for each keyword followed by
;; value). This one is particularly funky with the ":" prefix.
(cl-prettyprint custom-suffixes)
(setq-local cursor-type nil)
(set-buffer-modified-p nil)
(goto-char (point-min)))
;; FIXME: If the user presses an invalid key in the menu after
;; answering prompt, the menu does not quit until a valid key is
;; pressed (e.g. "C-g" doesn't quit it, but "SPC").
(save-window-excursion
(pop-to-buffer buf '(display-buffer-at-bottom))
(prog1
(pcase (read-char-choice "Type y, n, or !: " '(?y ?n ?!))
(?y t)
(?n nil)
(?! (progn
(setf (alist-get root-directory
disproject-custom-allowed-suffixes
nil nil #'equal)
(list custom-suffixes))
(customize-push-and-save
'disproject-custom-allowed-suffixes
disproject-custom-allowed-suffixes)
t)))
(quit-window t)))))))
(defun disproject--selected-project-description ()
"Return a Transient menu headline to indicate the currently selected project."
(format (propertize "Project: %s" 'face 'transient-heading)
(if-let* ((scope (disproject--scope))
(project (disproject-scope-selected-project scope))
(root (disproject-project-root project)))
(propertize root 'face 'transient-value)
(propertize "None detected" 'face 'transient-inapt-suffix))))
;;;; Prefix classes.
;;;;; General Disproject prefix class.
(defclass disproject-prefix (transient-prefix) ()
"General Disproject prefix class.
All prefixes that need to make use of `disproject-scope' as the
scope object should be of this type or inherit from it, as it is
responsible for preserving the scope across menus.")
(cl-defmethod initialize-instance :after ((obj disproject-prefix) &rest _slots)
"Add OBJ command to `disproject-prefix--transient-commands' if not a member."
(let ((command (oref obj command)))
(unless (memq command disproject-prefix--transient-commands)
(add-to-list 'disproject-prefix--transient-commands command))))
(cl-defmethod transient-init-scope ((obj disproject-prefix))
"Initialize transient scope for OBJ.
Inherit the current prefix's scope if it is part of
`disproject-prefix--transient-commands'; otherwise, initialize a
new `disproject-scope' scope value if it hasn't already been
initialized."
(if (memq transient-current-command disproject-prefix--transient-commands)
(let ((scope (disproject--scope)))
(setf (disproject-scope-prefer-other-window? scope)
(disproject--state-prefer-other-window?))
(oset obj scope scope))
;; This method is also called for situations like returning from a
;; sub-prefix, in which case we want to keep the existing scope.
(unless (oref obj scope)
(oset obj scope (disproject-scope)))))
;;;;; Disproject custom-suffixes prefix
;; HACK: A prefix specific to custom-dispatch is needed to avoid an issue caused
;; by prompts. `disproject-custom--setup-suffixes' is perfectly capable of
;; getting custom-suffixes, but when a prompt is made in it, there is breakage
;; in the menu; e.g. pressing invalid keys can result in the menu being "sticky"
;; and passing inputs to the current buffer instead of the transient menu. This
;; may be an upstream issue that has something to do with prompts made during
;; transient setup.
(defclass disproject--custom-suffixes-prefix (disproject-prefix) ()
"Class for Disproject prefixes that need to use custom suffixes.")
(cl-defmethod transient-init-scope ((obj disproject--custom-suffixes-prefix))
"Ensure custom suffixes are loaded after initializing scope for OBJ."
(cl-call-next-method)
(disproject-project-custom-suffixes
(disproject-scope-selected-project-ensure (oref obj scope))))
;;;; Disproject prefix command/group aptness predicates.
;; These predicates are specifically meant for usage during transient setup of
;; `disproject-prefix' prefixes. Calling these in any other situation may lead
;; to unexpected/undesired results.
(defun disproject-prefix--feature-magit-clone? ()
"Return non-nil if `magit-clone' is an available library."
(featurep 'magit-clone))
(defun disproject-prefix--feature-magit-status? ()
"Return non-nil if `magit-status' is an available library."
(featurep 'magit-status))
(defun disproject-prefix--git-clone-fallback-apt? ()
"Return non-nil if the \"git clone\" fallback command should be used."
(and (not (featurep 'magit-clone)) (executable-find "git")))
(defun disproject-prefix--git-init-fallback-apt? ()
"Return non-nil if the \"git init\" fallback command should be used."
(and (not (featurep 'magit-status)) (executable-find "git")))
(defun disproject-prefix--in-default-project? ()
"Return non-nil if the selected project is also the default project."
(if-let* ((scope (transient-scope)))
(disproject-scope-project-is-default? scope)))
(defun disproject-prefix--magit-apt? ()
"Return non-nil if magit commands are apt to show."
(and (featurep 'magit)
(if-let* ((scope (transient-scope))
(project (disproject-scope-selected-project scope)))
(eq 'Git (disproject-project-backend project)))))
(defun disproject-prefix--magit-todos-apt? ()
"Return non-nil if `magit-todos' commands are apt to show."
(and (featurep 'magit-todos)
(disproject-prefix--magit-apt?)))
(defun disproject-prefix--version-control-apt? ()
"Return non-nil if version control commands are apt to show.
Consider commands apt when no project is selected, since the
state already implies that a prompt will be made to select a
project."
(if-let* ((project (disproject-scope-selected-project (transient-scope))))
(disproject-project-backend project)
t))
;;;; Prefixes.
;;;###autoload (autoload 'disproject-dispatch "disproject" nil t)
(transient-define-prefix disproject-dispatch (&optional project)
"Dispatch some command for a project.
PROJECT is an optional argument that tells the function what to
start with as the selected project. This argument is deprecated;
`project-current-directory-override' should be used instead.
See Info node `(transient)Modifying Existing Transients' for
information on inserting user-defined suffix commands to this
menu."
:class disproject-prefix
:refresh-suffixes t
[:description
disproject--selected-project-description
("p" "Switch project" disproject-switch-project
:transient t)
("P" "Switch to open project" disproject-switch-project-open
:transient t)
("C-p" "Manage projects" disproject-manage-projects-dispatch)]
["Options"
(",o" "Prefer other window" "--prefer-other-window")]
["Deprecated options"
:hide always
;; DEPRECATED: Remove at least 1 month after deprecation.
("o" "Prefer other window (deprecated)"
(lambda () (interactive)
(seq-each (lambda (suffix)
(when (and (object-of-class-p suffix 'transient-switch)
(equal "--prefer-other-window"
(oref suffix argument)))
(oset suffix value (transient-infix-read suffix))
(message
(concat "Key-bind \"o\" for --prefer-other-window is"
" deprecated; please use \",o\" instead"))))
(transient-suffixes 'disproject-dispatch)))
:transient t)]
["Main commands"
:pad-keys t
[("b" "Switch buffer" disproject-switch-to-buffer)
("B" "Buffer list" disproject-list-buffers)
("c" disproject-compile)
("d" "Dired" disproject-dired)
("k" "Kill buffers" disproject-kill-buffers)
("l" "Dir-locals file" disproject-dir-locals)
("s" "Shell" disproject-shell)
("v" disproject-vc-status
:inapt-if-not disproject-prefix--version-control-apt?)]
[("!" "Run" disproject-shell-command)
("M-x" "Extended cmd." disproject-execute-extended-command)]
["Find"
("D" "directory" disproject-find-dir)
("f" "file" disproject-find-file)
("F" "file (+external)" disproject-or-external-find-file)
("g" "regexp" disproject-find-regexp)
("G" "regexp (+external)" disproject-or-external-find-regexp)
("L" "line occurrence" disproject-find-line)
("T" "todos" disproject-magit-todos-list
:if disproject-prefix--magit-todos-apt?)]]
["Version control"
:hide always
:if disproject-prefix--version-control-apt?
("m" "Magit" disproject-magit-commands-dispatch
:if disproject-prefix--magit-apt?)]
[("SPC" "Custom dispatch" disproject-custom-dispatch
:transient transient--do-replace)]
(interactive)
;; DEPRECATED: Remove at least 1 month after deprecation.
(when project
(display-warning 'disproject "\
PROJECT argument for `disproject-dispatch' is deprecated since after v1.2"))
(let ((project-current-directory-override (or (and project (project-root project))
project-current-directory-override)))
(transient-setup
'disproject-dispatch nil nil
;; XXX: Preserve options in scope if we're coming from another Disproject
;; Transient. `:refresh-suffixes' being true causes the `:init-value'
;; function to be called every refresh which messes up --prefer-other-window,
;; so that can't be used.
:value `(,@(if (disproject--state-prefer-other-window?)
'("--prefer-other-window"))))))
(transient-define-prefix disproject-custom-dispatch (&optional project)
"Dispatch custom suffix commands.
If non-nil, PROJECT is used as the project to dispatch custom
commands for. This argument is deprecated;
`project-current-directory-override' should be used instead.
This prefix can be configured with `disproject-custom-suffixes';
see its documentation for more information.
Suffixes have an associated buffer that is tracked for command
process activity; this is shown in the menu in the form of
\"[CHAR]\", where the string is color-coded and CHAR is a single
character. These characters represent the following states:
[a]: Command is active.
[i]: Command is inactive."
:class disproject--custom-suffixes-prefix
:refresh-suffixes t
disproject--selected-project-header-group
["Custom suffix commands"
:class transient-column
:pad-keys t
:setup-children disproject-custom--setup-suffixes]
[("SPC" "Main dispatch" disproject-dispatch
:transient transient--do-replace)]
(interactive)
;; DEPRECATED: Remove at least 1 month after deprecation.
(when project
(display-warning 'disproject "\
PROJECT argument for `disproject-custom-dispatch' is deprecated since after v1.2"))
(let ((project-current-directory-override (or (and project (project-root project))
project-current-directory-override)))
(transient-setup
'disproject-custom-dispatch nil nil)))
;; DEPRECATED: Remove at least 1 month after earliest release with deprecation.
(transient-define-prefix disproject-magit-commands-dispatch ()
"Dispatch Magit-related commands for a project.
Some commands may not be available if the selected project is not
the same as the default (current buffer) one."
:class disproject-prefix
disproject--selected-project-header-group
["Magit commands"
("d" "Dispatch" magit-dispatch
:inapt-if-not disproject-prefix--in-default-project?)
("f" "File dispatch" magit-file-dispatch
:inapt-if-not disproject-prefix--in-default-project?)
("m" "Status" disproject-magit-status)
("T" "Todos" disproject-magit-todos-list
:if (lambda () (featurep 'magit-todos)))])
(make-obsolete 'disproject-magit-commands-dispatch
"some commands have been moved to `disproject-dispatch'."
"after v1.2")
(transient-define-prefix disproject-manage-projects-dispatch ()
"Dispatch commands for managing projects."
["New"
("n g c" "git clone" magit-clone
:if disproject-prefix--feature-magit-clone?)
("n g c" "git clone" disproject-git-clone-fallback
:if disproject-prefix--git-clone-fallback-apt?)
("n g i" "git init" magit-init
:if disproject-prefix--feature-magit-status?)
("n g i" "git init" disproject-git-init-fallback
:if disproject-prefix--git-init-fallback-apt?)]
["Forget"
;; TODO: Could add an option to close buffers of the project to forget.
("f p" "a project" disproject-forget-project)
("f u" "projects under..." disproject-forget-projects-under)
("f z" "zombie projects" disproject-forget-zombie-projects)]
["Remember"
("r o" "open projects" disproject-remember-projects-open)
("r u" "projects under..." disproject-remember-projects-under)]
["Deprecated"
:hide always
;; DEPRECATED: Remove when `disproject-remember-projects-active' is removed.
("r a" "active projects" disproject-remember-projects-active)])
;;;
;;; Transient state handling.
;;;
(defun disproject--open-projects ()
"Return a list of projects with open buffers."
(let* ((buffer-list
;; Ignore ephemeral buffers
(match-buffers (lambda (buf)
(not (string-prefix-p " " (buffer-name buf))))))
(directories
(cl-remove-duplicates (mapcar
(lambda (buf)
(buffer-local-value 'default-directory buf))
buffer-list)
:test #'equal)))
(cl-remove-duplicates
(seq-mapcat (lambda (directory)
(if-let* ((project (project-current nil directory)))
(list project)))
directories)
:test (lambda (p1 p2) (equal (project-root p1) (project-root p2))))))
(defun disproject--scope ()
"Return the scope for a `disproject-prefix' prefix."
;; Always fall back to initializing scope from `disproject-prefix' (i.e. class
;; of `disproject-dispatch') rather than a child class to be predictable.
(transient-scope (cons 'disproject-dispatch
disproject-prefix--transient-commands)))
;;;; Transient state classes.
;;;;; Project class.
(defclass disproject-project ()
;; root must be a path to a valid project. An `initialize-instance' method
;; for this class enforces this.
((root :reader disproject-project-root
:initarg :root
:type string
:documentation "Project root directory.")
(instance :reader disproject-project-instance
:type list
:documentation "Project `project.el' instance.")
(backend :reader disproject-project-backend
:type symbol
:documentation "Project VC backend.")
(custom-suffixes :reader disproject-project-custom-suffixes
:type list
:documentation "\
Project's custom suffixes as described in
`disproject-custom-suffixes'."))
"Class representing a `project.el' project.
Instances of this class are initialized by providing the `:root'
initialization argument, which is the only argument available.
Other slots depend on this value, and are lazily fetched as
needed when calling readers. These fetched values are then
cached for subsequent queries.")
(cl-defmethod initialize-instance :after ((obj disproject-project) &rest _slots)
"Do additional initialization for a `disproject-project' instance.
This enforces that the root is part of a valid project. If
unbound, `project-current' will be invoked, which may prompt the
user for a path. If the path does not lead to a valid project,
an error will be signaled. \"Transient\" project instances are
not considered valid.
If the directory provided is not actually the root directory, the
slot will also be changed to the detected root.
Additionally, the project will be force-remembered as a known
project as a last step of initialization."
(let* ((provided-root (if (slot-boundp obj 'root)
(oref obj root)
(project-root (project-current t))))
(project (oset obj instance (project-current nil provided-root))))
(unless project
(error "Root directory does not lead to valid project: %s" provided-root))
;; The provided root may be a sub-directory, so we re-set it to the root
;; determined by `project.el'.
(oset obj root (project-root project))
;; Remember the project in case it's not in `project-known-project-roots'.
(project-remember-project project)))
(defun disproject-project-or-nil (&optional directory)
"Return a `disproject-project' instance for DIRECTORY, or maybe nil.
DIRECTORY is passed to `project-current' to detect a project."
(if-let* ((project (project-current nil directory)))
(disproject-project :root (project-root project))))
(cl-defmethod disproject-project-backend ((obj disproject-project))
"Return the OBJ project backend.
This internally uses `project-try-vc' to determine the backend."
(if (slot-boundp obj 'backend)
(oref obj backend)
;; XXX: `project-find-functions' (used in `project-current') doesn't enforce
;; a project instance format, so we can't expect the VC backend to be in the
;; same place in `disproject-project-instance'. Instead, we specifically
;; rely on `project-try-vc' (`project-vc-backend-markers-alist') to get the
;; backend.
(oset obj backend (let* ((root (disproject-project-root obj))
(instance (project-try-vc root)))
;; Expect index 1 to be the VC backend of the project
;; instance.
(nth 1 instance)))))
(cl-defmethod disproject-project-custom-suffixes ((obj disproject-project))
"Return the OBJ project custom suffixes."
(if (slot-boundp obj 'custom-suffixes)
(oref obj custom-suffixes)
(oset obj
custom-suffixes
(if-let*
((project (disproject-project-instance obj))
(root (disproject-project-root obj))
(suffixes
;; Retrieve custom suffixes without triggering dir-locals
;; permissions prompt.
(alist-get 'disproject-custom-suffixes
(with-temp-buffer
(let ((default-directory root))
(hack-dir-local--get-variables nil)))))
((disproject--assert-type 'disproject-custom-suffixes suffixes))
((disproject-custom--suffixes-allowed? project suffixes)))
suffixes
(default-value 'disproject-custom-suffixes)))))
;;;;; Scope class.
(defclass disproject-scope ()
((selected-project :initarg :selected-project
:accessor disproject-scope-selected-project
:initform nil
:type (or null disproject-project)
:documentation "\
Currently selected project object in the transient menu, if any.
If no value is provided during initialization, the function
`project-current' is used to find one for initializing a
`disproject-project' object. This slot may be nil.")
(default-project :reader disproject-scope-default-project
:initform nil
:type (or null disproject-project)
:documentation "\
Project object belonging to `default-directory' at the time of
initialization (or the current buffer, in other words), if any.")
(prefer-other-window? :initarg :prefer-other-window?
:accessor disproject-scope-prefer-other-window?
:initform nil
:documentation "Non-nil to prefer other window."))
"Class representing a Disproject menu's transient scope.
Objects of this type are intended to be used in a transient
prefix's `:scope' slot, and contains information regarding the
default project, selected project, and other state like option
values that should be shared with other menus.
In Disproject prefixes, this scope object is normally fetched via
the function `disproject--scope'.")
(cl-defmethod initialize-instance :after ((obj disproject-scope) &rest _slots)
"Do additional initialization for scope OBJ."
(let* ((default-project-obj
(disproject-project-or-nil default-directory))
(selected-project-obj
;; `project-current' may read other variables like
;; `project-current-directory-override', which may make the initial
;; selected project different from the default project (only
;; `default-directory' is read for the latter).
(if-let* ((current-project (project-current))
;; Use `default-project-obj' if the projects happen to be
;; the same so cached values are shared.
((or (not default-project-obj)
(not (file-equal-p
(project-root current-project)
(disproject-project-root default-project-obj))))))
(disproject-project :root (project-root current-project))
default-project-obj)))
(when default-project-obj
(oset obj default-project default-project-obj))
(when selected-project-obj
(oset obj selected-project selected-project-obj))))
(cl-defmethod disproject-scope-selected-project ((obj disproject-scope))
"Return scope OBJ selected project. May be nil."
(if (slot-boundp obj 'selected-project)
(oref obj selected-project)))
(cl-defmethod disproject-scope-selected-project-ensure ((obj disproject-scope))
"Return scope OBJ selected project.
If the selected-project slot is nil, a new instance of
`disproject-project' will be initialized and written to the slot.
The user may be prompted for a project."
(or (disproject-scope-selected-project obj)
(oset obj selected-project (disproject-project))))
(cl-defmethod disproject-scope-default-project ((obj disproject-scope))
"Return scope OBJ default project. May be nil."
(if (slot-boundp obj 'default-project)
(oref obj default-project)))
(cl-defmethod disproject-scope-project-is-default? ((obj disproject-scope))
"Return non-nil if the OBJ scope's selected and default projects are the same."
(and-let* ((default-project (disproject-scope-default-project obj))
(selected-project (disproject-scope-selected-project obj)))
(file-equal-p (disproject-project-root default-project)
(disproject-project-root selected-project))))
;;;; Getters for infix arguments.
(defun disproject--state-prefer-other-window? ()
"Return whether other window should be preferred when displaying buffers."
(if (eq transient-current-command 'disproject-dispatch)
(let ((args (transient-args transient-current-command)))
(and args (transient-arg-value "--prefer-other-window" args)))
(disproject-scope-prefer-other-window? (disproject--scope))))
;;;
;;; Suffix handling.
;;;
(defun disproject-process-buffer-name (project-dir &optional identifier)
"Return a project's process buffer name corresponding to IDENTIFIER.
PROJECT-DIR is the project directory, which will be used to give
project buffers a unique namespace.
IDENTIFIER is an optional string argument that can be specified
to make the buffer name unique to the project's process buffers.
If non-nil, \"default\" is used as the identifier.
This function is *not* meant to be used like
`project-prefixed-buffer-name', although it is similar in
functionality; the identifier should not be tied to the buffer
mode in any way. It should be the only means of making a name
unique in the context of a project. This allows users to track
buffers based on just an identifier and also allow specifying
incompatible commands (e.g. if two commands use the same buffer
name, they should not be allowed to run at the same time)."
(concat "*"
(file-name-nondirectory (directory-file-name project-dir))
"-process|"
(or identifier "default")
"*"))
(defun disproject-add-sentinel-refresh-transient (buffer-name)
"Add function to a buffer's process sentinel to refresh transient, if active.
BUFFER-NAME is the name of the buffer with a process sentinel the
function will be added to."
(when-let* ((buffer (get-buffer buffer-name))
(process (get-buffer-process buffer))
((not (advice-function-member-p
#'disproject--refresh-transient
(process-sentinel process)))))
(add-function
:before (process-sentinel process)
#'disproject--refresh-transient)))
(defun disproject-custom--suffix (spec-entry)
"Construct and return a suffix to be parsed by `transient-parse-suffixes'.
SPEC-ENTRY is a single entry from the specification described by
`disproject-custom-suffixes'."
(pcase spec-entry
(`( ,key ,description
.
,(map :command-type :command :identifier))
(let* ((project (disproject-scope-selected-project-ensure
(disproject--scope)))
;; Fall back to description if identifier is not provided.
;; Uniqueness is preferred over the name looking nice to prevent
;; unintentionally making commands incompatible.
(identifier (or identifier description))
(disproject-process-buffer-name (disproject-process-buffer-name
(disproject-project-root project)
identifier)))
`(,key
,(disproject-custom--suffix-description
(get-buffer disproject-process-buffer-name)
description)
(lambda ()
(interactive)
;; Expose buffer name to the user; see note in
;; `disproject-custom-suffixes'.
(let ((disproject-process-buffer-name ,disproject-process-buffer-name))
,(disproject-custom--suffix-command command-type command)
(disproject-add-sentinel-refresh-transient
disproject-process-buffer-name))))))))
(defun disproject-custom--suffix-command (command-type command)
"Dispatch a command s-expression to be evaluated in a custom suffix.
COMMAND-TYPE is a symbol corresponding to a command type
documented in `disproject-custom-suffixes'.
COMMAND is an yet-to-be-evaluated s-expression which is inserted
appropriately according to the command type.
Note that the returned s-expressions may expect
`disproject-process-buffer-name' to be set when evaluated; this
value is expected to be the name of the buffer which processes
will run."
(pcase command-type
('bare-call
`(let ((command ,command))
(cond
((commandp command t)
(call-interactively command))
(t
,(disproject-custom--suffix-command-type-error
"Not an interactive function" command-type command)))))
('call
`(disproject-with-environment
(let ((command ,command))
(cond
((commandp command t)
(call-interactively command))
(t
,(disproject-custom--suffix-command-type-error
"Not an interactive function" command-type command))))))
('compile
`(disproject-with-environment
(let* ((compilation-buffer-name-function
(lambda (&rest _ignore) disproject-process-buffer-name))
(command ,command))
(compile (cond