mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2025-01-23 19:19:20 -05:00
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:
parent
61d9c4458e
commit
18fc84bce8
2 changed files with 17 additions and 5 deletions
|
@ -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)))))))
|
||||||
|
|
||||||
|
|
||||||
;;;
|
;;;
|
||||||
|
|
|
@ -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
|
||||||
|
|
Loading…
Reference in a new issue