me
/
guix
Archived
1
0
Fork 0
Code

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.
Ludovic Courtès 2022-08-08 17:37:12 +02:00
parent cf60a0a906
commit 64a070717c
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
2 changed files with 35 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
guix/channels.scm
View File

@ -77,6 +77,7 @@
%default-guix-channel %default-guix-channel
%default-channels %default-channels
guix-channel? guix-channel?
repository->guix-channel
channel-instance? channel-instance?
channel-instance-channel channel-instance-channel
@ -202,6 +203,26 @@ introduction, add it."
(introduction %guix-channel-introduction)) (introduction %guix-channel-introduction))
chan)) 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> (define-record-type <channel-instance>
(channel-instance channel commit checkout) (channel-instance channel commit checkout)
channel-instance? channel-instance?

40
guix/scripts/describe.scm
View File

@ -29,7 +29,6 @@
#:use-module (guix profiles) #:use-module (guix profiles)
#:autoload (guix colors) (supports-hyperlinks? hyperlink) #:autoload (guix colors) (supports-hyperlinks? hyperlink)
#:autoload (guix openpgp) (openpgp-format-fingerprint) #:autoload (guix openpgp) (openpgp-format-fingerprint)
#:use-module (git)
#:autoload (json builder) (scm->json-string) #:autoload (json builder) (scm->json-string)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-26) #: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 "Display information about the current checkout according to FMT, a symbol
denoting the requested format. Exit if the current directory does not lie denoting the requested format. Exit if the current directory does not lie
within a Git checkout." within a Git checkout."
(let* ((program (car (command-line))) (let* ((program (car (command-line)))
(directory (catch 'git-error (channel (repository->guix-channel (dirname program))))
(lambda () (unless channel
(repository-discover (dirname program))) (report-error (G_ "failed to determine origin~%"))
(lambda (key err) (display-hint (format #f (G_ "Perhaps this
(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 @command{guix} command was not obtained with @command{guix pull}? Its version
string is ~a.~%") string is ~a.~%")
%guix-version)) %guix-version))
(exit 1)))) (exit 1))
(repository (repository-open directory))
(head (repository-head repository))
(commit (oid->string (reference-target head))))
(match fmt (match fmt
('human ('human
(format #t (G_ "Git checkout:~%")) (format #t (G_ "Git checkout:~%"))
(format #t (G_ " repository: ~a~%") (dirname directory)) (format #t (G_ " repository: ~a~%") (channel-url channel))
(format #t (G_ " branch: ~a~%") (reference-shorthand head)) (format #t (G_ " branch: ~a~%") (channel-branch channel))
(format #t (G_ " commit: ~a~%") commit)) (format #t (G_ " commit: ~a~%") (channel-commit channel)))
('channels ('channels
(pretty-print `(list ,(channel->code (channel (name 'guix) (pretty-print `(list ,(channel->code channel))))
(url (dirname directory))
(commit commit))))))
('json ('json
(display (channel->json (channel (name 'guix) (display (channel->json channel))
(url (dirname directory))
(commit commit))))
(newline)) (newline))
('recutils ('recutils
(channel->recutils (channel (name 'guix) (channel->recutils channel (current-output-port))))
(url (dirname directory))
(commit commit))
(current-output-port))))
(display-package-search-path fmt))) (display-package-search-path fmt)))
(define* (display-profile-info profile fmt (define* (display-profile-info profile fmt