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
|
;; SPDX-License-Identifier: EUPL-1.2
;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs <perkontevs@gmail.com>
(defpackage :ukkoclot/tg/macros
(:use :c2cl)
(:import-from :ukkoclot/bot/impl :bot :do-call :parse-value)
(:import-from :ukkoclot/hash-tables :gethash-lazy)
(:import-from :ukkoclot/strings :lisp->snake-case)
(:local-nicknames
(:jzon :com.inuoe.jzon))
(:export :define-tg-method :define-tg-type))
(in-package :ukkoclot/tg/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+)
(list '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 parse-field-specs (field-specs)
(loop for field-spec in field-specs
collect (apply #'make-field field-spec)))
(defun field-hash-key (field)
(string-downcase (lisp->snake-case (symbol-name (field-name field)))))
(defun field-accessor (struc-name field)
(intern (concatenate 'string (symbol-name struc-name) "-" (symbol-name (field-name field)))))
(defun field->coerced-field-spec (field struc-name obj-name)
`(list ,(string-downcase (lisp->snake-case (symbol-name (field-name field))))
(,(field-accessor struc-name field) ,obj-name)
',(field-type field)))
(defun field->defun-spec (field)
(list (field-name field) (field-default field)))
(defun field->format-arg (field name struc)
`(',(field-name field) (,(field-accessor name field) ,struc)))
(defun field->ftype-spec (field)
(list (intern (symbol-name (field-name field)) :keyword) (field-type field)))
(defun field->gethash-spec (field hash-table-sym)
(let ((hash-key (field-hash-key field)))
(list 'gethash-lazy hash-key hash-table-sym (field-default field))))
(defun field->sethash-spec (field name struc hash-table-sym)
(let ((hash-key (field-hash-key field))
(skip-if-default (field-skip-if-default field))
(default (field-default field)))
(if skip-if-default
(let ((tmpsym (gensym "TMP")))
`(let ((,tmpsym (,(field-accessor name field) ,struc)))
(unless (equal ,tmpsym ,default)
(setf (gethash ,hash-key ,hash-table-sym) ,tmpsym))))
`(setf (gethash ,hash-key ,hash-table-sym) (,(field-accessor name field) ,struc)))))
(defun field->let-gethash-spec (field hash-table-sym)
`(,(field-name field)
(parse-value ',(field-type field) ,(field->gethash-spec field hash-table-sym))))
(defun field->make-spec (field)
(list (intern (symbol-name (field-name field)) :keyword)
(field-name field)))
(defun field->struct-spec (field)
(list (field-name field) (field-default field) :type (field-type field))))
;; TODO: Automatically derive path from name
;; TODO: Automatically derive mapfn from type
(defmacro define-tg-method (
(name type path &optional (method :POST))
&body field-specs)
(let* ((fields (parse-field-specs field-specs))
(revfields (reverse fields))
(args (gensym "ARGS"))
(bot (gensym "BOT-")))
`(progn
(declaim (ftype (function (bot &key ,@(loop for field in fields
collect (field->ftype-spec field)))
,type)
,name))
(defun ,name (,bot &key ,@(loop for field in fields collect (field->defun-spec field)))
(let (,args)
,@(loop for field in revfields
collecting
(if (field-skip-if-default field)
`(unless (equal ,(field-name field) ,(field-default field))
(setf ,args (acons ',(field-name field) ,(field-name field) ,args)))
`(setf ,args (acons ',(field-name field) ,(field-name field) ,args))))
(do-call ,bot ,method ,path ',type ,args))))))
(defmacro define-tg-type (name &body field-specs)
(let* ((fields (parse-field-specs field-specs))
(revfields (reverse fields))
(make-name (intern (concatenate 'string "MAKE-" (symbol-name name))))
(printer (gensym (concatenate 'string "PRINT-" (symbol-name name))))
(hash (gensym "HASH-"))
(struc (gensym (symbol-name name)))
(stream (gensym "STREAM"))
(depth (gensym "DEPTH"))
(pprint-args (gensym "PPRINT-ARGS"))
(res (gensym "RES"))
(type (gensym "TYPE")))
`(progn
(defstruct (,name (:print-function ,printer))
,@(loop for field in fields
collect (field->struct-spec field)))
(defun ,printer (,struc ,stream ,depth)
(declare (ignore ,depth))
(let (,pprint-args)
,@(loop for field in revfields
collecting
(if (field-skip-if-default field)
`(let ((value (,(field-accessor name field) ,struc)))
(unless (equal value ,(field-default field))
(setf ,pprint-args (list* ',(field-name field) value ,pprint-args))))
`(setf ,pprint-args (list* ',(field-name field) (,(field-accessor name field) ,struc) ,pprint-args))))
(format ,stream "~A~<[~;~@{~_~1I~W = ~W~^, ~}~;]~:>" ',name ,pprint-args)))
(defmethod parse-value ((,type (eql ',name)) ,hash)
(let ,(loop for field in fields
collect (field->let-gethash-spec field hash))
(,make-name ,@(loop for field in fields
append (field->make-spec field)))))
(defmethod jzon:coerced-fields ((,struc ,name))
(let (,res)
,@(loop for field in revfields
collecting
(if (field-skip-if-default field)
`(let ((value (,(field-accessor name field) ,struc)))
(unless (equal value ,(field-default field))
(setf ,res (cons ,(field->coerced-field-spec field name struc) ,res))))
`(setf ,res (cons ,(field->coerced-field-spec field name struc) ,res))))
,res)))))
|
