diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/bot/method-macros.lisp | 64 | ||||
| -rw-r--r-- | src/bot/methods.lisp | 2 | ||||
| -rw-r--r-- | src/tg/macros.lisp | 26 |
3 files changed, 66 insertions, 26 deletions
diff --git a/src/bot/method-macros.lisp b/src/bot/method-macros.lisp new file mode 100644 index 0000000..7b54dc9 --- /dev/null +++ b/src/bot/method-macros.lisp | |||
| @@ -0,0 +1,64 @@ | |||
| 1 | ;; SPDX-License-Identifier: EUPL-1.2 | ||
| 2 | ;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs <perkontevs@gmail.com> | ||
| 3 | (defpackage :ukkoclot/bot/method-macros | ||
| 4 | (:use :c2cl :iterate :ukkoclot/bot/impl) | ||
| 5 | (:export :define-tg-method)) | ||
| 6 | (in-package :ukkoclot/bot/method-macros) | ||
| 7 | |||
| 8 | (eval-when (:compile-toplevel :load-toplevel :execute) | ||
| 9 | (defstruct (param (:constructor make-param%)) name type default skip-if-default) | ||
| 10 | |||
| 11 | (defparameter +unique+ (gensym)) | ||
| 12 | |||
| 13 | (defun make-param (name type &optional (default +unique+) &key (skip-if-default (not (eq default +unique+)))) | ||
| 14 | (let ((default (if (eq default +unique+) | ||
| 15 | `(error ,(format nil "No value given for ~A" name)) | ||
| 16 | default))) | ||
| 17 | (make-param% :name name | ||
| 18 | :type type | ||
| 19 | :default default | ||
| 20 | :skip-if-default skip-if-default))) | ||
| 21 | |||
| 22 | (defun parse-param-specs (param-specs) | ||
| 23 | (iter (for param-spec in param-specs) | ||
| 24 | (collect (apply #'make-param param-spec)))) | ||
| 25 | |||
| 26 | (defun emit-append-to-args (param args) | ||
| 27 | `(setf ,args (acons ',(param-name param) ,(param-name param) ,args))) | ||
| 28 | |||
| 29 | (defun emit-arg-type (param) | ||
| 30 | `(,(intern (symbol-name (param-name param)) :keyword) | ||
| 31 | ,(param-type param))) | ||
| 32 | |||
| 33 | (defun emit-defun-arg (param) | ||
| 34 | `(,(param-name param) ,(param-default param))) | ||
| 35 | |||
| 36 | (defun emit-defun (name return-type params method path) | ||
| 37 | (let ((revparams (reverse params)) | ||
| 38 | (args (gensym "ARGS")) | ||
| 39 | (bot (gensym "BOT"))) | ||
| 40 | `(defun ,name (,bot &key ,@(iter (for param in params) | ||
| 41 | (collect (emit-defun-arg param)))) | ||
| 42 | (let (,args) | ||
| 43 | ,@(iter (for param in revparams) | ||
| 44 | (collect (if (param-skip-if-default param) | ||
| 45 | `(unless (equal ,(param-name param) | ||
| 46 | ,(param-default param)) | ||
| 47 | ,(emit-append-to-args param args)) | ||
| 48 | (emit-append-to-args param args)))) | ||
| 49 | (do-call ,bot ,method ,path ',return-type ,args))))) | ||
| 50 | |||
| 51 | (defun emit-ftype (name return-type params) | ||
| 52 | `(declaim (ftype (function (bot &key ,@(iter (for param in params) | ||
| 53 | (collect (emit-arg-type param)))) | ||
| 54 | ,return-type) | ||
| 55 | ,name)))) | ||
| 56 | |||
| 57 | ;; TODO: Automatically derive path from name | ||
| 58 | (defmacro define-tg-method ( | ||
| 59 | (name type path &optional (method :POST)) | ||
| 60 | &body param-specs) | ||
| 61 | (let ((params (parse-param-specs param-specs))) | ||
| 62 | `(progn | ||
| 63 | ,(emit-ftype name type params) | ||
| 64 | ,(emit-defun name type params method path)))) | ||
diff --git a/src/bot/methods.lisp b/src/bot/methods.lisp index 6ef507c..bddb9ff 100644 --- a/src/bot/methods.lisp +++ b/src/bot/methods.lisp | |||
| @@ -1,7 +1,7 @@ | |||
| 1 | ;; SPDX-License-Identifier: EUPL-1.2 | 1 | ;; SPDX-License-Identifier: EUPL-1.2 |
| 2 | ;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs <perkontevs@gmail.com> | 2 | ;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs <perkontevs@gmail.com> |
| 3 | (defpackage :ukkoclot/bot/methods | 3 | (defpackage :ukkoclot/bot/methods |
| 4 | (:use :c2cl :ukkoclot/bot/impl :ukkoclot/tg :ukkoclot/tg/macros) | 4 | (:use :c2cl :ukkoclot/bot/method-macros :ukkoclot/bot/impl :ukkoclot/tg) |
| 5 | (:export :answer-callback-query :delete-message :send-animation :edit-message-text :get-me :get-updates :send-message :set-my-name)) | 5 | (:export :answer-callback-query :delete-message :send-animation :edit-message-text :get-me :get-updates :send-message :set-my-name)) |
| 6 | (in-package :ukkoclot/bot/methods) | 6 | (in-package :ukkoclot/bot/methods) |
| 7 | 7 | ||
diff --git a/src/tg/macros.lisp b/src/tg/macros.lisp index 92afd6e..9577d94 100644 --- a/src/tg/macros.lisp +++ b/src/tg/macros.lisp | |||
| @@ -7,7 +7,7 @@ | |||
| 7 | (:import-from :ukkoclot/strings :lisp->snake-case) | 7 | (:import-from :ukkoclot/strings :lisp->snake-case) |
| 8 | (:local-nicknames | 8 | (:local-nicknames |
| 9 | (:jzon :com.inuoe.jzon)) | 9 | (:jzon :com.inuoe.jzon)) |
| 10 | (:export :define-tg-method :define-tg-type)) | 10 | (:export :define-tg-type)) |
| 11 | (in-package :ukkoclot/tg/macros) | 11 | (in-package :ukkoclot/tg/macros) |
| 12 | 12 | ||
| 13 | (eval-when (:compile-toplevel :load-toplevel :execute) | 13 | (eval-when (:compile-toplevel :load-toplevel :execute) |
| @@ -74,30 +74,6 @@ | |||
| 74 | (defun field->struct-spec (field) | 74 | (defun field->struct-spec (field) |
| 75 | (list (field-name field) (field-default field) :type (field-type field)))) | 75 | (list (field-name field) (field-default field) :type (field-type field)))) |
| 76 | 76 | ||
| 77 | ;; TODO: Automatically derive path from name | ||
| 78 | ;; TODO: Automatically derive mapfn from type | ||
| 79 | (defmacro define-tg-method ( | ||
| 80 | (name type path &optional (method :POST)) | ||
| 81 | &body field-specs) | ||
| 82 | (let* ((fields (parse-field-specs field-specs)) | ||
| 83 | (revfields (reverse fields)) | ||
| 84 | (args (gensym "ARGS")) | ||
| 85 | (bot (gensym "BOT-"))) | ||
| 86 | `(progn | ||
| 87 | (declaim (ftype (function (bot &key ,@(loop for field in fields | ||
| 88 | collect (field->ftype-spec field))) | ||
| 89 | ,type) | ||
| 90 | ,name)) | ||
| 91 | (defun ,name (,bot &key ,@(loop for field in fields collect (field->defun-spec field))) | ||
| 92 | (let (,args) | ||
| 93 | ,@(loop for field in revfields | ||
| 94 | collecting | ||
| 95 | (if (field-skip-if-default field) | ||
| 96 | `(unless (equal ,(field-name field) ,(field-default field)) | ||
| 97 | (setf ,args (acons ',(field-name field) ,(field-name field) ,args))) | ||
| 98 | `(setf ,args (acons ',(field-name field) ,(field-name field) ,args)))) | ||
| 99 | (do-call ,bot ,method ,path ',type ,args)))))) | ||
| 100 | |||
| 101 | (defmacro define-tg-type (name &body field-specs) | 77 | (defmacro define-tg-type (name &body field-specs) |
| 102 | (let* ((fields (parse-field-specs field-specs)) | 78 | (let* ((fields (parse-field-specs field-specs)) |
| 103 | (revfields (reverse fields)) | 79 | (revfields (reverse fields)) |