From 45de3afb9e0b6c8e57c5752cc21a11bb1a71f8ad Mon Sep 17 00:00:00 2001 From: Uko Kokņevičs Date: Mon, 13 Oct 2025 01:27:14 +0300 Subject: Rewrite define-tg-type and move it into type-macros --- src/tg/animation.lisp | 2 +- src/tg/bot-name.lisp | 2 +- src/tg/business-bot-rights.lisp | 2 +- src/tg/business-connection.lisp | 2 +- src/tg/callback-query.lisp | 2 +- src/tg/chat-administrator-rights.lisp | 2 +- src/tg/chat.lisp | 2 +- src/tg/force-reply.lisp | 2 +- src/tg/inline-keyboard-button.lisp | 2 +- src/tg/inline-keyboard-markup.lisp | 2 +- src/tg/keyboard-button-poll-type.lisp | 2 +- src/tg/keyboard-button-request-chat.lisp | 2 +- src/tg/keyboard-button-request-users.lisp | 2 +- src/tg/keyboard-button.lisp | 2 +- src/tg/link-preview-options.lisp | 2 +- src/tg/macros.lisp | 118 ---------------------------- src/tg/message-entity.lisp | 2 +- src/tg/message-reaction-updated.lisp | 2 +- src/tg/message.lisp | 2 +- src/tg/photo-size.lisp | 2 +- src/tg/reaction-type-custom-emoji.lisp | 2 +- src/tg/reaction-type-emoji.lisp | 2 +- src/tg/reaction-type-paid.lisp | 2 +- src/tg/reaction-type.lisp | 2 +- src/tg/reply-keyboard-markup.lisp | 2 +- src/tg/reply-keyboard-remove.lisp | 2 +- src/tg/reply-parameters.lisp | 2 +- src/tg/suggested-post-parameters.lisp | 2 +- src/tg/suggested-post-price.lisp | 2 +- src/tg/type-macros.lisp | 125 ++++++++++++++++++++++++++++++ src/tg/update.lisp | 2 +- src/tg/user.lisp | 2 +- src/tg/web-app-info.lisp | 2 +- 33 files changed, 156 insertions(+), 149 deletions(-) delete mode 100644 src/tg/macros.lisp create mode 100644 src/tg/type-macros.lisp (limited to 'src') diff --git a/src/tg/animation.lisp b/src/tg/animation.lisp index d17db94..cae4933 100644 --- a/src/tg/animation.lisp +++ b/src/tg/animation.lisp @@ -1,7 +1,7 @@ ;; SPDX-License-Identifier: EUPL-1.2 ;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs (defpackage :ukkoclot/tg/animation - (:use :c2cl :ukkoclot/tg/macros :ukkoclot/tg/photo-size) + (:use :c2cl :ukkoclot/tg/type-macros :ukkoclot/tg/photo-size) (:export #:animation #:make-animation diff --git a/src/tg/bot-name.lisp b/src/tg/bot-name.lisp index 933ce8c..10e873c 100644 --- a/src/tg/bot-name.lisp +++ b/src/tg/bot-name.lisp @@ -1,7 +1,7 @@ ;; SPDX-License-Identifier: EUPL-1.2 ;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs (defpackage :ukkoclot/tg/bot-name - (:use :c2cl :ukkoclot/tg/macros) + (:use :c2cl :ukkoclot/tg/type-macros) (:export #:bot-name #:make-bot-name diff --git a/src/tg/business-bot-rights.lisp b/src/tg/business-bot-rights.lisp index f5a44c0..8d852d2 100644 --- a/src/tg/business-bot-rights.lisp +++ b/src/tg/business-bot-rights.lisp @@ -1,7 +1,7 @@ ;; SPDX-License-Identifier: EUPL-1.2 ;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs (defpackage :ukkoclot/tg/business-bot-rights - (:use :c2cl :ukkoclot/tg/macros) + (:use :c2cl :ukkoclot/tg/type-macros) (:export #:business-bot-rights #:make-business-bot-rights diff --git a/src/tg/business-connection.lisp b/src/tg/business-connection.lisp index 74f6c9e..726cdd4 100644 --- a/src/tg/business-connection.lisp +++ b/src/tg/business-connection.lisp @@ -3,7 +3,7 @@ (defpackage :ukkoclot/tg/business-connection (:use :c2cl - :ukkoclot/tg/macros + :ukkoclot/tg/type-macros :ukkoclot/tg/business-bot-rights :ukkoclot/tg/user) (:export diff --git a/src/tg/callback-query.lisp b/src/tg/callback-query.lisp index 6b89755..3f8cf2d 100644 --- a/src/tg/callback-query.lisp +++ b/src/tg/callback-query.lisp @@ -1,7 +1,7 @@ ;; SPDX-License-Identifier: EUPL-1.2 ;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs (defpackage :ukkoclot/tg/callback-query - (:use :c2cl :ukkoclot/tg/macros) + (:use :c2cl :ukkoclot/tg/type-macros) (:use :ukkoclot/tg/message :ukkoclot/tg/user) diff --git a/src/tg/chat-administrator-rights.lisp b/src/tg/chat-administrator-rights.lisp index 2c37757..4cbe47f 100644 --- a/src/tg/chat-administrator-rights.lisp +++ b/src/tg/chat-administrator-rights.lisp @@ -1,7 +1,7 @@ ;; SPDX-License-Identifier: EUPL-1.2 ;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs (defpackage :ukkoclot/tg/chat-administrator-rights - (:use :c2cl :ukkoclot/tg/macros) + (:use :c2cl :ukkoclot/tg/type-macros) (:export #:chat-administrator-rights #:make-chat-administrator-rights diff --git a/src/tg/chat.lisp b/src/tg/chat.lisp index 1fa3f7e..bdb698a 100644 --- a/src/tg/chat.lisp +++ b/src/tg/chat.lisp @@ -1,7 +1,7 @@ ;; SPDX-License-Identifier: EUPL-1.2 ;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs (defpackage :ukkoclot/tg/chat - (:use :c2cl :ukkoclot/tg/chat-type :ukkoclot/tg/macros) + (:use :c2cl :ukkoclot/tg/chat-type :ukkoclot/tg/type-macros) (:export #:chat #:make-chat diff --git a/src/tg/force-reply.lisp b/src/tg/force-reply.lisp index 816eb75..21a4ac6 100644 --- a/src/tg/force-reply.lisp +++ b/src/tg/force-reply.lisp @@ -1,7 +1,7 @@ ;; SPDX-License-Identifier: EUPL-1.2 ;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs (defpackage :ukkoclot/tg/force-reply - (:use :c2cl :ukkoclot/tg/macros) + (:use :c2cl :ukkoclot/tg/type-macros) (:export #:force-reply #:make-force-reply diff --git a/src/tg/inline-keyboard-button.lisp b/src/tg/inline-keyboard-button.lisp index e403f2a..7b49be6 100644 --- a/src/tg/inline-keyboard-button.lisp +++ b/src/tg/inline-keyboard-button.lisp @@ -1,7 +1,7 @@ ;; SPDX-License-Identifier: EUPL-1.2 ;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs (defpackage :ukkoclot/tg/inline-keyboard-button - (:use :c2cl :ukkoclot/tg/macros :ukkoclot/tg/web-app-info) + (:use :c2cl :ukkoclot/tg/type-macros :ukkoclot/tg/web-app-info) (:export #:inline-keyboard-button #:make-inline-keyboard-button diff --git a/src/tg/inline-keyboard-markup.lisp b/src/tg/inline-keyboard-markup.lisp index 023b87f..a242557 100644 --- a/src/tg/inline-keyboard-markup.lisp +++ b/src/tg/inline-keyboard-markup.lisp @@ -1,7 +1,7 @@ ;; SPDX-License-Identifier: EUPL-1.2 ;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs (defpackage :ukkoclot/tg/inline-keyboard-markup - (:use :c2cl :ukkoclot/tg/inline-keyboard-button :ukkoclot/tg/macros) + (:use :c2cl :ukkoclot/tg/inline-keyboard-button :ukkoclot/tg/type-macros) (:export #:inline-keyboard-markup #:make-inline-keyboard-markup diff --git a/src/tg/keyboard-button-poll-type.lisp b/src/tg/keyboard-button-poll-type.lisp index 7b5b063..7aecc48 100644 --- a/src/tg/keyboard-button-poll-type.lisp +++ b/src/tg/keyboard-button-poll-type.lisp @@ -1,7 +1,7 @@ ;; SPDX-License-Identifier: EUPL-1.2 ;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs (defpackage :ukkoclot/tg/keyboard-button-poll-type - (:use :c2cl :ukkoclot/tg/macros) + (:use :c2cl :ukkoclot/tg/type-macros) (:export #:keyboard-button-poll-type #:make-keyboard-button-poll-type diff --git a/src/tg/keyboard-button-request-chat.lisp b/src/tg/keyboard-button-request-chat.lisp index 07f0d27..4128571 100644 --- a/src/tg/keyboard-button-request-chat.lisp +++ b/src/tg/keyboard-button-request-chat.lisp @@ -1,7 +1,7 @@ ;; SPDX-License-Identifier: EUPL-1.2 ;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs (defpackage :ukkoclot/tg/keyboard-button-request-chat - (:use :c2cl :ukkoclot/tg/chat-administrator-rights :ukkoclot/tg/macros) + (:use :c2cl :ukkoclot/tg/chat-administrator-rights :ukkoclot/tg/type-macros) (:export #:keyboard-button-request-chat #:make-keyboard-button-request-chat diff --git a/src/tg/keyboard-button-request-users.lisp b/src/tg/keyboard-button-request-users.lisp index 82b9151..2782870 100644 --- a/src/tg/keyboard-button-request-users.lisp +++ b/src/tg/keyboard-button-request-users.lisp @@ -1,7 +1,7 @@ ;; SPDX-License-Identifier: EUPL-1.2 ;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs (defpackage :ukkoclot/tg/keyboard-button-request-users - (:use :c2cl :ukkoclot/tg/macros) + (:use :c2cl :ukkoclot/tg/type-macros) (:export #:keyboard-button-request-users #:make-keyboard-button-request-users diff --git a/src/tg/keyboard-button.lisp b/src/tg/keyboard-button.lisp index 79c87d6..7e0791f 100644 --- a/src/tg/keyboard-button.lisp +++ b/src/tg/keyboard-button.lisp @@ -6,7 +6,7 @@ :ukkoclot/tg/keyboard-button-poll-type :ukkoclot/tg/keyboard-button-request-chat :ukkoclot/tg/keyboard-button-request-users - :ukkoclot/tg/macros + :ukkoclot/tg/type-macros :ukkoclot/tg/web-app-info) (:export #:keyboard-button diff --git a/src/tg/link-preview-options.lisp b/src/tg/link-preview-options.lisp index 7ed4859..a6fe618 100644 --- a/src/tg/link-preview-options.lisp +++ b/src/tg/link-preview-options.lisp @@ -1,7 +1,7 @@ ;; SPDX-License-Identifier: EUPL-1.2 ;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs (defpackage :ukkoclot/tg/link-preview-options - (:use :c2cl :ukkoclot/tg/macros) + (:use :c2cl :ukkoclot/tg/type-macros) (:export #:link-preview-options #:make-link-preview-options diff --git a/src/tg/macros.lisp b/src/tg/macros.lisp deleted file mode 100644 index 9577d94..0000000 --- a/src/tg/macros.lisp +++ /dev/null @@ -1,118 +0,0 @@ -;; SPDX-License-Identifier: EUPL-1.2 -;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs -(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-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)))) - -(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))))) diff --git a/src/tg/message-entity.lisp b/src/tg/message-entity.lisp index c5be269..3413763 100644 --- a/src/tg/message-entity.lisp +++ b/src/tg/message-entity.lisp @@ -1,7 +1,7 @@ ;; SPDX-License-Identifier: EUPL-1.2 ;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs (defpackage :ukkoclot/tg/message-entity - (:use :c2cl :iterate :ukkoclot/tg/macros :ukkoclot/tg/message-entity-type :ukkoclot/tg/user) + (:use :c2cl :iterate :ukkoclot/tg/type-macros :ukkoclot/tg/message-entity-type :ukkoclot/tg/user) (:export #:message-entity #:make-message-entity diff --git a/src/tg/message-reaction-updated.lisp b/src/tg/message-reaction-updated.lisp index f91a8f1..3792246 100644 --- a/src/tg/message-reaction-updated.lisp +++ b/src/tg/message-reaction-updated.lisp @@ -4,7 +4,7 @@ (:use :c2cl :ukkoclot/tg/chat - :ukkoclot/tg/macros + :ukkoclot/tg/type-macros :ukkoclot/tg/reaction-type :ukkoclot/tg/user) (:export diff --git a/src/tg/message.lisp b/src/tg/message.lisp index 18eb5c4..4707c57 100644 --- a/src/tg/message.lisp +++ b/src/tg/message.lisp @@ -5,9 +5,9 @@ :c2cl :ukkoclot/tg/animation :ukkoclot/tg/chat - :ukkoclot/tg/macros :ukkoclot/tg/message-entity :ukkoclot/tg/photo-size + :ukkoclot/tg/type-macros :ukkoclot/tg/user) (:export #:message-chat-id diff --git a/src/tg/photo-size.lisp b/src/tg/photo-size.lisp index 32b586c..f55c0df 100644 --- a/src/tg/photo-size.lisp +++ b/src/tg/photo-size.lisp @@ -1,7 +1,7 @@ ;; SPDX-License-Identifier: EUPL-1.2 ;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs (defpackage :ukkoclot/tg/photo-size - (:use :c2cl :ukkoclot/tg/macros) + (:use :c2cl :ukkoclot/tg/type-macros) (:export #:photo-size #:make-photo-size diff --git a/src/tg/reaction-type-custom-emoji.lisp b/src/tg/reaction-type-custom-emoji.lisp index 9191f1e..21cb966 100644 --- a/src/tg/reaction-type-custom-emoji.lisp +++ b/src/tg/reaction-type-custom-emoji.lisp @@ -1,7 +1,7 @@ ;; SPDX-License-Identifier: EUPL-1.2 ;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs (defpackage :ukkoclot/tg/reaction-type-custom-emoji - (:use :c2cl :ukkoclot/enum :ukkoclot/tg/macros) + (:use :c2cl :ukkoclot/enum :ukkoclot/tg/type-macros) (:export #:custom-emoji-type #:reaction-type-custom-emoji-type diff --git a/src/tg/reaction-type-emoji.lisp b/src/tg/reaction-type-emoji.lisp index bf4920a..6939e41 100644 --- a/src/tg/reaction-type-emoji.lisp +++ b/src/tg/reaction-type-emoji.lisp @@ -1,7 +1,7 @@ ;; SPDX-License-Identifier: EUPL-1.2 ;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs (defpackage :ukkoclot/tg/reaction-type-emoji - (:use :c2cl :ukkoclot/enum :ukkoclot/tg/macros) + (:use :c2cl :ukkoclot/enum :ukkoclot/tg/type-macros) (:export #:reaction-type-emoji-type #:emoji-type diff --git a/src/tg/reaction-type-paid.lisp b/src/tg/reaction-type-paid.lisp index f5b1bfd..8d53610 100644 --- a/src/tg/reaction-type-paid.lisp +++ b/src/tg/reaction-type-paid.lisp @@ -1,7 +1,7 @@ ;; SPDX-License-Identifier: EUPL-1.2 ;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs (defpackage :ukkoclot/tg/reaction-type-paid - (:use :c2cl :ukkoclot/enum :ukkoclot/tg/macros) + (:use :c2cl :ukkoclot/enum :ukkoclot/tg/type-macros) (:export #:reaction-type-paid-type #:paid-type diff --git a/src/tg/reaction-type.lisp b/src/tg/reaction-type.lisp index 35bf4cd..1fd07f5 100644 --- a/src/tg/reaction-type.lisp +++ b/src/tg/reaction-type.lisp @@ -3,7 +3,7 @@ (defpackage :ukkoclot/tg/reaction-type (:use :c2cl - :ukkoclot/tg/macros + :ukkoclot/tg/type-macros :ukkoclot/tg/reaction-type-custom-emoji :ukkoclot/tg/reaction-type-emoji :ukkoclot/tg/reaction-type-paid) diff --git a/src/tg/reply-keyboard-markup.lisp b/src/tg/reply-keyboard-markup.lisp index 2674c10..a0c16ca 100644 --- a/src/tg/reply-keyboard-markup.lisp +++ b/src/tg/reply-keyboard-markup.lisp @@ -1,7 +1,7 @@ ;; SPDX-License-Identifier: EUPL-1.2 ;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs (defpackage :ukkoclot/tg/reply-keyboard-markup - (:use :c2cl :ukkoclot/tg/keyboard-button :ukkoclot/tg/macros) + (:use :c2cl :ukkoclot/tg/keyboard-button :ukkoclot/tg/type-macros) (:export #:reply-keyboard-markup #:make-reply-keyboard-markup diff --git a/src/tg/reply-keyboard-remove.lisp b/src/tg/reply-keyboard-remove.lisp index 908e46d..595ff31 100644 --- a/src/tg/reply-keyboard-remove.lisp +++ b/src/tg/reply-keyboard-remove.lisp @@ -1,7 +1,7 @@ ;; SPDX-License-Identifier: EUPL-1.2 ;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs (defpackage :ukkoclot/tg/reply-keyboard-remove - (:use :c2cl :ukkoclot/tg/macros) + (:use :c2cl :ukkoclot/tg/type-macros) (:export #:reply-keyboard-remove #:make-reply-keyboard-remove diff --git a/src/tg/reply-parameters.lisp b/src/tg/reply-parameters.lisp index e41d837..9527c40 100644 --- a/src/tg/reply-parameters.lisp +++ b/src/tg/reply-parameters.lisp @@ -1,7 +1,7 @@ ;; SPDX-License-Identifier: EUPL-1.2 ;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs (defpackage :ukkoclot/tg/reply-parameters - (:use :c2cl :ukkoclot/tg/macros :ukkoclot/tg/message-entity) + (:use :c2cl :ukkoclot/tg/type-macros :ukkoclot/tg/message-entity) (:export #:reply-parameters #:make-reply-parameters diff --git a/src/tg/suggested-post-parameters.lisp b/src/tg/suggested-post-parameters.lisp index 525272a..2bf3753 100644 --- a/src/tg/suggested-post-parameters.lisp +++ b/src/tg/suggested-post-parameters.lisp @@ -1,7 +1,7 @@ ;; SPDX-License-Identifier: EUPL-1.2 ;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs (defpackage :ukkoclot/tg/suggested-post-parameters - (:use :c2cl :ukkoclot/tg/macros :ukkoclot/tg/suggested-post-price) + (:use :c2cl :ukkoclot/tg/type-macros :ukkoclot/tg/suggested-post-price) (:export #:suggested-post-parameters #:make-suggested-post-parameters diff --git a/src/tg/suggested-post-price.lisp b/src/tg/suggested-post-price.lisp index 9012e75..1369b89 100644 --- a/src/tg/suggested-post-price.lisp +++ b/src/tg/suggested-post-price.lisp @@ -1,7 +1,7 @@ ;; SPDX-License-Identifier: EUPL-1.2 ;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs (defpackage :ukkoclot/tg/suggested-post-price - (:use :c2cl :ukkoclot/tg/macros) + (:use :c2cl :ukkoclot/tg/type-macros) (:export #:suggested-post-price #:make-suggested-post-price 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 +(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)))) diff --git a/src/tg/update.lisp b/src/tg/update.lisp index 1f0a463..1c4ae46 100644 --- a/src/tg/update.lisp +++ b/src/tg/update.lisp @@ -3,7 +3,7 @@ (defpackage :ukkoclot/tg/update (:use :c2cl - :ukkoclot/tg/macros + :ukkoclot/tg/type-macros :ukkoclot/tg/business-connection :ukkoclot/tg/callback-query :ukkoclot/tg/message diff --git a/src/tg/user.lisp b/src/tg/user.lisp index c5b5b4d..b16ee15 100644 --- a/src/tg/user.lisp +++ b/src/tg/user.lisp @@ -1,7 +1,7 @@ ;; SPDX-License-Identifier: EUPL-1.2 ;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs (defpackage :ukkoclot/tg/user - (:use :c2cl :ukkoclot/tg/macros) + (:use :c2cl :ukkoclot/tg/type-macros) (:import-from :ukkoclot/strings :escape-xml) (:export #:user diff --git a/src/tg/web-app-info.lisp b/src/tg/web-app-info.lisp index 8e96df2..3f8dc42 100644 --- a/src/tg/web-app-info.lisp +++ b/src/tg/web-app-info.lisp @@ -1,7 +1,7 @@ ;; SPDX-License-Identifier: EUPL-1.2 ;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs (defpackage :ukkoclot/tg/web-app-info - (:use :c2cl :ukkoclot/tg/macros) + (:use :c2cl :ukkoclot/tg/type-macros) (:export #:web-app-info #:make-web-app-info -- cgit v1.2.3