bug#67048: [PATCH] DRAFT guix: upstream: Allow relative file name.

[Simon Tournier]

Fixes <https://issues.guix.gnu.org/issue/67048>.
Reported by Andreas Enge <andreas@enge.fr>.

* guix/diagnostics.scm (absolute-location): Return FILE from
'canonicalize-path' when 'search-path' fails.
* guix/packages.scm (package-field-location): New procedure 'file-name' and
use it.  When 'search-path' does not find FILE in %LOAD-PATH, try
'canonicalize-path'.
* guix/upstream.scm (update-package-source): When 'search-path' fails, test if
FILE exists.

Change-Id: I9337041b43e17ace82416db5840f04113f9544fc
---
 guix/diagnostics.scm | 13 +++++-----
 guix/packages.scm    | 57 +++++++++++++++++++++++++-------------------
 guix/upstream.scm    |  6 +++--
 3 files changed, 43 insertions(+), 33 deletions(-)

diff --git a/guix/diagnostics.scm b/guix/diagnostics.scm
index 3f1f527b43..f79df1ca2d 100644
--- a/guix/diagnostics.scm
+++ b/guix/diagnostics.scm
@@ -349,12 +349,13 @@ (define (absolute-location loc)
                 ;; 'search-path' might return #f in obscure cases, such as
                 ;; when %LOAD-PATH includes "." or ".." and LOC comes from a
                 ;; file in a subdirectory thereof.
-                (match (search-path %load-path (location-file loc))
-                  (#f
-                   (raise (formatted-message
-                           (G_ "file '~a' not found on load path")
-                           (location-file loc))))
-                  (str str)))
+                (let ((file (location-file loc)))
+                  (or (search-path %load-path file)
+                      (and (file-exists? file)
+                           (canonicalize-path file))
+                      (raise (formatted-message
+                              (G_ "file '~a' not found on load path")
+                              file)))))
             (location-line loc)
             (location-column loc)))
 
diff --git a/guix/packages.scm b/guix/packages.scm
index e2e82692ad..ea05b739a8 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -750,37 +750,44 @@ (define (deprecated-package old-name p)
 (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."
+  (define (file-name relative-file file-found line column)
+    (catch 'system-error
+      (lambda ()
+        ;; In general we want to keep relative file names for modules.
+        (call-with-input-file file-found
+          (lambda (port)
+            (go-to-location port line column)
+            (match (read port)
+              ((or ('package inits ...)
+                   ('package/inherit _ inits ...))
+               (let ((field (assoc field inits)))
+                 (match field
+                   ((_ value)
+                    (let ((loc (and=> (source-properties value)
+                                      source-properties->location)))
+                      (and loc
+                           ;; Preserve the original file name, which may be a
+                           ;; relative file name.
+                           (set-field loc (location-file) relative-file))))
+                   (_
+                    #f))))
+              (_
+               #f)))))
+      (lambda _
+        #f)))
+
   (match (package-location package)
     (($ <location> file line column)
      (match (search-path %load-path file)
        ((? string? file-found)
-        (catch 'system-error
-          (lambda ()
-            ;; In general we want to keep relative file names for modules.
-            (call-with-input-file file-found
-              (lambda (port)
-                (go-to-location port line column)
-                (match (read port)
-                  ((or ('package inits ...)
-                       ('package/inherit _ inits ...))
-                   (let ((field (assoc field inits)))
-                     (match field
-                       ((_ value)
-                        (let ((loc (and=> (source-properties value)
-                                          source-properties->location)))
-                          (and loc
-                               ;; Preserve the original file name, which may 
be a
-                               ;; relative file name.
-                               (set-field loc (location-file) file))))
-                       (_
-                        #f))))
-                  (_
-                   #f)))))
-          (lambda _
-            #f)))
+        (file-name file file-found line column))
        (#f
         ;; FILE could not be found in %LOAD-PATH.
-        #f)))
+        (let ((file-found (and (file-exists? file)
+                               (canonicalize-path file))))
+          (if file-found
+              (file-name file file-found line column)
+              #f)))))
     (_ #f)))
 
 (define-syntax-rule (this-package-input name)
diff --git a/guix/upstream.scm b/guix/upstream.scm
index e28ae12f3f..5403aa833d 100644
--- a/guix/upstream.scm
+++ b/guix/upstream.scm
@@ -645,8 +645,10 @@ (define* (update-package-source package source hash)
                               ((? git-reference? ref)
                                (git-reference-commit ref))
                               (_ #f)))
-               (file        (and=> (location-file loc)
-                                   (cut search-path %load-path <>))))
+               (file        (or (and=> (location-file loc)
+                                       (cut search-path %load-path <>))
+                                (and=> (location-file loc)
+                                       file-exists?))))
           (if file
               ;; Be sure to use absolute filename.  Replace the URL directory
               ;; when OLD-URL is available; this is useful notably for

base-commit: 3d15e9e5bcd7cdad33f9832e4956f494c47e1937
-- 
2.41.0