From db650186699ec82de2cfc9c2cbed1816b231cfec Mon Sep 17 00:00:00 2001 From: Sean Whitton Date: Sat, 13 Mar 2021 14:01:38 -0700 Subject: attempt to implement revised propspecs spec Signed-off-by: Sean Whitton --- src/propspec.lisp | 377 ++++++++++++++++++++++++------------------------------ 1 file changed, 166 insertions(+), 211 deletions(-) (limited to 'src/propspec.lisp') diff --git a/src/propspec.lisp b/src/propspec.lisp index 4e0dc8e..bb5fa71 100644 --- a/src/propspec.lisp +++ b/src/propspec.lisp @@ -19,71 +19,10 @@ ;;;; Property application specifications -(defmacro in-consfig (systems) - "Sets the variable *CONSFIG* in the current package to SYSTEMS, or (SYSTEMS) -if SYSTEMS is an atom. Used at the top of your consfig, right after IN-PACKAGE. - -This is used to record a list of the names of the ASDF systems in which you -define your hosts, site-specific properties and deployments. These systems -should depend on the \"consfigurator\" system. - -SYSTEMS should satisfy the following condition: in normal usage of -Consfigurator, evaluating -(mapc #'asdf:load-system (if (atom SYSTEMS) (list SYSTEMS) SYSTEMS) should be -sufficient to define all the properties you intend to apply to hosts. - -Consfigurator uses this information when starting up remote Lisp images to -effect deployments: it sends over the ASDF systems specified by SYSTEMS." - (setq systems (ensure-cons systems)) - (let ((sym (intern "*CONSFIG*"))) - `(eval-when (:compile-toplevel :load-toplevel :execute) - (defparameter ,sym ',systems - "ASDF systems the loading of all of which is sufficient to define all the -Consfigurator properties code in this symbol's package applies to hosts.")))) - -(defclass propspec () - ((systems - :initarg :systems - :initform (or (symbol-value (find-symbol "*CONSFIG*")) - (error - "Looks like *CONSFIG* is not set; please call IN-CONSFIG")) - :reader propspec-systems - :documentation "List of names of systems, the loading of all of which is -sufficient to deploy this propspec.") - (applications - :initarg :props - :reader propspec-props - :documentation "Ordered list of property applications. -The base case valid entry is of the form (PROPERTY . ARGS) where PROPERTY is -a symbol naming a property (typically as defined by DEFPROP) and ARGS is a -list of arguments to be passed when calling the property's subroutines. These -ARGS will not be evaluated before calling the function. - -Additionally, entries can be of the following forms: - - (unapply (PROPERTY . ARGS)) -- unapply the property, if it supports that. - - ((PROPERTY . ARGS) onchange (PROPERTY . ARGS) onchange (PROPERTY . ARGS)) - -- apply the second and third properties in the case that the first - property actually had work to do. - -... and combinations thereof. - -Deployments apply properties in the order specified here, so later entries in -the list implicitly depend on earlier ones. - -Members of ARGS must all be objects which can be serialised. In particular, -function objects are not permitted.")) - (:documentation - "The point of this data structure is to be a way to inform a Lisp image -running on a remote host how it can apply some properties: load each of the -systems, resolve unapply, onchange etc., and then look in the value cell of -each PROPERTY to find a property, and pass each of ARGS to the function in the -property's apply slot.")) - (defun map-propspec-propapps (function propspec &optional env) "Map FUNCTION over each propapp occurring in PROPSPEC after macroexpansion. -FUNCTION designates a pure function from propapps to propapps." +FUNCTION designates a pure function from propapps to propapps. PROPSPEC is a +property application specification expression." ;; The work of this function cannot be implemented fully portably. See ;; ;; Michael Raskin. 2017. Writing a best-effort portable code walker in @@ -124,167 +63,183 @@ FUNCTION designates a pure function from propapps to propapps." env))) env)))) -(defun make-propspec (&key (systems nil systems-supplied-p) props) - (setq props (copy-tree props)) - (labels ((preprocess (item) - (cond - ((and (listp item) (isprop (car item))) - (rplacd item (apply (proppp (car item)) (cdr item)))) - ((consp item) - (mapc #'preprocess item))))) - (preprocess props)) - (if systems-supplied-p - (make-instance 'propspec :props props :systems systems) - (make-instance 'propspec :props props))) +(defmacro in-consfig (systems) + "Sets the variable *CONSFIG* in the current package to SYSTEMS, or (SYSTEMS) +if SYSTEMS is an atom. Used at the top of your consfig, right after IN-PACKAGE. + +This is used to record a list of the names of the ASDF systems in which you +define your hosts, site-specific properties and deployments. These systems +should depend on the \"consfigurator\" system. + +SYSTEMS should satisfy the following condition: in normal usage of +Consfigurator, evaluating +(mapc #'asdf:load-system (if (atom SYSTEMS) (list SYSTEMS) SYSTEMS) should be +sufficient to define all the properties you intend to apply to hosts and +property combinators you intend to use in specifying propspecs. + +Consfigurator uses this information when starting up remote Lisp images to +effect deployments: it sends over the ASDF systems specified by SYSTEMS." + (setq systems (ensure-cons systems)) + (let ((sym (intern "*CONSFIG*"))) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (defparameter ,sym ',systems + "ASDF systems the loading of all of which is sufficient to define all the +Consfigurator properties and property combinators code in this symbol's +package applies to hosts.")))) -;; does not use MAKE-PROPSPEC because we do not want the :PREPROCESS -;; subroutines to be run again when the object is read back in +(defclass propspec () + ((systems + :initarg :systems + :initform (or (symbol-value (find-symbol "*CONSFIG*")) + (error + "Looks like *CONSFIG* is not set; please call IN-CONSFIG")) + :reader propspec-systems + :documentation + "List of names of ASDF systems, the loading of all of which is sufficient +to deploy this propspec.") + (preprocessed-propspec + :initarg :preprocessed-propspec + :documentation + "Preprocessed propspec corresponding to the propspec represented by this +PROPSPEC object. A preprocessed propspec is not itself a valid propspec, so +the value of this slot should be considered opaque.")) + (:documentation + "Object representing a propspec; specifically, a property application +specification expression associated with a list of ASDF systems. Use +MAKE-PROPSPEC to create instances of this class. + +The only valid methods operating directly on instances of this class are +PROPSPEC-SYSTEMS, APPEND-PROPSPECS, EVAL-PROPSPEC and PRINT-OBJECT.")) + +(defun make-propspec (&key (systems nil systems-supplied-p) propspec) + "Convert a property application specification expression into a property +application specification proper by associating it with a list of ASDF +systems." + (let ((preprocessed (map-propspec-propapps + (lambda (propapp) + (destructuring-bind (prop . args) propapp + `',(cons prop (apply (proppp prop) args)))) + propspec))) + (if systems-supplied-p + (make-instance 'propspec :systems systems + :preprocessed-propspec preprocessed) + (make-instance 'propspec :preprocessed-propspec preprocessed)))) + +;; since there are no unquoted propapps remaining in the propspec, we could +;; use MAKE-PROPSPEC here, but it is simpler just to use MAKE-INSTANCE (defmethod print-object ((propspec propspec) stream) (format stream "#.~S" `(make-instance 'propspec :systems ',(slot-value propspec 'systems) - :props ',(slot-value propspec 'applications))) + :preprocessed-propspec + ',(slot-value propspec 'preprocessed-propspec))) propspec) - -;; doesn't use MAKE-PROPSPEC because each of the propspecs will already have -;; had its :PREPROCESS subroutines run +;; likewise, there aren't any unquoted propapps in either of FIRST and SECOND, +;; so we could use MAKE-PROPSPEC, but it's simpler and more efficient not to (defmethod append-propspecs ((first propspec) (second propspec)) - (make-instance 'propspec - :props (append (slot-value first 'applications) - (slot-value second 'applications)) - :systems (loop with new = (slot-value first 'systems) - for s in (slot-value second 'systems) - do (pushnew s new) - finally (return new)))) - -;; All knowledge of the possible combinator symbols should be confined to -;; between here and the end of the file -- i.e., if we are to add any -;; combinators, this is the code that needs to change - -(defun compile-propapp (propapp) - "Recursively apply the effects of property combinators in PROPAPP to produce -an atomic property application." - (let ((sym (gensym))) - (cond - ;; UNAPPLY - ((symbol-named unapply (car propapp)) - (destructuring-bind (psym . args) (compile-propapp (cadr propapp)) - (setprop sym (proptype psym) - :desc (lambda (&rest args) - (strcat "Unapply: " (apply #'propdesc psym args))) - :check (complement (get psym 'check)) - :apply (get psym 'unapply) - :unapply (get psym 'apply)) - (cons sym args))) - ;; ON-CHANGE - ;; Following pretty much assumes that on-change is our only infix - ;; property combinator. - ((symbol-named on-change (cadr propapp)) - (let ((propapps (loop with remaining = (cdr propapp) - with apps - for s = (pop remaining) - for a = (pop remaining) - unless (symbol-named on-change s) - do (error "Invalid on-change expression") - else - do (push (compile-propapp a) apps) - unless remaining return apps))) - (destructuring-bind (psym . args) (compile-propapp (car propapp)) - (setprop sym (collapse-types (proptype psym) - (mapcar #'propapptype propapps)) - :desc (propdesc psym) - :hostattrs (lambda (&rest args) - (apply #'propattrs psym args) - (mapc #'propappattrs propapps)) - :check (get psym 'check) - :apply (lambda (&rest args) - (unless (eq :no-change - (apply psym args)) - (loop for propapp in propapps - do (propappapply propapp)))) - :unapply (lambda (&rest args) - (unless (eq :no-change - (apply #'propunapply psym args)) - (loop for propapp in propapps - do (propappapply propapp))))) - (cons sym args)))) - ;; atomic property application - (t - propapp)))) + (make-instance + 'propspec + :systems (union (slot-value first 'systems) + (slot-value second 'systems)) + :preprocessed-propspec `(silent-seqprops + ,(slot-value first 'preprocessed-propspec) + ,(slot-value second 'preprocessed-propspec)))) (defmethod eval-propspec ((propspec propspec)) - "Apply properties as specified by PROPSPEC." - ;; TODO should have this check in the closures produced by DEFPROP too, so - ;; that we will catch attempts to programmatically apply :LISP properties. - ;; for the check here, could offer a restart to apply all the properties up - ;; to but not including the first :LISP property (we don't just want to - ;; apply all non-:LISP because that might violate dependencies established - ;; by the order of the elements of PROPSPEC's props) - (when (and (subtypep (class-of *connection*) 'posix-connection) - (eq :lisp (propspec->type propspec))) - (error "Cannot apply :LISP properties using a POSIX connection")) ;; Don't try to load systems if we are a remote Lisp, as we don't upload the ;; .asd files, and we don't want to load out of /usr/share/common-lisp as we ;; might get a different version of the library at worst, or a lot of ;; warnings at best (unless *remote-lisp* - (loop for system in (slot-value propspec 'systems) - unless (asdf:component-loaded-p system) - do (asdf:load-system system))) - (loop for form in (slot-value propspec 'applications) - for propapp = (compile-propapp form) - do (let ((change-made (not (eq :no-change (propappapply propapp))))) - (format t "~@[~A :: ~]~@[~A ... ~]~:[ok~;done~]~%" - (get-hostname) - (propappdesc propapp) - change-made)))) - -(defmethod propspec->type ((propspec propspec)) - "Return :lisp if any types of the properties to be applied by PROPSPEC is -:lisp, else return :posix." - (loop for form in (slot-value propspec 'applications) - for propapp = (compile-propapp form) - if (eq (propapptype propapp) :lisp) - return :lisp - finally (return :posix))) - -(defun props (forms &optional (systems nil systems-supplied-p)) - "Where FORMS is the elements of an unevaluated property application -specification, return code which will evaluate the expressions and produce the -corresponding property application specification. - -SYSTEMS is the 'systems attribute of the property application specification -that the returned code should produce. - -Intended for use by macros which allow the user to provide expressions instead -of values as the arguments to properties when building a property application -specification." - (labels ((dedot-symbol (s) - (let ((n (symbol-name s))) - (intern (subseq n 0 (1- (length n))) (symbol-package s)))) - (special-eval (args) - (let ((first (if (and (listp (car args)) - (or (keywordp (caar args)) - (and (listp (caar args)) - (keywordp (caaar args))))) - `(quote ,(car args)) - (car args))) - (rest (nreverse (cdr (reverse (cdr args)))))) - `(,first ,@rest ,(props (lastcar args))))) - (make-eval-propspec (form) - (if (atom form) - `(quote ,form) - (destructuring-bind (first . rest) form - (if (and (symbolp first) - (not (member (symbol-name first) - '("UNAPPLY") - :test #'string=))) - (if (char= #\. (last-char (symbol-name first))) - `(list ',(dedot-symbol first) - ,@(special-eval rest)) - `(list ',first ,@rest)) - `(list ,@(mapcar #'make-eval-propspec form))))))) + (dolist (system (propspec-systems propspec)) + (unless (asdf:component-loaded-p system) + (asdf:load-system system)))) + (eval (slot-value propspec 'preprocessed-propspec))) + +(defmacro props (combinator &rest forms &aux replaced-propapps) + "Apply variadic COMBINATOR to FORMS and convert from an unevaluated property +application specification expression to a property application specification." + (labels ((replace-propapp (propapp) + (let ((gensym (gensym))) + (push (cons gensym propapp) replaced-propapps) + gensym)) + (walk (tree) + (if (atom tree) + (if-let ((propapp (assoc tree replaced-propapps))) + `(list ',(cadr propapp) ,@(cddr propapp)) + `',tree) + `(list ,@(mapcar #'walk tree))))) `(make-propspec - ,@(and systems-supplied-p `(:systems ,systems)) - :props (list ,@(mapcar #'make-eval-propspec forms))))) + :propspec ,(walk (map-propspec-propapps #'replace-propapp + (cons combinator forms)))))) + + +;;;; Property combinators + +(defmacro define-function-property-combinator (name args &body body) + (multiple-value-bind (forms declarations docstring) + (parse-body body :documentation t) + `(defun ,name ,args + ,@docstring + ,@declarations + (flet ((retprop (&rest all &key args &allow-other-keys) + (let ((psym (gensym)) + (setprop-args (remove-from-plist all :args))) + (apply #'setprop psym setprop-args) + (return-from ,name (list* psym args))))) + ,@forms)))) + +(define-function-property-combinator eseqprops (&rest propapps) + (retprop :type (collapse-types (mapcar #'propapptype propapps)) + :check (constantly nil) + :hostattrs (lambda () (mapc #'propappattrs propapps)) + :apply (lambda () (apply-and-print propapps)))) + +(define-function-property-combinator seqprops (&rest propapps) + (retprop :type (collapse-types (mapcar #'propapptype propapps)) + :check (constantly nil) + :hostattrs (lambda () (mapc #'propappattrs propapps)) + :apply (lambda () + (handler-bind + ((failed-change + (lambda (c) + (declare (ignore c)) + (invoke-restart 'skip-property)))) + (apply-and-print propapps))))) + +(define-function-property-combinator silent-seqprops (&rest propapps) + (retprop :type (collapse-types (mapcar #'propapptype propapps)) + :check (constantly nil) + :hostattrs (lambda () (mapc #'propappattrs propapps)) + :apply (lambda () + (handler-bind + ((failed-change + (lambda (c) + (declare (ignore c)) + (invoke-restart 'skip-property)))) + (mapc #'propappapply propapps))))) + +;; note that the :FAILED-CHANGE value is only used within this function and +;; should not be returned by property subroutines, per the spec +(defun apply-and-print (propapps) + (dolist (propapp propapps) + (let* ((result (restart-case (propappapply propapp) + (skip-property () :failed-change))) + (status (case result + (:no-change "ok") + (:failed-change "failed") + (t "done")))) + (format t "~@[~A :: ~]~@[~A ... ~]~A~%" + (get-hostname) (propappdesc propapp) status)))) + +(define-function-property-combinator unapply (propapp) + (destructuring-bind (psym . args) propapp + (retprop :type (proptype psym) + :lambda (propargs psym) + :desc (lambda (&rest args) + (strcat "Unapply: " (apply #'propdesc psym args))) + :check (complement (get psym 'check)) + :apply (get psym 'unapply) + :unapply (get psym 'apply) + :args args))) -- cgit v1.2.3