describe: Remove dependency on (guix scripts pull).
Until now, 'guix describe' would perform ~3K stat calls and ~1K openat calls because it was pulling (guix scripts pull), which in turn pulls in many (gnu packages …) modules. * guix/scripts/pull.scm (display-profile-content, %vcs-web-views) (channel-commit-hyperlink): Move to... * guix/scripts/describe.scm: ... here. Remove import of (guix scripts pull).
This commit is contained in:
Ludovic Courtès
parent
1deca767be
commit
1d88470e10
|
|
@ -1,5 +1,5 @@
|
|||
;;; GNU Guix --- Functional package management for GNU
|
||||
;;; Copyright © 2018, 2019 Ludovic Courtès <ludo@gnu.org>
|
||||
;;; Copyright © 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
|
||||
;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com>
|
||||
;;;
|
||||
;;; This file is part of GNU Guix.
|
||||
|
|
@ -20,18 +20,22 @@
|
|||
(define-module (guix scripts describe)
|
||||
#:use-module ((guix config) #:select (%guix-version))
|
||||
#:use-module ((guix ui) #:hide (display-profile-content))
|
||||
#:use-module ((guix utils) #:select (string-replace-substring))
|
||||
#:use-module (guix channels)
|
||||
#:use-module (guix scripts)
|
||||
#:use-module (guix describe)
|
||||
#:use-module (guix profiles)
|
||||
#:use-module ((guix scripts pull) #:select (display-profile-content))
|
||||
#:use-module (git)
|
||||
#:use-module (json)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (srfi srfi-37)
|
||||
#:use-module (ice-9 match)
|
||||
#:autoload (ice-9 pretty-print) (pretty-print)
|
||||
#:export (guix-describe))
|
||||
#:use-module (web uri)
|
||||
#:export (display-profile-content
|
||||
channel-commit-hyperlink
|
||||
|
||||
guix-describe))
|
||||
|
||||
|
||||
;;;
|
||||
|
|
@ -173,6 +177,76 @@ in the format specified by FMT."
|
|||
channels))))
|
||||
(display-package-search-path fmt))
|
||||
|
||||
(define (display-profile-content profile number)
|
||||
"Display the packages in PROFILE, generation NUMBER, in a human-readable
|
||||
way and displaying details about the channel's source code."
|
||||
(display-generation profile number)
|
||||
(for-each (lambda (entry)
|
||||
(format #t " ~a ~a~%"
|
||||
(manifest-entry-name entry)
|
||||
(manifest-entry-version entry))
|
||||
(match (assq 'source (manifest-entry-properties entry))
|
||||
(('source ('repository ('version 0)
|
||||
('url url)
|
||||
('branch branch)
|
||||
('commit commit)
|
||||
_ ...))
|
||||
(let ((channel (channel (name 'nameless)
|
||||
(url url)
|
||||
(branch branch)
|
||||
(commit commit))))
|
||||
(format #t (G_ " repository URL: ~a~%") url)
|
||||
(when branch
|
||||
(format #t (G_ " branch: ~a~%") branch))
|
||||
(format #t (G_ " commit: ~a~%")
|
||||
(if (supports-hyperlinks?)
|
||||
(channel-commit-hyperlink channel commit)
|
||||
commit))))
|
||||
(_ #f)))
|
||||
|
||||
;; Show most recently installed packages last.
|
||||
(reverse
|
||||
(manifest-entries
|
||||
(profile-manifest (if (zero? number)
|
||||
profile
|
||||
(generation-file-name profile number)))))))
|
||||
|
||||
(define %vcs-web-views
|
||||
;; Hard-coded list of host names and corresponding web view URL templates.
|
||||
;; TODO: Allow '.guix-channel' files to specify a URL template.
|
||||
(let ((labhub-url (lambda (repository-url commit)
|
||||
(string-append
|
||||
(if (string-suffix? ".git" repository-url)
|
||||
(string-drop-right repository-url 4)
|
||||
repository-url)
|
||||
"/commit/" commit))))
|
||||
`(("git.savannah.gnu.org"
|
||||
,(lambda (repository-url commit)
|
||||
(string-append (string-replace-substring repository-url
|
||||
"/git/" "/cgit/")
|
||||
"/commit/?id=" commit)))
|
||||
("notabug.org" ,labhub-url)
|
||||
("framagit.org" ,labhub-url)
|
||||
("gitlab.com" ,labhub-url)
|
||||
("gitlab.inria.fr" ,labhub-url)
|
||||
("github.com" ,labhub-url))))
|
||||
|
||||
(define* (channel-commit-hyperlink channel
|
||||
#:optional
|
||||
(commit (channel-commit channel)))
|
||||
"Return a hyperlink for COMMIT in CHANNEL, using COMMIT as the hyperlink's
|
||||
text. The hyperlink links to a web view of COMMIT, when available."
|
||||
(let* ((url (channel-url channel))
|
||||
(uri (string->uri url))
|
||||
(host (and uri (uri-host uri))))
|
||||
(if host
|
||||
(match (assoc host %vcs-web-views)
|
||||
(#f
|
||||
commit)
|
||||
((_ template)
|
||||
(hyperlink (template url commit) commit)))
|
||||
commit)))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Entry point.
|
||||
|
|
|
|||
|
|
@ -18,7 +18,7 @@
|
|||
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
(define-module (guix scripts pull)
|
||||
#:use-module (guix ui)
|
||||
#:use-module ((guix ui) #:hide (display-profile-content))
|
||||
#:use-module (guix colors)
|
||||
#:use-module (guix utils)
|
||||
#:use-module ((guix status) #:select (with-status-verbosity))
|
||||
|
|
@ -37,6 +37,7 @@
|
|||
inferior-available-packages
|
||||
close-inferior)
|
||||
#:use-module (guix scripts build)
|
||||
#:use-module (guix scripts describe)
|
||||
#:autoload (guix build utils) (which)
|
||||
#:use-module ((guix build syscalls)
|
||||
#:select (with-file-lock/no-wait))
|
||||
|
|
@ -56,13 +57,12 @@
|
|||
#:use-module (srfi srfi-34)
|
||||
#:use-module (srfi srfi-35)
|
||||
#:use-module (srfi srfi-37)
|
||||
#:use-module (web uri)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (ice-9 vlist)
|
||||
#:use-module (ice-9 format)
|
||||
#:export (display-profile-content
|
||||
channel-list
|
||||
channel-commit-hyperlink
|
||||
#:re-export (display-profile-content
|
||||
channel-commit-hyperlink)
|
||||
#:export (channel-list
|
||||
with-git-error-handling
|
||||
guix-pull))
|
||||
|
||||
|
|
@ -188,42 +188,6 @@ Download and deploy the latest version of Guix.\n"))
|
|||
|
||||
%standard-build-options))
|
||||
|
||||
(define %vcs-web-views
|
||||
;; Hard-coded list of host names and corresponding web view URL templates.
|
||||
;; TODO: Allow '.guix-channel' files to specify a URL template.
|
||||
(let ((labhub-url (lambda (repository-url commit)
|
||||
(string-append
|
||||
(if (string-suffix? ".git" repository-url)
|
||||
(string-drop-right repository-url 4)
|
||||
repository-url)
|
||||
"/commit/" commit))))
|
||||
`(("git.savannah.gnu.org"
|
||||
,(lambda (repository-url commit)
|
||||
(string-append (string-replace-substring repository-url
|
||||
"/git/" "/cgit/")
|
||||
"/commit/?id=" commit)))
|
||||
("notabug.org" ,labhub-url)
|
||||
("framagit.org" ,labhub-url)
|
||||
("gitlab.com" ,labhub-url)
|
||||
("gitlab.inria.fr" ,labhub-url)
|
||||
("github.com" ,labhub-url))))
|
||||
|
||||
(define* (channel-commit-hyperlink channel
|
||||
#:optional
|
||||
(commit (channel-commit channel)))
|
||||
"Return a hyperlink for COMMIT in CHANNEL, using COMMIT as the hyperlink's
|
||||
text. The hyperlink links to a web view of COMMIT, when available."
|
||||
(let* ((url (channel-url channel))
|
||||
(uri (string->uri url))
|
||||
(host (and uri (uri-host uri))))
|
||||
(if host
|
||||
(match (assoc host %vcs-web-views)
|
||||
(#f
|
||||
commit)
|
||||
((_ template)
|
||||
(hyperlink (template url commit) commit)))
|
||||
commit)))
|
||||
|
||||
(define* (display-profile-news profile #:key concise?
|
||||
current-is-newer?)
|
||||
"Display what's up in PROFILE--new packages, and all that. If
|
||||
|
|
@ -559,40 +523,6 @@ true, display what would be built without actually building it."
|
|||
;;; Queries.
|
||||
;;;
|
||||
|
||||
(define (display-profile-content profile number)
|
||||
"Display the packages in PROFILE, generation NUMBER, in a human-readable
|
||||
way and displaying details about the channel's source code."
|
||||
(display-generation profile number)
|
||||
(for-each (lambda (entry)
|
||||
(format #t " ~a ~a~%"
|
||||
(manifest-entry-name entry)
|
||||
(manifest-entry-version entry))
|
||||
(match (assq 'source (manifest-entry-properties entry))
|
||||
(('source ('repository ('version 0)
|
||||
('url url)
|
||||
('branch branch)
|
||||
('commit commit)
|
||||
_ ...))
|
||||
(let ((channel (channel (name 'nameless)
|
||||
(url url)
|
||||
(branch branch)
|
||||
(commit commit))))
|
||||
(format #t (G_ " repository URL: ~a~%") url)
|
||||
(when branch
|
||||
(format #t (G_ " branch: ~a~%") branch))
|
||||
(format #t (G_ " commit: ~a~%")
|
||||
(if (supports-hyperlinks?)
|
||||
(channel-commit-hyperlink channel commit)
|
||||
commit))))
|
||||
(_ #f)))
|
||||
|
||||
;; Show most recently installed packages last.
|
||||
(reverse
|
||||
(manifest-entries
|
||||
(profile-manifest (if (zero? number)
|
||||
profile
|
||||
(generation-file-name profile number)))))))
|
||||
|
||||
(define (indented-string str indent)
|
||||
"Return STR with each newline preceded by IDENT spaces."
|
||||
(define indent-string
|
||||
|
|
|
|||
Loading…
Reference in New Issue