1 files changed, 125 insertions, 0 deletions

diff --git a/src/tg/type-macros.lisp b/src/tg/type-macros.lisp
new file mode 100644
index 0000000..06de32d
--- /dev/null
+++ b/src/tg/type-macros.lisp
@@ -0,0 +1,125 @@
+;; SPDX-License-Identifier: EUPL-1.2
+;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs <perkontevs@gmail.com>
+(defpackage :ukkoclot/tg/type-macros
+  (:use :c2cl :iterate)
+  (:import-from :ukkoclot/hash-tables :gethash-lazy)
+  (:import-from :ukkoclot/strings :lisp->snake-case)
+  (:local-nicknames
+   (:jzon :com.inuoe.jzon))
+  (:export :define-tg-type))
+(in-package :ukkoclot/tg/type-macros)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defstruct (field (:constructor make-field%)) name type default skip-if-default)
+
+  (defparameter +unique+ (gensym))
+
+  (defun make-field (name type &optional (default +unique+) &key (skip-if-default (not (eq default +unique+))))
+    (let ((default (if (eq default +unique+)
+                       `(error ,(format nil "No value given for ~A" name))
+                       default)))
+      (make-field% :name name
+                   :type type
+                   :default default
+                   :skip-if-default skip-if-default)))
+
+  (defun type-constructor (name)
+    (intern (concatenate 'string "MAKE-" (symbol-name name))))
+
+  (defun field-accessor (name field)
+    (intern (concatenate 'string (symbol-name name) "-" (symbol-name (field-name field)))))
+
+  (defun field-hash-key (field)
+    (string-downcase (lisp->snake-case (symbol-name (field-name field)))))
+
+  (defun field-keyword (field)
+    (intern (symbol-name (field-name field)) :keyword))
+
+  (defun parse-field-specs (field-specs)
+    (iter (for field-spec in field-specs)
+          (collect (apply #'make-field field-spec))))
+
+  (defun emit-append-to-pprint-args (field value pprint-args)
+    `(setf ,pprint-args (list* ',(field-name field) ,value ,pprint-args)))
+
+  (defun emit-coerced-field (field value)
+    `(list ,(field-hash-key field) ,value ',(field-type field)))
+
+  (defun emit-collect-nondefault-fields (name fields obj collector)
+    (let ((value (gensym "VALUE")))
+      (iter (for field in (reverse fields))
+            (collect
+                (if (field-skip-if-default field)
+                    `(let ((,value (,(field-accessor name field) ,obj)))
+                       (unless (equal ,value ,(field-default field))
+                         ,(funcall collector field value)))
+                    (funcall collector field (list (field-accessor name field) obj)))))))
+
+  (defun emit-constructor-args (field)
+    `(,(field-keyword field) ,(field-name field)))
+
+  (defun emit-gethash (field source)
+    `(gethash-lazy ,(field-hash-key field) ,source ,(field-default field)))
+
+  (defun emit-jzon-coerced-fields (name fields)
+    (let ((obj (gensym "OBJ"))
+          (result (gensym "RESULT")))
+      `(defmethod jzon:coerced-fields ((,obj ,name))
+         (let (,result)
+           ,@(emit-collect-nondefault-fields
+              name fields obj
+              (lambda (field value)
+                `(setf ,result (cons ,(emit-coerced-field field value) ,result))))
+           ,result))))
+
+  (defun emit-let-gethash (field source)
+    `(,(field-name field)
+      (parse-value ',(field-type field) ,(emit-gethash field source))))
+
+  (defun emit-parse-value (name fields)
+    (let ((type-sym (gensym "TYPE-SYM"))
+          (source (gensym "SOURCE")))
+      `(defmethod parse-value ((,type-sym (eql ',name)) ,source)
+         (let ,(iter (for field in fields)
+                     (collect (emit-let-gethash field source)))
+           (,(type-constructor name)
+            ,@(print (iter (for field in fields)
+                    (appending (print (emit-constructor-args field))))))))))
+
+  (defun emit-printer (name printer-name fields)
+    (let ((obj (gensym "OBJ"))
+          (stream (gensym "STREAM"))
+          (depth (gensym "DEPTH"))
+          (pprint-args (gensym "PPRINT-ARGS")))
+      `(defun ,printer-name (,obj ,stream ,depth)
+         (declare (ignore ,depth))
+         (let (,pprint-args)
+           ,@(emit-collect-nondefault-fields
+              name fields obj
+              (lambda (field value)
+                `(setf ,pprint-args (list* ',(field-name field) ,value ,pprint-args))))
+           ;; ,@(iter (for field in (reverse fields))
+           ;;         (collect
+           ;;             (if (field-skip-if-default field)
+           ;;                 `(let ((,value (,(field-accessor name field) ,obj)))
+           ;;                    (unless (equal ,value ,(field-default field))
+           ;;                      ,(emit-append-to-pprint-args field value pprint-args)))
+           ;;                 (emit-append-to-pprint-args field `(,(field-accessor name field) ,obj) pprint-args))))
+           (format ,stream "~A~<[~;~@{~_~1I~W = ~W~^, ~}~;]~:>" ',name ,pprint-args)))))
+
+  (defun emit-struct (name printer-name fields)
+    `(defstruct (,name (:print-function ,printer-name))
+       ,@(iter (for field in fields)
+               (collect (emit-struct-field field)))))
+
+  (defun emit-struct-field (field)
+    `(,(field-name field) ,(field-default field) :type ,(field-type field))))
+
+(defmacro define-tg-type (name &body field-specs)
+  (let ((fields (parse-field-specs field-specs))
+        (printer-name (gensym "PRINTER")))
+    `(progn
+       ,(emit-struct name printer-name fields)
+       ,(emit-printer name printer-name fields)
+       ,(emit-parse-value name fields)
+       ,(emit-jzon-coerced-fields name fields))))