add WITH-UNAPPLY & COLLAPSE-PROPAPP-TYPES

Signed-off-by: Sean Whitton <spwhitton@spwhitton.name>

3 files changed, 35 insertions, 0 deletions

diff --git a/src/combinator.lisp b/src/combinator.lisp
index 68ae61e..4dcd878 100644
--- a/src/combinator.lisp
+++ b/src/combinator.lisp
@@ -248,3 +248,32 @@ FLAGFILE exists, PROPAPPS are assumed to all be already applied."
                        (prog1 (propappunapply propapp)
                          (mrun "rm" flagfile)))
             :args (cdr propapp)))
+
+(define-function-property-combinator with-unapply (&rest propapps)
+  "As ESEQPROPS, except that if :UNAPPLY appears in PROPAPPS, then return a
+property which applies the elements of PROPAPPS prior to :UNAPPLY, but which
+when unapplied ignores the elements of PROPAPPS prior to :UNAPPLY, and instead
+applies the elements of PROPAPPS appearing after :UNAPPLY.
+
+Analogously to how DEFPROPLIST/DEFPROPSPEC allow you to define a property
+which works by calling other properties, this combinator allows you to define
+an :UNAPPLY subroutine for a property which works by calling other properties."
+  (let* ((apply (loop for propapp in propapps
+                      until (eql propapp :unapply) collect propapp))
+         (unapply (member :unapply propapps))
+         (apply-propapp
+           (if (cdr apply) (apply #'eseqprops apply) (car apply)))
+         (unapply-propapp (if (cddr unapply)
+                              (apply #'eseqprops (cdr unapply))
+                              (cadr unapply))))
+    (if unapply
+        (:retprop :type (collapse-propapp-types apply (cdr unapply))
+                  :hostattrs (lambda-ignoring-args
+                               (propappattrs apply-propapp)
+                               ;; as in definition of UNAPPLY combinator
+                               (with-preserve-hostattrs
+                                 (propappattrs unapply-propapp)))
+                  :apply (lambda-ignoring-args (propappapply apply-propapp))
+                  :unapply (lambda-ignoring-args
+                             (propappapply unapply-propapp)))
+        apply-propapp)))
diff --git a/src/package.lisp b/src/package.lisp
index 4af1b15..ba500ef 100644
--- a/src/package.lisp
+++ b/src/package.lisp
@@ -140,6 +140,7 @@
            #:propattrs
            #:propunapply
            #:collapse-types
+           #:collapse-propapp-types
            #:propapptype
            #:propappdesc
            #:propappattrs
@@ -194,6 +195,7 @@
            #:on-change
 	   #:as
            #:with-flagfile
+           #:with-unapply
 
            ;; host.lisp
            #:host
diff --git a/src/property.lisp b/src/property.lisp
index 2ef9f5d..499e061 100644
--- a/src/property.lisp
+++ b/src/property.lisp
@@ -66,6 +66,10 @@
 (defun collapse-types (&rest lists)
   (if (member :posix (flatten lists)) :posix :lisp))
 
+(defun collapse-propapp-types (&rest lists)
+  (if (member :posix (mapcan (curry #'mapcar #'propapptype) lists))
+      :posix :lisp))
+
 (defun propdesc (prop &rest args)
   (apply (get prop 'desc #'noop) args))