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
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
|
;; SPDX-License-Identifier: EUPL-1.2
;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs <perkontevs@gmail.com>
(defpackage :ukkoclot/src/tg/type-macros
(:documentation "Macros for easy defining TG types.")
(: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)
(:local-nicknames
(:jzon :com.inuoe.jzon))
(:export :define-tg-type))
(in-package :ukkoclot/src/tg/type-macros)
(eval-when (:compile-toplevel :load-toplevel :execute)
(enable-f-strings))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defstruct (field (:constructor make-field%)) name type default skip-if-default)
(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+))))
(let ((default (if (eq default +unique+)
`(error ,#f"No value given for {name}")
default)))
(make-field% :name name
:type type
: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))))
(-> 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))
(collect
(if (field-skip-if-default field)
`(let ((,value (,(field-accessor name field) ,obj)))
(unless (equal ,value ,(field-default field))
,(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))
(let (,result)
,@(emit-collect-nondefault-fields
name fields obj
(lambda (field value)
`(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)
(let (,@(iter (for field in fields)
(collect (emit-let-gethash field source))))
(,(type-constructor name)
,@(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
(declare (ignore ,depth))
(let (,pprint-args)
,@(emit-collect-nondefault-fields
name fields obj
(lambda (field value)
`(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))))
(defmacro define-tg-type (name &body field-specs)
(let ((fields (parse-field-specs field-specs)))
(with-gensyms (printer)
`(progn
,(emit-struct name printer fields)
,(emit-printer name printer fields)
,(emit-parse-value name fields)
,(emit-jzon-coerced-fields name fields)))))
|
