1 files changed, 142 insertions, 0 deletions

diff --git a/src/tg/macros.lisp b/src/tg/macros.lisp
new file mode 100644
index 0000000..92afd6e
--- /dev/null
+++ b/src/tg/macros.lisp
@@ -0,0 +1,142 @@
+;; SPDX-License-Identifier: EUPL-1.2
+;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs <perkontevs@gmail.com>
+(defpackage :ukkoclot/tg/macros
+  (:use :c2cl)
+  (:import-from :ukkoclot/bot/impl :bot :do-call :parse-value)
+  (:import-from :ukkoclot/hash-tables :gethash-lazy)
+  (:import-from :ukkoclot/strings :lisp->snake-case)
+  (:local-nicknames
+   (:jzon :com.inuoe.jzon))
+  (:export :define-tg-method :define-tg-type))
+(in-package :ukkoclot/tg/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+)
+                       (list '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 parse-field-specs (field-specs)
+    (loop for field-spec in field-specs
+          collect (apply #'make-field field-spec)))
+
+  (defun field-hash-key (field)
+    (string-downcase (lisp->snake-case (symbol-name (field-name field)))))
+
+  (defun field-accessor (struc-name field)
+    (intern (concatenate 'string (symbol-name struc-name) "-" (symbol-name (field-name field)))))
+
+  (defun field->coerced-field-spec (field struc-name obj-name)
+    `(list ,(string-downcase (lisp->snake-case (symbol-name (field-name field))))
+           (,(field-accessor struc-name field) ,obj-name)
+           ',(field-type field)))
+
+  (defun field->defun-spec (field)
+    (list (field-name field) (field-default field)))
+
+  (defun field->format-arg (field name struc)
+    `(',(field-name field) (,(field-accessor name field) ,struc)))
+
+  (defun field->ftype-spec (field)
+    (list (intern (symbol-name (field-name field)) :keyword) (field-type field)))
+
+  (defun field->gethash-spec (field hash-table-sym)
+    (let ((hash-key (field-hash-key field)))
+      (list 'gethash-lazy hash-key hash-table-sym (field-default field))))
+
+  (defun field->sethash-spec (field name struc hash-table-sym)
+    (let ((hash-key (field-hash-key field))
+          (skip-if-default (field-skip-if-default field))
+          (default (field-default field)))
+      (if skip-if-default
+          (let ((tmpsym (gensym "TMP")))
+            `(let ((,tmpsym (,(field-accessor name field) ,struc)))
+               (unless (equal ,tmpsym ,default)
+                 (setf (gethash ,hash-key ,hash-table-sym) ,tmpsym))))
+          `(setf (gethash ,hash-key ,hash-table-sym) (,(field-accessor name field) ,struc)))))
+
+  (defun field->let-gethash-spec (field hash-table-sym)
+    `(,(field-name field)
+      (parse-value ',(field-type field) ,(field->gethash-spec field hash-table-sym))))
+
+  (defun field->make-spec (field)
+    (list (intern (symbol-name (field-name field)) :keyword)
+          (field-name field)))
+
+  (defun field->struct-spec (field)
+    (list (field-name field) (field-default field) :type (field-type field))))
+
+;; TODO: Automatically derive path from name
+;; TODO: Automatically derive mapfn from type
+(defmacro define-tg-method (
+                            (name type path &optional (method :POST))
+                            &body field-specs)
+  (let* ((fields (parse-field-specs field-specs))
+         (revfields (reverse fields))
+         (args (gensym "ARGS"))
+         (bot (gensym "BOT-")))
+    `(progn
+       (declaim (ftype (function (bot &key ,@(loop for field in fields
+                                                 collect (field->ftype-spec field)))
+                                 ,type)
+                       ,name))
+       (defun ,name (,bot &key ,@(loop for field in fields collect (field->defun-spec field)))
+         (let (,args)
+           ,@(loop for field in revfields
+                   collecting
+                   (if (field-skip-if-default field)
+                       `(unless (equal ,(field-name field) ,(field-default field))
+                          (setf ,args (acons ',(field-name field) ,(field-name field) ,args)))
+                       `(setf ,args (acons ',(field-name field) ,(field-name field) ,args))))
+           (do-call ,bot ,method ,path ',type ,args))))))
+
+(defmacro define-tg-type (name &body field-specs)
+  (let* ((fields (parse-field-specs field-specs))
+         (revfields (reverse fields))
+         (make-name (intern (concatenate 'string "MAKE-" (symbol-name name))))
+         (printer (gensym (concatenate 'string "PRINT-" (symbol-name name))))
+         (hash (gensym "HASH-"))
+         (struc (gensym (symbol-name name)))
+         (stream (gensym "STREAM"))
+         (depth (gensym "DEPTH"))
+         (pprint-args (gensym "PPRINT-ARGS"))
+         (res (gensym "RES"))
+         (type (gensym "TYPE")))
+    `(progn
+       (defstruct (,name (:print-function ,printer))
+         ,@(loop for field in fields
+                 collect (field->struct-spec field)))
+       (defun ,printer (,struc ,stream ,depth)
+         (declare (ignore ,depth))
+         (let (,pprint-args)
+           ,@(loop for field in revfields
+                   collecting
+                   (if (field-skip-if-default field)
+                       `(let ((value (,(field-accessor name field) ,struc)))
+                          (unless (equal value ,(field-default field))
+                            (setf ,pprint-args (list* ',(field-name field) value ,pprint-args))))
+                       `(setf ,pprint-args (list* ',(field-name field) (,(field-accessor name field) ,struc) ,pprint-args))))
+         (format ,stream "~A~<[~;~@{~_~1I~W = ~W~^, ~}~;]~:>" ',name ,pprint-args)))
+       (defmethod parse-value ((,type (eql ',name)) ,hash)
+         (let ,(loop for field in fields
+                     collect (field->let-gethash-spec field hash))
+           (,make-name ,@(loop for field in fields
+                               append (field->make-spec field)))))
+       (defmethod jzon:coerced-fields ((,struc ,name))
+         (let (,res)
+           ,@(loop for field in revfields
+                   collecting
+                   (if (field-skip-if-default field)
+                       `(let ((value (,(field-accessor name field) ,struc)))
+                          (unless (equal value ,(field-default field))
+                            (setf ,res (cons ,(field->coerced-field-spec field name struc) ,res))))
+                       `(setf ,res (cons ,(field->coerced-field-spec field name struc) ,res))))
+           ,res)))))