bug#73357: [PATCH] Make vc-clone interactive

[Aleksandr Vityazev via "Bug reports for GNU Emacs, the Swiss army knife of text editors" <bug-gnu-emacs@gnu.org>]

On 2024-10-12 15:06, Eli Zaretskii wrote:

>> From: Aleksandr Vityazev <avityazev@disroot.org>
>> Cc: Eli Zaretskii <eliz@gnu.org>,  73357@debbugs.gnu.org
>> Date: Sun, 06 Oct 2024 17:50:54 +0300
>> 
>> On 2024-10-01 11:09, Philip Kaludercic wrote:
>> 
>> > Aleksandr Vityazev <avityazev@disroot.org> writes:
>> >
>> >
>> > [...]
>> >
>> >>>> +          (if backend
>> >>>> +              (progn
>> >>>> +                (unless (memq backend vc-handled-backends)
>> >>>> +                  (error "Unknown VC backend %s" backend))
>> >>>> +                (vc-call-backend backend 'clone remote directory rev))
>> >>>> +            (catch 'ok
>> >>>> +              (dolist (backend vc-handled-backends)
>> >>>> +                (ignore-error vc-not-supported
>> >>>> +                  (when-let ((res (vc-call-backend
>> >>>> +                                   backend 'clone
>> >>>> +                                   remote directory rev)))
>> >>>> +                    (throw 'ok res)))))))
>> >>>> +    (when (file-directory-p directory)
>> >>>> +      (if (called-interactively-p 'interactive)
>> >>>
>> >>> Perhaps we can add a FIND-FILE argument to the end, so that it is also
>> >>> possible to open the directory from a script as well.
>> >>
>> >> might be useful, added and documented in doc string.
>> >>
>> >>>
>> >>>> +          (find-file directory)
>> >>>> +        directory))))
>> >>>
>> >>> I'd always return `directory', that seems simpler.
>> >>
>> >> Simpler, but it seems logical to switch to a directory when using it
>> >> interactively. I left it as it was.
>> >
>> > What I meant was to write
>> >
>> >   (defun vc-clone (... &optional ... open-dir)
>> >     (interactive (list ... t))
>> >     ...
>> >     (when open-dir
>> >       (dired directory))
>> >     directory)  
>> >
>> > instead of
>> >
>> >   (defun vc-clone (... &optional ... open-dir)
>> >     (interactive (list ... t))
>> >     ...
>> >     (if open-dir
>> >         (dired directory)
>> >       directory))
>> >
>> > The advantage is that you can still request the directory to be opened
>> > when invoked non-interactively, you avoid the ambiguity of
>> > `called-interactively-p' and the return value is always of the same
>> > type, and not sometimes whatever `find-file'/`dired' returns.
>> >
>> >>>
>> >>>>  
>> >>>>  (declare-function log-view-current-tag "log-view" (&optional pos))
>> >>>>  (defun vc-default-last-change (_backend file line)
>> >>>> -- 
>> >>>> 2.46.0
>> >>
>> >> V3 patch: 
>> >>
>> >> From 6d5dbb1d1354d7476caaeeecfe15b8fd6335490a Mon Sep 17 00:00:00 2001
>> >> Message-ID: <6d5dbb1d1354d7476caaeeecfe15b8fd6335490a.1727634026.git.avityazev@disroot.org>
>> >> From: Aleksandr Vityazev <avityazev@disroot.org>
>> >> Date: Sun, 29 Sep 2024 21:13:28 +0300
>> >> Subject: [PATCH] Make vc-clone interactive
>> >>
>> >> * lisp/vc/vc.el (vc-clone): Make interactive.  Add optional
>> >> argument FIND-FILE. Mention these changes in the doc string.
>> >> (vc--remotes-history): New defvar.
>> >> * lisp/emacs-lisp/package-vc (package-vc--backend-type,
>> >> package-vc-heuristic-alist, package-vc--guess-backend):
>> >> Rename and move to ...
>> >> (package-vc-default-backend): Set type to vc-backend-type.
>> >> (package-vc--clone, package-vc--read-package-name, package-vc-install,
>> >> package-vc-checkout): Use vc-guess-backend.
>> >> * lisp/vc/vc (vc-backend-type, vc-heuristic-alist, vc-guess-backend):
>> >> ... here.
>> >> * etc/NEWS: Announce these changes.
>> >
>> > I think it would cleaner if we split this up into two commits:
>> >
>> > 1. Moving `package-vc-heuristic-alist',
>> > 2. Making `vc-clone' interactive.
>> >
>> 
>> done
>> 
>> >> ---
>> >>  etc/NEWS                      |  12 ++++
>> >>  lisp/emacs-lisp/package-vc.el |  75 ++--------------------
>> >>  lisp/vc/vc.el                 | 115 +++++++++++++++++++++++++++++-----
>> >>  3 files changed, 118 insertions(+), 84 deletions(-)
>> >>
>> >> diff --git a/etc/NEWS b/etc/NEWS
>> >> index aaf3783f006..3722e12c01d 100644
>> >> --- a/etc/NEWS
>> >> +++ b/etc/NEWS
>> >> @@ -444,6 +444,18 @@ toggle.
>> >>  Putting (require 'midnight) in your init file no longer activates the
>> >>  mode.  Now, one needs to say (midnight-mode +1) instead.
>> >>  
>> >> +** VC
>> >> +
>> >> +*** 'vc-clone' is now an interactive command.
>> >> +When called interactively, 'vc-clone' now prompts for the remote
>> >> +repository address, the backend for cloning, if it has not been
>> >> +determined automatically according to the URL, and the directory to
>> >> +clone the repository into.
>> >> +
>> >> +*** 'vc-clone' now accepts an optional argument FIND-FILE.
>> >> +When the argument is non-nil, the function switches to a buffer visiting
>> >> +directory to which the repository was cloned.
>> >> +
>> >>  \f
>> >>  * New Modes and Packages in Emacs 31.1
>> >>  
>> >> diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el
>> >> index e168096e153..82b450368d0 100644
>> >> --- a/lisp/emacs-lisp/package-vc.el
>> >> +++ b/lisp/emacs-lisp/package-vc.el
>> >> @@ -63,62 +63,6 @@ package-vc
>> >>  (defconst package-vc--elpa-packages-version 1
>> >>    "Version number of the package specification format understood by package-vc.")
>> >>  
>> >> -(defconst package-vc--backend-type
>> >> -  `(choice :convert-widget
>> >> -           ,(lambda (widget)
>> >> -              (let (opts)
>> >> -                (dolist (be vc-handled-backends)
>> >> -                  (when (or (vc-find-backend-function be 'clone)
>> >> -                            (alist-get 'clone (get be 'vc-functions)))
>> >> -                    (push (widget-convert (list 'const be)) opts)))
>> >> -                (widget-put widget :args opts))
>> >> -              widget))
>> >> -  "The type of VC backends that support cloning package VCS repositories.")
>> >> -
>> >> -(defcustom package-vc-heuristic-alist
>> >> -  `((,(rx bos "http" (? "s") "://"
>> >> -          (or (: (? "www.") "github.com"
>> >> -                 "/" (+ (or alnum "-" "." "_"))
>> >> -                 "/" (+ (or alnum "-" "." "_")))
>> >> -              (: "codeberg.org"
>> >> -                 "/" (+ (or alnum "-" "." "_"))
>> >> -                 "/" (+ (or alnum "-" "." "_")))
>> >> -              (: (? "www.") "gitlab" (+ "." (+ alnum))
>> >> -                 "/" (+ (or alnum "-" "." "_"))
>> >> -                 "/" (+ (or alnum "-" "." "_")))
>> >> -              (: "git.sr.ht"
>> >> -                 "/~" (+ (or alnum "-" "." "_"))
>> >> -                 "/" (+ (or alnum "-" "." "_")))
>> >> -              (: "git." (or "savannah" "sv") "." (? "non") "gnu.org/"
>> >> -                 (or "r" "git") "/"
>> >> -                 (+ (or alnum "-" "." "_")) (? "/")))
>> >> -          (or (? "/") ".git") eos)
>> >> -     . Git)
>> >> -    (,(rx bos "http" (? "s") "://"
>> >> -          (or (: "hg.sr.ht"
>> >> -                 "/~" (+ (or alnum "-" "." "_"))
>> >> -                 "/" (+ (or alnum "-" "." "_")))
>> >> -              (: "hg." (or "savannah" "sv") "." (? "non") "gnu.org/hgweb/"
>> >> -                 (+ (or alnum "-" "." "_")) (? "/")))
>> >> -          eos)
>> >> -     . Hg)
>> >> -    (,(rx bos "http" (? "s") "://"
>> >> -          (or (: "bzr." (or "savannah" "sv") "." (? "non") "gnu.org/r/"
>> >> -                 (+ (or alnum "-" "." "_")) (? "/")))
>> >> -          eos)
>> >> -     . Bzr))
>> >> -  "Alist mapping repository URLs to VC backends.
>> >> -`package-vc-install' consults this alist to determine the VC
>> >> -backend from the repository URL when you call it without
>> >> -specifying a backend.  Each element of the alist has the form
>> >> -\(URL-REGEXP . BACKEND).  `package-vc-install' will use BACKEND of
>> >> -the first association for which the URL of the repository matches
>> >> -the URL-REGEXP of the association.  If no match is found,
>> >> -`package-vc-install' uses `package-vc-default-backend' instead."
>> >> -  :type `(alist :key-type (regexp :tag "Regular expression matching URLs")
>> >> -                :value-type ,package-vc--backend-type)
>> >> -  :version "29.1")
>> >> -
>> >
>> > This should certainly be replaced by a
>> > `define-obsolete-variable-alias'!
>> 
>> Fixed 
>> >
>> >>  (defcustom package-vc-default-backend 'Git
>> >>    "Default VC backend to use for cloning package repositories.
>> >>  `package-vc-install' uses this backend when you specify neither
>> >> @@ -127,7 +71,7 @@ package-vc-default-backend
>> >>  
>> >>  The value must be a member of `vc-handled-backends' that supports
>> >>  the `clone' VC function."
>> >> -  :type package-vc--backend-type
>> >> +  :type vc-backend-type
>> >>    :version "29.1")
>> >>  
>> >>  (defcustom package-vc-register-as-project t
>> >> @@ -626,13 +570,6 @@ package-vc--unpack-1
>> >>                   "")))
>> >>      t))
>> >>  
>> >> -(defun package-vc--guess-backend (url)
>> >> -  "Guess the VC backend for URL.
>> >> -This function will internally query `package-vc-heuristic-alist'
>> >> -and return nil if it cannot reasonably guess."
>> >> -  (and url (alist-get url package-vc-heuristic-alist
>> >> -                      nil nil #'string-match-p)))
>> >> -
>> >>  (declare-function project-remember-projects-under "project" (dir &optional recursive))
>> >>  
>> >>  (defun package-vc--clone (pkg-desc pkg-spec dir rev)
>> >> @@ -646,7 +583,7 @@ package-vc--clone
>> >>      (unless (file-exists-p dir)
>> >>        (make-directory (file-name-directory dir) t)
>> >>        (let ((backend (or (plist-get pkg-spec :vc-backend)
>> >> -                         (package-vc--guess-backend url)
>> >> +                         (vc-guess-backend url)
>> >>                           (plist-get (alist-get (package-desc-archive pkg-desc)
>> >>                                                 package-vc--archive-data-alist
>> >>                                                 nil nil #'string=)
>> >> @@ -753,7 +690,7 @@ package-vc--read-package-name
>> >>                             ;; pointing towards a repository, and use that as a backup
>> >>                             (and-let* ((extras (package-desc-extras (cadr pkg)))
>> >>                                        (url (alist-get :url extras))
>> >> -                                      ((package-vc--guess-backend url)))))))
>> >> +                                      ((vc-guess-backend url)))))))
>> >>                     (not allow-url)))
>> >>  
>> >>  (defun package-vc--read-package-desc (prompt &optional installed)
>> >> @@ -917,7 +854,7 @@ package-vc-install
>> >>       (cdr package)
>> >>       rev))
>> >>     ((and-let* (((stringp package))
>> >> -               (backend (or backend (package-vc--guess-backend package))))
>> >> +               (backend (or backend (vc-guess-backend package))))
>> >>        (package-vc--unpack
>> >>         (package-desc-create
>> >>          :name (or name (intern (file-name-base package)))
>> >> @@ -930,7 +867,7 @@ package-vc-install
>> >>         (or (package-vc--desc->spec (cadr desc))
>> >>             (and-let* ((extras (package-desc-extras (cadr desc)))
>> >>                        (url (alist-get :url extras))
>> >> -                      (backend (package-vc--guess-backend url)))
>> >> +                      (backend (vc-guess-backend url)))
>> >>               (list :vc-backend backend :url url))
>> >>             (user-error "Package `%s' has no VC data" package))
>> >>         rev)))
>> >> @@ -958,7 +895,7 @@ package-vc-checkout
>> >>    (let ((pkg-spec (or (package-vc--desc->spec pkg-desc)
>> >>                        (and-let* ((extras (package-desc-extras pkg-desc))
>> >>                                   (url (alist-get :url extras))
>> >> -                                 (backend (package-vc--guess-backend url)))
>> >> +                                 (backend (vc-guess-backend url)))
>> >>                          (list :vc-backend backend :url url))
>> >>                        (user-error "Package `%s' has no VC data"
>> >>                                    (package-desc-name pkg-desc)))))
>> >> diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el
>> >> index 597a1622f5a..cd877bd8097 100644
>> >> --- a/lisp/vc/vc.el
>> >> +++ b/lisp/vc/vc.el
>> >> @@ -929,7 +929,69 @@ vc-find-revision-no-save
>> >>    :type 'boolean
>> >>    :version "27.1")
>> >>  
>> >> +(defconst vc-backend-type
>> >> +  `(choice :convert-widget
>> >> +     ,(lambda (widget)
>> >> +        (let (opts)
>> >> +          (dolist (be vc-handled-backends)
>> >> +            (when (or (vc-find-backend-function be 'clone)
>> >> +                      (alist-get 'clone (get be 'vc-functions)))
>> >> +              (push (widget-convert (list 'const be)) opts)))
>> >> +          (widget-put widget :args opts))
>> >> +        widget))
>> >> +  "The type of VC backends that support cloning VCS repositories.")
>> >> +
>> >> +(defcustom vc-heuristic-alist
>> >> +  `((,(rx bos "http" (? "s") "://"
>> >> +          (or (: (? "www.") "github.com"
>> >> +               "/" (+ (or alnum "-" "." "_"))
>> >> +               "/" (+ (or alnum "-" "." "_")))
>> >> +              (: "codeberg.org"
>> >> +               "/" (+ (or alnum "-" "." "_"))
>> >> +               "/" (+ (or alnum "-" "." "_")))
>> >> +              (: (? "www.") "gitlab" (+ "." (+ alnum))
>> >> +               "/" (+ (or alnum "-" "." "_"))
>> >> +               "/" (+ (or alnum "-" "." "_")))
>> >> +              (: "git.sr.ht"
>> >> +               "/~" (+ (or alnum "-" "." "_"))
>> >> +               "/" (+ (or alnum "-" "." "_")))
>> >> +              (: "git." (or "savannah" "sv") "." (? "non") "gnu.org/"
>> >> +               (or "r" "git") "/"
>> >> +               (+ (or alnum "-" "." "_")) (? "/")))
>> >> +          (or (? "/") ".git") eos)
>> >> +     . Git)
>> >> +    (,(rx bos "http" (? "s") "://"
>> >> +          (or (: "hg.sr.ht"
>> >> +               "/~" (+ (or alnum "-" "." "_"))
>> >> +               "/" (+ (or alnum "-" "." "_")))
>> >> +              (: "hg." (or "savannah" "sv") "." (? "non") "gnu.org/hgweb/"
>> >> +               (+ (or alnum "-" "." "_")) (? "/")))
>> >> +          eos)
>> >> +     . Hg)
>> >> +    (,(rx bos "http" (? "s") "://"
>> >> +          (or (: "bzr." (or "savannah" "sv") "." (? "non") "gnu.org/r/"
>> >> +               (+ (or alnum "-" "." "_")) (? "/")))
>> >> +          eos)
>> >> +     . Bzr))
>> >> +  "Alist mapping repository URLs to VC backends.
>> >> +`vc-clone' consults this alist to determine the VC
>> >> +backend from the repository URL when you call it without
>> >> +specifying a backend.  Each element of the alist has the form
>> >> +\(URL-REGEXP . BACKEND).  `vc-clone' will use BACKEND of
>> >> +the first association for which the URL of the repository matches
>> >> +the URL-REGEXP of the association."
>> >> +  :type `(alist :key-type (regexp :tag "Regular expression matching URLs")
>> >> +                :value-type ,vc-backend-type)
>> >> +  :version "29.1")
>> >> +
>> >>  \f
>> >> +(defun vc-guess-backend (url)
>> >> +  "Guess the VC backend for URL.
>> >> +This function will internally query `vc-heuristic-alist'
>> >> +and return nil if it cannot reasonably guess."
>> >> +  (and url (alist-get url vc-heuristic-alist
>> >> +                      nil nil #'string-match-p)))
>> >> +
>> >>  ;; File property caching
>> >>  
>> >>  (defun vc-clear-context ()
>> >> @@ -3804,7 +3866,9 @@ vc-check-headers
>> >>    (interactive)
>> >>    (vc-call-backend (vc-backend buffer-file-name) 'check-headers))
>> >>  
>> >> -(defun vc-clone (remote &optional backend directory rev)
>> >> +(defvar vc--remotes-history)
>> >> +
>> >> +(defun vc-clone (remote &optional backend directory rev find-file)
>> >>    "Clone repository REMOTE using version-control BACKEND, into DIRECTORY.
>> >>  If successful, return the string with the directory of the checkout;
>> >>  otherwise return nil.
>> >> @@ -3814,20 +3878,41 @@ vc-clone
>> >>  If BACKEND is nil or omitted, the function iterates through every known
>> >>  backend in `vc-handled-backends' until one succeeds to clone REMOTE.
>> >>  If REV is non-nil, it indicates a specific revision to check out after
>> >> -cloning; the syntax of REV depends on what BACKEND accepts."
>> >> -  (setq directory (expand-file-name (or directory default-directory)))
>> >> -  (if backend
>> >> -      (progn
>> >> -        (unless (memq backend vc-handled-backends)
>> >> -          (error "Unknown VC backend %s" backend))
>> >> -        (vc-call-backend backend 'clone remote directory rev))
>> >> -    (catch 'ok
>> >> -      (dolist (backend vc-handled-backends)
>> >> -        (ignore-error vc-not-supported
>> >> -          (when-let ((res (vc-call-backend
>> >> -                           backend 'clone
>> >> -                           remote directory rev)))
>> >> -            (throw 'ok res)))))))
>> >> +cloning; the syntax of REV depends on what BACKEND accepts.
>> >> +If FIND-FILE is non-nil, switches to a buffer visiting DIRECTORY to
>> >> +which the repository was cloned.  It would be useful in scripts, but not
>> >> +in regular code.
>> >> +If called interactively, prompt for REMOTE, DIRECTORY and BACKEND,
>> >> +if BACKEND has not been automatically determined according to the REMOTE
>> >> +URL, in the minibuffer."
>> >> +  (interactive
>> >> +   (let* ((url (read-string "Remote: " nil 'vc--remotes-history))
>> >> +          (backend (or (vc-guess-backend url)
>> >> +                       (intern (completing-read
>> >> +                                "Backend: " vc-handled-backends nil t)))))
>> >> +     (list url backend
>> >> +           (read-directory-name
>> >> +            "Clone into new or empty directory: " nil nil
>> >> +            (lambda (dir) (or (not (file-exists-p dir))
>> >> +                              (directory-empty-p dir)))))))
>> >> +  (let* ((directory (expand-file-name (or directory default-directory)))
>> >> +         (backend (or backend (vc-guess-backend remote)))
>> >> +         (directory (if backend
>> >> +                        (progn
>> >> +                          (unless (memq backend vc-handled-backends)
>> >> +                            (error "Unknown VC backend %s" backend))
>> >> +                          (vc-call-backend backend 'clone remote directory rev))
>> >> +                      (catch 'ok
>> >> +                        (dolist (backend vc-handled-backends)
>> >> +                          (ignore-error vc-not-supported
>> >> +                            (when-let ((res (vc-call-backend
>> >> +                                             backend 'clone
>> >> +                                             remote directory rev)))
>> >> +                              (throw 'ok res))))))))
>> >> +    (when (file-directory-p directory)
>> >
>> > When is this not true?
>> 
>> 
>> When calling interactively, we can choose a path to a directory that
>> does not exist, then if the clone operation fails, a path that is not a
>> directory will be returned. If the cloning operation succeeds, it will
>> be true. This also applies if the directory already exists.
>> 
>> >
>> >> +      (if (or find-file (called-interactively-p 'interactive))
>> >> +          (find-file directory)
>> >> +        directory))))
>> >>  
>> >>  (declare-function log-view-current-tag "log-view" (&optional pos))
>> >>  (defun vc-default-last-change (_backend file line)
>> >> -- 
>> >> 2.46.0
>> 
>> V4 patches:
>
> Thanks.
>
> Dmitry, any comments, or should I install this?

Just a gentle ping, any news on this bug?

-- 
Best regards,
Aleksandr Vityazev