Add utilities 'make-option' and 'add-option' to make new work simpler

diff --git a/define-proto.lisp b/define-proto.lisp
index 11919749e3f85262c818ceefd6d8404653c9acf6..358955c8329f98dab2bfeee30cbc55acfd855cc3 100644 (file)
--- a/define-proto.lisp
+++ b/define-proto.lisp
@@ -45,9 +45,7 @@
          (lisp-pkg (and lisp-package (if (stringp lisp-package) lisp-package (string lisp-package))))
          (options  (remove-options
                      (loop for (key val) on options by #'cddr
-                           collect (make-instance 'protobuf-option
-                                     :name  (if (symbolp key) (slot-name->proto key) key)
-                                     :value val))
+                           collect (make-option (if (symbolp key) (slot-name->proto key) key) val))
                      "optimize_for" "lisp_package"))
          (imports  (if (listp import) import (list import)))
          (schema   (make-instance 'protobuf-schema
@@ -58,10 +56,8 @@
                      :lisp-package (or lisp-pkg (substitute #\- #\_ package))
                      :imports  imports
                      :options  (if optimize
-                                 (append options (list (make-instance 'protobuf-option
-                                                         :name  "optimize_for"
-                                                         :value (if (eq optimize :speed) "SPEED" "CODE_SIZE")
-                                                         :type  'symbol)))
+                                 (append options
+                                         (list (make-option "optimize_for" (if (eq optimize :speed) "SPEED" "CODE_SIZE") 'symbol)))
                                  options)
                      :documentation documentation))
          (*protobuf* schema)
@@ -171,9 +167,7 @@
    The body consists of the enum values in the form 'name' or (name index)."
   (let* ((name    (or name (class-name->proto type)))
          (options (loop for (key val) on options by #'cddr
-                        collect (make-instance 'protobuf-option
-                                  :name  (if (symbolp key) (slot-name->proto key) key)
-                                  :value val)))
+                        collect (make-option (if (symbolp key) (slot-name->proto key) key) val)))
          (conc-name (conc-name-for-type type conc-name))
          (index -1)
          (enum  (make-instance 'protobuf-enum
@@ -243,9 +237,7 @@
    'writer' is a Lisp slot writer function to use to set the value."
   (let* ((name    (or name (class-name->proto type)))
          (options (loop for (key val) on options by #'cddr
-                        collect (make-instance 'protobuf-option
-                                  :name  (if (symbolp key) (slot-name->proto key) key)
-                                  :value val)))
+                        collect (make-option (if (symbolp key) (slot-name->proto key) key) val)))
          (conc-name (conc-name-for-type type conc-name))
          (message (make-instance 'protobuf-message
                     :class type
@@ -355,9 +347,7 @@
    'writer' is a Lisp slot writer function to use to set the value."
   (let* ((name    (or name (class-name->proto type)))
          (options (loop for (key val) on options by #'cddr
-                        collect (make-instance 'protobuf-option
-                                  :name  (if (symbolp key) (slot-name->proto key) key)
-                                  :value val)))
+                        collect (make-option (if (symbolp key) (slot-name->proto key) key) val)))
          (message   (find-message *protobuf* type))
          (conc-name (or (conc-name-for-type type conc-name)
                         (and message (proto-conc-name message))))
@@ -542,9 +532,7 @@
   (let* ((slot    (or type (and name (proto->slot-name name *protobuf-package*))))
          (name    (or name (class-name->proto type)))
          (options (loop for (key val) on options by #'cddr
-                        collect (make-instance 'protobuf-option
-                                  :name  (if (symbolp key) (slot-name->proto key) key)
-                                  :value val)))
+                        collect (make-option (if (symbolp key) (slot-name->proto key) key) val)))
          (conc-name (conc-name-for-type type conc-name))
          (reader  (or reader
                       (let ((msg-conc (proto-conc-name *protobuf*)))
@@ -667,13 +655,9 @@
            (options (append
                      (loop for (key val) on other-options by #'cddr
                            unless (member key '(:type :reader :writer :name :default :packed :documentation))
-                             collect (make-instance 'protobuf-option
-                                       :name  (slot-name->proto key)
-                                       :value val))
+                             collect (make-option (slot-name->proto key) val))
                      (loop for (key val) on options by #'cddr
-                         collect (make-instance 'protobuf-option
-                                   :name  (if (symbolp key) (slot-name->proto key) key)
-                                   :value val)))))
+                           collect (make-option (if (symbolp key) (slot-name->proto key) key) val)))))
       (multiple-value-bind (ptype pclass)
           (clos-type-to-protobuf-type type)
         (multiple-value-bind (reqd vectorp)
@@ -741,9 +725,7 @@
    'input-type' and 'output-type' may also be of the form (type &key name)."
   (let* ((name    (or name (class-name->proto type)))
          (options (loop for (key val) on options by #'cddr
-                        collect (make-instance 'protobuf-option
-                                  :name  (if (symbolp key) (slot-name->proto key) key)
-                                  :value val)))
+                        collect (make-option (if (symbolp key) (slot-name->proto key) key) val)))
          (service (make-instance 'protobuf-service
                     :class type
                     :name  name
@@ -772,9 +754,7 @@
                                     (getf (cdr streams-type) :name)))
                  (streams-type (if (listp streams-type) (car streams-type) streams-type))
                  (options (loop for (key val) on options by #'cddr
-                                collect (make-instance 'protobuf-option
-                                          :name  (if (symbolp key) (slot-name->proto key) key)
-                                          :value val)))
+                                collect (make-option (if (symbolp key) (slot-name->proto key) key) val)))
                  (package   *protobuf-rpc-package*)
                  (client-fn (intern (format nil "~A-~A" 'call function) package))
                  (server-fn (intern (format nil "~A-~A" function 'impl) package))

diff --git a/model-classes.lisp b/model-classes.lisp
index 6d99a66b3f11ff281ab6e98c14a087fc58e8891a..f41ca7aa995cf0c93389472519a6471debbb753c 100644 (file)
--- a/model-classes.lisp
+++ b/model-classes.lisp
@@ -306,6 +306,11 @@
       (format stream "~A~@[ = ~S~]" (proto-name o) (proto-value o)))
     (format stream "~A" (proto-name o))))
 
+(defun make-option (name value &optional (type 'string))
+  (check-type name string)
+  (make-instance 'protobuf-option
+    :name key :value val :type type))
+
 (defgeneric find-option (protobuf name)
   (:documentation
    "Given a Protobufs schema, message, enum, etc and the name of an option,
@@ -324,6 +329,28 @@
       (values (proto-value option) (proto-type option) t)
       (values nil nil nil))))
 
+(defgeneric add-option (protobuf name value &optional type)
+  (:documentation
+   "Given a Protobufs schema, message, enum, etc
+    add the option called 'name' with the value 'value' and type 'type'.
+    If the option was previoously present, it is replaced."))
+
+(defmethod add-option ((protobuf base-protobuf) (name string) value &optional (type 'string))
+  (let ((option (find name (proto-options protobuf) :key #'proto-name :test #'option-name=)))
+    (if option
+      ;; This side-effects the old option
+      (setf (proto-value option) value
+            (proto-type option)  type)
+      ;; This side-effects 'proto-options'
+      (setf (proto-options protobuf) 
+            (append (proto-options protobuf)
+                    (list (make-option key val type)))))))
+
+(defmethod add-option ((options list) (name string) value &optional (type 'string))
+  (let ((option (find name options :key #'proto-name :test #'option-name=)))
+    (setq options (append (remove option options)
+                          (list (make-option key val type))))))
+
 (defgeneric remove-options (protobuf &rest names)
   (:documentation
    "Given a Protobufs schema, message, enum, etc and a set of option names,

diff --git a/parser.lisp b/parser.lisp
index 26c72053905756e254ddbfeb07c85595b9fea72e..1c6e75900494b842a7501d1da5bff7e3dac1d109 100644 (file)
--- a/parser.lisp
+++ b/parser.lisp
@@ -434,9 +434,7 @@
                              (t (kintern (parse-token stream)))))
                 (setq terminator (expect-char stream terminators () "option"))
                 (maybe-skip-comments stream)))
-         (option (make-instance 'protobuf-option
-                   :name  key
-                   :value val)))
+         (option (make-option key val)))
     (cond (protobuf
            (setf (proto-options protobuf) (nconc (proto-options protobuf) (list option)))
            (values option terminator))

diff --git a/pkgdcl.lisp b/pkgdcl.lisp
index b94ee8932f66b3d2906a8bda626ca4e8231ff73b..bbdceee8670845359bc10585d9fda989f473a280 100644 (file)
--- a/pkgdcl.lisp
+++ b/pkgdcl.lisp
@@ -220,7 +220,9 @@
    "FIND-ENUM"
    "FIND-FIELD"
    "FIND-METHOD"                ;if you ":use proto-impl", watch for name clash
+   "MAKE-OPTION"
    "FIND-OPTION"
+   "ADD-OPTION"
    "REMOVE-OPTIONS"
 
    ;; Printing