guix-devel
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[PATCH] scripts: add guix lint


From: Cyril Roelandt
Subject: [PATCH] scripts: add guix lint
Date: Mon, 25 Aug 2014 03:52:44 +0200

* 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.
* guix/scripts/build.scm (specification->package): Move from here...
* guix/ui.scm: ... to here.
* po/guix/Makevars: Update appropriately.
* po/guix/POTFILES.in: Update appropriately.
* doc/guix.texi: Document "guix lint".
---
 Makefile.am            |   4 +-
 doc/guix.texi          |  27 +++++++
 guix/scripts/build.scm |  21 -----
 guix/scripts/lint.scm  | 213 +++++++++++++++++++++++++++++++++++++++++++++++++
 guix/ui.scm            |  23 ++++++
 po/guix/Makevars       |   3 +-
 po/guix/POTFILES.in    |   1 +
 tests/lint.scm         | 110 +++++++++++++++++++++++++
 8 files changed, 379 insertions(+), 23 deletions(-)
 create mode 100644 guix/scripts/lint.scm
 create mode 100644 tests/lint.scm

diff --git a/Makefile.am b/Makefile.am
index fff5958..371b85c 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 09ed392..9a43543 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -1459,6 +1459,10 @@ 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.
 
+In order to catch common errors and stylistic issues, the packages might
+actually be checked by running the @command{guix lint} command
+(@pxref{Invoking guix lint}).
+
 Eventually, updating the package definition to a new upstream version
 can be partly automated by the @command{guix refresh} command
 (@pxref{Invoking guix refresh}).
@@ -2326,6 +2330,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
@@ -2703,6 +2708,28 @@ for in @code{$PATH}.
 
 @end table
 
address@hidden Invoking guix lint
address@hidden Invoking @command{guix lint}
+The @command{guix lint} command runs a few checks on a given set of
+packages in order to find common mistakes in their definitions.
+
+The general syntax is:
+
address@hidden
+guix lint @var{options} @address@hidden
address@hidden 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:
+
address@hidden @code
+
address@hidden --list-checkers
address@hidden -l
+List and describe all the available checkers that will be run on packages
+and exit.
+
address@hidden table
 
 @c *********************************************************************
 @node GNU Distribution
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index 5e4647d..b2682a1 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -41,27 +41,6 @@
 
             guix-build))
 
-(define (specification->package spec)
-  "Return a package matching SPEC.  SPEC may be a package name, or a package
-name followed by a hyphen and a version number.  If the version number is not
-present, return the preferred newest version."
-  (let-values (((name version)
-                (package-name->name+version spec)))
-    (match (find-best-packages-by-name name version)
-      ((p)                                      ; one match
-       p)
-      ((p x ...)                                ; several matches
-       (warning (_ "ambiguous package specification `~a'~%") spec)
-       (warning (_ "choosing ~a from ~a~%")
-                (package-full-name p)
-                (location->string (package-location p)))
-       p)
-      (_                                        ; no matches
-       (if version
-           (leave (_ "~A: package not found for version ~a~%")
-                  name version)
-           (leave (_ "~A: unknown package~%") name))))))
-
 (define (register-root store paths root)
   "Register ROOT as an indirect GC root for all of PATHS."
   (let* ((root (string-append (canonicalize-path (dirname root))
diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm
new file mode 100644
index 0000000..e3b0697
--- /dev/null
+++ b/guix/scripts/lint.scm
@@ -0,0 +1,213 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2014 Cyril Roelandt <address@hidden>
+;;;
+;;; 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/guix/ui.scm b/guix/ui.scm
index f11c2e9..86bd8f7 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -37,6 +37,7 @@
   #:use-module (ice-9 match)
   #:use-module (ice-9 format)
   #:use-module (ice-9 regex)
+  #:autoload   (gnu packages) (find-best-packages-by-name)
   #:export (_
             N_
             P_
@@ -64,6 +65,7 @@
             program-name
             guix-warning-port
             warning
+            specification->package
             guix-main))
 
 ;;; Commentary:
@@ -669,6 +671,27 @@ found."
 (define guix-warning-port
   (make-parameter (current-warning-port)))
 
+(define (specification->package spec)
+  "Return a package matching SPEC.  SPEC may be a package name, or a package
+name followed by a hyphen and a version number.  If the version number is not
+present, return the preferred newest version."
+  (let-values (((name version)
+                (package-name->name+version spec)))
+    (match (find-best-packages-by-name name version)
+      ((p)                                      ; one match
+       p)
+      ((p x ...)                                ; several matches
+       (warning (_ "ambiguous package specification `~a'~%") spec)
+       (warning (_ "choosing ~a from ~a~%")
+                (package-full-name p)
+                (location->string (package-location p)))
+       p)
+      (_                                        ; no matches
+       (if version
+           (leave (_ "~A: package not found for version ~a~%")
+                  name version)
+           (leave (_ "~A: unknown package~%") name))))))
+
 (define (guix-main arg0 . args)
   (initialize-guix)
   (let ()
diff --git a/po/guix/Makevars b/po/guix/Makevars
index 87bb438..f5b498c 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 bf2d313..5cc68ff 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 0000000..f6dae47
--- /dev/null
+++ b/tests/lint.scm
@@ -0,0 +1,110 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2012, 2013 Cyril Roelandt <address@hidden>
+;;;
+;;; 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))
-- 
1.8.4.rc3




reply via email to

[Prev in Thread] Current Thread [Next in Thread]