diff options
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/build/copy-build-system.scm | 8 | ||||
| -rw-r--r-- | guix/build/emacs-build-system.scm | 22 | ||||
| -rw-r--r-- | guix/build/emacs-utils.scm | 10 | ||||
| -rw-r--r-- | guix/scripts.scm | 12 | ||||
| -rw-r--r-- | guix/scripts/describe.scm | 15 | ||||
| -rw-r--r-- | guix/scripts/package.scm | 7 | ||||
| -rw-r--r-- | guix/ui.scm | 2 |
7 files changed, 52 insertions, 24 deletions
diff --git a/guix/build/copy-build-system.scm b/guix/build/copy-build-system.scm index 6d9dc8f93b..a86f0cde29 100644 --- a/guix/build/copy-build-system.scm +++ b/guix/build/copy-build-system.scm @@ -91,7 +91,13 @@ if TARGET ends with a '/', the source is installed underneath." file)))) (format (current-output-port) "`~a' -> `~a'~%" file dest) (mkdir-p (dirname dest)) - (copy-file file dest))) + (let ((stat (lstat file))) + (case (stat:type stat) + ((symlink) + (let ((target (readlink file))) + (symlink target dest))) + (else + (copy-file file dest)))))) (define* (make-file-predicate suffixes matches-regexp #:optional (default-value #t)) "Return a predicate that returns #t if its file argument matches the diff --git a/guix/build/emacs-build-system.scm b/guix/build/emacs-build-system.scm index 09de244993..219310cf08 100644 --- a/guix/build/emacs-build-system.scm +++ b/guix/build/emacs-build-system.scm @@ -225,6 +225,21 @@ parallel. PARALLEL-TESTS? is ignored when using a non-make TEST-COMMAND." (parameterize ((%emacs emacs)) (emacs-generate-autoloads elpa-name site-lisp)))) +(define* (enable-autoloads-compilation #:key outputs #:allow-other-keys) + "Remove the NO-BYTE-COMPILATION local variable embedded in the generated +autoload files." + (let* ((out (assoc-ref outputs "out")) + (autoloads (find-files out "-autoloads.el$"))) + (substitute* autoloads + ((";; no-byte-compile.*") "")) + #t)) + +(define* (validate-compiled-autoloads #:key outputs #:allow-other-keys) + "Verify whether the byte compiled autoloads load fine." + (let* ((out (assoc-ref outputs "out")) + (autoloads (find-files out "-autoloads.elc$"))) + (emacs-batch-eval (format #f "(mapc #'load '~s)" autoloads)))) + (define (emacs-package? name) "Check if NAME correspond to the name of an Emacs package." (string-prefix? "emacs-" name)) @@ -253,10 +268,13 @@ second hyphen. This corresponds to 'name-version' as used in ELPA packages." (replace 'check check) (replace 'install install) (add-after 'install 'make-autoloads make-autoloads) - (add-after 'make-autoloads 'patch-el-files patch-el-files) + (add-after 'make-autoloads 'enable-autoloads-compilation + enable-autoloads-compilation) + (add-after 'enable-autoloads-compilation 'patch-el-files patch-el-files) ;; The .el files are byte compiled directly in the store. (add-after 'patch-el-files 'build build) - (add-after 'build 'move-doc move-doc))) + (add-after 'build 'validate-compiled-autoloads validate-compiled-autoloads) + (add-after 'validate-compiled-autoloads 'move-doc move-doc))) (define* (emacs-build #:key inputs (phases %standard-phases) #:allow-other-keys #:rest args) diff --git a/guix/build/emacs-utils.scm b/guix/build/emacs-utils.scm index 885fd0a217..ab64e3714c 100644 --- a/guix/build/emacs-utils.scm +++ b/guix/build/emacs-utils.scm @@ -41,16 +41,22 @@ ;; The `emacs' command. (make-parameter "emacs")) +(define (expr->string expr) + "Converts EXPR, an expression, into a string." + (if (string? expr) + expr + (format #f "~s" expr))) + (define (emacs-batch-eval expr) "Run Emacs in batch mode, and execute the elisp code EXPR." (invoke (%emacs) "--quick" "--batch" - (format #f "--eval=~S" expr))) + (string-append "--eval=" (expr->string expr)))) (define (emacs-batch-edit-file file expr) "Load FILE in Emacs using batch mode, and execute the elisp code EXPR." (invoke (%emacs) "--quick" "--batch" (string-append "--visit=" file) - (format #f "--eval=~S" expr))) + (string-append "--eval=" (expr->string expr)))) (define (emacs-batch-disable-compilation file) (emacs-batch-edit-file file diff --git a/guix/scripts.scm b/guix/scripts.scm index 7ad1d5194c..e235c8d4c3 100644 --- a/guix/scripts.scm +++ b/guix/scripts.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014 Deck Pickard <deck.r.pickard@gmail.com> ;;; Copyright © 2015, 2016 Alex Kost <alezost@gmail.com> ;;; @@ -228,17 +228,19 @@ Show what and how will/would be built." (thresholds (%disk-space-warning))) "Display a hint about 'guix gc' if less than THRESHOLD of /gnu/store is available. -THRESHOLD is a pair of (ABSOLUTE-THRESHOLD RELATIVE-THRESHOLD)." +THRESHOLDS is a pair (ABSOLUTE-THRESHOLD . RELATIVE-THRESHOLD)." + (define GiB (expt 2 30)) + (let* ((stats (statfs (%store-prefix))) (block-size (file-system-block-size stats)) (available (* block-size (file-system-blocks-available stats))) (total (* block-size (file-system-block-count stats))) (relative-threshold-in-bytes (* total (cadr thresholds))) - (absolute-threshold-in-bytes (* 1024 1024 1024 (car thresholds)))) - (when (< available (min relative-threshold-in-bytes + (absolute-threshold-in-bytes (car thresholds))) + (when (< available (max relative-threshold-in-bytes absolute-threshold-in-bytes)) (warning (G_ "only ~,1f GiB of free space available on ~a~%") - available (%store-prefix)) + (/ available 1. GiB) (%store-prefix)) (display-hint (format #f (G_ "Consider deleting old profile generations and collecting garbage, along these lines: diff --git a/guix/scripts/describe.scm b/guix/scripts/describe.scm index 5e00067ef8..f13f221da9 100644 --- a/guix/scripts/describe.scm +++ b/guix/scripts/describe.scm @@ -201,11 +201,7 @@ way and displaying details about the channel's source code." (format #t (G_ " commit: ~a~%") (if (supports-hyperlinks?) (channel-commit-hyperlink channel commit) - commit)) - (when (not (supports-hyperlinks?)) - (format #t (G_ " URL: ~a~%") - (channel-commit-hyperlink channel commit - (lambda (url msg) url)))))) + commit)))) (_ #f))) ;; Show most recently installed packages last. @@ -237,12 +233,9 @@ way and displaying details about the channel's source code." (define* (channel-commit-hyperlink channel #:optional - (commit (channel-commit channel)) - (transformer hyperlink)) + (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. -TRANSFORMER is a procedure of 2 arguments, a URI and text, and returns a -string for display." +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)))) @@ -251,7 +244,7 @@ string for display." (#f commit) ((_ template) - (transformer (template url commit) commit))) + (hyperlink (template url commit) commit))) commit))) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 1cb0d382bf..d2f4f1ccd3 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -81,12 +81,15 @@ "Ensure the default profile symlink and directory exist and are writable." (ensure-profile-directory) - ;; Create ~/.guix-profile if it doesn't exist yet. + ;; Try to create ~/.guix-profile if it doesn't exist yet. (when (and %user-profile-directory %current-profile (not (false-if-exception (lstat %user-profile-directory)))) - (symlink %current-profile %user-profile-directory))) + (catch 'system-error + (lambda () + (symlink %current-profile %user-profile-directory)) + (const #t)))) (define (delete-generations store profile generations) "Delete GENERATIONS from PROFILE. diff --git a/guix/ui.scm b/guix/ui.scm index 22a6d6c8e3..fbe2b70485 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -1638,7 +1638,7 @@ DURATION-RELATION with the current time." (let* ((file (generation-file-name profile number)) (link (if (supports-hyperlinks?) (cut file-hyperlink file <>) - (cut format #f (G_ "~a~%file: ~a") <> file))) + identity)) (header (format #f (link (highlight (G_ "Generation ~a\t~a"))) number (date->string |