ui: 'warn-about-load-error' warns about file/module name mismatches.

* guix/discovery.scm (scheme-modules): Rename the inner 'file' to
'relative'.  Pass FILE as an addition argument to WARN.
* guix/ui.scm (warn-about-load-error): Add 'module' argument (actually,
what was called 'file' really contained a module name.)  Call
'check-module-matches-file' in the catch-all error case.
(check-module-matches-file): New procedure.
* tests/guix-build.sh: Test it.
This commit is contained in:
Ludovic Courtès 2019-07-19 23:48:09 +02:00
parent ddc586ea5c
commit a2a94b6e58
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
3 changed files with 50 additions and 7 deletions

View file

@ -106,14 +106,14 @@ (define prefix-len
(string-length directory)) (string-length directory))
(filter-map (lambda (file) (filter-map (lambda (file)
(let* ((file (substring file prefix-len)) (let* ((relative (string-drop file prefix-len))
(module (file-name->module-name file))) (module (file-name->module-name relative)))
(catch #t (catch #t
(lambda () (lambda ()
(resolve-interface module)) (resolve-interface module))
(lambda args (lambda args
;; Report the error, but keep going. ;; Report the error, but keep going.
(warn module args) (warn file module args)
#f)))) #f))))
(scheme-files (if sub-directory (scheme-files (if sub-directory
(string-append directory "/" sub-directory) (string-append directory "/" sub-directory)

View file

@ -311,6 +311,36 @@ (define* (report-unbound-variable-error args #:key frame)
(display-hint (format #f (G_ "Did you forget @code{(use-modules ~a)}?") (display-hint (format #f (G_ "Did you forget @code{(use-modules ~a)}?")
(module-name module)))))))) (module-name module))))))))
(define (check-module-matches-file module file)
"Check whether FILE starts with 'define-module MODULE' and print a hint if
it doesn't."
;; This is a common mistake when people start writing their own package
;; definitions and try loading them with 'guix build -L …', so help them
;; diagnose the problem.
(define (hint)
(display-hint (format #f (G_ "File @file{~a} should probably start with:
@example\n(define-module ~a)\n@end example")
file module)))
(catch 'system-error
(lambda ()
(let* ((sexp (call-with-input-file file read))
(loc (and (pair? sexp)
(source-properties->location (source-properties sexp)))))
(match sexp
(('define-module (names ...) _ ...)
(unless (equal? module names)
(warning loc
(G_ "module name ~a does not match file name '~a'~%")
names (module->source-file-name module))
(hint)))
((? eof-object?)
(warning (G_ "~a: file is empty~%") file))
(else
(hint)))))
(const #f)))
(define* (report-load-error file args #:optional frame) (define* (report-load-error file args #:optional frame)
"Report the failure to load FILE, a user-provided Scheme file. "Report the failure to load FILE, a user-provided Scheme file.
ARGS is the list of arguments received by the 'throw' handler." ARGS is the list of arguments received by the 'throw' handler."
@ -352,13 +382,13 @@ (define* (report-load-error file args #:optional frame)
;; above and need to be printed with 'print-exception'. ;; above and need to be printed with 'print-exception'.
(print-exception (current-error-port) frame key args)))))) (print-exception (current-error-port) frame key args))))))
(define (warn-about-load-error file args) ;FIXME: factorize with ↑ (define (warn-about-load-error file module args) ;FIXME: factorize with ↑
"Report the failure to load FILE, a user-provided Scheme file, without "Report the failure to load FILE, a user-provided Scheme file, without
exiting. ARGS is the list of arguments received by the 'throw' handler." exiting. ARGS is the list of arguments received by the 'throw' handler."
(match args (match args
(('system-error . rest) (('system-error . rest)
(let ((err (system-error-errno args))) (let ((err (system-error-errno args)))
(warning (G_ "failed to load '~a': ~a~%") file (strerror err)))) (warning (G_ "failed to load '~a': ~a~%") module (strerror err))))
(('syntax-error proc message properties form . rest) (('syntax-error proc message properties form . rest)
(let ((loc (source-properties->location properties))) (let ((loc (source-properties->location properties)))
(warning loc (G_ "~a~%") message))) (warning loc (G_ "~a~%") message)))
@ -370,8 +400,9 @@ (define (warn-about-load-error file args) ;FIXME: factorize with ↑
(warning (G_ "failed to load '~a': exception thrown: ~s~%") (warning (G_ "failed to load '~a': exception thrown: ~s~%")
file obj))) file obj)))
((error args ...) ((error args ...)
(warning (G_ "failed to load '~a':~%") file) (warning (G_ "failed to load '~a':~%") module)
(apply display-error #f (current-error-port) args)))) (apply display-error #f (current-error-port) args)
(check-module-matches-file module file))))
(define (call-with-unbound-variable-handling thunk) (define (call-with-unbound-variable-handling thunk)
(define tag (define tag

View file

@ -164,6 +164,17 @@ grep "unbound" "$module_dir/err" # actual error
grep "forget.*(gnu packages base)" "$module_dir/err" # hint grep "forget.*(gnu packages base)" "$module_dir/err" # hint
rm -f "$module_dir"/* rm -f "$module_dir"/*
# Wrong 'define-module' clause reported by 'warn-about-load-error'.
cat > "$module_dir/foo.scm" <<EOF
(define-module (something foo)
#:use-module (guix)
#:use-module (gnu))
EOF
guix build guile-bootstrap -n 2> "$module_dir/err"
grep "does not match file name" "$module_dir/err"
rm "$module_dir"/*
# Should all return valid log files. # Should all return valid log files.
drv="`guix build -d -e '(@@ (gnu packages bootstrap) %bootstrap-guile)'`" drv="`guix build -d -e '(@@ (gnu packages bootstrap) %bootstrap-guile)'`"
out="`guix build -e '(@@ (gnu packages bootstrap) %bootstrap-guile)'`" out="`guix build -e '(@@ (gnu packages bootstrap) %bootstrap-guile)'`"
@ -265,6 +276,7 @@ cat > "$module_dir/gexp.scm"<<EOF
EOF EOF
guix build --file="$module_dir/gexp.scm" -d guix build --file="$module_dir/gexp.scm" -d
guix build --file="$module_dir/gexp.scm" -d | grep 'gexp\.drv' guix build --file="$module_dir/gexp.scm" -d | grep 'gexp\.drv'
rm "$module_dir"/*.scm
# Using 'GUIX_BUILD_OPTIONS'. # Using 'GUIX_BUILD_OPTIONS'.
GUIX_BUILD_OPTIONS="--dry-run --no-grafts" GUIX_BUILD_OPTIONS="--dry-run --no-grafts"