From 7988cad98d72ac07faec7e538cc9c21c02b82bc6 Mon Sep 17 00:00:00 2001
From: Sean Whitton <spwhitton@spwhitton.name>
Date: Fri, 2 Apr 2021 16:34:15 -0700
Subject: add OS:TYPECASE and OS:HOST-TYPECASE

Signed-off-by: Sean Whitton <spwhitton@spwhitton.name>
---
 src/combinator.lisp  |  5 +++++
 src/package.lisp     |  5 ++++-
 src/property/os.lisp | 52 +++++++++++++++++++++++++++++++++++++---------------
 3 files changed, 46 insertions(+), 16 deletions(-)

(limited to 'src')

diff --git a/src/combinator.lisp b/src/combinator.lisp
index 3c1d21d..9f209c8 100644
--- a/src/combinator.lisp
+++ b/src/combinator.lisp
@@ -20,6 +20,11 @@
 
 ;;;; Property combinators
 
+(defprop noop :posix (&rest args)
+  "A property which accepts any number of arguments and does nothing."
+  (:desc (declare (ignore args)) "No-op property")
+  (:hostattrs (declare (ignore args))))
+
 (defmacro define-function-property-combinator (name args &body body)
   (multiple-value-bind (forms declarations docstring)
       (parse-body body :documentation t)
diff --git a/src/package.lisp b/src/package.lisp
index c870ad2..10c2ed8 100644
--- a/src/package.lisp
+++ b/src/package.lisp
@@ -143,6 +143,7 @@
            #:append-propspecs
 
 	   ;; combinator.lisp
+           #:noop
            #:define-function-property-combinator
            #:define-choosing-property-combinator
            #:seqprops
@@ -236,7 +237,7 @@
 
 (defpackage :consfigurator.property.os
   (:use #:cl #:consfigurator)
-  (:shadow #:etypecase)
+  (:shadow #:typecase #:etypecase)
   (:export #:unixlike
            #:linux
            #:linux-architecture
@@ -247,6 +248,8 @@
            #:debian-unstable
            #:debian-suite
            #:debian-architecture
+           #:typecase
+           #:host-typecase
            #:etypecase
            #:host-etypecase
            #:required
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
 
-- 
cgit v1.2.3