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.
This commit is contained in:
Ludovic Courtès 2020-11-05 14:32:04 +01:00
parent 61d9c4458e
commit 18fc84bce8
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
2 changed files with 17 additions and 5 deletions

View file

@ -146,12 +146,17 @@ (define-module (guix gexp)
;; "G expressions". ;; "G expressions".
(define-record-type <gexp> (define-record-type <gexp>
(make-gexp references modules extensions proc) (make-gexp references modules extensions proc location)
gexp? gexp?
(references gexp-references) ;list of <gexp-input> (references gexp-references) ;list of <gexp-input>
(modules gexp-self-modules) ;list of module names (modules gexp-self-modules) ;list of module names
(extensions gexp-self-extensions) ;list of lowerable things (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) (define (write-gexp gexp port)
"Write GEXP on PORT." "Write GEXP on PORT."
@ -164,6 +169,11 @@ (define (write-gexp gexp port)
(write (apply (gexp-proc gexp) (write (apply (gexp-proc gexp)
(gexp-references gexp)) (gexp-references gexp))
port)) port))
(let ((loc (gexp-location gexp)))
(when loc
(format port " ~a" (location->string loc))))
(format port " ~a>" (format port " ~a>"
(number->string (object-address gexp) 16))) (number->string (object-address gexp) 16)))
@ -1084,7 +1094,8 @@ (define (add-modules exp modules)
(make-gexp (gexp-references exp) (make-gexp (gexp-references exp)
(append modules (gexp-self-modules exp)) (append modules (gexp-self-modules exp))
(gexp-self-extensions exp) (gexp-self-extensions exp)
(gexp-proc exp)))) (gexp-proc exp)
(gexp-location exp))))
(mlet* %store-monad ( ;; The following binding forces '%current-system' and (mlet* %store-monad ( ;; The following binding forces '%current-system' and
;; '%current-target-system' to be looked up at >>= ;; '%current-target-system' to be looked up at >>=
@ -1414,7 +1425,8 @@ (define (substitute-references exp substs)
current-imported-modules current-imported-modules
current-imported-extensions current-imported-extensions
(lambda #,formals (lambda #,formals
#,sexp))))))) #,sexp)
(current-source-location)))))))
;;; ;;;

View file

@ -1413,7 +1413,7 @@ (define (contents=? file str)
(test-assert "printer" (test-assert "printer"
(string-match "^#<gexp \\(string-append .*#<package coreutils.*\ (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 (with-output-to-string
(lambda () (lambda ()
(write (write