From fec434a4e2d0ff65510581e461d87a945d25759a Mon Sep 17 00:00:00 2001 From: Uko Kokņevičs Date: Thu, 23 Oct 2025 10:17:00 +0300 Subject: Use serapeum's -> & defsubst --- src/tg/delete-message.lisp | 7 +++++-- src/tg/get-me.lisp | 4 ++++ src/tg/message-entity.lisp | 3 +++ src/tg/message.lisp | 13 +++++++------ src/tg/method-macros.lisp | 23 +++++++++++++++++------ src/tg/send-animation.lisp | 9 +++++++++ src/tg/send-message.lisp | 6 ++++++ src/tg/set-my-name.lisp | 4 ++++ src/tg/type-macros.lisp | 28 +++++++++++++++++++++++++--- src/tg/user.lisp | 37 ++++++++++++++++--------------------- 10 files changed, 96 insertions(+), 38 deletions(-) (limited to 'src/tg') diff --git a/src/tg/delete-message.lisp b/src/tg/delete-message.lisp index 2b332df..44fccd2 100644 --- a/src/tg/delete-message.lisp +++ b/src/tg/delete-message.lisp @@ -3,6 +3,7 @@ (defpackage :ukkoclot/src/tg/delete-message (:documentation "deleteMessage Telegram method") (:use :c2cl :ukkoclot/src/tg/message :ukkoclot/src/tg/method-macros :ukkoclot/src/tg/send-animation) + (:import-from :serapeum :->) (:export :delete-message :try-delete-message)) (in-package :ukkoclot/src/tg/delete-message) @@ -10,6 +11,7 @@ (chat-id (or integer string)) (message-id integer)) +(-> try-delete-message (message) boolean) (defun try-delete-message (msg) "Attempt to delete the MSG, on failure reply with a GIF of the DO NOT cat." (handler-case @@ -17,6 +19,7 @@ :message-id (message-id msg)) (error () (handler-case - (reply-animation msg #P"blob/do-not.mp4" - :allow-sending-without-reply nil) + (prog1 nil + (reply-animation msg #P"blob/do-not.mp4" + :allow-sending-without-reply nil)) (error () nil))))) diff --git a/src/tg/get-me.lisp b/src/tg/get-me.lisp index e7d41a1..5360f16 100644 --- a/src/tg/get-me.lisp +++ b/src/tg/get-me.lisp @@ -3,12 +3,14 @@ (defpackage :ukkoclot/src/tg/get-me (:documentation "getMe Telegram method") (:use :c2cl :ukkoclot/src/tg/method-macros :ukkoclot/src/tg/user) + (:import-from :serapeum :->) (:import-from :state) (:export :bot-id :bot-username :get-me)) (in-package :ukkoclot/src/tg/get-me) (define-tg-method (get-me% user :GET)) +(-> get-me () user) (defun get-me () "getMe Telegram method" (let ((me (get-me%))) @@ -16,6 +18,7 @@ (setf (state:username%) (user-username me)) me)) +(-> bot-id () integer) (defun bot-id () "Get the bot's ID, this memoizes the result" (or (state:id%) @@ -23,6 +26,7 @@ (get-me) (state:id%)))) +(-> bot-username () string) (defun bot-username () "Get the bot's username, this memoizes the result" (or (state:username%) diff --git a/src/tg/message-entity.lisp b/src/tg/message-entity.lisp index 1a8cd27..c87dca0 100644 --- a/src/tg/message-entity.lisp +++ b/src/tg/message-entity.lisp @@ -3,6 +3,7 @@ (defpackage :ukkoclot/src/tg/message-entity (:documentation "MessageEntity Telegram type") (:use :c2cl :iterate :ukkoclot/src/enum :ukkoclot/src/tg/type-macros :ukkoclot/src/tg/user) + (:import-from :serapeum :->) (:export #:message-entity-type #:mention @@ -72,6 +73,7 @@ (unless (= char-code-limit #x110000) (error "Some UTF-16 fuckery assumes that system chars are UTF-32")) +(-> utf16-width (character) (member 1 2)) (defun utf16-width (ch) "Calculate the size of char in UTF-16 units." (declare (type character ch)) @@ -79,6 +81,7 @@ 1 2)) +(-> message-entity-extract (message-entity string) string) (defun message-entity-extract (entity text) "Extract the text corresponding to the ENTITY from the message text (in TEXT)." (check-type entity message-entity) diff --git a/src/tg/message.lisp b/src/tg/message.lisp index 13162a5..70155ab 100644 --- a/src/tg/message.lisp +++ b/src/tg/message.lisp @@ -10,6 +10,7 @@ :ukkoclot/src/tg/photo-size :ukkoclot/src/tg/type-macros :ukkoclot/src/tg/user) + (:import-from :serapeum :-> :defsubst) (:export #:message-chat-id #:message-thread-id @@ -163,17 +164,17 @@ ;; (reply-markup (or inline-keyboard-markup null) nil) ) ; lint:suppress closing-parens-same-line whitespace-before-close-paren -(declaim (inline message-id)) -(defun message-id (msg) +(-> message-id (message) integer) +(defsubst message-id (msg) "Better named version of `message-message-id'." (message-message-id msg)) -(declaim (inline message-chat-id)) -(defun message-chat-id (msg) +(-> message-chat-id (message) integer) +(defsubst message-chat-id (msg) "Shortcut for (CHAT-ID (MESSAGE-CHAT MSG))." (chat-id (message-chat msg))) -(declaim (inline message-thread-id)) -(defun message-thread-id (msg) +(-> message-thread-id (message) (or integer null)) +(defsubst message-thread-id (msg) "Better named version of `message-message-thread-id'." (message-message-thread-id msg)) diff --git a/src/tg/method-macros.lisp b/src/tg/method-macros.lisp index 0d33ffb..9ab9e89 100644 --- a/src/tg/method-macros.lisp +++ b/src/tg/method-macros.lisp @@ -5,10 +5,10 @@ (:use :c2cl :iterate) (:import-from :alexandria :make-keyword :with-gensyms) (:import-from :com.dieggsy.f-string :enable-f-strings) - (:import-from :serapeum :take) + (:import-from :serapeum :-> :take) (:import-from :state) (:import-from :str) - (:import-from :ukkoclot/src/transport :do-call) + (:import-from :ukkoclot/src/transport :do-call :http-method) (:export :define-tg-method)) (in-package :ukkoclot/src/tg/method-macros) @@ -21,6 +21,7 @@ (defparameter +unique+ (gensym)) ;; TODO: Fix optional-and-key ! + (-> make-param (symbol t &optional t &key (:skip-if-default boolean)) param) (defun make-param (name type ; lint:suppress avoid-optional-and-key &optional (default +unique+) &key (skip-if-default (not (eq default +unique+)))) @@ -32,26 +33,34 @@ :default default :skip-if-default skip-if-default))) + ;; TODO: list-of-params, list-of-param-specs + (-> parse-param-specs (list) list) (defun parse-param-specs (param-specs) (iter (for param-spec in param-specs) (collect (apply #'make-param param-spec)))) + (-> path-from-name (symbol) string) (defun path-from-name (name) (let ((str (str:camel-case name))) (if (str:ends-with-p "%" str :ignore-case nil) (take (- (length str) 1) str) str))) + (-> emit-append-to-args (param symbol) list) (defun emit-append-to-args (param args) `(setf ,args (acons ',(param-name param) ,(param-name param) ,args))) + (-> emit-arg-type (param) list) (defun emit-arg-type (param) `(,(make-keyword (param-name param)) ,(param-type param))) + (-> emit-defun-arg (param) list) (defun emit-defun-arg (param) `(,(param-name param) ,(param-default param))) + ;; TODO: list-of-params + (-> emit-defun (symbol t list http-method) list) (defun emit-defun (name return-type params method) (with-gensyms (args) `(defun ,name (&key ,@(iter (for param in params) ; lint:suppress lambda-list-invalid @@ -65,11 +74,13 @@ (emit-append-to-args param args)))) (do-call ,method ,(path-from-name name) ',return-type ,args))))) + ;; TODO: list-of-params + (-> emit-ftype (symbol t list) list) (defun emit-ftype (name return-type params) - `(declaim (ftype (function (&key ,@(iter (for param in params) - (collect (emit-arg-type param)))) - ,return-type) - ,name)))) + `(-> ,name + (&key ,@(iter (for param in params) + (collect (emit-arg-type param)))) + ,return-type))) (defmacro define-tg-method ((name type &optional (method :POST)) &body param-specs) diff --git a/src/tg/send-animation.lisp b/src/tg/send-animation.lisp index 560b331..acddb21 100644 --- a/src/tg/send-animation.lisp +++ b/src/tg/send-animation.lisp @@ -2,6 +2,7 @@ ;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs (defpackage :ukkoclot/src/tg/send-animation (:documentation "sendAnimation Telegram method") + (:import-from :serapeum :->) (:use :c2cl :ukkoclot/src/tg/force-reply @@ -41,6 +42,14 @@ (reply-markup (or inline-keyboard-markup reply-keyboard-markup reply-keyboard-remove force-reply null) nil)) ;; TODO: Some kind of caching for files? +(-> reply-animation (message + pathname + &key + (:allow-sending-without-reply boolean) + (:text (or string null)) + (:parse-mode (or parse-mode null)) + (:caption-above boolean)) + message) (defun reply-animation (msg animation &key allow-sending-without-reply text parse-mode caption-above) "Shortcut to reply to a given MSG with an animation." (send-animation :chat-id (message-chat-id msg) diff --git a/src/tg/send-message.lisp b/src/tg/send-message.lisp index befecbe..7c24f87 100644 --- a/src/tg/send-message.lisp +++ b/src/tg/send-message.lisp @@ -2,6 +2,7 @@ ;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs (defpackage :ukkoclot/src/tg/send-message (:documentation "sendMessage Telegram method") + (:import-from :serapeum :->) (:use :c2cl :ukkoclot/src/tg/force-reply @@ -31,6 +32,11 @@ (reply-parameters (or reply-parameters null) nil) (reply-markup (or inline-keyboard-markup reply-keyboard-markup reply-keyboard-remove force-reply null) nil)) +(-> reply-message (message + string + &key + (:parse-mode (or parse-mode null)) + (:allow-sending-without-reply boolean))) (defun reply-message (msg text &key parse-mode allow-sending-without-reply) "Shortcut to reply to a given MSG." (send-message :chat-id (message-chat-id msg) diff --git a/src/tg/set-my-name.lisp b/src/tg/set-my-name.lisp index 2b3869a..f0b5c5f 100644 --- a/src/tg/set-my-name.lisp +++ b/src/tg/set-my-name.lisp @@ -2,6 +2,7 @@ ;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs (defpackage :ukkoclot/src/tg/set-my-name (:documentation "setMyName Telegram method.") + (:import-from :serapeum :->) (:use :c2cl :ukkoclot/src/tg/bot-name :ukkoclot/src/tg/get-my-name :ukkoclot/src/tg/method-macros) (:export :set-my-name)) (in-package :ukkoclot/src/tg/set-my-name) @@ -10,6 +11,9 @@ (name (or string null) nil) (language-code (or string null) nil)) +(-> set-my-name + (&key (:name (or string null)) (:language-code (or string null))) + boolean) (defun set-my-name (&key (name nil) (language-code nil)) "setMyName Telegram method. diff --git a/src/tg/type-macros.lisp b/src/tg/type-macros.lisp index ea35f48..02437ec 100644 --- a/src/tg/type-macros.lisp +++ b/src/tg/type-macros.lisp @@ -5,6 +5,7 @@ (:use :c2cl :iterate) (:import-from :alexandria :make-keyword :symbolicate :with-gensyms) (:import-from :com.dieggsy.f-string :enable-f-strings) + (:import-from :serapeum :->) (:import-from :str) (:import-from :ukkoclot/src/serializing :parse-value) (:import-from :ukkoclot/src/hash-tables :gethash-lazy) @@ -22,6 +23,7 @@ (defparameter +unique+ (gensym)) ;; TODO: Fix optional-and-key ! + (-> make-field (symbol t &optional t &key (:skip-if-default boolean)) field) (defun make-field (name type ; lint:suppress avoid-optional-and-key &optional (default +unique+) &key (skip-if-default (not (eq default +unique+)))) @@ -33,28 +35,36 @@ :default default :skip-if-default skip-if-default))) + (-> type-constructor (symbol) symbol) (defun type-constructor (name) (symbolicate "MAKE-" name)) + (-> field-accessor (symbol field) symbol) (defun field-accessor (name field) (symbolicate name "-" (field-name field))) + (-> field-hash-key (field) string) (defun field-hash-key (field) (str:snake-case (field-name field))) + (-> field-keyword (field) keyword) (defun field-keyword (field) (make-keyword (field-name field))) + ;; TODO: list-of-fields, list-of-field-specs + (-> parse-field-specs (list) list) (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))) - + (-> emit-coerced-field (field (or symbol list)) list) (defun emit-coerced-field (field value) `(list ,(field-hash-key field) ,value ',(field-type field))) + ;; TODO: list-of-fields + (-> emit-collect-nondefault-fields + (symbol list symbol (function (field (or symbol list)) list)) + list) (defun emit-collect-nondefault-fields (name fields obj collector) (with-gensyms (value) (iter (for field in (reverse fields)) @@ -65,12 +75,16 @@ ,(funcall collector field value))) (funcall collector field (list (field-accessor name field) obj))))))) + (-> emit-constructor-args (field) list) (defun emit-constructor-args (field) `(,(field-keyword field) ,(field-name field))) + (-> emit-gethash (field symbol) list) (defun emit-gethash (field source) `(gethash-lazy ,(field-hash-key field) ,source ,(field-default field))) + ;; TODO: list-of-fields + (-> emit-jzon-coerced-fields (symbol list) list) (defun emit-jzon-coerced-fields (name fields) (with-gensyms (obj result) `(defmethod jzon:coerced-fields ((,obj ,name)) @@ -81,10 +95,13 @@ `(push ,(emit-coerced-field field value) ,result))) ,result)))) + (-> emit-let-gethash (field symbol) list) (defun emit-let-gethash (field source) `(,(field-name field) (parse-value ',(field-type field) ,(emit-gethash field source)))) + ;; TODO: list-of-fields + (-> emit-parse-value (symbol list) list) (defun emit-parse-value (name fields) (with-gensyms (source type) `(defmethod parse-value ((,type (eql ',name)) ,source) @@ -94,6 +111,8 @@ ,@(iter (for field in fields) (appending (emit-constructor-args field)))))))) + ;; TODO: list-of-fields + (-> emit-printer (symbol symbol list) list) (defun emit-printer (name printer-name fields) (with-gensyms (depth obj pprint-args stream) `(defun ,printer-name (,obj ,stream ,depth) ; lint:suppress lambda-list-invalid @@ -105,11 +124,14 @@ `(setf ,pprint-args (list* ',(field-name field) ,value ,pprint-args)))) (format ,stream "~A~<[~;~@{~_~1I~W = ~W~^, ~}~;]~:>" ',name ,pprint-args))))) + ;; TODO: list-of-fields + (-> emit-struct (symbol symbol list) list) (defun emit-struct (name printer-name fields) `(defstruct (,name (:print-function ,printer-name)) ,@(iter (for field in fields) (collect (emit-struct-field field))))) + (-> emit-struct-field (field) list) (defun emit-struct-field (field) `(,(field-name field) ,(field-default field) :type ,(field-type field)))) diff --git a/src/tg/user.lisp b/src/tg/user.lisp index 0768d12..aefdeeb 100644 --- a/src/tg/user.lisp +++ b/src/tg/user.lisp @@ -3,6 +3,8 @@ (defpackage :ukkoclot/src/tg/user (:documentation "User Telegram type") (:use :c2cl :ukkoclot/src/tg/type-macros) + (:import-from :serapeum :->) + (:import-from :ukkoclot/src/streams :with-format-like-stream) (:import-from :ukkoclot/src/strings :escape-xml) (:export #:user @@ -39,26 +41,19 @@ (supports-inline-queries boolean nil) (can-connect-to-business boolean nil)) -(defun user-format-name% (user out) - "Format the USER's name in a nice way to stream OUT." - (format out "" (user-id user)) - (escape-xml (user-first-name user) out) - (when (user-last-name user) - (write-char #\Space out) - (escape-xml (user-last-name user) out)) - (write-string "" out) +(-> user-format-name (user &optional (or stream boolean)) (or string null)) +(defun user-format-name (user &optional out-spec) + "Format the `user''s name in a nice way." + (with-format-like-stream (out out-spec) + (format out "" (user-id user)) + (escape-xml (user-first-name user) out) + (when (user-last-name user) + (write-char #\Space out) + (escape-xml (user-last-name user) out)) + (write-string "" out) - (when (user-username user) - (write-string " @" out) - (escape-xml (user-username user) out)) + (when (user-username user) + (write-string " @" out) + (escape-xml (user-username user) out)) - (format out " [~A]" (user-id user))) - -(defun user-format-name (user &optional out) - "Format the USER's name in a nice way to stream OUT. - -If OUT is `nil', return the formatted name as a string instead." - (if out - (user-format-name% user out) - (with-output-to-string (stream) - (user-format-name% user stream)))) + (format out " [~A]" (user-id user)))) -- cgit v1.2.3