From 49c7bb8b4ce3b7c1f2993b5cc7b757cb716b25ae Mon Sep 17 00:00:00 2001
From: Sean Whitton <spwhitton@spwhitton.name>
Date: Sun, 21 Mar 2021 20:43:17 -0700
Subject: move combinators to their own file to avoid dependency loop

Signed-off-by: Sean Whitton <spwhitton@spwhitton.name>
---
 src/propspec.lisp | 114 ------------------------------------------------------
 1 file changed, 114 deletions(-)

(limited to 'src/propspec.lisp')

diff --git a/src/propspec.lisp b/src/propspec.lisp
index 00e76f2..bde3826 100644
--- a/src/propspec.lisp
+++ b/src/propspec.lisp
@@ -264,117 +264,3 @@ expression."
 	;; resignal with a more specific error message
 	(error 'ambiguous-unevaluated-propspec
 	       :name (cell-error-name c))))))
-
-
-;;;; 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
-       ,@(and docstring `(,docstring))
-       ,@declarations
-       (flet ((:retprop (&rest all &key args &allow-other-keys)
-		(let ((psym (gensym ,(symbol-name name)))
-		      (setprop-args (remove-from-plist all :args)))
-		  (apply #'setprop psym setprop-args)
-		  (return-from ,name (list* psym args)))))
-	 ,@forms))))
-
-(defmacro with-skip-failed-changes (&body forms)
-  `(handler-bind ((failed-change
-		    (lambda (c)
-		      (with-indented-inform
-			(informat t
-				  (simple-condition-format-control c)
-				  (simple-condition-format-arguments c)))
-		      (invoke-restart 'skip-property))))
-     ,@forms))
-
-(define-function-property-combinator eseqprops (&rest propapps)
-  (:retprop :type (collapse-types (mapcar #'propapptype propapps))
-	    :hostattrs (lambda () (mapc #'propappattrs propapps))
-	    :apply (lambda () (apply-and-print propapps))
-	    :unapply (lambda () (apply-and-print propapps t))))
-
-(define-function-property-combinator seqprops (&rest propapps)
-  (:retprop :type (collapse-types (mapcar #'propapptype propapps))
-	    :hostattrs (lambda () (mapc #'propappattrs propapps))
-	    :apply (lambda ()
-		     (with-skip-failed-changes
-		       (apply-and-print propapps)))
-	    :unapply (lambda ()
-		       (with-skip-failed-changes
-			 (apply-and-print propapps t)))))
-
-(defmacro with-requirements (propapp &body requirements)
-  "Apply PROPAPP only after applying each dependency in REQUIREMENTS.
-Each item in REQUIREMENTS implicitly depends on the one preceding it, i.e., we
-apply the elements of REQUIREMENTS in reverse order."
-  `(eseqprops ,@(reverse requirements) ,propapp))
-
-(define-function-property-combinator silent-seqprops (&rest propapps)
-  (:retprop :type (collapse-types (mapcar #'propapptype propapps))
-	    :hostattrs (lambda () (mapc #'propappattrs propapps))
-	    :apply (lambda ()
-		     (with-skip-failed-changes
-		       (mapc #'propappapply propapps)))
-	    :unapply (lambda ()
-		       (with-skip-failed-changes
-			 (mapc #'propappunapply (reverse 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 &optional unapply)
-  (dolist (pa (if unapply (reverse propapps) propapps))
-    (let* ((result (restart-case
-		       (with-indented-inform
-			 (if unapply (propappunapply pa) (propappapply pa)))
-		     (skip-property () :failed-change)))
-	   (status (case result
-		     (:no-change     "ok")
-		     (:failed-change "failed")
-		     (t              "done"))))
-      (informat t "~&~@[~A :: ~]~@[~A ... ~]~A~%"
-		(get-hostname) (propappdesc pa) status))))
-
-(define-function-property-combinator unapply (propapp)
-  (destructuring-bind (psym . args) propapp
-    (:retprop :type (proptype psym)
-	      :lambda (proplambda psym)
-	      :desc (lambda (&rest args)
-		      (strcat "Unapply: " (apply #'propdesc psym args)))
-	      :check (when-let ((check (get psym 'check)))
-		       (complement check))
-	      :hostattrs (lambda (&rest args)
-			   ;; run the :HOSTATTRS subroutine but throw away any
-			   ;; new hostattrs; when unapplying, the :HOSTATTRS
-			   ;; subroutine is only to check compatibility
-			   (with-preserve-hostattrs
-			     (apply #'propattrs psym args)))
-	      :apply (get psym 'unapply)
-	      :unapply (get psym 'papply)
-	      :args args)))
-
-(defmacro on-change (propapp &body on-change)
-  "If applying PROPAPP makes a change, also apply each of of the propapps
-ON-CHANGE in order."
-  `(on-change* ,propapp ,@on-change))
-
-(define-function-property-combinator on-change* (propapp &rest propapps)
-  (:retprop :type (collapse-types (propapptype propapp)
-				  (mapcar #'propapptype propapps))
-	    :desc (get (car propapp) 'desc)
-	    :hostattrs (lambda (&rest args)
-			 (apply #'propattrs (car propapp) args))
-	    :apply (lambda (&rest args)
-		     (unless (eq (propappapply (cons (car propapp) args))
-				 :no-change)
-		       (dolist (propapp propapps)
-			 (propappapply propapp))))
-	    :unapply (lambda (&rest args)
-		       (unless (eq (propappunapply (cons (car propapp) args))
-				   :no-change)
-			 (dolist (propapp (reverse propapps))
-			   (propappunapply propapp))))
-	    :args (cdr propapp)))
-- 
cgit v1.2.3