TakeV
/
guix
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

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.
This commit is contained in:
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?

32
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)
@ -149,39 +148,28 @@ Display information about the channels currently in use.\n"))
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)))
(lambda (key err)
(report-error (G_ "failed to determine origin~%")) (report-error (G_ "failed to determine origin~%"))
(display-hint (format #f (G_ "Perhaps this (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