1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
|
;; SPDX-License-Identifier: EUPL-1.2
;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs <perkontevs@gmail.com>
(defpackage :ukkoclot/src/enum
(:documentation "Macro for generating an enum type.")
(:use :c2cl :iterate)
(:import-from :alexandria :with-gensyms)
(:import-from :serapeum :->)
(:import-from :string-case :string-case)
(:import-from :ukkoclot/src/serializing :fixup-value :parse-value)
(:local-nicknames
(:jzon :com.inuoe.jzon))
(:export :define-enum))
(in-package :ukkoclot/src/enum)
(eval-when (:compile-toplevel :load-toplevel :execute)
(defstruct (field (:constructor make-field%)) name string)
(-> make-field (symbol string) field)
(defun make-field (name string)
"Better constructor for `field'."
(make-field% :name name :string string))
;; TODO: list-of-fields, list-of-field-specs
(-> parse-field-specs (list) list)
(defun parse-field-specs (field-specs)
"Parse a list of field specs into a list of fields."
(iter (for field-spec in field-specs)
(collect (apply #'make-field field-spec))))
(-> emit-defconst (field) list)
(defun emit-defconst (field)
"Emit the `defconstant' statement for a specific field."
`(defconstant ,(field-name field) ',(field-name field)))
;; TODO: list-of-fields
(-> emit-deftype (symbol list) list)
(defun emit-deftype (name fields)
"Emit the `deftype' statement for the enum."
`(deftype ,name ()
'(member ,@(iter (for field in fields) (collect (field-name field))))))
(-> emit-fixup-method (field) list)
(defun emit-fixup-method (field)
"Emit the `fixup-value' specialization for the enum."
(with-gensyms (arg)
`(defmethod fixup-value ((,arg (eql ',(field-name field))))
,(field-string field))))
(-> emit-jzon-write-method (field) list)
(defun emit-jzon-write-method (field)
"Emit the `json:write-value' specialization for the enum."
(with-gensyms (arg writer)
`(defmethod jzon:write-value ((,writer jzon:writer) (,arg (eql ',(field-name field))))
(jzon:write-value ,writer ,(field-string field)))))
;; TODO: list-of-fields
(-> emit-parse-value (symbol list) list)
(defun emit-parse-value (name fields)
"Emit the `parse-value' specialization for the enum."
(with-gensyms (source type)
`(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)
"Define a new enumeration type.
FIELD-SPECS := FIELD-SPEC*
FIELD-SPEC := (FIELD-NAME FIELD-SERIALIZATION)
FIELD-NAME is the symbol name of the field.
FIELD-SERIALIZATION is the string serialization of the field."
(let ((fields (parse-field-specs field-specs)))
`(progn
,@(iter (for field in fields)
(collect (emit-defconst field)))
,(emit-deftype name fields)
,(emit-parse-value name fields)
,@(iter (for field in fields)
(collect `(progn
,(emit-fixup-method field)
,(emit-jzon-write-method field)))))))
|
