Class star

build-scripts/guix.scm

@@ -144,6 +144,7 @@
        ("dexador" ,cl-dexador)
        ("enchant" ,cl-enchant)
        ("fset" ,cl-fset)
+       ("hu.dwim.defclass-star" ,cl-hu.dwim.defclass-star)
        ("iolib" ,cl-iolib)
        ("local-time" ,cl-local-time)
        ("log4cl" ,cl-log4cl)

libraries/class-star/class-star.lisp

@@ -0,0 +1,187 @@
+;;;; SPDX-FileCopyrightText: Atlas Engineer LLC
+;;;; SPDX-License-Identifier: BSD-3-Clause
+
+(in-package :class*)
+
+(defun name-identity (name definition)
+  (declare (ignore definition))
+  name)
+
+(defun initform (definition)
+  "Return (BOOLEAN INITFORM) when initform is found."
+  (let ((definition (rest definition)))
+    (if (oddp (length definition))
+        (values t (first definition))
+        (multiple-value-bind (found? value)
+            (get-properties definition '(:initform))
+          (values (not (null found?)) value)))))
+
+(defun definition-type (definition)
+  "Return definition's TYPE.
+Return nil if not found."
+  (let ((definition (rest definition)))
+    (when (oddp (length definition))
+      (setf definition (rest definition)))
+    (getf definition :type)))
+
+(defun basic-type-zero-values (type)
+  "Return TYPE zero value.
+An error is raised if the type is unsupported."
+  (cond
+    ((subtypep type 'string) "")
+    ((subtypep type 'boolean) nil)
+    ((subtypep type 'list) '())
+    ((subtypep type 'array) (make-array 0))
+    ((subtypep type 'hash-table) (make-hash-table))
+    ;; Order matters for numbers:
+    ((subtypep type 'integer) 0)
+    ((subtypep type 'complex) #c(0 0))
+    ((subtypep type 'number) 0.0)
+    (t (error "Unknown type"))))
+
+(defun basic-type-inference (definition)
+  "Return general type of VALUE.
+This is like `type-of' but returns less specialized types for some common
+subtypes, e.g.  for \"\" return 'string instead of `(SIMPLE-ARRAY CHARACTER
+\(0))'.
+
+Note that in a slot definition, '() is infered to be a list while NIL is infered
+to be a boolean.
+
+Non-basic form types are not infered (returns nil).
+Non-basic scalar types are derived to their own type (with `type-of')."
+  (multiple-value-bind (found? value)
+      (initform definition)
+    (when found?
+      (cond
+        ((and (consp value)
+              (eq (first value) 'quote)
+              (symbolp (second value)))
+         (if (eq (type-of (second value)) 'null)
+             'list                      ; The empty list.
+             'symbol))
+        ((and (consp value)
+              (eq (first value) 'function))
+         'function)
+        ((and (consp value)
+              (not (eq (first value) 'quote)))
+         ;; Non-basic form.
+         nil)
+        (t (let* ((type (if (symbolp value)
+                            (handler-case
+                                ;; We can get type of externally defined symbol.
+                                (type-of (eval value))
+                              (error ()
+                                ;; Don't infer type if symbol is not yet defined.
+                                nil))
+                            (type-of value))))
+             (if type
+                 (flet ((derive-type (general-type)
+                          (when (subtypep type general-type)
+                            general-type)))
+                   (or (some #'derive-type '(string boolean list array hash-table integer
+                                             complex number))
+                       ;; Only allow objects of the same type by default.
+                       ;; We could have returned nil to inhibit the generation of a
+                       ;; :type property.
+                       type))
+                 nil)))))))
+
+(defun type-zero-initform-inference (definition)
+  "Infer basic type zero values.
+See `basic-type-zero-values'.
+Raise a condition at macro-expansion time when initform is missing for unsupported types."
+  (let ((type (definition-type definition)))
+    (if type
+        (handler-case (basic-type-zero-values type)
+          (error ()
+            ;; Compile-time error:
+            (error "Missing initform.")))
+        ;; Default initform when type is missing:
+        nil)))
+
+(defun no-unbound-initform-inference (definition)
+  "Infer basic type zero values.
+Raise a condition when instantiating if initform is missing for unsupported types."
+  (let ((type (definition-type definition)))
+    (if type
+        (handler-case (basic-type-zero-values type)
+          (error ()
+            ;; Run-time error:
+            '(error "Slot must be bound.")))
+        ;; Default initform when type is missing:
+        nil)))
+
+(defun nil-fallback-initform-inference (definition)
+  "Infer basic type zero values.
+Fall back to nil if initform is missing for unsupported types."
+  (let ((type (definition-type definition)))
+    (if type
+        (handler-case (basic-type-zero-values type)
+          (error ()
+            ;; Fall-back to nil:
+            nil))
+        ;; Default initform when type is missing:
+        nil)))
+
+(defvar *initform-inference* 'type-zero-initform-inference
+  "Fallback initform inference function.
+Set this to nil to disable inference.")
+(defvar *type-inference* 'basic-type-inference
+  "Fallback type inference function.
+Set this to nil to disable inference.")
+
+(defun process-slot-initform (definition &key ; See `hu.dwim.defclass-star:process-slot-definition'.
+                                           initform-inference
+                                           type-inference)
+  (unless (consp definition)
+    (setf definition (list definition)))
+  (cond
+    ((and (initform definition)
+          (or (definition-type definition)
+              (not type-inference)))
+     definition)
+    ((and (initform definition)
+          (not (definition-type definition))
+          type-inference)
+     (append definition
+             (let ((result-type (funcall type-inference definition)))
+               (when result-type
+                 (list :type result-type)))))
+    ((and (not (initform definition))
+          initform-inference)
+     (append definition
+             (list :initform (funcall initform-inference definition))))
+    ((and (not (initform definition))
+          (not initform-inference))
+     definition)
+    (t (error "Condition fell through!"))))
+
+(defmacro define-class (name supers &body (slots . options))
+  "Define class like `defclass*' but with extensions.
+
+The default initforms can be automatically inferred by the function specified
+in the `:initform-inference' option, which defaults to `*initform-inference*'.
+The initform can still be specified manually with `:initform' or as second
+argument, right after the slot name.
+
+The same applies to the types with the `:type-inference' option, the
+`*type-inference*' default and the `:type' argument respectively."
+  (let* ((initform-option (assoc :initform-inference options))
+         (initform-inference (or (when initform-option
+                                   (setf options (delete :initform-inference options :key #'car))
+                                   (eval (second initform-option)))
+                                 *initform-inference*))
+         (type-option (assoc :type-inference options))
+         (type-inference (or (when type-option
+                               (setf options (delete :type-inference options :key #'car))
+                               (eval (second type-option)))
+                             *type-inference*)))
+    `(hu.dwim.defclass-star:defclass* ,name ,supers
+       ,(mapcar (lambda (definition)
+                  (process-slot-initform
+                   definition
+                   :initform-inference initform-inference
+                   :type-inference type-inference))
+                slots)
+       ,@options)))

libraries/class-star/package.lisp

@@ -0,0 +1,17 @@
+;;;; SPDX-FileCopyrightText: Atlas Engineer LLC
+;;;; SPDX-License-Identifier: BSD-3-Clause
+
+(in-package :cl-user)
+
+(defpackage :class-star
+  (:nicknames class*)
+  (:use :common-lisp)
+  (:import-from :hu.dwim.defclass-star)
+  (:export #:define-class
+           #:name-identity
+           #:*initform-inference*
+           #:type-zero-initform-inference
+           #:no-unbound-initform-inference
+           #:nil-fallback-initform-inference
+           #:*type-inference*
+           #:basic-type-inference))

libraries/class-star/readme.org

@@ -0,0 +1,68 @@
+This library enhances the class definition idiom with saner defaults and more
+slot and class options.  It wraps around the =hu.dwim.defclass-star= macro and
+adds a few more features:
+
+- initform customization (such as zero values);
+- type inference (optionally errors out when type cannot be inferred).
+
+Metaclasses would not be very useful here since most of our features need to be
+enacted at compile-time, while metaclasses are mostly useful on classe
+/instances/.
+
+=defclass/std= is another popular library with a similar goal, but with more
+insistance on conciseness, maybe at the expanse of readability.  In particular,
+it implements a way to specify slots by properties which may seem unnatural (we
+read slots by their name, not by their properties).
+
+* Features
+
+- Implicit, customizable initarg and accessor like =defclass*=.
+- Implicit, customizable initform.  The default =*type-zero-function*= derives
+  the initform from the zero-value of basic types (e.g. 0 for integers, "" for
+  strings) or raise a macro-expansion-time error for unsupported types.
+  Other functions with different behaviours are provided, or you can provide your own.
+- Implicit, customizable type inference from the initform.
+- The initform can be specified as usual with =:initform= or directly in second
+  position, right after the slot name.
+- Class option to toggle the default slot exportation.
+- The `:export' slot option allows to specify the exportation of individual slots.
+
+* Examples
+
+#+begin_src lisp
+  (define-class foo ()
+    ((slot1 :type integer) ; defaults to 0
+     (slot2 "hello!" :type string)
+     (unexported-slot :export nil))
+    (:export-class-name-p t)
+    (:export-accessor-names-p t)
+    (:accessor-name-transformer #'class*:name-identity))
+
+  (make-instance 'foo :my-slot1 17)
+#+end_src
+
+You can customize how to infer the default value.  For instance, to fall back to
+nil when the type is not one of the known basic types (see =basic-type-zero-values=):
+
+#+begin_src lisp
+(define-class bar ()
+  ((name :type class))
+  (:type-zero-function #'nil-fallback-type-zero-function))
+#+end_src
+
+See the =*type-zero-function*= for the default inference function.
+
+You can also set this option to nil, in which case you get the default behaviour
+of no inference at all.
+
+* References
+
+- defclass/std:
+  https://github.com/EuAndreh/defclass-std
+  http://quickdocs.org/defclass-std/
+- hu.dwim.defclass-star / defclass*:
+  http://quickdocs.org/hu.dwim.defclass-star/api
+  https://common-lisp.net/project/defclass-star/configuration.lisp.html
+- Serapeum:
+  https://github.com/ruricolist/serapeum/
+  https://github.com/ruricolist/serapeum/issues/38

libraries/class-star/tests/tests.lisp

@@ -0,0 +1,108 @@
+;;;; SPDX-FileCopyrightText: Atlas Engineer LLC
+;;;; SPDX-License-Identifier: BSD-3-Clause
+
+(in-package :cl-user)
+
+(prove:plan nil)
+
+(prove:subtest "Simple class"
+  (prove:is (progn
+              (class*:define-class foo ()
+                ((name "fooname")))
+              (let ((foo (make-instance 'foo)))
+                (name-of foo)))
+            "fooname"))
+
+(prove:subtest "Simple class with custom accessors"
+  (class*:define-class bar ()
+    ((name "fooname")
+     (age :accessor this-age)
+     (address :accessor nil))
+    (:accessor-name-transformer (lambda (name def) (declare (ignore def)) name)))
+  (make-instance 'bar)
+  (prove:ok (fboundp 'name))
+  (prove:ok (fboundp 'this-age))
+  (prove:is (fboundp 'address) nil))
+
+(prove:subtest "Simple class default value"
+  (prove:is (progn
+              (class*:define-class foo-default ()
+                ((name :type string)
+                 (age :type number)))
+              (let ((foo (make-instance 'foo-default)))
+                (name-of foo)))
+            ""))
+
+;; TODO: Fix following test and try to make it portable.
+#+nil
+(prove:subtest "No initarg"
+  (prove:is-error (let ((hu.dwim.defclass-star:*automatic-initargs-p* nil))
+                    (class*:define-class foo-no-initarg ()
+                      ((name :type string)))
+                    (make-instance 'foo-no-initarg :name "bar"))
+                  'sb-pcl::initarg-error))
+
+(prove:subtest "No accessor"
+  (prove:is (progn
+              (class*:define-class foo-no-accessors ()
+                ((name-no-acc :type string))
+                (:automatic-accessors-p nil))
+              (make-instance 'foo-no-accessors)
+              (fboundp 'name-no-acc-of))
+            nil))
+
+(prove:subtest "Initform inference"
+  (class*:define-class foo-initform-infer ()
+    ((name :type string)))
+  (prove:is (name-of (make-instance 'foo-initform-infer))
+            "")
+  (class*:define-class foo-initform-infer-no-unbound ()
+    ((name :type function))
+    (:initform-inference 'class*:no-unbound-initform-inference))
+  (prove:is-error (make-instance 'foo-initform-infer-no-unbound)
+                  'simple-error)
+  (class*:define-class foo-initform-infer-nil-fallback ()
+    ((name :type (or function null)))
+    (:initform-inference 'class*:nil-fallback-initform-inference))
+  (prove:is (name-of (make-instance 'foo-initform-infer-nil-fallback))
+            nil))
+
+(defvar street-name "bar")
+(prove:subtest "Type inference"
+  (class*:define-class foo-type-infer ()
+    ((name "foo")
+     (nickname street-name)
+     (age 1)
+     (height 2.0)
+     (width 2 :type number)
+     (lisper nil)
+     (empty-list '())
+     (nonempty-list '(1 2 3))
+     (mark :foo)
+     (sym 'sims)
+     (fun #'list)
+     (composite (error "Should not eval, type should not be infered"))))
+  (prove:is (getf (mopu:slot-properties 'foo-type-infer 'name) :type)
+            'string)
+  (prove:is (getf (mopu:slot-properties 'foo-type-infer 'nickname) :type)
+            'string)
+  (prove:is (getf (mopu:slot-properties 'foo-type-infer 'age) :type)
+            'integer)
+  (prove:is (getf (mopu:slot-properties 'foo-type-infer 'height) :type)
+            'number)
+  (prove:is (getf (mopu:slot-properties 'foo-type-infer 'width) :type)
+            'number)
+  (prove:is (getf (mopu:slot-properties 'foo-type-infer 'lisper) :type)
+            'boolean)
+  (prove:is (getf (mopu:slot-properties 'foo-type-infer 'empty-list) :type)
+            'list)
+  (prove:is (getf (mopu:slot-properties 'foo-type-infer 'nonempty-list) :type)
+            'list)
+  (prove:is (getf (mopu:slot-properties 'foo-type-infer 'sym) :type)
+            'symbol)
+  (prove:is (getf (mopu:slot-properties 'foo-type-infer 'fun) :type)
+            'function)
+  (prove:is (getf (mopu:slot-properties 'foo-type-infer 'composite) :type)
+            nil))
+
+(prove:finalize)