Introduce enums and a pretty parse-mode type

6 files changed, 83 insertions, 11 deletions

diff --git a/src/bot/methods.lisp b/src/bot/methods.lisp
index 7ccc4ad..984646a 100644
--- a/src/bot/methods.lisp
+++ b/src/bot/methods.lisp
@@ -23,7 +23,7 @@
   (message-id (or integer null) nil)
   (inline-message-id (or string null) nil)
   (text string)
-  (parse-mode (or string null) nil)
+  (parse-mode (or parse-mode null) nil)
   (entities (or (array message-entity) null) nil)
   (link-preview-options (or link-preview-options null) nil)
   (reply-markup (or inline-keyboard-markup null) nil))
@@ -56,7 +56,7 @@
   (height (or integer null) nil)
   (thumbnail (or pathname string null) nil)
   (caption (or string null) nil)
-  (parse-mode (or string null) nil)
+  (parse-mode (or parse-mode null) nil)
   (caption-entities (or (array message-entity) null) nil)
   (show-caption-above-media boolean nil)
   (has-spoiler boolean nil)
@@ -73,8 +73,7 @@
   (chat-id (or integer string))
   (message-thread-id (or integer null) nil)
   (text string)
-  ;; TODO: parse-mode should maybe be keywords?
-  (parse-mode (or string null) nil)
+  (parse-mode (or parse-mode null) nil)
   (entities (or (array message-entity) null) nil)
   (link-preview-options (or link-preview-options null) nil)
   (disable-notification (or boolean null) nil)
diff --git a/src/enum.lisp b/src/enum.lisp
new file mode 100644
index 0000000..c678ec7
--- /dev/null
+++ b/src/enum.lisp
@@ -0,0 +1,59 @@
+;; SPDX-License-Identifier: EUPL-1.2
+;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs <perkontevs@gmail.com>
+(defpackage :ukkoclot/enum
+  (:use :c2cl :iterate)
+  (:import-from :ukkoclot/bot/impl :fixup-value :parse-value)
+  (:import-from :string-case :string-case)
+  (:local-nicknames
+   (:jzon :com.inuoe.jzon))
+  (:export :define-enum))
+(in-package :ukkoclot/enum)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defstruct (field (:constructor make-field%)) name string)
+
+  (defun make-field (name string)
+    (make-field% :name name :string string))
+
+  (defun parse-field-specs (field-specs)
+    (iter (for field-spec in field-specs)
+      (collect (apply #'make-field field-spec))))
+
+  (defun emit-defconst (field)
+    `(defconstant ,(field-name field) ',(field-name field)))
+
+  (defun emit-deftype (name fields)
+    `(deftype ,name ()
+       '(member ,@(iter (for field in fields) (collect (field-name field))))))
+
+  (defun emit-fixup-method (field)
+    (let ((arg (gensym "ARG")))
+      `(defmethod fixup-value ((,arg (eql ',(field-name field))))
+         ,(field-string field))))
+
+  (defun emit-jzon-write-method (field)
+    (let ((writer (gensym "WRITER"))
+          (arg (gensym "ARG")))
+      `(defmethod jzon:write-value (,writer (,arg (eql ',(field-name field))))
+         (jzon::write-string ,(field-string field) ,writer))))
+
+  (defun emit-parse-value (name fields)
+    (let ((type (gensym "TYPE"))
+          (source (gensym "SOURCE")))
+      `(defmethod parse-value ((,type (eql ',name)) ,source)
+         ;; nil in, nil out
+         (when ,source
+           (string-case (,source)
+             ,@(iter (for field in fields)
+                 (collect `(,(field-string field) ,(field-name field))))))))))
+
+(defmacro define-enum (name &body field-specs)
+  (let ((fields (parse-field-specs field-specs)))
+    `(progn
+       ,(emit-deftype name fields)
+       ,(emit-parse-value name fields)
+       ,@(iter (for field in fields)
+           (collect `(progn
+                       ,(emit-defconst field)
+                       ,(emit-fixup-method field)
+                       ,(emit-jzon-write-method field)))))))
diff --git a/src/inline-bots.lisp b/src/inline-bots.lisp
index eb20f21..3ed85e9 100644
--- a/src/inline-bots.lisp
+++ b/src/inline-bots.lisp
@@ -32,7 +32,7 @@
                             :text (format nil "Deleted a message sent via inline bot @~A <code>~A</code>"
                                           (user-username via)
                                           (user-id via))
-                            :parse-mode "HTML"
+                            :parse-mode html
                             :reply-markup (make-inline-keyboard-markup
                                            :inline-keyboard
                                            (make-array '(1 2) :initial-contents (list (list whitelist blacklist)))))))
diff --git a/src/main.lisp b/src/main.lisp
index 96f73a0..4b05ee2 100644
--- a/src/main.lisp
+++ b/src/main.lisp
@@ -110,7 +110,7 @@
                        :text (concatenate 'string "Hello there, "
                                           (user-format-name new-member)
                                           "!  Be on your bestest behaviour now!!")
-                       :parse-mode "HTML"
+                       :parse-mode html
                        :caption-above t
                        :allow-sending-without-reply t)))
 
@@ -138,11 +138,12 @@
                       (= (message-entity-offset entity) 0))
               do (on-text-command bot msg text (message-entity-extract entity text))))
 
+    ;; TODO: Replace this cond with a nicer dispatch.  Something like string-case?
     (cond ((equal text ":3")
            (reply-message bot msg ">:3"))
 
           ((equal text ">:3")
-           (reply-message bot msg "<b>&gt;:3</b>" :parse-mode "HTML"))
+           (reply-message bot msg "<b>&gt;:3</b>" :parse-mode html))
 
           ((starts-with-ignore-case text "big ")
            (let ((the-text (subseq text 4)))
@@ -152,7 +153,7 @@
                                            "<b>"
                                            (escape-xml (string-upcase the-text))
                                            "</b>")
-                              :parse-mode "HTML"))))
+                              :parse-mode html))))
 
           ((string-equal text "dio cane")
            (reply-message bot
@@ -166,7 +167,7 @@
            (reply-message bot msg "idgi"))
 
           ((string= text "H")
-           (reply-message bot msg "<code>Randomly selected reminder that h &gt; H.</code>" :parse-mode "HTML"))
+           (reply-message bot msg "<code>Randomly selected reminder that h &gt; H.</code>" :parse-mode html))
 
           ((string-equal text "porco dio")
            (reply-message bot
@@ -216,9 +217,10 @@
 (defun on-text-command (bot msg text cmd)
   (let ((simple-cmd (simplify-cmd bot cmd)))
     (log-debug "text-command: ~A AKA ~A" cmd simple-cmd)
+    ;; TODO: Replace this cond with a nicer dispatch.  Something like string-case?
     (acond
       ((equal simple-cmd "chatid")
-       (reply-message bot msg (format nil "<code>~A</code>" (message-chat-id msg)) :parse-mode "HTML"))
+       (reply-message bot msg (format nil "<code>~A</code>" (message-chat-id msg)) :parse-mode html))
 
       ((and (equal simple-cmd "msginfo")
             (message-reply-to-message msg))
@@ -252,4 +254,4 @@ Send time: ..."))
     (send-message bot
                       :chat-id (config-dev-group (bot-config bot))
                       :text msg
-                      :parse-mode "HTML")))
+                      :parse-mode html)))
diff --git a/src/tg-types.lisp b/src/tg-types.lisp
index ba3ec3b..ec14363 100644
--- a/src/tg-types.lisp
+++ b/src/tg-types.lisp
@@ -18,6 +18,7 @@
    :ukkoclot/tg-types/link-preview-options
    :ukkoclot/tg-types/message
    :ukkoclot/tg-types/message-entity
+   :ukkoclot/tg-types/parse-mode
    :ukkoclot/tg-types/photo-size
    :ukkoclot/tg-types/reply-keyboard-markup
    :ukkoclot/tg-types/reply-keyboard-remove
diff --git a/src/tg-types/parse-mode.lisp b/src/tg-types/parse-mode.lisp
new file mode 100644
index 0000000..80c24aa
--- /dev/null
+++ b/src/tg-types/parse-mode.lisp
@@ -0,0 +1,11 @@
+;; SPDX-License-Identifier: EUPL-1.2
+;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs <perkontevs@gmail.com>
+(defpackage :ukkoclot/tg-types/parse-mode
+  (:use :c2cl :ukkoclot/enum)
+  (:export :html :markdown-legacy :markdown :parse-mode))
+(in-package :ukkoclot/tg-types/parse-mode)
+
+(define-enum parse-mode
+  (markdown-legacy "Markdown")
+  (markdown "MarkdownV2")
+  (html "HTML"))