diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/enum.lisp | 24 | ||||
| -rw-r--r-- | src/hash-tables.lisp | 12 | ||||
| -rw-r--r-- | src/tg/method-macros.lisp | 7 | ||||
| -rw-r--r-- | src/tg/type-macros.lisp | 30 |
4 files changed, 45 insertions, 28 deletions
diff --git a/src/enum.lisp b/src/enum.lisp index 8943a90..a047c1d 100644 --- a/src/enum.lisp +++ b/src/enum.lisp | |||
| @@ -1,7 +1,9 @@ | |||
| 1 | ;; SPDX-License-Identifier: EUPL-1.2 | 1 | ;; SPDX-License-Identifier: EUPL-1.2 |
| 2 | ;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs <perkontevs@gmail.com> | 2 | ;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs <perkontevs@gmail.com> |
| 3 | (defpackage :ukkoclot/enum | 3 | (defpackage :ukkoclot/enum |
| 4 | (:documentation "Macro for generating an enum type.") | ||
| 4 | (:use :c2cl :iterate) | 5 | (:use :c2cl :iterate) |
| 6 | (:import-from :alexandria :with-gensyms) | ||
| 5 | (:import-from :ukkoclot/serializing :fixup-value :parse-value) | 7 | (:import-from :ukkoclot/serializing :fixup-value :parse-value) |
| 6 | (:import-from :string-case :string-case) | 8 | (:import-from :string-case :string-case) |
| 7 | (:local-nicknames | 9 | (:local-nicknames |
| @@ -13,33 +15,38 @@ | |||
| 13 | (defstruct (field (:constructor make-field%)) name string) | 15 | (defstruct (field (:constructor make-field%)) name string) |
| 14 | 16 | ||
| 15 | (defun make-field (name string) | 17 | (defun make-field (name string) |
| 18 | "Better constructor for `field'." | ||
| 16 | (make-field% :name name :string string)) | 19 | (make-field% :name name :string string)) |
| 17 | 20 | ||
| 18 | (defun parse-field-specs (field-specs) | 21 | (defun parse-field-specs (field-specs) |
| 22 | "Parse a list of field specs into a list of fields." | ||
| 19 | (iter (for field-spec in field-specs) | 23 | (iter (for field-spec in field-specs) |
| 20 | (collect (apply #'make-field field-spec)))) | 24 | (collect (apply #'make-field field-spec)))) |
| 21 | 25 | ||
| 22 | (defun emit-defconst (field) | 26 | (defun emit-defconst (field) |
| 27 | "Emit the `defconstant' statement for a specific field." | ||
| 23 | `(defconstant ,(field-name field) ',(field-name field))) | 28 | `(defconstant ,(field-name field) ',(field-name field))) |
| 24 | 29 | ||
| 25 | (defun emit-deftype (name fields) | 30 | (defun emit-deftype (name fields) |
| 31 | "Emit the `deftype' statement for the enum." | ||
| 26 | `(deftype ,name () | 32 | `(deftype ,name () |
| 27 | '(member ,@(iter (for field in fields) (collect (field-name field)))))) | 33 | '(member ,@(iter (for field in fields) (collect (field-name field)))))) |
| 28 | 34 | ||
| 29 | (defun emit-fixup-method (field) | 35 | (defun emit-fixup-method (field) |
| 30 | (let ((arg (gensym "ARG"))) | 36 | "Emit the `fixup-value' specialization for the enum." |
| 37 | (with-gensyms (arg) | ||
| 31 | `(defmethod fixup-value ((,arg (eql ',(field-name field)))) | 38 | `(defmethod fixup-value ((,arg (eql ',(field-name field)))) |
| 32 | ,(field-string field)))) | 39 | ,(field-string field)))) |
| 33 | 40 | ||
| 34 | (defun emit-jzon-write-method (field) | 41 | (defun emit-jzon-write-method (field) |
| 35 | (let ((writer (gensym "WRITER")) | 42 | "Emit the `json:write-value' specialization for the enum." |
| 36 | (arg (gensym "ARG"))) | 43 | (with-gensyms (arg writer) |
| 37 | `(defmethod jzon:write-value ((,writer jzon:writer) (,arg (eql ',(field-name field)))) | 44 | `(defmethod jzon:write-value ((,writer jzon:writer) (,arg (eql ',(field-name field)))) |
| 38 | (jzon:write-value ,writer ,(field-string field))))) | 45 | (jzon:write-value ,writer ,(field-string field))))) |
| 39 | 46 | ||
| 40 | (defun emit-parse-value (name fields) | 47 | (defun emit-parse-value (name fields) |
| 41 | (let ((type (gensym "TYPE")) | 48 | "Emit the `parse-value' specialization for the enum." |
| 42 | (source (gensym "SOURCE"))) | 49 | (with-gensyms (source type) |
| 43 | `(defmethod parse-value ((,type (eql ',name)) ,source) | 50 | `(defmethod parse-value ((,type (eql ',name)) ,source) |
| 44 | ;; nil in, nil out | 51 | ;; nil in, nil out |
| 45 | (when ,source | 52 | (when ,source |
| @@ -48,6 +55,13 @@ | |||
| 48 | (collect `(,(field-string field) ,(field-name field)))))))))) | 55 | (collect `(,(field-string field) ,(field-name field)))))))))) |
| 49 | 56 | ||
| 50 | (defmacro define-enum (name &body field-specs) | 57 | (defmacro define-enum (name &body field-specs) |
| 58 | "Define a new enumeration type. | ||
| 59 | |||
| 60 | FIELD-SPECS := FIELD-SPEC* | ||
| 61 | FIELD-SPEC := (FIELD-NAME FIELD-SERIALIZATION) | ||
| 62 | |||
| 63 | FIELD-NAME is the symbol name of the field. | ||
| 64 | FIELD-SERIALIZATION is the string serialization of the field." | ||
| 51 | (let ((fields (parse-field-specs field-specs))) | 65 | (let ((fields (parse-field-specs field-specs))) |
| 52 | `(progn | 66 | `(progn |
| 53 | ,@(iter (for field in fields) | 67 | ,@(iter (for field in fields) |
diff --git a/src/hash-tables.lisp b/src/hash-tables.lisp index 9e41b26..d3b66dd 100644 --- a/src/hash-tables.lisp +++ b/src/hash-tables.lisp | |||
| @@ -1,19 +1,24 @@ | |||
| 1 | ;; SPDX-License-Identifier: EUPL-1.2 | 1 | ;; SPDX-License-Identifier: EUPL-1.2 |
| 2 | ;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs <perkontevs@gmail.com> | 2 | ;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs <perkontevs@gmail.com> |
| 3 | (defpackage :ukkoclot/hash-tables | 3 | (defpackage :ukkoclot/hash-tables |
| 4 | (:documentation "Utilities for dealing with hash tables.") | ||
| 4 | (:use :c2cl) | 5 | (:use :c2cl) |
| 6 | (:import-from :alexandria :with-gensyms) | ||
| 5 | (:export :alist->hash-table :gethash-lazy :plist->hash-table)) | 7 | (:export :alist->hash-table :gethash-lazy :plist->hash-table)) |
| 6 | (in-package :ukkoclot/hash-tables) | 8 | (in-package :ukkoclot/hash-tables) |
| 7 | 9 | ||
| 8 | (defun alist->hash-table (alist &rest args &key &allow-other-keys) | 10 | (defun alist->hash-table (alist &rest args &key &allow-other-keys) |
| 11 | "Turn an association list into a hash table. | ||
| 12 | |||
| 13 | All key arguments are passed on to `make-hash-table'." | ||
| 9 | (let ((ht (apply #'make-hash-table args))) | 14 | (let ((ht (apply #'make-hash-table args))) |
| 10 | (loop for (key . value) in alist do | 15 | (loop for (key . value) in alist do |
| 11 | (setf (gethash key ht) value)) | 16 | (setf (gethash key ht) value)) |
| 12 | ht)) | 17 | ht)) |
| 13 | 18 | ||
| 14 | (defmacro gethash-lazy (key hash-table default-lazy) | 19 | (defmacro gethash-lazy (key hash-table default-lazy) |
| 15 | (let ((unique (gensym "UNIQUE-")) | 20 | "`gethash' alternative with lazily evaluated default value." |
| 16 | (res (gensym "RES-"))) | 21 | (with-gensyms (res unique) |
| 17 | `(let* ((,unique ',unique) | 22 | `(let* ((,unique ',unique) |
| 18 | (,res (gethash ,key ,hash-table ,unique))) | 23 | (,res (gethash ,key ,hash-table ,unique))) |
| 19 | (if (eq ,res ,unique) | 24 | (if (eq ,res ,unique) |
| @@ -21,6 +26,9 @@ | |||
| 21 | ,res)))) | 26 | ,res)))) |
| 22 | 27 | ||
| 23 | (defun plist->hash-table (plist &rest args &key &allow-other-keys) | 28 | (defun plist->hash-table (plist &rest args &key &allow-other-keys) |
| 29 | "Turn a property list into a hash table. | ||
| 30 | |||
| 31 | All key arguments are passed on to `make-hash-table'." | ||
| 24 | (let ((ht (apply #'make-hash-table args))) | 32 | (let ((ht (apply #'make-hash-table args))) |
| 25 | (loop for (key value) on plist by #'cddr do | 33 | (loop for (key value) on plist by #'cddr do |
| 26 | (setf (gethash key ht) value)) | 34 | (setf (gethash key ht) value)) |
diff --git a/src/tg/method-macros.lisp b/src/tg/method-macros.lisp index 215b2ab..b924e15 100644 --- a/src/tg/method-macros.lisp +++ b/src/tg/method-macros.lisp | |||
| @@ -3,6 +3,7 @@ | |||
| 3 | (defpackage :ukkoclot/tg/method-macros | 3 | (defpackage :ukkoclot/tg/method-macros |
| 4 | (:documentation "Macros for easy defining TG methods.") | 4 | (:documentation "Macros for easy defining TG methods.") |
| 5 | (:use :c2cl :iterate) | 5 | (:use :c2cl :iterate) |
| 6 | (:import-from :alexandria :with-gensyms) | ||
| 6 | (:import-from :com.dieggsy.f-string :enable-f-strings) | 7 | (:import-from :com.dieggsy.f-string :enable-f-strings) |
| 7 | (:import-from :serapeum :take) | 8 | (:import-from :serapeum :take) |
| 8 | (:import-from :ukkoclot/state :bot) | 9 | (:import-from :ukkoclot/state :bot) |
| @@ -51,13 +52,11 @@ | |||
| 51 | `(,(param-name param) ,(param-default param))) | 52 | `(,(param-name param) ,(param-default param))) |
| 52 | 53 | ||
| 53 | (defun emit-defun (name return-type params method) | 54 | (defun emit-defun (name return-type params method) |
| 54 | (let ((revparams (reverse params)) | 55 | (with-gensyms (args bot) |
| 55 | (args (gensym "ARGS")) | ||
| 56 | (bot (gensym "BOT"))) | ||
| 57 | `(defun ,name (,bot &key ,@(iter (for param in params) ; lint:suppress lambda-list-invalid | 56 | `(defun ,name (,bot &key ,@(iter (for param in params) ; lint:suppress lambda-list-invalid |
| 58 | (collect (emit-defun-arg param)))) | 57 | (collect (emit-defun-arg param)))) |
| 59 | (let (,args) | 58 | (let (,args) |
| 60 | ,@(iter (for param in revparams) | 59 | ,@(iter (for param in (reverse params)) |
| 61 | (collect (if (param-skip-if-default param) | 60 | (collect (if (param-skip-if-default param) |
| 62 | `(unless (equal ,(param-name param) | 61 | `(unless (equal ,(param-name param) |
| 63 | ,(param-default param)) | 62 | ,(param-default param)) |
diff --git a/src/tg/type-macros.lisp b/src/tg/type-macros.lisp index 390781f..5f99cba 100644 --- a/src/tg/type-macros.lisp +++ b/src/tg/type-macros.lisp | |||
| @@ -3,6 +3,7 @@ | |||
| 3 | (defpackage :ukkoclot/tg/type-macros | 3 | (defpackage :ukkoclot/tg/type-macros |
| 4 | (:documentation "Macros for easy defining TG types.") | 4 | (:documentation "Macros for easy defining TG types.") |
| 5 | (:use :c2cl :iterate) | 5 | (:use :c2cl :iterate) |
| 6 | (:import-from :alexandria :with-gensyms) | ||
| 6 | (:import-from :com.dieggsy.f-string :enable-f-strings) | 7 | (:import-from :com.dieggsy.f-string :enable-f-strings) |
| 7 | (:import-from :ukkoclot/serializing :parse-value) | 8 | (:import-from :ukkoclot/serializing :parse-value) |
| 8 | (:import-from :ukkoclot/hash-tables :gethash-lazy) | 9 | (:import-from :ukkoclot/hash-tables :gethash-lazy) |
| @@ -54,7 +55,7 @@ | |||
| 54 | `(list ,(field-hash-key field) ,value ',(field-type field))) | 55 | `(list ,(field-hash-key field) ,value ',(field-type field))) |
| 55 | 56 | ||
| 56 | (defun emit-collect-nondefault-fields (name fields obj collector) | 57 | (defun emit-collect-nondefault-fields (name fields obj collector) |
| 57 | (let ((value (gensym "VALUE"))) | 58 | (with-gensyms (value) |
| 58 | (iter (for field in (reverse fields)) | 59 | (iter (for field in (reverse fields)) |
| 59 | (collect | 60 | (collect |
| 60 | (if (field-skip-if-default field) | 61 | (if (field-skip-if-default field) |
| @@ -70,8 +71,7 @@ | |||
| 70 | `(gethash-lazy ,(field-hash-key field) ,source ,(field-default field))) | 71 | `(gethash-lazy ,(field-hash-key field) ,source ,(field-default field))) |
| 71 | 72 | ||
| 72 | (defun emit-jzon-coerced-fields (name fields) | 73 | (defun emit-jzon-coerced-fields (name fields) |
| 73 | (let ((obj (gensym "OBJ")) | 74 | (with-gensyms (obj result) |
| 74 | (result (gensym "RESULT"))) | ||
| 75 | `(defmethod jzon:coerced-fields ((,obj ,name)) | 75 | `(defmethod jzon:coerced-fields ((,obj ,name)) |
| 76 | (let (,result) | 76 | (let (,result) |
| 77 | ,@(emit-collect-nondefault-fields | 77 | ,@(emit-collect-nondefault-fields |
| @@ -85,9 +85,8 @@ | |||
| 85 | (parse-value ',(field-type field) ,(emit-gethash field source)))) | 85 | (parse-value ',(field-type field) ,(emit-gethash field source)))) |
| 86 | 86 | ||
| 87 | (defun emit-parse-value (name fields) | 87 | (defun emit-parse-value (name fields) |
| 88 | (let ((type-sym (gensym "TYPE-SYM")) | 88 | (with-gensyms (source type) |
| 89 | (source (gensym "SOURCE"))) | 89 | `(defmethod parse-value ((,type (eql ',name)) ,source) |
| 90 | `(defmethod parse-value ((,type-sym (eql ',name)) ,source) | ||
| 91 | (let (,@(iter (for field in fields) | 90 | (let (,@(iter (for field in fields) |
| 92 | (collect (emit-let-gethash field source)))) | 91 | (collect (emit-let-gethash field source)))) |
| 93 | (,(type-constructor name) | 92 | (,(type-constructor name) |
| @@ -95,10 +94,7 @@ | |||
| 95 | (appending (emit-constructor-args field)))))))) | 94 | (appending (emit-constructor-args field)))))))) |
| 96 | 95 | ||
| 97 | (defun emit-printer (name printer-name fields) | 96 | (defun emit-printer (name printer-name fields) |
| 98 | (let ((obj (gensym "OBJ")) | 97 | (with-gensyms (depth obj pprint-args stream) |
| 99 | (stream (gensym "STREAM")) | ||
| 100 | (depth (gensym "DEPTH")) | ||
| 101 | (pprint-args (gensym "PPRINT-ARGS"))) | ||
| 102 | `(defun ,printer-name (,obj ,stream ,depth) ; lint:suppress lambda-list-invalid | 98 | `(defun ,printer-name (,obj ,stream ,depth) ; lint:suppress lambda-list-invalid |
| 103 | (declare (ignore ,depth)) | 99 | (declare (ignore ,depth)) |
| 104 | (let (,pprint-args) | 100 | (let (,pprint-args) |
| @@ -117,10 +113,10 @@ | |||
| 117 | `(,(field-name field) ,(field-default field) :type ,(field-type field)))) | 113 | `(,(field-name field) ,(field-default field) :type ,(field-type field)))) |
| 118 | 114 | ||
| 119 | (defmacro define-tg-type (name &body field-specs) | 115 | (defmacro define-tg-type (name &body field-specs) |
| 120 | (let ((fields (parse-field-specs field-specs)) | 116 | (let ((fields (parse-field-specs field-specs))) |
| 121 | (printer-name (gensym "PRINTER"))) | 117 | (with-gensyms (printer) |
| 122 | `(progn | 118 | `(progn |
| 123 | ,(emit-struct name printer-name fields) | 119 | ,(emit-struct name printer fields) |
| 124 | ,(emit-printer name printer-name fields) | 120 | ,(emit-printer name printer fields) |
| 125 | ,(emit-parse-value name fields) | 121 | ,(emit-parse-value name fields) |
| 126 | ,(emit-jzon-coerced-fields name fields)))) | 122 | ,(emit-jzon-coerced-fields name fields))))) |