Finishing first MOP utility.

make-instance-from-hash-table will attempt to build a CLOS instance from
a hash table, e.g. such as returned by Yason's parser.

docs/example.json

@@ -0,0 +1,8 @@
+{
+    "name": "something",
+    "ref": {
+        "link": "https://common-lisp.net/",
+        "title": "Common Lisp"
+    },
+    "value": "just a thing"
+}

docs/manifest.lisp

@@ -1,5 +1,5 @@
 (:docstring-markup-format :scriba
- :systems (:kutils)
+ :systems (:kutils :kutils-mop)
  :documents ((:title "kutils"
               :authors ("K. Isom")
               :output-format (:type :multi-html

docs/manual.scr

@@ -226,18 +226,67 @@ some code should be executed based on the results of those bindings.
 These macros abstract common operations on files.
 
 @cl:with-package[name="kutils"](
-@cl:doc(macro! read-file-as-string)
-@cl:doc(macro! with-string-output-to-file)
 @cl:doc(macro with-read-from-file)
 @cl:doc(macro with-write-to-file)
 )
 
+The following two macros aren't yet able to be documented with
+@link[uri="https://github.com/CommonDoc/codex"](Codex), as they are
+defined using the @c(defmacro!) macro:
+
+@code(
+read-file-as-string (path &rest args
+                          &key (direction nil directionp)
+                          &allow-other-keys))
+
+Read the contents of the file at @c(path) as a string. Any remaining
+arguments are sent to @c(with-open-file).
+
+@code(
+with-string-output-to-file
+  ((path &rest args &key (direction :output directionp)
+         &allow-other-keys)
+   &body body))
+
+Evaluate @c(body), and call @c(mkstr) on the result. Write the
+resulting string to @c(path). Any remaining arguments are sent to
+@c(with-open-file).
+
+
+
 @end(def)
 
 @end(deflist)
 
 @end(section)
 
+@begin(section)
+@title(Metaobject utilities)
+
+The package @c(kutils-mop) contains utilities taking advantage of the
+metaobject protocol.
+
+The @c(make-instance-from-hash-table) function will attempt to create
+an instance of an object from a hash table.
+
+@cl:with-package[name="kutils-mop"](
+@cl:doc(function make-instance-from-hash-table))
+
+This is motivated by the fact that
+@link[uri="http://quickdocs.org/yason/"](Yason) parses JSON as hash
+tables; this function is used to facilitate rapidly parsing CLOS
+objects from JSON.
+
+For example, with the following @c(example.json)
+
+@code(@include[path=example.json]())
+
+the following code will produce an instance of the @c(class-d) class.
+
+@code(@include[path=mop-table-demo.lisp]())
+
+@end(section)
+
 @begin(section)
 @title(Symbol index)
 
@@ -320,6 +369,10 @@ functions".)
 @item(@c(macroexpand-n) is a function defined in @c(kutils.lisp),
 described in "Miscellaneous utilities" under "General".)
 
+@item(@c(make-instance-from-hash-table) is a function defined in the
+@c(#:kutils-mop) package in @c(kmop/kmop.lisp), described in
+"Metaobject utilities".)
+
 @item(@c(mapv) is a macro defined in @c(kutils.lisp), described in
 "Miscellaneous utilities" under "Vector-related".)
 
@@ -422,7 +475,6 @@ Alphabetical documentation for all exported symbols.
 @cl:doc(function new-hash-table)
 @cl:doc(function new-vector)
 @cl:doc(function partial)
-@cl:doc(macro! read-file-as-string)
 @cl:doc(macro sethash)
 @cl:doc(function symb)
 @cl:doc(function take)
@@ -432,8 +484,15 @@ Alphabetical documentation for all exported symbols.
 @cl:doc(macro whenlet*)
 @cl:doc(macro with-new-hash-table)
 @cl:doc(macro with-read-from-file)
-@cl:doc(macro! with-string-output-to-file)
 @cl:doc(macro with-write-to-file)
 @cl:doc(function zip))
 
+The following functions cannot be automatically documented by Codex,
+as they are defined using the @c(defmacro!) macro. Their description
+is in the "Macro" section.
+
+@begin(list)
+@item(@c(read-file-as-string))
+@item(@c(with-string-output-to-file))
+@end(list)
 @end(section)

docs/mop-table-demo.lisp

@@ -0,0 +1,69 @@
+(defpackage #:kutils-example
+  (:use #:cl #:kutils #:kutils-mop))
+
+(in-package :kutils-example)
+
+KUTILS-EXAMPLE> (defclass class-a ()
+		  ((name :initarg :name
+			 :accessor name-of)
+		   (value :initarg :value
+			  :accessor value-of)))
+#<STANDARD-CLASS KUTILS-EXAMPLE::CLASS-A>
+KUTILS-EXAMPLE> (defun new-class-a (n v)
+		  (make-instance 'class-a :name n :value v))
+NEW-CLASS-A
+KUTILS-EXAMPLE> (defclass reference ()
+		  ((link :initarg :link
+			 :accessor link-of)
+		   (title :initarg :title
+			  :accessor title-of)))
+#<STANDARD-CLASS KUTILS-EXAMPLE::REFERENCE>
+KUTILS-EXAMPLE> (defun new-reference (l title)
+		  (make-instance 'reference :link l :title title))
+NEW-REFERENCE
+KUTILS-EXAMPLE> (defclass class-b (class-a)
+		  ((tag :initarg :tag
+			:accessor tag-of)))
+#<STANDARD-CLASS KUTILS-EXAMPLE::CLASS-B>
+KUTILS-EXAMPLE> (defun new-class-b (n v tag)
+		  (make-instance 'class-b :name n :value v :tag tag))
+NEW-CLASS-B
+KUTILS-EXAMPLE> (defclass class-c (class-a)
+		  ((initialised :initform nil)))
+#<STANDARD-CLASS KUTILS-EXAMPLE::CLASS-C>
+KUTILS-EXAMPLE> (defun new-class-c (n v)
+		  (make-instance 'class-c :name n :value v))
+NEW-CLASS-C
+KUTILS-EXAMPLE> (defclass class-d (class-a)
+		  ((reference :initarg ref
+			      :type reference
+			      :accessor reference-of)))
+#<STANDARD-CLASS KUTILS-EXAMPLE::CLASS-D>
+KUTILS-EXAMPLE> (defun new-class-d (n v ref)
+		  (make-instance 'class-a :name n :value v :ref ref))
+NEW-CLASS-D
+KUTILS-EXAMPLE> (defvar *class-d-table*
+		  (yason:parse
+		   ;; there is an example.json in the docs directory
+		   ;; of kutils.
+		   (read-file-as-string #P"/tmp/example.json")))
+*CLASS-D-TABLE*
+KUTILS-EXAMPLE> (let ((obj
+		       (make-instance-from-hash-table
+			'class-d *class-d-table*)))
+		  (describe obj)
+		  (describe (reference-of obj)))
+#<CLASS-D {1007F0B013}>
+  [standard-object]
+
+Slots with :INSTANCE allocation:
+  NAME       = "something"
+  VALUE      = "just a thing"
+  REFERENCE  = #<REFERENCE {1007F0A853}>
+#<REFERENCE {1007F0A853}>
+  [standard-object]
+
+Slots with :INSTANCE allocation:
+  LINK   = "https://common-lisp.net/"
+  TITLE  = "Common Lisp"
+; No value

docs/mop-table.lisp

@@ -0,0 +1,57 @@
+(ql:quickload :kutils-mop)
+(ql:quickload :yason)
+
+(defpackage #:kutils-example
+  (:use #:cl #:kutils #:kutils-mop))
+
+(in-package :kutils-example)
+
+ (defclass class-a ()
+    ((name :initarg :name
+	   :accessor name-of)
+     (value :initarg :value
+	    :accessor value-of)))
+
+(defun new-class-a (n v)
+  (make-instance 'class-a :name n :value v))
+
+(defclass reference ()
+  ((link :initarg :link
+	 :accessor link-of)
+   (title :initarg :title
+	  :accessor title-of)))
+
+(defun new-reference (l title)
+  (make-instance 'reference :link l :title title))
+
+(defclass class-b (class-a)
+  ((tag :initarg :tag
+	:accessor tag-of)))
+
+(defun new-class-b (n v tag)
+  (make-instance 'class-b :name n :value v :tag tag))
+
+(defclass class-c (class-a)
+  ((initialised :initform nil)))
+
+(defun new-class-c (n v)
+  (make-instance 'class-c :name n :value v))
+
+(defclass class-d (class-a)
+  ((reference :initarg ref
+	       :type reference
+	       :accessor reference-of)))
+
+(defun new-class-d (n v ref)
+  (make-instance 'class-a :name n :value v :ref ref))
+
+(defvar *class-d-table*
+  (yason:parse
+   ;; there is an example.json in the docs directory of kutils.
+   (read-file-as-string #P"/tmp/example.json")))
+
+(let ((obj
+       (make-instance-from-hash-table 'class-d *class-d-table*)))
+  (describe obj)
+  (describe (reference-of obj)))
+

kmop/kmop.lisp

@@ -4,11 +4,33 @@
 
 ;;; metaobject interactions
 
+(defun sym-lookup (sym &optional (package *package*))
+  (find-symbol (mkstr sym) package))
+
+(defun class-symbol (sym &optional (package *package*))
+  (cond
+    ((symbolp sym)
+     (whenlet (sym (sym-lookup sym package))
+       (find-class sym)))
+    ((keywordp sym) nil)
+    (t sym)))
+
+(defvar *standard-object* (class-symbol 'standard-object))
+
+(defun subclassp (child parent)
+  (whenlet ((child  (class-symbol child))
+	    (parent (class-symbol parent)))
+    (closer-mop:subclassp child parent)))
+
+(defun objectp (sym)
+  (subclassp sym *standard-object*))
+
 (defun get-class-initargs (slots)
-)
+  (flatten
+   (mapcar #'closer-mop:slot-definition-initargs slots)))
 
 
-(defun get-all-init-args (class-sym &optional (package *package*))
+(defun get-all-slots (class-sym &optional (package *package*))
   (let ((class-val (find-class
 			  (find-symbol
 			   (mkstr class-sym)
@@ -20,23 +42,53 @@
 		    (null (closer-mop:slot-definition-initargs slot)))
 		  (closer-mop:class-slots class-val))))))
 
-(defun kw-key (kw)
+(defun kw-key (slot &optional snake-case)
-  (string-downcase
+  (let ((s (string-downcase
-   (mkstr kw)))
+	    (mkstr
+	     (first
+	      (closer-mop:slot-definition-initargs slot))))))
+    (if snake-case
+	(nsubstitute #\- #\_ s)
+	(nsubstitute #\_ #\- s))))
 
-(defun dispatch-get-value (value))
+(defun dispatch-get-value (slot value)
+  (let ((slot-type (closer-mop:slot-definition-type slot)))
+    (if (objectp slot-type)
+	(make-instance-from-hash-table slot-type value)
+	value)))
 
+(defun slot-initarg (slot)
+  (first
+   (closer-mop:slot-definition-initargs slot)))
 
-(defun zip-initargs-hash-table (args ht)
+(defun slot-table-value (slot ht &optional snake-case)
+  (when ht
+    (gethash (kw-key slot snake-case) ht)))
+
+(defun zip-initargs-hash-table (slots ht &optional snake-case)
   (flatten
-   (mapcar (lambda (slot)
+   (remove-if #'null
-	     (list slot (gethash (kw-key slot) ht)))
+	      (mapcar (lambda (slot)
-	   args)))
+			(whenlet ((kwarg (slot-initarg slot))
+				  (value (dispatch-get-value
+					  slot
+					  (slot-table-value
+					   slot ht snake-case))))
+			  (list kwarg value)))
+		      slots))))
 
-(defun make-instance-from-hash-table (class-type table &optional (package *package*))
+(defun make-instance-from-hash-table
-  (let ((class-sym (find-class class-type)))
+    (class-type table
-    (when class-sym
+     &optional (package *package*) snake-case)
-      (apply #'make-instance class-sym
+  "Given a class symbol and a hash table, attempt to build an instance
-	     (zip-initargs-hash-table
+from it. The instance initargs are derived from the slot definitions,
-	      (get-all-init-args class-type package)
+and an attempt is made to pair the slot with a string derivation. It
-	      table)))))
+is expected that the hash table keys will be downcase. If
+@c(snake-case) is t, the keys should use hyphens; otherwise, they
+should use underscores. The slot type is used to determine whether
+to attempt to parse another object as a hash table entry."
+  (whenlet ((class-sym (class-symbol class-type))
+	    (arglst (zip-initargs-hash-table
+		     (get-all-slots class-type package)
+		     table snake-case)))
+    (apply #'make-instance class-sym arglst)))

kmop/package.lisp

@@ -1,4 +1,5 @@
 ;;;; package.lisp
 
 (defpackage #:kutils-mop
-  (:use #:cl #:kutils))
+  (:use #:cl #:kutils)
+  (:export #:make-instance-from-hash-table))

kutils-mop.asd

@@ -5,7 +5,8 @@
   :author "K. Isom <kyle@metacircular.net>"
   :license "MIT License"
   :serial t
+  :pathname #P"kmop/"
   :depends-on (#:closer-mop #:kutils)
-  :components ((:file "kmop/package")
+  :components ((:file "package")
-               (:file "kmop/kmop")))
+               (:file "kmop")))
 

kutils.asd

@@ -5,7 +5,6 @@
   :author "K. Isom <kyle@metacircular.net>"
   :license "MIT License"
   :serial t
-  :depends-on (#:closer-mop)
   :components ((:file "package")
 	       (:file "on")
 	       (:file "lol")