79 lines
2.5 KiB
Common Lisp
79 lines
2.5 KiB
Common Lisp
;;;; cl-scopes/shape - really abstract basic data shape definitions.
|
|
|
|
(defpackage :scopes/shape
|
|
(:use :common-lisp)
|
|
(:local-nicknames (:util :scopes/util)
|
|
(:mop :closer-mop))
|
|
(:export #:meta #:get-meta #:create #:record-meta
|
|
#:record #:print-fields #:print-slots
|
|
#:head-fields #:head #:head-value #:head-plist
|
|
#:data-fields #:data #:data-value))
|
|
|
|
(in-package :scopes/shape)
|
|
|
|
;;;; abstract base item
|
|
|
|
(defclass item ()
|
|
((meta :reader meta :initarg :meta :allocation :class)))
|
|
|
|
(defun get-meta (cls)
|
|
(when (symbolp cls)
|
|
(setf cls (find-class cls)))
|
|
(mop:ensure-finalized cls)
|
|
(meta (mop:class-prototype cls)))
|
|
|
|
(defun create (cs &rest args)
|
|
(apply #'make-instance cs :meta (get-meta cs) args))
|
|
|
|
;;;; record class, factory, utilities
|
|
|
|
(defclass record-meta ()
|
|
((head-fields :reader head-fields :initarg :head-fields
|
|
:initform '(:taskid :username))
|
|
(data-fields :reader data-fields :initarg :data-fields :initform nil)))
|
|
|
|
(defclass record (item)
|
|
((meta :initform (make-instance 'record-meta) :allocation :class)
|
|
(head :reader head :initarg :head)
|
|
(data :accessor data :initarg :data :initform nil)))
|
|
|
|
(defmethod initialize-instance :after ((rec record) &key head &allow-other-keys)
|
|
(setf (slot-value rec 'head) (util:rfill (head-fields rec) head)))
|
|
|
|
(defmethod print-object ((rec record) stream)
|
|
(print-slots rec stream 'head 'data))
|
|
|
|
(defmethod head-fields ((rec record))
|
|
(head-fields (meta rec)))
|
|
|
|
(defun head-value (rec key)
|
|
(elt (head rec) (position key (head-fields rec))))
|
|
|
|
(defun (setf head-value) (val rec key)
|
|
(setf (elt (head rec) (position key (head-fields rec))) val))
|
|
|
|
(defun head-plist (rec)
|
|
(let (pl (hv (head rec)))
|
|
(dolist (hf (head-fields rec))
|
|
(setf pl (cons hf (cons (util:from-keyword (pop hv)) pl))))
|
|
pl))
|
|
|
|
(defun data-value (rec key)
|
|
(getf (data rec) key))
|
|
|
|
(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)))))
|