persistent-struct.lisp

;;; -*- Mode: Lisp; coding: utf-8; -*-

(in-package "GITHACK")

;;; DEFINE-PERSISTENT-STRUCT gives DEFSTRUCT's familiar surface syntax
;;; (a struct name, optional :CONC-NAME, and slot descriptions of the
;;; form SLOT-NAME or (SLOT-NAME DEFAULT-INITFORM &KEY TYPE READ-ONLY
;;; TRANSIENT)) while expanding into an ordinary DEFCLASS with
;;; :METACLASS PERSISTENT-STANDARD-CLASS, so the generated class gets
;;; the full PERSISTENT-OBJECT machinery (transparent Git tree
;;; serialization, transient-slot filtering, SLOT-VALUE-USING-CLASS
;;; proxy auto-resolution) for free, alongside DEFSTRUCT's usual
;;; MAKE-<NAME> constructor and <NAME>-P predicate.

(defclass persistent-struct (persistent-object)
  ()
  (:metaclass persistent-standard-class)
  (:documentation
   "Mandatory base class for every DEFINE-PERSISTENT-STRUCT-generated
class, itself a PERSISTENT-OBJECT (and so, transitively, a GIT-TREE
and STANDARD-OBJECT), identifying every such generated class as one
family for EQL/TYPEP-based introspection."))

(defun persistent-struct-parse-name-and-options (name-and-options)
  "Return two values, the struct's NAME (a symbol) and its CONC-NAME
prefix (a string, possibly empty), parsed DEFSTRUCT-style from
NAME-AND-OPTIONS: either a bare symbol NAME (CONC-NAME then defaults
to \"<NAME>-\"), or a list (NAME &KEY CONC-NAME) (CONC-NAME defaults
identically if not supplied at all, but is the empty string if
explicitly supplied as NIL, exactly as DEFSTRUCT's own :CONC-NAME NIL
disables any prefix)."
  (if (symbolp name-and-options)
      (values name-and-options (concatenate 'string (string name-and-options) "-"))
      (destructuring-bind (name &key (conc-name nil conc-name-supplied?)) name-and-options
        (values name
                (cond
                  ((not conc-name-supplied?) (concatenate 'string (string name) "-"))
                  ((null conc-name) "")
                  (t (string conc-name)))))))

(defun persistent-struct-parse-slot-description (slot-description)
  "Return a plist (:NAME :INITFORM :TYPE :READ-ONLY :TRANSIENT)
parsed DEFSTRUCT-style from SLOT-DESCRIPTION: either a bare symbol
NAME (INITFORM defaults to NIL, with no :TYPE/:READ-ONLY/:TRANSIENT),
or a list (NAME &OPTIONAL INITFORM &KEY TYPE READ-ONLY TRANSIENT)."
  (if (symbolp slot-description)
      (list :name slot-description :initform nil :type nil :read-only nil :transient nil)
      (destructuring-bind (name &optional initform &key type read-only transient) slot-description
        (list :name name :initform initform :type type :read-only read-only :transient transient))))

(defun persistent-struct-slot-accessor-name (slot conc-name package)
  "Return the symbol, interned in PACKAGE, DEFINE-PERSISTENT-STRUCT
generates as SLOT's :ACCESSOR (or :READER, if SLOT is :READ-ONLY):
CONC-NAME concatenated with SLOT's own :NAME."
  (intern (concatenate 'string conc-name (string (getf slot :name))) package))

(defun persistent-struct-slot-documentation (name slot)
  "Return the docstring DEFINE-PERSISTENT-STRUCT attaches, via the
generated DEFCLASS's own per-slot :DOCUMENTATION option, to SLOT
itself (as opposed to its generated accessor/reader function -- see
PERSISTENT-STRUCT-ACCESSOR-DOCUMENTATION), templated from NAME and
SLOT (a plist as returned by
PERSISTENT-STRUCT-PARSE-SLOT-DESCRIPTION). This is what
PERSISTENT-OBJECT-README-CONTENT lists in a persisted instance's own
\"README.md\" bullet list of slots."
  (format nil "The ~:@(~A~) slot of a ~:@(~A~) instance~:[~; (a TRANSIENT slot, excluded from serialization)~]."
          (getf slot :name) name (getf slot :transient)))

(defun persistent-struct-class-slot-spec (struct-name slot conc-name package)
  "Return the CLOS slot specifier DEFINE-PERSISTENT-STRUCT emits for
SLOT within its generated DEFCLASS (named STRUCT-NAME): :INITARG the
keyword version of SLOT's :NAME, :INITFORM its :INITFORM, :ACCESSOR
(or :READER, if :READ-ONLY) CONC-NAME concatenated with :NAME (via
PERSISTENT-STRUCT-SLOT-ACCESSOR-NAME), :DOCUMENTATION templated via
PERSISTENT-STRUCT-SLOT-DOCUMENTATION, and, if present, SLOT's own
:TYPE and :TRANSIENT passed through verbatim so
PERSISTENT-STANDARD-CLASS's MOP can see them."
  (let ((name (getf slot :name))
        (accessor (persistent-struct-slot-accessor-name slot conc-name package)))
    `(,name
      :initarg ,(intern (symbol-name name) "KEYWORD")
      :initform ,(getf slot :initform)
      ,(if (getf slot :read-only) :reader :accessor) ,accessor
      :documentation ,(persistent-struct-slot-documentation struct-name slot)
      ,@(when (getf slot :type) (list :type (getf slot :type)))
      ,@(when (getf slot :transient) (list :transient t)))))

(defun persistent-struct-class-documentation (name slots)
  "Return the docstring DEFINE-PERSISTENT-STRUCT attaches to its
generated DEFCLASS for NAME, templated from NAME and SLOTS (each a
plist as returned by PERSISTENT-STRUCT-PARSE-SLOT-DESCRIPTION)."
  (format nil "A PERSISTENT-STRUCT (and so, transitively, a PERSISTENT-OBJECT, GIT-TREE, and STANDARD-OBJECT) generated by DEFINE-PERSISTENT-STRUCT, with one slot per name in ~A. See MAKE-~:@(~A~) and ~:@(~A~)-P."
          (mapcar (lambda (slot) (getf slot :name)) slots)
          name name))

(defun persistent-struct-constructor-documentation (name make-name slots)
  "Return the docstring DEFINE-PERSISTENT-STRUCT attaches to its
generated MAKE-NAME constructor function, templated from NAME,
MAKE-NAME, and SLOTS (each a plist as returned by
PERSISTENT-STRUCT-PARSE-SLOT-DESCRIPTION)."
  (format nil "Construct and return a new ~:@(~A~) instance via MAKE-INSTANCE, accepting one &KEY argument per slot (~{~A~^, ~}), each defaulting to that slot's own DEFINE-PERSISTENT-STRUCT DEFAULT-INITFORM when not supplied."
          name
          (mapcar (lambda (slot) (format nil "~:@(~A~)" (getf slot :name))) slots)
          make-name))

(defun persistent-struct-predicate-documentation (name predicate-name)
  "Return the docstring DEFINE-PERSISTENT-STRUCT attaches to its
generated NAME-P predicate function, templated from NAME and
PREDICATE-NAME."
  (declare (ignore predicate-name))
  (format nil "Return true if OBJECT is a ~:@(~A~) (via TYPEP), NIL otherwise." name))

(defun persistent-struct-accessor-documentation (name slot)
  "Return the docstring DEFINE-PERSISTENT-STRUCT attaches (via SETF
DOCUMENTATION, since the generic function is only implicitly created
by DEFCLASS's own :ACCESSOR/:READER slot option, with no docstring
argument of its own) to the generated accessor/reader for SLOT,
templated from NAME and SLOT (a plist as returned by
PERSISTENT-STRUCT-PARSE-SLOT-DESCRIPTION)."
  (format nil "Return the ~:@(~A~) slot of a ~:@(~A~) instance~:[~; (a TRANSIENT slot, excluded from serialization)~]."
          (getf slot :name) name (getf slot :transient)))

(defmacro define-persistent-struct (name-and-options &rest slot-descriptions)
  "Define a PERSISTENT-STANDARD-CLASS-metaclassed class, DEFSTRUCT-
style: NAME-AND-OPTIONS is a bare struct name symbol, or a list
(NAME &KEY CONC-NAME); each of SLOT-DESCRIPTIONS is a bare slot name
symbol, or a list (NAME DEFAULT-INITFORM &KEY TYPE READ-ONLY
TRANSIENT). Expands into a DEFCLASS named NAME, inheriting from
PERSISTENT-STRUCT, with :METACLASS PERSISTENT-STANDARD-CLASS and one
slot per description (see PERSISTENT-STRUCT-CLASS-SLOT-SPEC),
alongside a MAKE-<NAME> constructor function (accepting the same
&KEY defaults as the slot descriptions themselves, and calling
MAKE-INSTANCE) and a <NAME>-P predicate function (calling TYPEP).
The generated class, MAKE-<NAME>, <NAME>-P, and every generated slot
accessor are all given a docstring templated from NAME and
SLOT-DESCRIPTIONS (via PERSISTENT-STRUCT-CLASS-DOCUMENTATION,
PERSISTENT-STRUCT-CONSTRUCTOR-DOCUMENTATION,
PERSISTENT-STRUCT-PREDICATE-DOCUMENTATION, and
PERSISTENT-STRUCT-ACCESSOR-DOCUMENTATION), so no
DEFINE-PERSISTENT-STRUCT-generated public symbol is ever left
undocumented. Each generated slot itself also gets its own
:DOCUMENTATION option (via PERSISTENT-STRUCT-SLOT-DOCUMENTATION),
which PERSISTENT-OBJECT-README-CONTENT lists in a persisted
instance's own \"README.md\" bullet list of slots."
  (multiple-value-bind (name conc-name) (persistent-struct-parse-name-and-options name-and-options)
    (let* ((package (symbol-package name))
           (slots (mapcar #'persistent-struct-parse-slot-description slot-descriptions))
           (class-slot-specs (mapcar (lambda (slot) (persistent-struct-class-slot-spec name slot conc-name package))
                                      slots))
           (make-name (intern (concatenate 'string "MAKE-" (string name)) package))
           (predicate-name (intern (concatenate 'string (string name) "-P") package)))
      `(progn
         (defclass ,name (persistent-struct)
           ,class-slot-specs
           (:metaclass persistent-standard-class)
           (:documentation ,(persistent-struct-class-documentation name slots)))
         (defun ,make-name (&key ,@(mapcar (lambda (slot) (list (getf slot :name) (getf slot :initform))) slots))
           ,(persistent-struct-constructor-documentation name make-name slots)
           (make-instance ',name
                          ,@(mapcan (lambda (slot)
                                      (list (intern (symbol-name (getf slot :name)) "KEYWORD") (getf slot :name)))
                                    slots)))
         (defun ,predicate-name (object)
           ,(persistent-struct-predicate-documentation name predicate-name)
           (typep object ',name))
         ,@(mapcar (lambda (slot)
                     `(setf (documentation ',(persistent-struct-slot-accessor-name slot conc-name package) 'function)
                            ,(persistent-struct-accessor-documentation name slot)))
                   slots)))))