diff --git a/nasdf/compilation-tests.lisp b/nasdf/compilation-tests.lisp index 61c6a9e..60bff48 100644 --- a/nasdf/compilation-tests.lisp +++ b/nasdf/compilation-tests.lisp @@ -11,6 +11,11 @@ :reader packages :documentation "Packages to check for unbound exports. Sub-packages are included in the check.") + (unbound-symbols-to-ignore + :initform '() + :initarg :unbound-symbols-to-ignore + :reader unbound-symbols-to-ignore + :documentation "Symbols to ignore when checking for unbound exports.") (undocumented-symbols-to-ignore :initform '() :initarg :undocumented-symbols-to-ignore @@ -21,11 +26,37 @@ Likely, slot names (these don't have native `documentation' support.")) (import 'nasdf-compilation-test-system :asdf-user) (defun valid-type-p (type-specifier) - (handler-case - (progn - (typep t type-specifier) - t) - (error () nil))) + "Check the TYPE-SPECIFIER for being a valid type. +The logic is: +- If the type is documented as a type, then a type it is. +- Otherwise, if `typep' exits normally (with whatever return value) + when checking arbitrary value against this specifier, then + TYPE-SPECIFIER is valid. +- And if there's an error about argument types, then TYPE-SPECIFIER is + the type requiring arguments. Which means: type exists, even if + requiring arguments. +- If there's any other error raised by `typep', then TYPE-SPECIFIER is + likely not a type." + (or (ignore-errors (documentation type-specifier 'type)) + (handler-case + (progn + (typep t type-specifier) + t) + #+sbcl + (sb-kernel::arg-count-error () + t) + #+ccl + (ccl::simple-program-error (e) + (search "can't be destructured against the lambda list" (format nil "~a" e))) + #+ecl + (simple-error (e) + (or (search "Too few arguments" (format nil "~a" e)) + (not (search "not a valid type specifier" (format nil "~a" e))))) + #+clisp + (simple-error (e) + (or (search "may not be called with 0 arguments" (format nil "~a" e)) + (not (search "invalid type specification" (format nil "~a" e))))) + (error () nil)))) (defun list-unbound-exports (package) (let ((result '())) @@ -49,14 +80,30 @@ A sub-package has a name that starts with that of PACKAGE followed by a '/' sepa (remove-if (lambda (pkg) (not (subpackage-p pkg package))) (list-all-packages))) (defun list-undocumented-exports (package) - (let ((result '())) - (do-external-symbols (s (find-package package) result) - (unless (or (some (lambda (doctype) (documentation s doctype)) - '(variable function compiler-macro setf method-combination type structure)) - ;; Parenscript macros don't have documentation. - (and (find-package :parenscript) - (gethash s (symbol-value (find-symbol "*MACRO-TOPLEVEL*" :parenscript))))) - (push s result))))) + (let ((result '()) + (classes (loop for s being the external-symbol in package + when (find-class s nil) + collect s))) + (flet ((accessor-p (symbol) + "Check whether the SYMBOL is a slot accessor. +This is necessary because accessors rarely have documentation and thus +have to be excluded from the undocumented symbols list. +Uses the built-in MOP abilities of every Lisp." + (and (fboundp symbol) + (typep (symbol-function symbol) 'generic-function) + (some (lambda (class) + (ignore-errors + (typep (find-method (symbol-function symbol) '() (list (find-class class))) + '(or standard-accessor-method standard-reader-method standard-writer-method)))) + classes)))) + (do-external-symbols (s (find-package package) result) + (unless (or (some (lambda (doctype) (ignore-errors (documentation s doctype))) + '(variable function compiler-macro setf method-combination type structure)) + (accessor-p s) + ;; Parenscript macros don't have documentation. + (and (find-package :parenscript) + (gethash s (symbol-value (find-symbol "*MACRO-TOPLEVEL*" :parenscript))))) + (push s result)))))) (flet ((list-offending-packages (package export-lister testing-for) (let* ((package (find-package package))) @@ -67,13 +114,27 @@ A sub-package has a name that starts with that of PACKAGE followed by a '/' sepa (when exports (list package exports)))) (cons (find-package package) (list-subpackages package))))))) - (defun unbound-exports (package) + (defun unbound-exports (package symbols-to-ignore) "Report unbound exported symbols for PACKAGE and all its subpackages." ;; NOTE: these implementations throw errors on atypical type specifier, enabling `valid-type-p' #+(or sbcl ccl ecl clisp) - (let ((report (list-offending-packages package #'list-unbound-exports "unbound exports"))) + (let* ((report (list-offending-packages package #'list-unbound-exports "unbound exports")) + (report (delete + nil + (mapcar (lambda (rep) + (destructuring-bind (package symbols) + rep + (let ((really-undocumented-symbols + (remove-if (lambda (sym) + (member (symbol-name sym) symbols-to-ignore + :key #'symbol-name :test #'equal)) + symbols))) + (if really-undocumented-symbols + (list package really-undocumented-symbols) + nil)))) + report)))) (when report - (error "~a~&Found unbound exported symbols in ~a package~:p." + (error "~s~&Found unbound exported symbols in ~a package~:p." report (length report)))) #-(or sbcl ccl ecl clisp) nil) @@ -97,11 +158,11 @@ documentation (e.g. slot names)." nil)))) report)))) (when report - (error "~a~&Found undocumented exported symbols in ~a package~:p." + (error "~s~&Found undocumented exported symbols in ~a package~:p." report (length report)))))) (defmethod asdf:perform ((op asdf:test-op) (c nasdf-compilation-test-system)) (logger "------- STARTING Compilation Testing: ~a" (packages c)) - (mapc #'unbound-exports (packages c)) + (mapc #'(lambda (p) (unbound-exports p (unbound-symbols-to-ignore c))) (packages c)) (mapc #'(lambda (p) (undocumented-exports p (undocumented-symbols-to-ignore c))) (packages c)) (logger "------- ENDING Compilation Testing: ~a" (packages c))) diff --git a/nasdf/install.lisp b/nasdf/install.lisp index af583a5..a88dc84 100644 --- a/nasdf/install.lisp +++ b/nasdf/install.lisp @@ -84,8 +84,8 @@ Destination directory is given by the `dest-source-dir' generic function.")) (first (last (pathname-directory ;; Ensure directory _after_ truenamizing, otherwise if ;; non-directory file exists it may not yield a directory. - (uiop:ensure-directory-pathname - (uiop:ensure-pathname pathname :truenamize t))))))) + (ensure-directory-pathname + (ensure-pathname pathname :truenamize t))))))) (defun path-from-env (environment-variable default) (let ((env (getenv environment-variable))) @@ -120,11 +120,16 @@ Destination directory is given by the `dest-source-dir' generic function.")) *libdir*) (export-always '*dest-source-dir*) -(defvar *dest-source-dir* (path-from-env "NASDF_SOURCE_PATH" *datadir*)) +(defvar *dest-source-dir* (path-from-env "NASDF_SOURCE_PATH" *datadir*) + "Root of where the source will be installed. +Final path is resolved in `dest-source-dir'.") (export-always 'dest-source-dir) (defmethod dest-source-dir ((component nasdf-source-directory)) - *dest-source-dir*) + "The directory into which the source is installed." + (let ((name (asdf:primary-system-name (asdf:component-system component)))) + (ensure-directory-pathname + (merge-pathnames* name *dest-source-dir*)))) (export-always '*chmod-program*) (defvar *chmod-program* "chmod") @@ -158,12 +163,12 @@ Destination directory is given by the `dest-source-dir' generic function.")) nil) (defmethod asdf:output-files ((op asdf:compile-op) (c nasdf-file)) - (values (list (uiop:merge-pathnames* (pathname-name (asdf:component-name c)) - *prefix*)) + (values (list (merge-pathnames* (pathname-name (asdf:component-name c)) + *prefix*)) t)) (defmethod asdf:output-files ((op asdf:compile-op) (c nasdf-binary-file)) - (values (list (uiop:merge-pathnames* (basename (asdf:component-name c)) *bindir*)) + (values (list (merge-pathnames* (basename (asdf:component-name c)) *bindir*)) t)) (defmethod asdf:perform ((op asdf:compile-op) (c nasdf-binary-file)) @@ -172,14 +177,14 @@ Destination directory is given by the `dest-source-dir' generic function.")) nil) (defmethod asdf:output-files ((op asdf:compile-op) (c nasdf-library-file)) - (values (list (uiop:merge-pathnames* (basename (asdf:component-name c)) (libdir c))) + (values (list (merge-pathnames* (basename (asdf:component-name c)) (libdir c))) t)) (defmethod asdf:output-files ((op asdf:compile-op) (c nasdf-desktop-file)) - (values (list (uiop:merge-pathnames* (uiop:merge-pathnames* - (basename (asdf:component-name c)) - "applications/") - *datadir*)) + (values (list (merge-pathnames* (merge-pathnames* + (basename (asdf:component-name c)) + "applications/") + *datadir*)) t)) (defun scan-last-number (path) @@ -192,7 +197,7 @@ Return NIL is there is none." (if result (return-from red result) result))) - (uiop:native-namestring path) + (native-namestring path) :initial-value '() :from-end t)))) (when result @@ -202,8 +207,8 @@ Return NIL is there is none." "Return all files of NASDF-ICON-DIRECTORY `type' in its directory. File must contain a number in their path." (let ((result (remove-if (complement #'scan-last-number) - (uiop:directory-files (asdf:component-pathname c) - (uiop:strcat "*." (asdf:file-type c)))))) + (directory-files (asdf:component-pathname c) + (strcat "*." (asdf:file-type c)))))) (let* ((dimensions (mapcar #'scan-last-number result)) (dups (set-difference dimensions (remove-duplicates dimensions) @@ -242,13 +247,13 @@ File must contain a number in their path." (constantly t) (lambda (dir) (notany (lambda (exclusion) - (uiop:string-suffix-p (basename dir) exclusion)) + (string-suffix-p (basename dir) exclusion)) (mapcar #'basename exclude-subpath))) (lambda (subdirectory) (setf result (append result (remove-if (lambda (file) (file-excluded-type file exclude-types)) - (uiop:directory-files subdirectory)))))) + (directory-files subdirectory)))))) result)) (export-always 'copy-directory) @@ -273,18 +278,18 @@ They are either listed with 'git ls-files' or directly if Git is not found." (let ((source (asdf:component-pathname component)) (root (asdf:system-source-directory (asdf:component-system component)))) (handler-case - (uiop:with-current-directory (root) + (with-current-directory (root) (let ((absolute-exclusions (mapcar (lambda (exclusion) (namestring (merge-pathnames* - (uiop:ensure-directory-pathname exclusion) - (uiop:ensure-directory-pathname source)))) + (ensure-directory-pathname exclusion) + (ensure-directory-pathname source)))) (exclude-subpath component)))) (remove-if (lambda (file) (or (file-excluded-type file (exclude-types component)) (let ((file-string (namestring file))) (some (lambda (exclusion) - (uiop:string-prefix-p exclusion file-string)) + (string-prefix-p exclusion file-string)) absolute-exclusions)))) (mapcar (lambda (path) (ensure-pathname path :truenamize t)) @@ -293,7 +298,7 @@ They are either listed with 'git ls-files' or directly if Git is not found." source))))) (error (c) (warn "~a~&Git error, falling back to direct listing." c) - (uiop:with-current-directory (root) + (with-current-directory (root) (list-directory source :exclude-subpath (exclude-subpath component) :exclude-types (exclude-types component))))))) @@ -304,3 +309,20 @@ They are either listed with 'git ls-files' or directly if Git is not found." (merge-pathnames* (uiop:subpathp path root) (dest-source-dir component))) (asdf:input-files op component)) t))) + +(export-always 'nasdf-source-file) +(defclass nasdf-source-file (nasdf-file) () + (:documentation "Common Lisp source files. + +Destination directory is given by the `dest-source-dir' generic function.")) +(import 'nasdf-source-file :asdf-user) + +(defmethod dest-source-dir ((component nasdf-source-file)) ; TODO: Factor with other method? + "The directory into which the source is installed." + (let ((name (asdf:primary-system-name (asdf:component-system component)))) + (ensure-directory-pathname + (merge-pathnames* name *dest-source-dir*)))) + +(defmethod asdf:output-files ((op asdf:compile-op) (c nasdf-source-file)) + (values (list (merge-pathnames* (basename (asdf:component-name c)) (dest-source-dir c))) + t)) diff --git a/nasdf/nasdf.asd b/nasdf/nasdf.asd index ec6f1fc..d3f8c45 100644 --- a/nasdf/nasdf.asd +++ b/nasdf/nasdf.asd @@ -2,7 +2,7 @@ ;;;; SPDX-License-Identifier: BSD-3-Clause (defsystem "nasdf" - :version "0.1.3" + :version "0.1.7" :author "Atlas Engineer LLC" :homepage "https://github.com/atlas-engineer/ntemplate" :description "ASDF helpers for system setup, testing and installation." diff --git a/nasdf/package.lisp b/nasdf/package.lisp index 20a99bd..faae1b0 100644 --- a/nasdf/package.lisp +++ b/nasdf/package.lisp @@ -26,13 +26,33 @@ #:run-program #:split-string #:strcat + #:string-prefix-p + #:string-suffix-p #:subpathp - #:symbol-call) + #:symbol-call + #:with-current-directory) (:import-from :asdf #:clear-configuration #:perform #:system-relative-pathname #:system-source-directory) + (:import-from + #+abcl #:mop + #+allegro #:mop + #+clisp #:clos + #+clozure #:ccl + #+cmu #:clos-mop + #+ecl #:clos + #+clasp #:clos + #+lispworks #:clos + #+mcl #:ccl + #+sbcl #:sb-mop + #+scl #:clos + #+mezzano #:mezzano.clos + #+sicl #:sicl-clos + #:standard-accessor-method + #:standard-reader-method + #:standard-writer-method) (:documentation "ASDF helpers for system setup, testing and installation. To tell ASDF to fail loading a system on warnings, add this line to the system diff --git a/nasdf/submodules.lisp b/nasdf/submodules.lisp index 0e0e731..4c2fc2b 100644 --- a/nasdf/submodules.lisp +++ b/nasdf/submodules.lisp @@ -45,6 +45,13 @@ A naive benchmark on a 16 Mbps bandwidth gives us (system-relative-pathname component path)))) (setf (getenv "CL_SOURCE_REGISTRY") (strcat + ;; Register this repository's NASDF path first, to ensure we don't + ;; use any NASDF from submodules. + (native-namestring + (ensure-directory-pathname + (ensure-absolute-path "libraries/nasdf" component))) + (inter-directory-separator) + ;; Submodules: (native-namestring (ensure-directory-pathname (ensure-absolute-path *submodules-directory* component)))