scripts: add guix lint

* guix/scripts/lint.scm: New file. Defines a 'lint' tool for Guix packages.
* tests/lint.scm: New file.
* Makefile.am (MODULES, SCM_TESTS): Add them.
* po/guix/Makevars: Update appropriately.
* po/guix/POTFILES.in: Update appropriately.
* doc/guix.texi: Document "guix lint".

6 files changed, 357 insertions, 3 deletions

diff --git a/Makefile.am b/Makefile.am
index fff5958355..371b85c235 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -89,6 +89,7 @@ MODULES =					\
   guix/scripts/authenticate.scm			\
   guix/scripts/refresh.scm			\
   guix/scripts/system.scm			\
+  guix/scripts/lint.scm				\
   guix.scm					\
   $(GNU_SYSTEM_MODULES)
 
@@ -159,7 +160,8 @@ SCM_TESTS =					\
   tests/nar.scm					\
   tests/union.scm				\
   tests/profiles.scm				\
-  tests/syscalls.scm
+  tests/syscalls.scm				\
+  tests/lint.scm
 
 SH_TESTS =					\
   tests/guix-build.sh				\
diff --git a/doc/guix.texi b/doc/guix.texi
index 46f2c70b85..384e2a9ced 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -1459,7 +1459,10 @@ definitions like the one above may be automatically converted from the
 Nixpkgs distribution using the @command{guix import} command.}, the
 package may actually be built using the @code{guix build} command-line
 tool (@pxref{Invoking guix build}).  @xref{Packaging Guidelines}, for
-more information on how to test package definitions.
+more information on how to test package definitions, and
+@ref{Invoking guix lint}, for information on how to check a definition
+for style conformance.
+
 
 Eventually, updating the package definition to a new upstream version
 can be partly automated by the @command{guix refresh} command
@@ -2328,6 +2331,7 @@ programming interface of Guix in a convenient way.
 * Invoking guix download::      Downloading a file and printing its hash.
 * Invoking guix hash::          Computing the cryptographic hash of a file.
 * Invoking guix refresh::       Updating package definitions.
+* Invoking guix lint::          Finding errors in package definitions.
 @end menu
 
 @node Invoking guix build
@@ -2705,6 +2709,29 @@ for in @code{$PATH}.
 
 @end table
 
+@node Invoking guix lint
+@section Invoking @command{guix lint}
+The @command{guix lint} is meant to help package developers avoid common
+errors and use a consistent style.  It runs a few checks on a given set of
+packages in order to find common mistakes in their definitions.
+
+The general syntax is:
+
+@example
+guix lint @var{options} @var{package}@dots{}
+@end example
+
+If no package is given on the command line, then all packages are checked.
+The @var{options} may be zero or more of the following:
+
+@table @code
+
+@item --list-checkers
+@itemx -l
+List and describe all the available checkers that will be run on packages
+and exit.
+
+@end table
 
 @c *********************************************************************
 @node GNU Distribution
diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm
new file mode 100644
index 0000000000..e3b06977ee
--- /dev/null
+++ b/guix/scripts/lint.scm
@@ -0,0 +1,213 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2014 Cyril Roelandt <tipecaml@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix scripts lint)
+  #:use-module (guix base32)
+  #:use-module (guix packages)
+  #:use-module (guix records)
+  #:use-module (guix ui)
+  #:use-module (guix utils)
+  #:use-module (gnu packages)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-11)
+  #:use-module (srfi srfi-37)
+  #:export (guix-lint
+            check-inputs-should-be-native
+            check-patches
+            check-synopsis-style))
+
+
+;;;
+;;; Command-line options.
+;;;
+
+(define %default-options
+  ;; Alist of default option values.
+  '())
+
+(define (show-help)
+  (display (_ "Usage: guix lint [OPTION]... [PACKAGE]...
+Run a set of checkers on the specified package; if none is specified, run the checkers on all packages.\n"))
+  (display (_ "
+  -h, --help             display this help and exit"))
+  (display (_ "
+  -l, --list-checkers    display the list of available lint checkers"))
+  (display (_ "
+  -V, --version          display version information and exit"))
+  (newline)
+  (show-bug-report-information))
+
+(define %options
+  ;; Specification of the command-line options.
+  ;; TODO: add some options:
+  ;; * --checkers=checker1,checker2...: only run the specified checkers
+  ;; * --certainty=[low,medium,high]: only run checkers that have at least this
+  ;;                                  'certainty'.
+  (list (option '(#\h "help") #f #f
+                (lambda args
+                  (show-help)
+                  (exit 0)))
+        (option '(#\l "list-checkers") #f #f
+                (lambda args
+                   (list-checkers-and-exit)))
+        (option '(#\V "version") #f #f
+                (lambda args
+                  (show-version-and-exit "guix lint")))))
+
+
+;;;
+;;; Helpers
+;;;
+(define* (emit-warning package message #:optional field)
+  ;; Emit a warning about PACKAGE, printing the location of FIELD if it is
+  ;; given, the location of PACKAGE otherwise, the full name of PACKAGE and the
+  ;; provided MESSAGE.
+  (let ((loc (or (package-field-location package field)
+                 (package-location package))))
+    (warning (_ "~a: ~a: ~a~%")
+             (location->string loc)
+             (package-full-name package)
+             message)))
+
+
+;;;
+;;; Checkers
+;;;
+(define-record-type* <lint-checker>
+  lint-checker make-lint-checker
+  lint-checker?
+  ;; TODO: add a 'certainty' field that shows how confident we are in the
+  ;; checker. Then allow users to only run checkers that have a certain
+  ;; 'certainty' level.
+  (name        lint-checker-name)
+  (description lint-checker-description)
+  (check       lint-checker-check))
+
+(define (list-checkers-and-exit)
+  ;; Print information about all available checkers and exit.
+  (format #t (_ "Available checkers:~%"))
+  (for-each (lambda (checker)
+              (format #t "- ~a: ~a~%"
+                      (lint-checker-name checker)
+                      (lint-checker-description checker)))
+            %checkers)
+  (exit 0))
+
+(define (check-inputs-should-be-native package)
+  ;; Emit a warning if some inputs of PACKAGE are likely to belong to its
+  ;; native inputs.
+  (let ((inputs (package-inputs package)))
+    (match inputs
+      (((labels packages . _) ...)
+       (when (member "pkg-config"
+                     (map package-name (filter package? packages)))
+        (emit-warning package
+                      "pkg-config should probably be a native input"
+                      'inputs))))))
+
+
+(define (check-synopsis-style package)
+  ;; Emit a warning if stylistic issues are found in the synopsis of PACKAGE.
+  (define (check-final-period synopsis)
+    ;; Synopsis should not end with a period, except for some special cases.
+    (if (and (string=? (string-take-right synopsis 1) ".")
+             (not (string=? (string-take-right synopsis 4) "etc.")))
+        (emit-warning package
+                      "no period allowed at the end of the synopsis"
+                      'synopsis)))
+
+  (define (check-start-article synopsis)
+   (if (or (string=? (string-take synopsis 2) "A ")
+           (string=? (string-take synopsis 3) "An "))
+       (emit-warning package
+                     "no article allowed at the beginning of the synopsis"
+                     'synopsis)))
+
+ (let ((synopsis (package-synopsis package)))
+   (if (string? synopsis)
+       (begin
+        (check-final-period synopsis)
+        (check-start-article synopsis)))))
+
+(define (check-patches package)
+  ;; Emit a warning if the patches requires by PACKAGE are badly named.
+  (let ((patches   (and=> (package-source package) origin-patches))
+        (name      (package-name package))
+        (full-name (package-full-name package)))
+    (if (and patches
+             (any (lambda (patch)
+                    (let ((filename (basename patch)))
+                      (not (or (eq? (string-contains filename name) 0)
+                               (eq? (string-contains filename full-name) 0)))))
+                  patches))
+        (emit-warning package
+          "file names of patches should start with the package name"
+          'patches))))
+
+(define %checkers
+  (list
+   (lint-checker
+     (name        "inputs-should-be-native")
+     (description "Identify inputs that should be native inputs")
+     (check       check-inputs-should-be-native))
+   (lint-checker
+     (name        "patch-filenames")
+     (description "Validate filenames of patches")
+     (check       check-patches))
+   (lint-checker
+     (name        "synopsis")
+     (description "Validate package synopsis")
+     (check       check-synopsis-style))))
+
+(define (run-checkers package)
+  ;; Run all the checkers on PACKAGE.
+  (for-each (lambda (checker)
+              ((lint-checker-check checker) package))
+            %checkers))
+
+
+;;;
+;;; Entry Point
+;;;
+
+(define (guix-lint . args)
+  (define (parse-options)
+    ;; Return the alist of option values.
+    (args-fold* args %options
+                (lambda (opt name arg result)
+                  (leave (_ "~A: unrecognized option~%") name))
+                (lambda (arg result)
+                  (alist-cons 'argument arg result))
+                %default-options))
+
+  (let* ((opts (parse-options))
+         (args (filter-map (match-lambda
+                            (('argument . value)
+                             value)
+                            (_ #f))
+                           (reverse opts))))
+
+
+   (if (null? args)
+        (fold-packages (lambda (p r) (run-checkers p)) '())
+        (for-each
+          (lambda (spec)
+            (run-checkers spec))
+          (map specification->package args)))))
diff --git a/po/guix/Makevars b/po/guix/Makevars
index 87bb438418..f5b498caa9 100644
--- a/po/guix/Makevars
+++ b/po/guix/Makevars
@@ -10,7 +10,8 @@ top_builddir = ../..
 XGETTEXT_OPTIONS =				\
   --language=Scheme --from-code=UTF-8		\
   --keyword=_ --keyword=N_			\
-  --keyword=message
+  --keyword=message				\
+  --keyword=description
 
 COPYRIGHT_HOLDER = Ludovic Courtès
 
diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in
index bf2d31306a..5cc68ff404 100644
--- a/po/guix/POTFILES.in
+++ b/po/guix/POTFILES.in
@@ -10,6 +10,7 @@ guix/scripts/pull.scm
 guix/scripts/substitute-binary.scm
 guix/scripts/authenticate.scm
 guix/scripts/system.scm
+guix/scripts/lint.scm
 guix/gnu-maintenance.scm
 guix/ui.scm
 guix/http-client.scm
diff --git a/tests/lint.scm b/tests/lint.scm
new file mode 100644
index 0000000000..f6dae47ca6
--- /dev/null
+++ b/tests/lint.scm
@@ -0,0 +1,110 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2012, 2013 Cyril Roelandt <tipecaml@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+
+(define-module (test-packages)
+  #:use-module (guix build download)
+  #:use-module (guix build-system gnu)
+  #:use-module (guix packages)
+  #:use-module (guix scripts lint)
+  #:use-module (guix ui)
+  #:use-module (gnu packages)
+  #:use-module (gnu packages pkg-config)
+  #:use-module (srfi srfi-64))
+
+;; Test the linter.
+
+
+(test-begin "lint")
+
+(define-syntax-rule (dummy-package name* extra-fields ...)
+  (package extra-fields ... (name name*) (version "0") (source #f)
+           (build-system gnu-build-system)
+           (synopsis #f) (description #f)
+           (home-page #f) (license #f) ))
+
+(define (call-with-warnings thunk)
+       (let ((port (open-output-string)))
+         (parameterize ((guix-warning-port port))
+           (thunk))
+         (get-output-string port)))
+
+(test-assert "synopsis: ends with a period"
+  (->bool
+   (string-contains (call-with-warnings
+                      (lambda ()
+                        (let ((pkg (dummy-package "x"
+                                     (synopsis "Bad synopsis."))))
+                          (check-synopsis-style pkg))))
+                    "no period allowed at the end of the synopsis")))
+
+(test-assert "synopsis: ends with 'etc.'"
+  (->bool
+   (string-null? (call-with-warnings
+                   (lambda ()
+                     (let ((pkg (dummy-package "x"
+                                  (synopsis "Foo, bar, etc."))))
+                       (check-synopsis-style pkg)))))))
+
+(test-assert "synopsis: starts with 'A'"
+  (->bool
+   (string-contains (call-with-warnings
+                      (lambda ()
+                        (let ((pkg (dummy-package "x"
+                                     (synopsis "A bad synopŝis"))))
+                          (check-synopsis-style pkg))))
+                    "no article allowed at the beginning of the synopsis")))
+
+(test-assert "synopsis: starts with 'An'"
+  (->bool
+   (string-contains (call-with-warnings
+                      (lambda ()
+                        (let ((pkg (dummy-package "x"
+                                     (synopsis "An awful synopsis"))))
+                        (check-synopsis-style pkg))))
+                    "no article allowed at the beginning of the synopsis")))
+
+(test-assert "inputs: pkg-config is probably a native input"
+  (->bool
+   (string-contains
+     (call-with-warnings
+       (lambda ()
+         (let ((pkg (dummy-package "x"
+                      (inputs `(("pkg-config" ,pkg-config))))))
+              (check-inputs-should-be-native pkg))))
+         "pkg-config should probably be a native input")))
+
+(test-assert "patches: file names"
+  (->bool
+   (string-contains
+     (call-with-warnings
+       (lambda ()
+         (let ((pkg (dummy-package "x"
+                      (source
+                       (origin
+                        (method url-fetch)
+                        (uri "someurl")
+                        (sha256 "somesha")
+                        (patches (list "/path/to/y.patch")))))))
+              (check-patches pkg))))
+         "file names of patches should start with the package name")))
+
+(test-end "lint")
+
+
+(exit (= (test-runner-fail-count (test-runner-current)) 0))