From: Matt Birkholz Date: Sat, 17 Mar 2018 09:10:56 +0000 (-0700) Subject: devops/lint.scm (plugin-deffn-lint): Add check-doc.sh functionality. X-Git-Tag: mit-scheme-pucked-x11-0.2.2~32 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=695b69802186f7cc48fdf96aef57d6b88465c329;p=mit-scheme.git devops/lint.scm (plugin-deffn-lint): Add check-doc.sh functionality. --- diff --git a/src/devops/Makefile.am b/src/devops/Makefile.am index 9046a6040..a08cbaf63 100644 --- a/src/devops/Makefile.am +++ b/src/devops/Makefile.am @@ -28,10 +28,11 @@ scmlib_subdir = $(scmlibdir)devops scmdocdir = $(datarootdir)/doc/@MIT_SCHEME_PROJECT@ scminfodir = $(scmdocdir)/info -sources = devops.scm build.scm +sources = devops.scm build.scm lint.scm binaries = devops.bin devops.bci devops.com binaries += build.bin build.bci build.com +binaries += lint.bin lint.bci lint.com scmlib_sub_DATA = $(sources) $(binaries) scmlib_sub_DATA += make.scm devops-@MIT_SCHEME_OS_SUFFIX@.pkd @@ -48,6 +49,9 @@ devops.com: stamp-scheme build.bin: stamp-scheme build.bci: stamp-scheme build.com: stamp-scheme +lint.bin: stamp-scheme +lint.bci: stamp-scheme +lint.com: stamp-scheme devops-@MIT_SCHEME_OS_SUFFIX@.pkd: stamp-scheme stamp-scheme: $(sources) devops.pkg touch stamp-scheme diff --git a/src/devops/compile.sh b/src/devops/compile.sh index 20ff61114..f3a20b2a6 100755 --- a/src/devops/compile.sh +++ b/src/devops/compile.sh @@ -9,6 +9,7 @@ ${MIT_SCHEME_EXE} --batch-mode <<\EOF (begin (compile-file "build") (compile-file "devops") + (compile-file "lint") (load-option 'cref) (cref/generate-constructors "devops") ) diff --git a/src/devops/devops.pkg b/src/devops/devops.pkg index 11da6ea68..fc705b0c5 100644 --- a/src/devops/devops.pkg +++ b/src/devops/devops.pkg @@ -24,6 +24,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. ;;;; Developer Operations System Packaging (global-definitions runtime/) +(global-definitions cref/) (define-package (devops build) (parent ()) @@ -35,4 +36,21 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (export () devops:status devops:release - devops:build)) \ No newline at end of file + devops:build + devops:make)) + +(define-package (devops lint) + (parent (devops)) + (files "lint") + (export (devops) + plugin-deffn-lint) + (import (cross-reference) + read-package-model + pmodel/packages + package/name + package/bindings + package/links + link/source + link/destination + binding/package + binding/name)) \ No newline at end of file diff --git a/src/devops/devops.scm b/src/devops/devops.scm index f1c9670ea..6d9f3e2cc 100644 --- a/src/devops/devops.scm +++ b/src/devops/devops.scm @@ -34,7 +34,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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)))) @@ -123,14 +123,14 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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.")) '()))) @@ -141,9 +141,9 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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))) @@ -151,23 +151,23 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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) diff --git a/src/devops/lint.scm b/src/devops/lint.scm new file mode 100644 index 000000000..9c41fe3e0 --- /dev/null +++ b/src/devops/lint.scm @@ -0,0 +1,131 @@ +#| -*-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 diff --git a/src/devops/make.scm b/src/devops/make.scm index 32285f6f7..ba86c0a51 100644 --- a/src/devops/make.scm +++ b/src/devops/make.scm @@ -2,6 +2,7 @@ Load the Developer Operations plugin. |# +(load-option 'cref) (with-loader-base-uri (system-library-uri "devops/") (lambda () (load-package-set "devops")))