mirror of git://git.savannah.gnu.org/guix.git
lint: Fold 'sync-descriptions' script as 'gnu-description' lint checker.
* build-aux/sync-descriptions.scm: Remove. Move payload to... * guix/scripts/lint.scm: ... here. (escape-quotes, official-gnu-packages*, check-gnu-synopsis+description): New procedures. (%checkers): Add 'gnu-descriptions'. * Makefile.am (EXTRA_DIST): Remove build-aux/sync-descriptions.scm. (sync-descriptions): Use 'guix lint'.
This commit is contained in:
Ludovic Courtès
parent
dd3b6d66b9
commit
37627ffa89
|
|
@ -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 \
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
@ -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,12 +220,71 @@ 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
|
||||
(name "description")
|
||||
(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")
|
||||
|
|
|
|||
Loading…
Reference in New Issue