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

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit a2a94b6e58e5120462d6861bdf72efa2170bfd73
Author: Ludovic Courtès <address@hidden>
Date:   Fri Jul 19 23:48:09 2019 +0200

    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.
---
 guix/discovery.scm  |  6 +++---
 guix/ui.scm         | 39 +++++++++++++++++++++++++++++++++++----
 tests/guix-build.sh | 12 ++++++++++++
 3 files changed, 50 insertions(+), 7 deletions(-)

diff --git a/guix/discovery.scm b/guix/discovery.scm
index 86f20ec..468b6c5 100644
--- a/guix/discovery.scm
+++ b/guix/discovery.scm
@@ -106,14 +106,14 @@ name and the exception key and arguments."
     (string-length directory))
 
   (filter-map (lambda (file)
-                (let* ((file   (substring file prefix-len))
-                       (module (file-name->module-name file)))
+                (let* ((relative (string-drop file prefix-len))
+                       (module   (file-name->module-name relative)))
                   (catch #t
                     (lambda ()
                       (resolve-interface module))
                     (lambda args
                       ;; Report the error, but keep going.
-                      (warn module args)
+                      (warn file module args)
                       #f))))
               (scheme-files (if sub-directory
                                 (string-append directory "/" sub-directory)
diff --git a/guix/ui.scm b/guix/ui.scm
index 76f6fc8..1812b01 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -311,6 +311,36 @@ arguments."
         (display-hint (format #f (G_ "Did you forget @code{(use-modules ~a)}?")
                               (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)
   "Report the failure to load FILE, a user-provided Scheme file.
 ARGS is the list of arguments received by the 'throw' handler."
@@ -352,13 +382,13 @@ ARGS is the list of arguments received by the 'throw' 
handler."
         ;; above and need to be printed with 'print-exception'.
         (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
 exiting.  ARGS is the list of arguments received by the 'throw' handler."
   (match args
     (('system-error . rest)
      (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)
      (let ((loc (source-properties->location properties)))
        (warning loc (G_ "~a~%") message)))
@@ -370,8 +400,9 @@ exiting.  ARGS is the list of arguments received by the 
'throw' handler."
          (warning (G_ "failed to load '~a': exception thrown: ~s~%")
                   file obj)))
     ((error args ...)
-     (warning (G_ "failed to load '~a':~%") file)
-     (apply display-error #f (current-error-port) args))))
+     (warning (G_ "failed to load '~a':~%") module)
+     (apply display-error #f (current-error-port) args)
+     (check-module-matches-file module file))))
 
 (define (call-with-unbound-variable-handling thunk)
   (define tag
diff --git a/tests/guix-build.sh b/tests/guix-build.sh
index 63a9fe6..d16b92d 100644
--- a/tests/guix-build.sh
+++ b/tests/guix-build.sh
@@ -164,6 +164,17 @@ grep "unbound" "$module_dir/err"                # actual 
error
 grep "forget.*(gnu packages base)" "$module_dir/err" # hint
 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.
 drv="`guix build -d -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
 guix build --file="$module_dir/gexp.scm" -d
 guix build --file="$module_dir/gexp.scm" -d | grep 'gexp\.drv'
+rm "$module_dir"/*.scm
 
 # Using 'GUIX_BUILD_OPTIONS'.
 GUIX_BUILD_OPTIONS="--dry-run --no-grafts"