diff options
| author | Sean Whitton <spwhitton@spwhitton.name> | 2021-03-15 20:41:49 -0700 |
|---|---|---|
| committer | Sean Whitton <spwhitton@spwhitton.name> | 2021-03-15 20:41:49 -0700 |
| commit | c4ecc5719262bd9e360a21418826dbe1fa35f4b2 (patch) | |
| tree | c1c9704d42a74308e6d2ef328beacf597ecfd363 | |
| parent | 430da99796663587de2ade6c4d7afe1a7e5a0f1a (diff) | |
| download | consfigurator-c4ecc5719262bd9e360a21418826dbe1fa35f4b2.tar.gz | |
add OS:TYPECASE
Signed-off-by: Sean Whitton <spwhitton@spwhitton.name>
| -rw-r--r-- | src/package.lisp | 2 | ||||
| -rw-r--r-- | src/property/os.lisp | 14 | ||||
| -rw-r--r-- | src/propspec.lisp | 24 |
3 files changed, 39 insertions, 1 deletions
diff --git a/src/package.lisp b/src/package.lisp index 7b93f2d..86ef23b 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -204,6 +204,7 @@ (defpackage :consfigurator.property.os (:use #:cl #:consfigurator) + (:shadow #:typecase) (:export #:unixlike #:linux #:debianlike @@ -212,6 +213,7 @@ #:debian-testing #:debian-unstable #:debian-suite + #:typecase #:required #:supports-arch-p)) diff --git a/src/property/os.lisp b/src/property/os.lisp index e4f3e65..6a23e97 100644 --- a/src/property/os.lisp +++ b/src/property/os.lisp @@ -77,6 +77,18 @@ :arch architecture)))) +;;;; Property combinators + +;; TODO should move OS-TYPECASE* here, once figure out API for property +;; combinator helper macros +(defmacro typecase (&rest cases) + `(consfigurator::os-typecase* + ,@(loop for case in cases + collect `',(intern (symbol-name (car case)) + (find-package :consfigurator.property.os)) + collect (cadr case)))) + + ;;;; Utilities (defun required (type) @@ -90,7 +102,7 @@ Used in property :HOSTATTRS subroutines." (defun supports-arch-p (os arch) "Can binaries of type ARCH run on OS?" - (typecase os + (cl:typecase os (debian (or (eq (linux-architecture os) arch) (member arch (assoc (linux-architecture os) '((:amd64 :i386) diff --git a/src/propspec.lisp b/src/propspec.lisp index 5f7b138..7f2019d 100644 --- a/src/propspec.lisp +++ b/src/propspec.lisp @@ -323,3 +323,27 @@ application specification expression to a property application specification." :apply (get psym 'unapply) :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) + (error 'inapplicable-property + :text "Host's OS fell through OS:TYPECASE.")))) + (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)))))) |