mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-24 21:38:07 -05:00
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:
parent
cf60a0a906
commit
64a070717c
2 changed files with 35 additions and 26 deletions
|
@ -77,6 +77,7 @@ (define-module (guix channels)
|
|||
%default-guix-channel
|
||||
%default-channels
|
||||
guix-channel?
|
||||
repository->guix-channel
|
||||
|
||||
channel-instance?
|
||||
channel-instance-channel
|
||||
|
@ -202,6 +203,26 @@ (define (ensure-default-introduction chan)
|
|||
(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?
|
||||
|
|
|
@ -29,7 +29,6 @@ (define-module (guix scripts describe)
|
|||
#: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)
|
||||
|
@ -149,39 +148,28 @@ (define (display-checkout-info fmt)
|
|||
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)
|
||||
(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))))
|
||||
(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
|
||||
|
|
Loading…
Reference in a new issue