unofficial mirror of guix-patches@gnu.org 
 help / color / mirror / code / Atom feed
* [bug#50286] [RFC PATCH] Let 'package-location' returns location of surrounding 'let'.
@ 2021-08-30 21:26 Maxime Devos
  2021-09-06 10:07 ` Ludovic Courtès
  0 siblings, 1 reply; 8+ messages in thread
From: Maxime Devos @ 2021-08-30 21:26 UTC (permalink / raw)
  To: 50286; +Cc: iskarian


[-- Attachment #1.1: Type: text/plain, Size: 883 bytes --]

X-Debbugs-CC: ludo@gnu.org
X-Debbugs-CC: iskarian@mgsn.dev

Hi guix,

These three patches allows (guix upstream) to replace the values in the surrounding 'let'
form, if any.  It's important for constructs like:

(define-public gnash
   (let ((version "0.8.11")
         (commit "583ccbc1275c7701dc4843ec12142ff86bb305b4")
         (revision "0"))
     (package
       (name "gnash")
       (version (git-version version revision commit))
       (source (git-reference
                 (url "https://example.org")
                 (commit commit)))
       [...])))

such that it can update the version, commit, revision. (Currently only the
version will be updatable, but see <https://issues.guix.gnu.org/50072#0>
and <https://issues.guix.gnu.org/50072#9> for work on making 'commit' updatable).

More details in the patches themselves.

Greetings,
Maxime

[-- Attachment #1.2: 0001-packages-package-location-returns-location-of-surrou.patch --]
[-- Type: text/x-patch, Size: 12994 bytes --]

From 0edae1f6eac69a38d23692ffe3ebc32aab00a3b7 Mon Sep 17 00:00:00 2001
From: Maxime Devos <maximedevos@telenet.be>
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 <https://issues.guix.gnu.org/50072>.

* 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 <efraim@flashner.co.il>
 ;;; Copyright © 2019 Marius Bakke <mbakke@fastmail.com>
 ;;; Copyright © 2021 Chris Marusich <cmmarusich@gmail.com>
+;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
 ;;;
 ;;; 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)
     (($ <location> 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))))))
+
+\f
+;;;
+;;; 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 <https://issues.guix.gnu.org/50072> 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 <ludo@gnu.org>
 ;;; Copyright © Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+;;; Copyright © 2021 Maxime Devos <maximeevos@telenet.be>
 ;;;
 ;;; 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
+   (($ <location> 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
-       (($ <location> 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


[-- Attachment #1.3: 0002-Remove-conflicting-SRFI-71-imports.patch --]
[-- Type: text/x-patch, Size: 2582 bytes --]

From 90c090fbf3da162e94e5467de897aa5cf1eb8c4c Mon Sep 17 00:00:00 2001
From: Maxime Devos <maximedevos@telenet.be>
Date: Mon, 30 Aug 2021 17:03:03 +0200
Subject: [PATCH 2/3] Remove conflicting SRFI-71 imports.

Don't import both (guix packages) and (srfi srfi-71),
as the let and let* bindings of one will replace the ones
of the other.

* guix/import/crate.scm: Don't import (srfi srfi-71).
* guix/import/egg.scm: Likewise.
* guix/import/utils.scm: Likewise.
* guix/scripts/pull.scm: Likewise.
* tests/packages.scm: Likewise.
---
 guix/import/crate.scm | 1 -
 guix/import/egg.scm   | 1 -
 guix/import/utils.scm | 1 -
 guix/scripts/pull.scm | 1 -
 tests/packages.scm    | 1 -
 5 files changed, 5 deletions(-)

diff --git a/guix/import/crate.scm b/guix/import/crate.scm
index 287ffd2536..eb2fa1e1c4 100644
--- a/guix/import/crate.scm
+++ b/guix/import/crate.scm
@@ -40,7 +40,6 @@
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-2)
   #:use-module (srfi srfi-26)
-  #:use-module (srfi srfi-71)
   #:export (crate->guix-package
             guix-package->crate-name
             string->license
diff --git a/guix/import/egg.scm b/guix/import/egg.scm
index 107894ddcf..a7535be8a6 100644
--- a/guix/import/egg.scm
+++ b/guix/import/egg.scm
@@ -21,7 +21,6 @@
   #:use-module (ice-9 ftw)
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
-  #:use-module (srfi srfi-71)
   #:use-module (gcrypt hash)
   #:use-module (guix git)
   #:use-module (guix i18n)
diff --git a/guix/import/utils.scm b/guix/import/utils.scm
index d1b8076ddd..e433449d18 100644
--- a/guix/import/utils.scm
+++ b/guix/import/utils.scm
@@ -47,7 +47,6 @@
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
-  #:use-module (srfi srfi-71)
   #:export (factorize-uri
 
             flatten
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index fb8ce50fa7..f81df47a0e 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -55,7 +55,6 @@
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
   #:use-module (srfi srfi-37)
-  #:use-module (srfi srfi-71)
   #:use-module (ice-9 match)
   #:use-module (ice-9 vlist)
   #:use-module (ice-9 format)
diff --git a/tests/packages.scm b/tests/packages.scm
index 50fb3d0718..5ff71b7af1 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -57,7 +57,6 @@
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
   #:use-module (srfi srfi-64)
-  #:use-module (srfi srfi-71)
   #:use-module (rnrs bytevectors)
   #:use-module (rnrs io ports)
   #:use-module (ice-9 vlist)
-- 
2.33.0


[-- Attachment #1.4: 0003-guix-Find-let-binding-when-using-guile-3.0.0.patch --]
[-- Type: text/x-patch, Size: 1659 bytes --]

From fd716c2924c96a0bf908f615adaa404a3e382e7c Mon Sep 17 00:00:00 2001
From: Maxime Devos <maximedevos@telenet.be>
Date: Mon, 30 Aug 2021 20:31:00 +0200
Subject: [PATCH 3/3] guix: Find 'let' binding when using guile@3.0.0.

Without this patch, errors like this result:

[ 90%] LOAD     gnu/services/nfs.scm
WARNING: (gnu services nfs): imported module (guix) overrides core binding `let'
WARNING: (gnu services nfs): `let' imported from both (guile) and (guix)
WARNING: (gnu services nfs): imported module (guix) overrides core binding `let'
WARNING: (gnu services nfs): `let' imported from both (guile) and (guix)
ice-9/eval.scm:293:34: error: let: unbound variable
hint: Did you forget `(use-modules (srfi srfi-71))'?

I don't know why this happens, but this patch stops this error.

* guix.scm: Hide 'let' and 'let*' when importing (guix packages).
---
 guix.scm | 7 ++++++-
 1 file changed, 6 insertions(+), 1 deletion(-)

diff --git a/guix.scm b/guix.scm
index 42bc8c8818..7e1e5fb109 100644
--- a/guix.scm
+++ b/guix.scm
@@ -36,5 +36,10 @@
 
     (for-each (let ((i (module-public-interface (current-module))))
                 (lambda (m)
-                  (module-use! i (resolve-interface `(guix ,m)))))
+                  (module-use! i (resolve-interface `(guix ,m)
+                                  ;; XXX: why is this required with Guile 3.0.2
+                                  ;; to allow (gnu services nfs) to compile?
+                                  #:hide (if (eq? m 'packages)
+                                             '(let let*)
+                                             '())))))
               %public-modules)))
-- 
2.33.0


[-- Attachment #2: This is a digitally signed message part --]
[-- Type: application/pgp-signature, Size: 260 bytes --]

^ permalink raw reply related	[flat|nested] 8+ messages in thread

end of thread, other threads:[~2021-09-13 10:38 UTC | newest]

Thread overview: 8+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2021-08-30 21:26 [bug#50286] [RFC PATCH] Let 'package-location' returns location of surrounding 'let' Maxime Devos
2021-09-06 10:07 ` Ludovic Courtès
2021-09-07 19:27   ` Ludovic Courtès
2021-09-07 20:15     ` Sarah Morgensen
2021-09-08 13:45       ` Ludovic Courtès
2021-09-07 20:30     ` Maxime Devos
2021-09-08 13:38       ` Ludovic Courtès
2021-09-13 10:37         ` bug#50286: " Ludovic Courtès

Code repositories for project(s) associated with this public inbox

	https://git.savannah.gnu.org/cgit/guix.git

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).