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
|
;; 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/serializing :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 jzon:writer) (,arg (eql ',(field-name field))))
(jzon:write-value ,writer ,(field-string field)))))
(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
,@(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)))))))
|
