From 0edae1f6eac69a38d23692ffe3ebc32aab00a3b7 Mon Sep 17 00:00:00 2001 From: Maxime Devos Date: Mon, 30 Aug 2021 16:41:08 +0200 Subject: [PATCH 1/3] packages: 'package-location' returns location of surrounding 'let'. The idea is to let "guix refresh -u" be able to update the version, revision and commit in packages defined like: (define-public emacs-flymake-quickdef (let ((version "1.0.0") (revision "0") (commit "150c5839768a3d32f988f9dc08052978a68f2ad7")) (package (name "emacs-flymake-quickdef") (version (git-version version revision commit)) [...]))) Updating the revision and commit is not yet supported by (guix upstream), but see . * guix/packages.scm: Re-export 'letrec' from SRFI-71 * guix/packages.scm (read-syntax*): Define as 'read-syntax', with some Guile < 3.0.7 compatibility code. (package-field-location)[syntax-case-loop]: New macro. (package-field-location)[syntax-assq]: New macro. (package-field-location): Use 'syntax-case-loop' and 'syntax-case' instead of 'match'. Recognise 'let' forms. Use syntax-source instead of source-properties, with some compatibility code for Guile < 3.0.7. (datum->syntax*): Define as 'datum->syntax', with some Guile < 3.0.6 compatibility code. (with-source-location): New macro. (let&): New macro (let*&): New macro. * tests/packages.scm (goto, read-at): Extract from "package-field-location" test. ("package-field-location and 'let'", "package-field-location and symbols"): New tests. --- guix/packages.scm | 134 +++++++++++++++++++++++++++++++++++++++++++-- tests/packages.scm | 60 ++++++++++++-------- 2 files changed, 165 insertions(+), 29 deletions(-) diff --git a/guix/packages.scm b/guix/packages.scm index c825f427d8..a71c9ac74f 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -6,6 +6,7 @@ ;;; Copyright © 2017, 2019, 2020 Efraim Flashner ;;; Copyright © 2019 Marius Bakke ;;; Copyright © 2021 Chris Marusich +;;; Copyright © 2021 Maxime Devos ;;; ;;; This file is part of GNU Guix. ;;; @@ -47,11 +48,17 @@ #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) + #:use-module (srfi srfi-71) ; used by let& and let*& + #:use-module ((system syntax) #:select (syntax?)) #:use-module (rnrs bytevectors) #:use-module (web uri) + #:use-module (system vm program) #:re-export (%current-system %current-target-system search-path-specification) ;for convenience + #:replace ((let& . let) + (let*& . let*)) + #:re-export-and-replace ((letrec . letrec)) ;for completeness #:export (content-hash content-hash? content-hash-algorithm @@ -466,6 +473,15 @@ object." (name old-name) (properties `((superseded . ,p))))) +;; XXX 'read-syntax' is new since Guile 3.0.7. +;; For previous versions of Guile, use 'read' instead. +;; See package-field-location for why 'read-syntax' is preferred +;; above 'read'. +(define read-syntax* + (if (defined? 'read-syntax) + read-syntax + read)) + (define (package-field-location package field) "Return the source code location of the definition of FIELD for PACKAGE, or #f if it could not be determined." @@ -474,6 +490,21 @@ object." (= (port-line port) (- line 1))) (unless (eof-object? (read-char port)) (goto port line column)))) + ;; Like 'syntax-case', but for catamorphisms. + (define-syntax-rule (syntax-case-loop loop obj . patterns) + (let loop ((x obj)) + (syntax-case x () . patterns))) + ;; Like 'assq', but the alist is a syntax object and the keys are converted + ;; to a datum before comparing them to KEY. + (define (syntax-assq key alist) + (syntax-case alist () + (() #f) + ((pair . rest) + (syntax-case #'pair () + ((x . y) + (if (eq? (syntax->datum #'x) key) + #'pair + (syntax-assq field #'rest))))))) (match (package-location package) (($ file line column) @@ -485,12 +516,19 @@ object." (call-with-input-file file-found (lambda (port) (goto port line column) - (match (read port) - (('package inits ...) - (let ((field (assoc field inits))) - (match field + ;; Use 'read-syntax' such that source properties are available + ;; even if the expression for the field value is a symbol. + (syntax-case-loop loop (read-syntax* port) + ((p inits ...) + (eq? 'package (syntax->datum #'p)) + (let ((field (syntax-assq field #'(inits ...)))) + (syntax-case field () ((_ value) - (let ((loc (and=> (source-properties value) + ;; XXX syntax? isn't necessary when read-syntax is used. + (let ((loc (and=> (or (and (syntax? #'value) + (syntax-source #'value)) + ;; XXX not required in Guile 3.0.7 + (source-properties #'value)) source-properties->location))) (and loc ;; Preserve the original file name, which may be a @@ -498,6 +536,9 @@ object." (set-field loc (location-file) file)))) (_ #f)))) + ((bind stuff ... exp) + (memq (syntax->datum #'bind) '(let let*)) + (loop #'exp)) (_ #f))))) (lambda _ @@ -1635,3 +1676,86 @@ outside of the store) or SOURCE itself (if SOURCE is already a store item.)" (add-to-store store (basename file) #t "sha256" file)) (_ (lower store source system)))))) + + +;;; +;;; These let* and let*& macros adjust the source location of the package +;;; (if any) to the location of the let* or let*& form. This hack allows +;;; the in-place updater to update the version number, revision and +;;; commit for packages defined like this: +;;; +;;; (define-public emacs-flymake-quickdef +;;; (let ((version "1.0.0") +;;; (revision "0") +;;; (commit "150c5839768a3d32f988f9dc08052978a68f2ad7")) +;;; (package +;;; (name "emacs-flymake-quickdef") +;;; (version (git-version version revision commit)) +;;; [...]))) +;;; +;;; See for some background. +;;; Note that updating the revision and commit is not yet supported. +;;; +;;; It is intended that these bindings replace the standard 'let' and +;;; 'let*' bindings, such that: +;;; +;;; (1) newcomers don't have to learn to use let& and let*& instead +;;; of let and let* in some situations, instead things mostly +;;; ‘just work’, and +;;; (2) old package definitions don't have to be adjusted. +;;; + +;; XXX the #:source argument is only introduced since Guile 3.0.6. +;; As adjusting the source location isn't terribly important +;; (only "guix refresh -e" needs the adjusted location sometimes and for most +;; packages it doesn't need it), for compatibility for Guile 3.0.5 just ignore +;; #:source. + +(define datum->syntax* + (if (member 'source (program-lambda-list datum->syntax)) + datum->syntax + (lambda* (template-id datum #:key source) + (datum->syntax template-id datum)))) + +(define-syntax with-source-location + (lambda (s) + "If (EXP . EXP*) is a PACKAGE or PACKAGE/INHERIT form, expand to (EXP . EXP*), +but with the source location replaced by the source location of SOURCE. Keep +the original source location otherwise." + (define (package-identifier? s) + (syntax-case s (package package/inherit) + (package #t) + (package/inherit #t) + (_ #f))) + (syntax-case s () + ((_ (exp . exp*) source) + (package-identifier? #'exp) + (datum->syntax* s (cons #'exp #'exp*) + #:source (syntax-source #'source))) + ((_ other-stuff source) #'other-stuff)))) + +(define-syntax let& + (lambda (s) + "Like SRFI-71 'let', but let the last inner expression have the location +of the 'let&' form when it is expanded, if it is a PACKAGE or PACKAGE/INHERIT +form." + (syntax-case s () + ;; These variable names aren't fully correct, + ;; because the 'named let' construction is possible as well. + ((_ bindings exp ... exp*) + (with-syntax ((s/syntax s)) + #'(let bindings exp ... (with-source-location exp* s/syntax))))))) + +(define-syntax let*& + (lambda (s) + "Like SRFI-71 'let*', but let the last inner expression have the location +of the 'let*&' form when it is expanded, if it is a PACKAGE or PACKAGE/INHERIT +form." + (syntax-case s () + ((_ bindings exp ... exp*) + (with-syntax ((s/syntax s)) + #'(let* bindings exp ... (with-source-location exp* s/syntax))))))) + +;; Local Variables: +;; eval: (put 'syntax-case-loop 'scheme-indent-function 2) +;; End: diff --git a/tests/packages.scm b/tests/packages.scm index 2a290bc353..50fb3d0718 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès ;;; Copyright © Jan (janneke) Nieuwenhuizen +;;; Copyright © 2021 Maxime Devos ;;; ;;; This file is part of GNU Guix. ;;; @@ -44,6 +45,7 @@ #:use-module (guix scripts package) #:use-module (guix sets) #:use-module (gnu packages) + #:use-module (gnu packages admin) ; for 'interrobang' #:use-module (gnu packages base) #:use-module (gnu packages guile) #:use-module (gnu packages bootstrap) @@ -236,31 +238,41 @@ (eq? item new))) (null? (manifest-transaction-remove tx))))))) +;; These two procedures are by the "package-field-location" +;; tests. +(define (goto port line column) + (unless (and (= (port-column port) (- column 1)) + (= (port-line port) (- line 1))) + (unless (eof-object? (get-char port)) + (goto port line column)))) + +(define read-at + (match-lambda + (($ file line column) + (call-with-input-file (search-path %load-path file) + (lambda (port) + (goto port line column) + (read port)))))) + (test-assert "package-field-location" - (let () - (define (goto port line column) - (unless (and (= (port-column port) (- column 1)) - (= (port-line port) (- line 1))) - (unless (eof-object? (get-char port)) - (goto port line column)))) - - (define read-at - (match-lambda - (($ file line column) - (call-with-input-file (search-path %load-path file) - (lambda (port) - (goto port line column) - (read port)))))) - - ;; Until Guile 2.0.6 included, source properties were added only to pairs. - ;; Thus, check against both VALUE and (FIELD VALUE). - (and (member (read-at (package-field-location %bootstrap-guile 'name)) - (let ((name (package-name %bootstrap-guile))) - (list name `(name ,name)))) - (member (read-at (package-field-location %bootstrap-guile 'version)) - (let ((version (package-version %bootstrap-guile))) - (list version `(version ,version)))) - (not (package-field-location %bootstrap-guile 'does-not-exist))))) + ;; Until Guile 2.0.6 included, source properties were added only to pairs. + ;; Thus, check against both VALUE and (FIELD VALUE). + (and (member (read-at (package-field-location %bootstrap-guile 'name)) + (let ((name (package-name %bootstrap-guile))) + (list name `(name ,name)))) + (member (read-at (package-field-location %bootstrap-guile 'version)) + (let ((version (package-version %bootstrap-guile))) + (list version `(version ,version)))) + (not (package-field-location %bootstrap-guile 'does-not-exist)))) + +(test-equal "package-field-location and 'let'" + (package-name interrobang) + (read-at (package-field-location interrobang 'name))) + +(test-skip (if (defined? 'read-syntax) 0 1)) +(test-eq "package-field-location and symbols" + 'gnu-build-system + (read-at (package-field-location hello 'build-system))) ;; Make sure we don't change the file name to an absolute file name. (test-equal "package-field-location, relative file name" -- 2.33.0