(else (error "Unknown developer operation:" cmdl)))))
(define (devops:status #!optional name)
- (load "devops/config.scm")
+ (load "devops/config.scm" (->environment '(devops)))
(if (default-object? name)
(status)
(plugin-status (->plugin name) (dirt))))
(define (debian-version-lint version filename dversion dfilename)
(append
(if (not version)
- (list (string filename": Warning: package version not found."))
+ (list (string filename": package version not found."))
'())
(if (not dversion)
- (list (string dfilename": Warning: Debian version not found."))
+ (list (string dfilename": Debian version not found."))
'())
(if (and version dversion
(not (version=? version dversion)))
- (list (string dfilename": Warning: Debian version"
+ (list (string dfilename": Debian version"
" ("(version-string dversion)")"
" does not match."))
'())))
(if (string=? nvers (version-string version))
'()
(list (string (plugin-directory plugin)"/NEWS:"
- " Warning: version ("nvers") does not match.")))
+ " version ("nvers") does not match.")))
(list (string (plugin-directory plugin)"/NEWS:"
- " Warning: version not found.")))))
+ " version not found.")))))
(define (subsystem-version-lint plugin version)
(let ((svers (read-subsystem-version plugin)))
(if (version=? svers version)
'()
(list (string (plugin-directory plugin)"/make.scm:"
- " Warning: subsystem version "svers
+ " subsystem version "svers
" does not match.")))
(list (string (plugin-directory plugin)"/make.scm:"
- " Warning: subsystem version not found.")))))
+ " subsystem version not found.")))))
(define (released-version-lint version released changes filename)
(cond ((eq? #f released)
(list "First release!"))
((and (pair? changes)
(not (version>? version released)))
- (list (string filename": Warning: version is out-of-date.")))
+ (list (string filename": version is out-of-date.")))
(else
'())))
(define (dirt-lint dirt)
(if (pair? dirt)
- (cons "Warning: uncommitted files:" dirt)
+ (cons "Uncommitted files:" dirt)
'()))
(define (changes-lint changes)
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 2016, 2017, 2018 Matthew Birkholz
+
+This file is part of a devops plugin for MIT/GNU Scheme Pucked.
+
+This plugin 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 2 of the License, or (at your
+option) any later version.
+
+This plugin 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 this plugin; if not, write to the Free Software Foundation,
+Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
+
+|#
+
+;;;; Developer Operations Lint Brush
+
+;;; See devops.texi for complete details.
+
+(define (plugin-deffn-lint plugin pkg exceptions)
+ ;; If the plugin contains a .texi file with the same name, check
+ ;; that it has a @deffn for every binding exported to () or PKG
+ ;; except for EXCEPTIONS.
+ (let* ((name (plugin-name plugin))
+ (dir (plugin-directory plugin))
+ (file (string dir"/"name".texi")))
+
+ (define (lint)
+ (let* ((texinfo (list->vector (call-with-input-file file read-lines)))
+ (deffns (texinfo-deffns texinfo))
+ (dups (duplicates deffns))
+ (pmodel (read-package-model (string dir"/"name)
+ microcode-id/operating-system))
+ (bindings (difference
+ (append (pmodel/global-exports pmodel)
+ (if (not pkg)
+ '()
+ (pmodel/package-bindings pmodel pkg)))
+ exceptions))
+ (missing (difference bindings deffns))
+ (extras (difference deffns bindings)))
+ (append!
+ (map (lambda (n) (string file": "n" has multiple descriptions")) dups)
+ (map (lambda (n) (string file": "n" is not bound")) extras)
+ (map (lambda (n) (string file": "n" is not documented")) missing))))
+
+ (define deffn-patt
+ (compile-regsexp '(seq "@deffn"(?"x")" "
+ (alt "Class" "Procedure" "{Generic Procedure}")" "
+ (group name
+ (+ (char-not-in whitespace))))))
+
+ (define (deffn-name line)
+ (let ((match (regsexp-match-string deffn-patt line)))
+ (if match
+ (intern (match-extract match 'name))
+ (error "Could not find binding name:" line))))
+
+ (define (texinfo-deffns lines)
+ (let ((len (vector-length lines)))
+ (let loop ((i 0) (deffns '()))
+ (if (fix:< i len)
+ (let ((line (vector-ref lines i)))
+ (loop (fix:1+ i)
+ (if (string-prefix? "@deffn" line)
+ (cons (deffn-name line) deffns)
+ deffns)))
+ deffns))))
+
+ (define (pmodel/find-package pmodel package-name)
+ (find-matching-item (pmodel/packages pmodel)
+ (lambda (p) (equal? package-name (package/name p)))))
+
+ (define (pmodel/global-exports pmodel)
+ (define (global-exports package)
+ (append-map! (lambda (link)
+ (if (eq? '() (package/name
+ (binding/package
+ (link/destination link))))
+ (list (binding/name (link/destination link)))
+ '()))
+ (package/links package)))
+ (append-map! global-exports (pmodel/packages pmodel)))
+
+ (define (pmodel/package-bindings pmodel package-name)
+ (let ((package (pmodel/find-package pmodel package-name)))
+ (if package
+ (map binding/name (package/bindings package))
+ (error "No such package:" package-name))))
+
+ (define (duplicates listset)
+ (let loop ((items listset) (duplicates '()))
+ (cond ((null? items)
+ (reverse! duplicates))
+ ((memq (car items) (cdr items))
+ (if (memq (car items) duplicates)
+ (loop (cdr items) duplicates)
+ (loop (cdr items) (cons (car items) duplicates))))
+ (else
+ (loop (cdr items) duplicates)))))
+
+ (define (difference set1 set2)
+ (let loop ((items set1) (difference '()))
+ (cond ((null? items)
+ difference)
+ ((memq (car items) set2)
+ (loop (cdr items) difference))
+ (else
+ (loop (cdr items) (cons (car items) difference))))))
+
+ (if (file-exists? file)
+ (lint)
+ '())))
+
+(define (plugin-texi-SCMVERS-lint file-name file-lines core-version-string)
+ ;; Too specific for general use.
+ (let ((line (find file-lines
+ (lambda (line)
+ (string-prefix? "@set SCMVERS " line)))))
+ (cond ((not line)
+ (list (string file-name": no @set SCMVERS found")))
+ ((not (string=? line (string "@set SCMVERS "core-version-string)))
+ (list (string file-name": wrong SCMVERS")))
+ (else '()))))
\ No newline at end of file
projects / mit-scheme.git / commitdiff