;;;; 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 (get-meta (class-of 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)))))