From 19054f600f9ea9b11e01ad50e0612a1389116938 Mon Sep 17 00:00:00 2001
From: Helmut Merz <helmutm@cy55.de>
Date: Sat, 12 Oct 2024 09:37:17 +0200
Subject: [PATCH] work in progress: use factory object for creating records

---
 core/message.lisp | 11 +++++++--
 shape/shape.lisp  | 61 ++++++++++++++++++++++++++++++++++-------------
 2 files changed, 54 insertions(+), 18 deletions(-)

diff --git a/core/message.lisp b/core/message.lisp
index 15d715e..50c5b10 100644
--- a/core/message.lisp
+++ b/core/message.lisp
@@ -10,12 +10,19 @@
 
 ;;;; message
 
+(defun message-factory ()
+  (make-instance 'shape:record-factory :item-class 'message
+                 :head-fields '(:domain :action :class :item)))
+
 (defclass message (shape:record)
-  ((shape:head-fields :initform '(:domain :action :class :item))
+  ((factory :initform (message-factory))
+   (shape:head-fields :initform '(:domain :action :class :item))
    (sender :reader sender :initarg :sender :initform nil)))
 
 (defun create (head &key data sender)
-  (make-instance 'message :head head :data data :sender sender))
+  (shape:create 'message :head head :data data :sender sender))
+  ;(shape:create-item (message-factory) :head head :data data :sender sender))
+  ;(make-instance 'message :head head :data data :sender sender))
 
 (defmethod print-object ((msg message) stream)
   (shape:print-slots msg stream 'shape:head 'sender 'shape:data))
diff --git a/shape/shape.lisp b/shape/shape.lisp
index dd71fed..b1aa669 100644
--- a/shape/shape.lisp
+++ b/shape/shape.lisp
@@ -2,15 +2,42 @@
 
 (defpackage :scopes/shape
   (:use :common-lisp)
-  (:local-nicknames (:util :scopes/util))
-  (:export #:record #:print-fields #:print-slots
+  (:local-nicknames (:util :scopes/util)
+                    (:mop :closer-mop))
+  (:export #:factory #:create #:create-item #:record-factory
+           #:record #:print-fields #:print-slots
            #:head-fields #:head #:head-value #:head-plist
            #:data-fields #:data #:data-value))
 
 (in-package :scopes/shape)
 
-(defclass record ()
-  ((head-fields :reader head-fields :initarg :head-fields 
+;;;; abstract base item and factory
+
+(defclass factory ()
+  ((item-class :reader item-class :initarg :item-class)))
+
+(defclass item ()
+  ((factory :reader factory :initarg :factory :allocation :class)))
+
+(defun create (cls &rest args)
+  (let* ((ic (find-class cls)))
+    (mop:ensure-finalized ic)
+    (apply #'make-instance cls :factory (factory (mop:class-prototype ic)) args)))
+
+(defun create-item (fac &rest args)
+  (apply #'make-instance (item-class fac) args))
+
+;;;; record class, factory, utilities
+ 
+(defclass record-factory (factory)
+  ((item-class :initform 'record)
+   (head-fields :reader head-fields :initarg :head-fields 
+                :initform '(:taskid :username))
+   (data-fields :reader data-fields :initarg :data-fields :initform nil)))
+
+(defclass record (item)
+  ((factory :initform (make-instance 'record-factory))
+   (head-fields :reader head-fields :initarg :head-fields 
                 :initform '(:taskid :username) :allocation :class)
    (data-fields :reader data-fields :initarg :data-fields 
                 :initform nil :allocation :class)
@@ -23,18 +50,6 @@
 (defmethod print-object ((rec record) stream)
   (print-fields rec stream 'head 'data))
 
-(defun print-fields (rec stream &rest fields)
-  (let ((fm (util:make-vars-format fields)))
-    (print-unreadable-object (rec stream :type t)
-      (apply #'format stream fm (mapcar #'(lambda (x) (funcall x rec)) fields)))))
-
-(defun print-slots (rec stream &rest fields)
-  (let ((fm (util:make-vars-format fields)))
-    (print-unreadable-object (rec stream :type t)
-      (apply #'format stream fm 
-             (mapcar #'(lambda (x) (when (slot-boundp rec x) (slot-value rec x)))
-                     fields)))))
-
 (defun head-value (rec key)
   (elt (head rec) (position key (head-fields rec))))
 
@@ -52,3 +67,17 @@
 
 (defun (setf data-value) (val rec key)
   (setf (getf (data rec) key) val))
+
+;;;; printing utilities
+
+(defun print-fields (rec stream &rest fields)
+  (let ((fm (util:make-vars-format fields)))
+    (print-unreadable-object (rec stream :type t)
+      (apply #'format stream fm (mapcar #'(lambda (x) (funcall x rec)) fields)))))
+
+(defun print-slots (rec stream &rest fields)
+  (let ((fm (util:make-vars-format fields)))
+    (print-unreadable-object (rec stream :type t)
+      (apply #'format stream fm 
+             (mapcar #'(lambda (x) (when (slot-boundp rec x) (slot-value rec x)))
+                     fields)))))