02/07: gexp: Store the source code location in <gexp>.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit 18fc84bce86eedb85d44a8708a9a5ef7c1b23da5
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Thu Nov 5 14:32:04 2020 +0100

    gexp: Store the source code location in <gexp>.
    
    * guix/gexp.scm (<gexp>)[location]: New field.
    (gexp-location): New procedure.
    (write-gexp): Print the location of GEXP.
    (gexp->derivation): Adjust call to 'make-gexp'.
    (gexp): Likewise.
---
 guix/gexp.scm  | 20 ++++++++++++++++----
 tests/gexp.scm |  2 +-
 2 files changed, 17 insertions(+), 5 deletions(-)

diff --git a/guix/gexp.scm b/guix/gexp.scm
index 9339b22..97a6101 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -146,12 +146,17 @@
 
 ;; "G expressions".
 (define-record-type <gexp>
-  (make-gexp references modules extensions proc)
+  (make-gexp references modules extensions proc location)
   gexp?
   (references gexp-references)                    ;list of <gexp-input>
   (modules    gexp-self-modules)                  ;list of module names
   (extensions gexp-self-extensions)               ;list of lowerable things
-  (proc       gexp-proc))                         ;procedure
+  (proc       gexp-proc)                          ;procedure
+  (location   %gexp-location))                    ;location alist
+
+(define (gexp-location gexp)
+  "Return the source code location of GEXP."
+  (and=> (%gexp-location gexp) source-properties->location))
 
 (define (write-gexp gexp port)
   "Write GEXP on PORT."
@@ -164,6 +169,11 @@
    (write (apply (gexp-proc gexp)
                  (gexp-references gexp))
           port))
+
+  (let ((loc (gexp-location gexp)))
+    (when loc
+      (format port " ~a" (location->string loc))))
+
   (format port " ~a>"
           (number->string (object-address gexp) 16)))
 
@@ -1084,7 +1094,8 @@ The other arguments are as for 'derivation'."
         (make-gexp (gexp-references exp)
                    (append modules (gexp-self-modules exp))
                    (gexp-self-extensions exp)
-                   (gexp-proc exp))))
+                   (gexp-proc exp)
+                   (gexp-location exp))))
 
   (mlet* %store-monad ( ;; The following binding forces '%current-system' and
                        ;; '%current-target-system' to be looked up at >>=
@@ -1414,7 +1425,8 @@ execution environment."
                       current-imported-modules
                       current-imported-extensions
                       (lambda #,formals
-                        #,sexp)))))))
+                        #,sexp)
+                      (current-source-location)))))))
 
 
 ;;;
diff --git a/tests/gexp.scm b/tests/gexp.scm
index 1beeb67..0487f2a 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -1413,7 +1413,7 @@
 
 (test-assert "printer"
   (string-match "^#<gexp \\(string-append .*#<package coreutils.*\
- \"/bin/uname\"\\) [[:xdigit:]]+>$"
+ \"/bin/uname\"\\) [[:graph:]]+tests/gexp\\.scm:[0-9]+:[0-9]+ [[:xdigit:]]+>$"
                 (with-output-to-string
                   (lambda ()
                     (write