From ca155a20aea25003b03ef5e0420c77e416d5f425 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Wed, 16 Feb 2022 11:27:43 +0100
Subject: gexp: Preserve source location for #~ and #$ read extensions.

Read hash extensions preserve source location info as source properties
on their result.  However, in Guile 3.0.8, that location would be
dismissed, leading 'local-file' to fail to resolve file names relative
to the source directory.

Fixes <https://issues.guix.gnu.org/54003>.
Reported by Aleksandr Vityazev <avityazev@posteo.org>.

* guix/gexp.scm <eval-when> [read-syntax-redefined?, read-procedure]
[read-syntax*]: New variables.
[read-ungexp]: Adjust to expect either sexps or syntax objects.
[read-gexp]: Call 'read-procedure'.
* tests/gexp.scm ("local-file, relative file name, within gexp")
("local-file, relative file name, within gexp, compiled"): New tests.
---
 guix/gexp.scm  | 50 +++++++++++++++++++++++++++++++++++++++++++++-----
 tests/gexp.scm | 27 +++++++++++++++++++++++++++
 2 files changed, 72 insertions(+), 5 deletions(-)

diff --git a/guix/gexp.scm b/guix/gexp.scm
index d23683e2a6..e229c1fc8f 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -2176,6 +2176,29 @@ is true, the derivation will not print anything."
 ;;;
 
 (eval-when (expand load eval)
+  (define-once read-syntax-redefined?
+    ;; Have we already redefined 'read-syntax'?  This needs to be done on
+    ;; 3.0.8 only to work around <https://issues.guix.gnu.org/54003>.
+    (or (not (module-variable the-scm-module 'read-syntax))
+        (not (guile-version>? "3.0.7"))))
+
+  (define read-procedure
+    ;; The current read procedure being called: either 'read' or
+    ;; 'read-syntax'.
+    (make-parameter read))
+
+  (define read-syntax*
+    ;; Replacement for 'read-syntax'.
+    (let ((read-syntax (and=> (module-variable the-scm-module 'read-syntax)
+                              variable-ref)))
+      (lambda (port . rest)
+        (parameterize ((read-procedure read-syntax))
+          (apply read-syntax port rest)))))
+
+  (unless read-syntax-redefined?
+    (set! (@ (guile) read-syntax) read-syntax*)
+    (set! read-syntax-redefined? #t))
+
   (define* (read-ungexp chr port #:optional native?)
     "Read an 'ungexp' or 'ungexp-splicing' form from PORT.  When NATIVE? is
 true, use 'ungexp-native' and 'ungexp-native-splicing' instead."
@@ -2191,22 +2214,39 @@ true, use 'ungexp-native' and 'ungexp-native-splicing' instead."
              'ungexp-native
              'ungexp))))
 
-    (match (read port)
-      ((? symbol? symbol)
-       (let ((str (symbol->string symbol)))
+    (define symbolic?
+      ;; Depending on whether (read-procedure) is 'read' or 'read-syntax', we
+      ;; might get either sexps or syntax objects.  Adjust accordingly.
+      (if (eq? (read-procedure) read)
+          symbol?
+          (compose symbol? syntax->datum)))
+
+    (define symbolic->string
+      (if (eq? (read-procedure) read)
+          symbol->string
+          (compose symbol->string syntax->datum)))
+
+    (define wrapped-symbol
+      (if (eq? (read-procedure) read)
+          (lambda (_ symbol) symbol)
+          datum->syntax))
+
+    (match ((read-procedure) port)
+      ((? symbolic? symbol)
+       (let ((str (symbolic->string symbol)))
          (match (string-index-right str #\:)
            (#f
             `(,unquote-symbol ,symbol))
            (colon
             (let ((name   (string->symbol (substring str 0 colon)))
                   (output (substring str (+ colon 1))))
-              `(,unquote-symbol ,name ,output))))))
+              `(,unquote-symbol ,(wrapped-symbol symbol name) ,output))))))
       (x
        `(,unquote-symbol ,x))))
 
   (define (read-gexp chr port)
     "Read a 'gexp' form from PORT."
-    `(gexp ,(read port)))
+    `(gexp ,((read-procedure) port)))
 
   ;; Extend the reader
   (read-hash-extend #\~ read-gexp)
diff --git a/tests/gexp.scm b/tests/gexp.scm
index bcda516623..33c0e4bf8c 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -28,6 +28,7 @@
   #:use-module (guix tests)
   #:use-module ((guix build utils) #:select (with-directory-excursion))
   #:use-module ((guix utils) #:select (call-with-temporary-directory))
+  #:use-module ((guix ui) #:select (load*))
   #:use-module (gnu packages)
   #:use-module (gnu packages base)
   #:use-module (gnu packages bootstrap)
@@ -222,6 +223,32 @@
       (let ((file (local-file (string-copy "../base32.scm"))))
         (local-file-absolute-file-name file)))))
 
+(test-assert "local-file, relative file name, within gexp"
+  (let* ((file     (search-path %load-path "guix/base32.scm"))
+         (interned (add-to-store %store "base32.scm" #f "sha256" file)))
+    (equal? `(the file is ,interned)
+            (gexp->sexp*
+             #~(the file is #$(local-file "../guix/base32.scm"))))))
+
+(test-assert "local-file, relative file name, within gexp, compiled"
+  ;; In Guile 3.0.8, everything read by the #~ and #$ read hash extensions
+  ;; would lack source location info, which in turn would lead
+  ;; (current-source-directory), called by 'local-file', to return #f, thereby
+  ;; breaking 'local-file' resolution.  See
+  ;; <https://issues.guix.gnu.org/54003>.
+  (let ((file (tmpnam)))
+    (call-with-output-file file
+      (lambda (port)
+        (display (string-append "#~(this file is #$(local-file \""
+                                (basename file) "\" \"t.scm\"))")
+                 port)))
+
+    (let* ((interned (add-to-store %store "t.scm" #f "sha256" file))
+           (module   (make-fresh-user-module)))
+      (module-use! module (resolve-interface '(guix gexp)))
+      (equal? `(this file is ,interned)
+              (gexp->sexp* (load* file module))))))
+
 (test-assertm "local-file, #:select?"
   (mlet* %store-monad ((select? -> (lambda (file stat)
                                      (member (basename file)
-- 
cgit v1.2.3