From 70833c2b02fba0506be10fb1610d0252ed9e0df1 Mon Sep 17 00:00:00 2001 From: Sean Whitton Date: Tue, 3 May 2022 14:00:53 -0700 Subject: add OS:{HOST-,}DEBIAN-SUITE-{E,}CASE combinators Signed-off-by: Sean Whitton --- src/property/os.lisp | 94 +++++++++++++++++++++++++++++----------------------- 1 file changed, 52 insertions(+), 42 deletions(-) (limited to 'src/property') diff --git a/src/property/os.lisp b/src/property/os.lisp index edb64c7..58741aa 100644 --- a/src/property/os.lisp +++ b/src/property/os.lisp @@ -88,50 +88,60 @@ ;;;; Property combinators -(defun typecase-type (cases) +(defun cases-type (cases) (combine-propapp-types (loop for pa in (cdr cases) by #'cddr collect pa))) -(defun typecase-host (host) - (class-of (if host - (get-hostattrs-car :os host) - (get-hostattrs-car :os)))) - -(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 (typecase-choose host cases)) - -(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 (let ((forms (cdr case))) - (if (cdr forms) `(eseqprops ,@forms) (car forms)))))) - -(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)) +(defun case-host (host fn) + (funcall fn (if host (get-hostattrs-car :os host) (get-hostattrs-car :os)))) + +(defun case-choose (host cases reader pred) + (loop with slot = (case-host host reader) + for (case propapp) on cases by #'cddr + when (funcall pred slot case) return propapp)) + +(defmacro define-host-case-combinators + (name ename reader pred convert-key error-control) + (with-gensyms (host cases key forms) + (let ((case* (symbolicate name 'case*)) + (ecase* (symbolicate ename 'case*)) + (flatten `(loop for (,key . ,forms) in ,cases + collect (funcall ,convert-key ,key) + collect (if (cdr ,forms) + `(eseqprops ,@,forms) + (car ,forms))))) + `(progn + (define-choosing-property-combinator ,case* (host &rest cases) + :type (cases-type cases) + :choose (case-choose host cases ,reader ,pred)) + + (define-choosing-property-combinator ,ecase* (host &rest cases) + :type (cases-type cases) + :choose + (or (case-choose host cases ,reader ,pred) + (inapplicable-property ,error-control (case-host host ,reader)))) + + (defmacro ,(symbolicate name 'case) (&body ,cases) + `(,',case* nil ,@,flatten)) + + (defmacro ,(symbolicate ename 'case) (&body ,cases) + `(,',ecase* nil ,@,flatten)) + + (defmacro ,(symbolicate 'host- name 'case) (,host &body ,cases) + `(,',case* ,,host ,@,flatten)) + + (defmacro ,(symbolicate 'host- ename 'case) (,host &body ,cases) + `(,',ecase* ,,host ,@,flatten)))))) + +(define-host-case-combinators type etype + #'class-of #'subtypep + (lambda (key) + `',(intern (symbol-name key) + (find-package :consfigurator.property.os))) + "Host's OS ~S fell through OS:ETYPECASE.") + +(define-host-case-combinators debian-suite- debian-suite-e + #'debian-suite #'string= #'identity + "Host's Debian suite ~S fell through OS:DEBIAN-SUITE-ECASE.") ;;;; Utilities -- cgit v1.2.3