Define check-shader automatically via the MOP

INSTALL.md

@@ -17,6 +17,7 @@ work!
 
 ### utility and portability libraries
 - alexandria
+- closer-mop
 - specialization-store
 - trivial-gray-streams
 - uiop

data/shader.lisp

@@ -86,53 +86,46 @@
 
 ;;;; Shader class
 
-(defclass shader ()
-  ((name
-    :initarg :name
-    :accessor name
-    :initform (error "Every shader needs a name.")
-    :documentation "The name of the shader. This must be a keyword.")
-   (shader-stage
-    :initarg :stage
-    :accessor shader-stage
-    :initform (error "Every shader needs a shader stage.")
-    :documentation "The stage of the shader. This must be of the type shader-stage.")
-   (source
-    :initarg :source
-    :accessor shader-source-string
-    :initform (error "Every shader needs a source code string.")
-    :documentation "The GLSL source code string of the shader. Normally, this is generated from s-expressions.")
-   (inputs
-    :initarg :inputs
-    :accessor inputs
-    :initform nil
-    :documentation "A list of shader-input-variables.")
-   (outputs
-    :initarg :outputs
-    :accessor outputs
-    :initform nil
-    :documentation "A list of shader-output-variables."))
-  (:documentation "A shader class provides information about a shader
-  to the game engine, which then compiles the shader in OpenGL."))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defclass shader ()
+    ((name
+      :initarg :name
+      :accessor name
+      :checked-type keyword
+      :initform (error "Every shader needs a name.")
+      :documentation "The name of the shader. This must be a keyword.")
+     (shader-stage
+      :initarg :stage
+      :accessor shader-stage
+      :checked-type shader-stage
+      :initform (error "Every shader needs a shader stage.")
+      :documentation "The stage of the shader. This must be of the type shader-stage.")
+     (source
+      :initarg :source
+      :accessor shader-source-string
+      :checked-type simple-string
+      :initform (error "Every shader needs a source code string.")
+      :documentation "The GLSL source code string of the shader. Normally, this is generated from s-expressions.")
+     (inputs
+      :initarg :inputs
+      :accessor inputs
+      :checked-type shader-input-variable-list
+      :initform nil
+      :documentation "A list of shader-input-variables.")
+     (outputs
+      :initarg :outputs
+      :accessor outputs
+      :checked-type shader-output-variable-list
+      :initform nil
+      :documentation "A list of shader-output-variables."))
+    (:documentation "A shader class provides information about a shader
+  to the game engine, which then compiles the shader in OpenGL.")
+    (:metaclass checked-types)
+    (:check-function check-shader)))
 
 (defmethod make-load-form ((object shader) &optional environment)
   (make-load-form-saving-slots object :environment environment))
 
-(define-function check-shader ((shader shader))
-  "Verifies that the shader's contents are of the correct types."
-  (with-accessors* (name
-                    inputs
-                    outputs
-                    shader-stage
-                    (source shader-source-string))
-      shader
-    (check-type name keyword)
-    (check-type shader-stage shader-stage)
-    (check-type source string)
-    (check-type inputs shader-input-variable-list)
-    (check-type outputs shader-output-variable-list))
-  t)
-
 (defmethod initialize-instance :after ((shader shader) &rest init-args)
   (declare (ignore init-args))
   (check-shader shader))

util/util.lisp

 (defpackage #:zombie-raptor/util/util
   (:use #:cl)
+  (:import-from #:closer-mop
+                #:direct-slot-definition-class
+                #:ensure-class-using-class
+                #:standard-direct-slot-definition
+                #:validate-superclass)
   (:export #:case=
+           #:checked-types
            #:decf-mod
            #:define-accessor-macro
            #:define-function
@@ -433,3 +439,56 @@ accessor name and the local binding are identical."
               (make-load-form-saving-slots object :environment environment))
             (deftype ,list ()
               ',name))))
+
+;;;; Metaclasses
+
+(defclass checked-types (standard-class)
+  ((check-function
+    :initarg :check-function
+    :initform nil
+    :reader class-definition-check-function
+    :documentation "Provides a name for the generated check-function
+    that can be called to verify the types of all slots of the
+    class."))
+  (:documentation "Ensures that types defined in a
+  slot's :checked-type are always checked."))
+
+(defclass slot-with-checked-type (standard-direct-slot-definition)
+  ((checked-type
+    :initarg :checked-type
+    :reader slot-definition-checked-type
+    :documentation "Provides a type that will be checked in the
+    setters and constructor. Unlike :type, :checked-type is guaranteed
+    to be checked in all implementations and all optimization
+    levels."))
+  (:documentation "Slots that provide a type that is guaranteed to be
+  checked with check-type."))
+
+(defmethod validate-superclass ((class checked-types) (super-class standard-class))
+  t)
+
+(defmethod direct-slot-definition-class ((class checked-types) &key checked-type &allow-other-keys)
+  (if checked-type
+      (find-class 'slot-with-checked-type)
+      (call-next-method)))
+
+(defmacro define-check-object-function (name (class-name) checks)
+  `(define-function ,name ((,class-name ,class-name))
+     ,@checks
+     t))
+
+(defmethod ensure-class-using-class :before ((class checked-types) name &key direct-slots &allow-other-keys)
+  (let ((check-name (or (nth 0 (class-definition-check-function class))
+                        (prefix-symbol #.(symbol-name '#:check-) name *package*)))
+        (check-slots (remove nil
+                             (mapcar (lambda (direct-slot)
+                                       (let ((checked-type (getf direct-slot :checked-type)))
+                                         (when checked-type
+                                           (let ((reader (nth 0 (getf direct-slot :readers))))
+                                             `(check-type (,reader object) ,checked-type)))))
+                                     direct-slots))))
+    (setf (fdefinition check-name)
+          (eval `(lambda (object)
+                   (assert (eql (class-of object) ,class))
+                   ,@check-slots
+                   t)))))