diff options
| author | Sean Whitton <spwhitton@spwhitton.name> | 2021-03-18 09:31:43 -0700 |
|---|---|---|
| committer | Sean Whitton <spwhitton@spwhitton.name> | 2021-03-18 09:55:57 -0700 |
| commit | 9288d579cce868af02e442ad8d910c06b710ef53 (patch) | |
| tree | e20d924c6c7be9ebe2b138c746438ffcc17cc485 /src | |
| parent | 415ce75b066526125c5647e54b0db4821f4ddc54 (diff) | |
| download | consfigurator-9288d579cce868af02e442ad8d910c06b710ef53.tar.gz | |
add OS:HOST-TYPECASE
Signed-off-by: Sean Whitton <spwhitton@spwhitton.name>
Diffstat (limited to 'src')
| -rw-r--r-- | src/package.lisp | 9 | ||||
| -rw-r--r-- | src/property/os.lisp | 33 | ||||
| -rw-r--r-- | src/propspec.lisp | 24 |
3 files changed, 39 insertions, 27 deletions
diff --git a/src/package.lisp b/src/package.lisp index 80f8849..11e36c7 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -86,6 +86,13 @@ ;; property.lisp #:propattrs #:propunapply + #:collapse-types + #:propapptype + #:propappdesc + #:propappattrs + #:propappcheck + #:propappapply + #:propappunapply #:defprop #:defpropspec #:defproplist @@ -105,6 +112,7 @@ #:in-consfig #:make-propspec #:append-propspecs + #:define-function-property-combinator #:seqprops #:eseqprops #:with-requirements @@ -216,6 +224,7 @@ #:debian-unstable #:debian-suite #:typecase + #:host-typecase #:required #:supports-arch-p)) diff --git a/src/property/os.lisp b/src/property/os.lisp index 67d0ebd..db4c2a2 100644 --- a/src/property/os.lisp +++ b/src/property/os.lisp @@ -79,10 +79,37 @@ ;;;; Property combinators -;; TODO should move OS-TYPECASE* here, once figure out API for property -;; combinator helper macros +(define-function-property-combinator os-typecase* (host &rest cases) + (flet ((choose-propapp () + (or (loop with os = (class-of (if host + (car (getf (hostattrs host) :os)) + (get-hostattrs-car :os))) + for (type propapp) on cases by #'cddr + when (subtypep os type) return propapp) + (inapplicable-property + "Host's OS ~S fell through OS:TYPECASE." + (class-of (get-hostattrs-car :os)))))) + (:retprop :type (collapse-types (loop for propapp in (cdr cases) by #'cddr + collect (propapptype propapp))) + :desc (lambda (&rest args) + (declare (ignore args)) + (propappdesc (choose-propapp))) + :check (lambda (&rest args) + (declare (ignore args)) + (propappcheck (choose-propapp))) + :apply (lambda (&rest args) + (declare (ignore args)) + (propappapply (choose-propapp))) + :unapply (lambda (&rest args) + (declare (ignore args)) + (propappunapply (choose-propapp)))))) + (defmacro typecase (&rest cases) - `(consfigurator::os-typecase* + `(host-typecase nil ,@cases)) + +(defmacro host-typecase (host &rest cases) + `(os-typecase* + ,host ,@(loop for case in cases collect `',(intern (symbol-name (car case)) (find-package :consfigurator.property.os)) diff --git a/src/propspec.lisp b/src/propspec.lisp index 46de09f..335def7 100644 --- a/src/propspec.lisp +++ b/src/propspec.lisp @@ -330,27 +330,3 @@ apply the elements of REQUIREMENTS in reverse order." :unapply (get psym 'apply) :args args))) -;; TODO should move this into property/os.lisp once we determine the API for -;; property combinator helper macros -(define-function-property-combinator os-typecase* (&rest cases) - (flet ((choose-propapp () - (or (loop with host = (class-of (get-hostattrs-car :os)) - for (type propapp) on cases by #'cddr - when (subtypep host type) return propapp) - (inapplicable-property - "Host's OS ~S fell through OS:TYPECASE." - (class-of (get-hostattrs-car :os)))))) - (:retprop :type (collapse-types (loop for propapp in (cdr cases) by #'cddr - collect (propapptype propapp))) - :desc (lambda (&rest args) - (declare (ignore args)) - (propappdesc (choose-propapp))) - :check (lambda (&rest args) - (declare (ignore args)) - (propappcheck (choose-propapp))) - :apply (lambda (&rest args) - (declare (ignore args)) - (propappapply (choose-propapp))) - :unapply (lambda (&rest args) - (declare (ignore args)) - (propappunapply (choose-propapp)))))) |