1 files changed, 134 insertions, 0 deletions

diff --git a/src/tg-types/macros.lisp b/src/tg-types/macros.lisp
new file mode 100644
index 0000000..668df17
--- /dev/null
+++ b/src/tg-types/macros.lisp
@@ -0,0 +1,134 @@
+;; SPDX-License-Identifier: EUPL-1.2
+;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs <perkontevs@gmail.com>
+(defpackage :ukkoclot/tg-types/macros
+  (:use :c2cl)
+  (:import-from :ukkoclot/bot/impl :arg-encode :bot :do-call :will-arg-encode)
+  (:import-from :ukkoclot/hash-tables :gethash-lazy)
+  (:import-from :ukkoclot/strings :lisp->snake-case)
+  (:export :define-tg-method :define-tg-type))
+(in-package :ukkoclot/tg-types/macros)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defstruct (field (:constructor make-field%)) name type default skip-if-default (parser 'identity))
+
+  (defparameter +unique+ (gensym))
+
+  (defun make-field (name type &optional (default +unique+) &key (parser 'identity) (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
+                   :parser parser)))
+
+  (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->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)
+    (list (field-name field)
+          (list 'funcall
+                (list 'function (field-parser 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
+;; TODO: Skip values that are already their defaults
+(defmacro define-tg-method (
+                            (name type path mapfn &optional (method :POST))
+                            &body field-specs)
+  (let ((fields (parse-field-specs field-specs))
+        (args-plist (gensym "ARGS-PLIST-"))
+        (bot (gensym "BOT-")))
+    `(progn
+       (declaim (ftype (function (bot &key ,@(loop for field in fields
+                                                 collect (field->ftype-spec field)))
+                                 ,type)
+                       ,name))
+       (defun ,name (,bot &rest ,args-plist &key ,@(loop for field in fields collect (field->defun-spec field)))
+         (declare ,@(loop for field in fields collect (list 'ignore (field-name field))))
+         (do-call ,bot ,method ,path ,mapfn ,args-plist)))))
+
+(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))))
+         (hash->name (intern (concatenate 'string "HASH->" (symbol-name name))))
+         (parse-name-array (intern (concatenate 'string "PARSE-" (symbol-name name) "-ARRAY")))
+         (printer (gensym (concatenate 'string "PRINT-" (symbol-name name))))
+         (hash (gensym "HASH-"))
+         (array (gensym "ARRAY-"))
+         (struc (gensym (symbol-name name)))
+         (stream (gensym "STREAM"))
+         (depth (gensym "DEPTH"))
+         (pprint-args (gensym "PPRINT-ARGS")))
+    `(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)))
+       (defun ,hash->name (,hash)
+         (when ,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 arg-encode ((,struc ,name))
+         (let ((,hash (make-hash-table)))
+           ,@(loop for field in fields
+                   collect (field->sethash-spec field name struc hash))
+           ,hash))
+       (defmethod will-arg-encode ((,struc ,name))
+         t)
+       (defun ,parse-name-array (,array)
+         (when ,array
+           (map 'vector #',hash->name ,array))))))