diff options
| -rw-r--r-- | guix/channels.scm | 21 | ||||
| -rw-r--r-- | guix/scripts/describe.scm | 40 |
2 files changed, 35 insertions, 26 deletions
diff --git a/guix/channels.scm b/guix/channels.scm index 689b30e0eb..a5e9d7774d 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -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? diff --git a/guix/scripts/describe.scm b/guix/scripts/describe.scm index 7e4f682053..0c310e3da8 100644 --- a/guix/scripts/describe.scm +++ b/guix/scripts/describe.scm @@ -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 |