03/06: channels: Add 'repository->guix-channel'.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit 64a070717c3de32332201df5d6d2d52a7f99dce9
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Mon Aug 8 17:37:12 2022 +0200

    channels: Add 'repository->guix-channel'.
    
    * guix/channels.scm (repository->guix-channel): New procedure.
    * guix/scripts/describe.scm (display-checkout-info): Use it instead of
    the (git) interface, and adjust accordingly.
---
 guix/channels.scm         | 21 +++++++++++++++++++++
 guix/scripts/describe.scm | 40 ++++++++++++++--------------------------
 2 files changed, 35 insertions(+), 26 deletions(-)

diff --git a/guix/channels.scm b/guix/channels.scm
index 689b30e0eb..a5e9d7774d 100644
--- a/guix/channels.scm
+++ b/guix/channels.scm
@@ -77,6 +77,7 @@
             %default-guix-channel
             %default-channels
             guix-channel?
+            repository->guix-channel
 
             channel-instance?
             channel-instance-channel
@@ -202,6 +203,26 @@ introduction, add it."
                (introduction %guix-channel-introduction))
       chan))
 
+(define* (repository->guix-channel directory
+                                   #:key
+                                   (introduction %guix-channel-introduction))
+  "Look for a Git repository in DIRECTORY or its ancestors and return a
+channel that uses that repository and the commit HEAD currently points to; use
+INTRODUCTION as the channel's introduction.  Return #f if no Git repository
+could be found at DIRECTORY or one of its ancestors."
+  (catch 'git-error
+    (lambda ()
+      (with-repository (repository-discover directory) repository
+        (let* ((head   (repository-head repository))
+               (commit (oid->string (reference-target head))))
+          (channel
+           (inherit %default-guix-channel)
+           (url (repository-working-directory repository))
+           (commit commit)
+           (branch (reference-shorthand head))
+           (introduction introduction)))))
+    (const #f)))
+
 (define-record-type <channel-instance>
   (channel-instance channel commit checkout)
   channel-instance?
diff --git a/guix/scripts/describe.scm b/guix/scripts/describe.scm
index 7e4f682053..0c310e3da8 100644
--- a/guix/scripts/describe.scm
+++ b/guix/scripts/describe.scm
@@ -29,7 +29,6 @@
   #:use-module (guix profiles)
   #:autoload   (guix colors) (supports-hyperlinks? hyperlink)
   #:autoload   (guix openpgp) (openpgp-format-fingerprint)
-  #:use-module (git)
   #:autoload   (json builder) (scm->json-string)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
@@ -148,40 +147,29 @@ Display information about the channels currently in 
use.\n"))
   "Display information about the current checkout according to FMT, a symbol
 denoting the requested format.  Exit if the current directory does not lie
 within a Git checkout."
-  (let* ((program    (car (command-line)))
-         (directory  (catch 'git-error
-                       (lambda ()
-                         (repository-discover (dirname program)))
-                       (lambda (key err)
-                         (report-error (G_ "failed to determine origin~%"))
-                         (display-hint (format #f (G_ "Perhaps this
+  (let* ((program (car (command-line)))
+         (channel (repository->guix-channel (dirname program))))
+    (unless channel
+      (report-error (G_ "failed to determine origin~%"))
+      (display-hint (format #f (G_ "Perhaps this
 @command{guix} command was not obtained with @command{guix pull}?  Its version
 string is ~a.~%")
-                                               %guix-version))
-                         (exit 1))))
-         (repository (repository-open directory))
-         (head       (repository-head repository))
-         (commit     (oid->string (reference-target head))))
+                            %guix-version))
+      (exit 1))
+
     (match fmt
       ('human
        (format #t (G_ "Git checkout:~%"))
-       (format #t (G_ "  repository: ~a~%") (dirname directory))
-       (format #t (G_ "  branch: ~a~%") (reference-shorthand head))
-       (format #t (G_ "  commit: ~a~%") commit))
+       (format #t (G_ "  repository: ~a~%") (channel-url channel))
+       (format #t (G_ "  branch: ~a~%") (channel-branch channel))
+       (format #t (G_ "  commit: ~a~%") (channel-commit channel)))
       ('channels
-       (pretty-print `(list ,(channel->code (channel (name 'guix)
-                                                     (url (dirname directory))
-                                                     (commit commit))))))
+       (pretty-print `(list ,(channel->code channel))))
       ('json
-       (display (channel->json (channel (name 'guix)
-                                        (url (dirname directory))
-                                        (commit commit))))
+       (display (channel->json channel))
        (newline))
       ('recutils
-       (channel->recutils (channel (name 'guix)
-                                   (url (dirname directory))
-                                   (commit commit))
-                          (current-output-port))))
+       (channel->recutils channel (current-output-port))))
     (display-package-search-path fmt)))
 
 (define* (display-profile-info profile fmt