1 files changed, 59 insertions, 0 deletions

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)))))))