[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
03/04: describe: Remove dependency on (guix scripts pull).
|
From: |
guix-commits |
|
Subject: |
03/04: describe: Remove dependency on (guix scripts pull). |
|
Date: |
Tue, 11 Feb 2020 06:34:31 -0500 (EST) |
civodul pushed a commit to branch master
in repository guix.
commit 1d88470e1001fa5a9c9235166a47ecbbc67eeeec
Author: Ludovic Courtès <address@hidden>
AuthorDate: Tue Feb 11 12:17:33 2020 +0100
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).
---
guix/scripts/describe.scm | 80 +++++++++++++++++++++++++++++++++++++++++++++--
guix/scripts/pull.scm | 80 +++--------------------------------------------
2 files changed, 82 insertions(+), 78 deletions(-)
diff --git a/guix/scripts/describe.scm b/guix/scripts/describe.scm
index 99a88c5..f13f221 100644
--- a/guix/scripts/describe.scm
+++ b/guix/scripts/describe.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2018, 2019 Ludovic Courtès <address@hidden>
+;;; Copyright © 2018, 2019, 2020 Ludovic Courtès <address@hidden>
;;; Copyright © 2018 Oleg Pykhalov <address@hidden>
;;;
;;; 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.
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index cb1be98..51d4da2 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -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