diff options
| -rw-r--r-- | Makefile.am | 4 | ||||
| -rw-r--r-- | build-aux/sync-descriptions.scm | 85 | ||||
| -rw-r--r-- | guix/scripts/lint.scm | 60 |
3 files changed, 61 insertions, 88 deletions
diff --git a/Makefile.am b/Makefile.am index 075726d309..ee029c3735 100644 --- a/Makefile.am +++ b/Makefile.am @@ -233,7 +233,6 @@ EXTRA_DIST = \ build-aux/check-final-inputs-self-contained.scm \ build-aux/download.scm \ build-aux/list-packages.scm \ - build-aux/sync-descriptions.scm \ srfi/srfi-37.scm.in \ srfi/srfi-64.scm \ srfi/srfi-64.upstream.scm \ @@ -308,8 +307,7 @@ dist-hook: sync-descriptions gen-ChangeLog assert-no-store-file-names distcheck-hook: assert-binaries-available assert-final-inputs-self-contained sync-descriptions: - -$(top_builddir)/pre-inst-env $(GUILE) \ - $(top_srcdir)/build-aux/sync-descriptions.scm + -$(top_builddir)/pre-inst-env guix lint --checkers=gnu-description gen-ChangeLog: if test -d .git; then \ diff --git a/build-aux/sync-descriptions.scm b/build-aux/sync-descriptions.scm deleted file mode 100644 index 6ff549c309..0000000000 --- a/build-aux/sync-descriptions.scm +++ /dev/null @@ -1,85 +0,0 @@ -;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org> -;;; -;;; 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/>. - -;;; -;;; Report package synopses and descriptions that defer from those found in -;;; the GNU Womb. -;;; - -(use-modules (guix gnu-maintenance) - (guix packages) - (guix utils) - (guix ui) - (gnu packages) - (srfi srfi-1) - (srfi srfi-26) - (ice-9 match)) - -(define official - ;; GNU package descriptors from the Womb. - (official-gnu-packages)) - -(define gnus - ;; GNU packages available in the distro. - (let ((lookup (lambda (p) - (find (lambda (descriptor) - (equal? (gnu-package-name descriptor) - (package-name p))) - official)))) - (fold-packages (lambda (package result) - (or (and=> (lookup package) - (cut alist-cons package <> result)) - result)) - '()))) - -(define (escape-quotes str) - "Replace any quote character in STR by an escaped quote character." - (list->string - (string-fold-right (lambda (chr result) - (match chr - (#\" (cons* #\\ #\"result)) - (_ (cons chr result)))) - '() - str))) - -;; Iterate over GNU packages. Report those whose synopsis defers from that -;; found upstream. -(for-each (match-lambda - ((package . descriptor) - (let ((upstream (gnu-package-doc-summary descriptor)) - (downstream (package-synopsis package)) - (loc (or (package-field-location package 'synopsis) - (package-location package)))) - (unless (and upstream (string=? upstream downstream)) - (format (guix-warning-port) - "~a: ~a: proposed synopsis: ~s~%" - (location->string loc) (package-name package) - upstream))) - - (let ((upstream (gnu-package-doc-description descriptor)) - (downstream (package-description package)) - (loc (or (package-field-location package 'description) - (package-location package)))) - (when (and upstream - (not (string=? (fill-paragraph upstream 100) - (fill-paragraph downstream 100)))) - (format (guix-warning-port) - "~a: ~a: proposed description:~% \"~a\"~%" - (location->string loc) (package-name package) - (fill-paragraph (escape-quotes upstream) 77 7)))))) - gnus) diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 237709848f..facc2bf60b 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014 Cyril Roelandt <tipecaml@gmail.com> ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org> +;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -219,6 +220,61 @@ line." "file names of patches should start with the package name" 'patches)))) +(define (escape-quotes str) + "Replace any quote character in STR by an escaped quote character." + (list->string + (string-fold-right (lambda (chr result) + (match chr + (#\" (cons* #\\ #\"result)) + (_ (cons chr result)))) + '() + str))) + +(define official-gnu-packages* + (memoize + (lambda () + "A memoizing version of 'official-gnu-packages' that returns the empty +list when something goes wrong, such as a networking issue." + (let ((gnus (false-if-exception (official-gnu-packages)))) + (or gnus '()))))) + +(define (check-gnu-synopsis+description package) + "Make sure that, if PACKAGE is a GNU package, it uses the synopsis and +descriptions maintained upstream." + (match (find (lambda (descriptor) + (string=? (gnu-package-name descriptor) + (package-name package))) + (official-gnu-packages*)) + (#f ;not a GNU package, so nothing to do + #t) + (descriptor ;a genuine GNU package + (let ((upstream (gnu-package-doc-summary descriptor)) + (downstream (package-synopsis package)) + (loc (or (package-field-location package 'synopsis) + (package-location package)))) + (unless (and upstream (string=? upstream downstream)) + (format (guix-warning-port) + "~a: ~a: proposed synopsis: ~s~%" + (location->string loc) (package-full-name package) + upstream))) + + (let ((upstream (gnu-package-doc-description descriptor)) + (downstream (package-description package)) + (loc (or (package-field-location package 'description) + (package-location package)))) + (when (and upstream + (not (string=? (fill-paragraph upstream 100) + (fill-paragraph downstream 100)))) + (format (guix-warning-port) + "~a: ~a: proposed description:~% \"~a\"~%" + (location->string loc) (package-full-name package) + (fill-paragraph (escape-quotes upstream) 77 7))))))) + + +;;; +;;; List of checkers. +;;; + (define %checkers (list (lint-checker @@ -226,6 +282,10 @@ line." (description "Validate package descriptions") (check check-description-style)) (lint-checker + (name "gnu-description") + (description "Validate synopsis & description of GNU packages") + (check check-gnu-synopsis+description)) + (lint-checker (name "inputs-should-be-native") (description "Identify inputs that should be native inputs") (check check-inputs-should-be-native)) |