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-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 @@ (define (ensure-default-introduction chan)
|
||||||
(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?
|
||||||
|
|
|
@ -29,7 +29,6 @@ (define-module (guix scripts describe)
|
||||||
#: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 @@ (define (display-checkout-info fmt)
|
||||||
"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
|
||||||
|
|
Loading…
Reference in a new issue