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-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?

40
guix/scripts/describe.scm
View File

@ -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