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
|
;; SPDX-License-Identifier: EUPL-1.2
;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs <perkontevs@gmail.com>
(defpackage :ukkoclot/tg/type-macros
(:use :c2cl :iterate)
(:import-from :ukkoclot/hash-tables :gethash-lazy)
(:import-from :ukkoclot/strings :lisp->snake-case)
(:local-nicknames
(:jzon :com.inuoe.jzon))
(:export :define-tg-type))
(in-package :ukkoclot/tg/type-macros)
(eval-when (:compile-toplevel :load-toplevel :execute)
(defstruct (field (:constructor make-field%)) name type default skip-if-default)
(defparameter +unique+ (gensym))
(defun make-field (name type &optional (default +unique+) &key (skip-if-default (not (eq default +unique+))))
(let ((default (if (eq default +unique+)
`(error ,(format nil "No value given for ~A" name))
default)))
(make-field% :name name
:type type
:default default
:skip-if-default skip-if-default)))
(defun type-constructor (name)
(intern (concatenate 'string "MAKE-" (symbol-name name))))
(defun field-accessor (name field)
(intern (concatenate 'string (symbol-name name) "-" (symbol-name (field-name field)))))
(defun field-hash-key (field)
(string-downcase (lisp->snake-case (symbol-name (field-name field)))))
(defun field-keyword (field)
(intern (symbol-name (field-name field)) :keyword))
(defun parse-field-specs (field-specs)
(iter (for field-spec in field-specs)
(collect (apply #'make-field field-spec))))
(defun emit-append-to-pprint-args (field value pprint-args)
`(setf ,pprint-args (list* ',(field-name field) ,value ,pprint-args)))
(defun emit-coerced-field (field value)
`(list ,(field-hash-key field) ,value ',(field-type field)))
(defun emit-collect-nondefault-fields (name fields obj collector)
(let ((value (gensym "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)))))))
(defun emit-constructor-args (field)
`(,(field-keyword field) ,(field-name field)))
(defun emit-gethash (field source)
`(gethash-lazy ,(field-hash-key field) ,source ,(field-default field)))
(defun emit-jzon-coerced-fields (name fields)
(let ((obj (gensym "OBJ"))
(result (gensym "RESULT")))
`(defmethod jzon:coerced-fields ((,obj ,name))
(let (,result)
,@(emit-collect-nondefault-fields
name fields obj
(lambda (field value)
`(setf ,result (cons ,(emit-coerced-field field value) ,result))))
,result))))
(defun emit-let-gethash (field source)
`(,(field-name field)
(parse-value ',(field-type field) ,(emit-gethash field source))))
(defun emit-parse-value (name fields)
(let ((type-sym (gensym "TYPE-SYM"))
(source (gensym "SOURCE")))
`(defmethod parse-value ((,type-sym (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))))))))
(defun emit-printer (name printer-name fields)
(let ((obj (gensym "OBJ"))
(stream (gensym "STREAM"))
(depth (gensym "DEPTH"))
(pprint-args (gensym "PPRINT-ARGS")))
`(defun ,printer-name (,obj ,stream ,depth)
(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))))
;; ,@(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))
;; ,(emit-append-to-pprint-args field value pprint-args)))
;; (emit-append-to-pprint-args field `(,(field-accessor name field) ,obj) pprint-args))))
(format ,stream "~A~<[~;~@{~_~1I~W = ~W~^, ~}~;]~:>" ',name ,pprint-args)))))
(defun emit-struct (name printer-name fields)
`(defstruct (,name (:print-function ,printer-name))
,@(iter (for field in fields)
(collect (emit-struct-field field)))))
(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))
(printer-name (gensym "PRINTER")))
`(progn
,(emit-struct name printer-name fields)
,(emit-printer name printer-name fields)
,(emit-parse-value name fields)
,(emit-jzon-coerced-fields name fields))))
|
