From 580cb5c21bd979dc388805b38ff95ffd170b0e87 Mon Sep 17 00:00:00 2001 From: Kyle Date: Tue, 1 Sep 2015 01:55:43 -0700 Subject: [PATCH] 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 | 8 ++++ docs/manifest.lisp | 2 +- docs/manual.scr | 67 +++++++++++++++++++++++++++++-- docs/mop-table-demo.lisp | 69 ++++++++++++++++++++++++++++++++ docs/mop-table.lisp | 57 ++++++++++++++++++++++++++ kmop/kmop.lisp | 86 ++++++++++++++++++++++++++++++++-------- kmop/package.lisp | 3 +- kutils-mop.asd | 5 ++- kutils.asd | 1 - 9 files changed, 272 insertions(+), 26 deletions(-) create mode 100644 docs/example.json create mode 100644 docs/mop-table-demo.lisp create mode 100644 docs/mop-table.lisp diff --git a/docs/example.json b/docs/example.json new file mode 100644 index 0000000..e538e6f --- /dev/null +++ b/docs/example.json @@ -0,0 +1,8 @@ +{ + "name": "something", + "ref": { + "link": "https://common-lisp.net/", + "title": "Common Lisp" + }, + "value": "just a thing" +} diff --git a/docs/manifest.lisp b/docs/manifest.lisp index 60e2584..c3e026d 100644 --- a/docs/manifest.lisp +++ b/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 diff --git a/docs/manual.scr b/docs/manual.scr index 00fb297..46cf899 100644 --- a/docs/manual.scr +++ b/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) diff --git a/docs/mop-table-demo.lisp b/docs/mop-table-demo.lisp new file mode 100644 index 0000000..070c20f --- /dev/null +++ b/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))) +# +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))) +# +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))) +# +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))) +# +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))) +# +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))) +# + [standard-object] + +Slots with :INSTANCE allocation: + NAME = "something" + VALUE = "just a thing" + REFERENCE = # +# + [standard-object] + +Slots with :INSTANCE allocation: + LINK = "https://common-lisp.net/" + TITLE = "Common Lisp" +; No value diff --git a/docs/mop-table.lisp b/docs/mop-table.lisp new file mode 100644 index 0000000..f5ac428 --- /dev/null +++ b/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))) + diff --git a/kmop/kmop.lisp b/kmop/kmop.lisp index 99c1422..6fed6ff 100644 --- a/kmop/kmop.lisp +++ b/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) - (string-downcase - (mkstr kw))) +(defun kw-key (slot &optional snake-case) + (let ((s (string-downcase + (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) - (list slot (gethash (kw-key slot) ht))) - args))) + (remove-if #'null + (mapcar (lambda (slot) + (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*)) - (let ((class-sym (find-class class-type))) - (when class-sym - (apply #'make-instance class-sym - (zip-initargs-hash-table - (get-all-init-args class-type package) - table))))) +(defun make-instance-from-hash-table + (class-type table + &optional (package *package*) snake-case) + "Given a class symbol and a hash table, attempt to build an instance +from it. The instance initargs are derived from the slot definitions, +and an attempt is made to pair the slot with a string derivation. It +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))) diff --git a/kmop/package.lisp b/kmop/package.lisp index a94a2a5..a942b88 100644 --- a/kmop/package.lisp +++ b/kmop/package.lisp @@ -1,4 +1,5 @@ ;;;; package.lisp (defpackage #:kutils-mop - (:use #:cl #:kutils)) + (:use #:cl #:kutils) + (:export #:make-instance-from-hash-table)) diff --git a/kutils-mop.asd b/kutils-mop.asd index c3562fb..abf1eb3 100644 --- a/kutils-mop.asd +++ b/kutils-mop.asd @@ -5,7 +5,8 @@ :author "K. Isom " :license "MIT License" :serial t + :pathname #P"kmop/" :depends-on (#:closer-mop #:kutils) - :components ((:file "kmop/package") - (:file "kmop/kmop"))) + :components ((:file "package") + (:file "kmop"))) diff --git a/kutils.asd b/kutils.asd index a73627e..5394493 100644 --- a/kutils.asd +++ b/kutils.asd @@ -5,7 +5,6 @@ :author "K. Isom " :license "MIT License" :serial t - :depends-on (#:closer-mop) :components ((:file "package") (:file "on") (:file "lol")