From a2a94b6e58e5120462d6861bdf72efa2170bfd73 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Fri, 19 Jul 2019 23:48:09 +0200
Subject: [PATCH] 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 86f20ec344..468b6c59de 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 76f6fc8eed..1812b01272 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 63a9fe68da..d16b92d189 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"