diff options
| author | Sean Whitton <spwhitton@spwhitton.name> | 2021-04-02 16:34:15 -0700 |
|---|---|---|
| committer | Sean Whitton <spwhitton@spwhitton.name> | 2021-04-02 16:34:15 -0700 |
| commit | 7988cad98d72ac07faec7e538cc9c21c02b82bc6 (patch) | |
| tree | f5ec2ae5e4e919c15941a9b78d9bd4fc8ba65a3c /src/property/os.lisp | |
| parent | 76c3ac60450fb144bf6cfd0fb4197b91af5a3f87 (diff) | |
| download | consfigurator-7988cad98d72ac07faec7e538cc9c21c02b82bc6.tar.gz | |
add OS:TYPECASE and OS:HOST-TYPECASE
Signed-off-by: Sean Whitton <spwhitton@spwhitton.name>
Diffstat (limited to 'src/property/os.lisp')
| -rw-r--r-- | src/property/os.lisp | 52 |
1 files changed, 37 insertions, 15 deletions
diff --git a/src/property/os.lisp b/src/property/os.lisp index 04ac5ab..f7cfb3d 100644 --- a/src/property/os.lisp +++ b/src/property/os.lisp @@ -83,29 +83,51 @@ ;;;; Property combinators -(define-choosing-property-combinator os-etypecase* (host &rest cases) - :type (collapse-types (loop for propapp in (cdr cases) by #'cddr - collect (propapptype propapp))) - :choose (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:ETYPECASE." - (class-of (get-hostattrs-car :os))))) +(defun typecase-type (cases) + (collapse-types (loop for propapp in (cdr cases) by #'cddr + collect (propapptype propapp)))) -(defmacro etypecase (&body cases) - `(host-etypecase nil ,@cases)) +(defun typecase-host (host) + (class-of (if host + (car (getf (hostattrs host) :os)) + (get-hostattrs-car :os)))) -(defmacro host-etypecase (host &body cases) - `(os-etypecase* +(defun typecase-choose (host cases) + (loop with os = (typecase-host host) + for (type propapp) on cases by #'cddr + when (subtypep os type) return propapp)) + +(define-choosing-property-combinator os-typecase* (host &rest cases) + :type (typecase-type cases) + :choose (or (typecase-choose host cases) '(noop))) + +(define-choosing-property-combinator os-etypecase* (host &rest cases) + :type (typecase-type cases) + :choose + (or (typecase-choose host cases) + (inapplicable-property + "Host's OS ~S fell through OS:ETYPECASE." (typecase-host host)))) + +(defmacro host-typecase* (macro host &body cases) + `(,macro ,host ,@(loop for case in cases collect `',(intern (symbol-name (car case)) (find-package :consfigurator.property.os)) collect (cadr case)))) +(defmacro typecase (&body cases) + `(host-typecase* os-typecase* nil ,@cases)) + +(defmacro etypecase (&body cases) + `(host-typecase* os-etypecase* nil ,@cases)) + +(defmacro host-typecase (host &body cases) + `(host-typecase* os-typecase* ,host ,@cases)) + +(defmacro host-etypecase (host &body cases) + `(host-typecase* os-etypecase* ,host ,@cases)) + ;;;; Utilities |