;;; ;;;
;;; Free Software published under an MIT-like license. See LICENSE ;;;
;;; ;;;
-;;; Copyright (c) 2012 Google, Inc. All rights reserved. ;;;
+;;; Copyright (c) 2012-2013 Google, Inc. All rights reserved. ;;;
;;; ;;;
;;; Original author: Scott McKay ;;;
;;; ;;;
(in-package "PROTO-IMPL")
-;;; Protol buffers model classes
+;;; Protocol buffers model classes
(defvar *all-schemas* (make-hash-table :test #'equal)
- "A table mapping names to 'protobuf-schema' objects.")
+ "A global table mapping names to 'protobuf-schema' objects.")
(defgeneric find-schema (name)
(:documentation
"Given a name (a symbol or string), return the 'protobuf-schema' object having that name."))
(defmethod find-schema ((name symbol))
- (values (gethash (keywordify name) *all-schemas*)))
-
-(defmethod find-schema ((name string))
- (values (gethash (string-upcase name) *all-schemas*)))
+ (assert (not (keywordp name)))
+ (values (gethash name *all-schemas*)))
(defmethod find-schema ((path pathname))
"Given a pathname, return the 'protobuf-schema' object that came from that path."
- (values (gethash (make-pathname :type nil :defaults (truename path)) *all-schemas*)))
+ (values (gethash path *all-schemas*)))
(defvar *all-messages* (make-hash-table :test #'equal)
- "A table mapping Lisp class names to 'protobuf-message' objects.")
+ "A global table mapping Lisp class names to 'protobuf-message' objects.")
(defgeneric find-message-for-class (class)
(:documentation
(values (gethash (class-name class) *all-messages*)))
-;; A few things (the pretty printer) want to keep track of the current schema
+;;; "Thread-local" variables
+
+;; Parsing (and even pretty printing schemas) want to keep track of the current schema
(defvar *protobuf* nil
- "The Protobufs object currently being defined, either a schema or a message.")
+ "Bound to the Protobufs object currently being defined, either a schema or a message.")
(defvar *protobuf-package* nil
- "The Lisp package in which the Protobufs schema is being defined.")
+ "Bound to the Lisp package in which the Protobufs schema is being defined.")
+
+(defvar *protobuf-rpc-package* nil
+ "Bound to the Lisp package in which the Protobufs schema's service definitions are being defined.")
(defvar *protobuf-conc-name* nil
- "A global conc-name to use for all the messages in this schema. This controls
- the name of the accessors the fields of each message.
- When it's nil, there is no global conc-name.
+ "Bound to a conc-name to use for all the messages in the schema being defined.
+ This controls the name of the accessors the fields of each message.
+ When it's nil, there is no \"global\" conc-name.
When it's t, each message will use the message name as the conc-name.
When it's a string, that string will be used as the conc-name for each message.
'parse-schema-from-file' defaults conc-name to \"\", meaning that each field in
every message has an accessor whose name is the name of the field.")
+(defvar *protobuf-pathname* nil
+ "Bound to he name of the file from where the .proto file is being parsed.")
+
(defvar *protobuf-search-path* ()
- "A search-path to use to resolve any relative pathnames.")
+ "Bound to the search-path to use to resolve any relative pathnames.")
(defvar *protobuf-output-path* ()
- "A path to use to direct output during imports, etc.")
+ "Bound to the path to use to direct output during imports, etc.")
;;; The model classes
(defclass abstract-protobuf () ())
+;; It would be nice if most of the slots had only reader functions, but
+;; that makes writing the Protobufs parser a good deal more complicated.
+;; Too bad Common Lisp exports '(setf foo)' when you only want to export 'foo'
(defclass base-protobuf (abstract-protobuf)
((class :type (or null symbol) ;the Lisp name for this object
:accessor proto-class ;this often names a type or class
:accessor proto-qualified-name
:initarg :qualified-name
:initform "")
+ (parent :type (or null base-protobuf) ;this object's parent
+ :accessor proto-parent
+ :initarg :parent)
(options :type (list-of protobuf-option) ;options, mostly just passed along
:accessor proto-options
:initarg :options
(doc :type (or null string) ;documentation for this object
:accessor proto-documentation
:initarg :documentation
- :initform nil))
+ :initform nil)
+ (location :accessor proto-source-location ;a list of (pathname start-pos end-pos)
+ :initarg :source-location
+ :initform nil))
(:documentation
"The base class for all Protobufs model classes."))
(defun find-qualified-name (name protos
&key (proto-key #'proto-name) (full-key #'proto-qualified-name)
- (lisp-key #'proto-class))
- "Find something by its string name.
- First do a simple name match.
- Failing that, exhaustively search qualified names."
+ relative-to)
+ "Find something by its string name, first doing a simple name match,
+ and, if that fails, exhaustively searching qualified names."
+ (declare (ignore relative-to))
(or (find name protos :key proto-key :test #'string=)
- (find name protos :key full-key :test #'string=)
- ;; Get desperate in the face of incomplete namespace support
- ;;--- This needs to be more sophisticated than just using Lisp packages
- (multiple-value-bind (name package path other)
- (proto->class-name name)
- (declare (ignore path))
- (let* ((name (string name))
- (symbol (or (and package (find-symbol name package))
- (and other
- (find-proto-package other)
- (find-symbol name (find-proto-package other))))))
- (when symbol
- (find symbol protos :key lisp-key))))))
+ ;;--- This needs more sophisticated search, e.g., relative to current namespace
+ (find name protos :key full-key :test #'string=)))
;; A Protobufs schema, corresponds to one .proto file
(services :type (list-of protobuf-service)
:accessor proto-services
:initarg :services
- :initform ()))
+ :initform ())
+ (aliases :type (list-of protobuf-type-alias) ;type aliases, a Lisp extension
+ :accessor proto-type-aliases
+ :initarg :type-aliases
+ :initform ()))
(:documentation
"The model class that represents a Protobufs schema, i.e., one .proto file."))
(defmethod make-load-form ((s protobuf-schema) &optional environment)
- (with-slots (class name) s
+ (with-slots (class) s
(multiple-value-bind (constructor initializer)
(make-load-form-saving-slots s :environment environment)
(values `(let ((s ,constructor))
- (record-protobuf s ',class ',name nil)
+ (record-protobuf s ',class nil)
s)
initializer))))
-(defgeneric record-protobuf (schema &optional symbol name type)
+(defgeneric record-protobuf (schema &optional symbol type)
(:documentation
"Record all the names by which the Protobufs schema might be known.")
- (:method ((schema protobuf-schema) &optional symbol name type)
+ (:method ((schema protobuf-schema) &optional symbol type)
(declare (ignore type))
- (let ((symbol (or symbol (proto-class schema)))
- (name (or name (proto-name schema))))
+ (let ((symbol (or symbol (proto-class schema))))
(when symbol
- (setf (gethash (keywordify symbol) *all-schemas*) schema))
- (when name
- (setf (gethash (string-upcase name) *all-schemas*) schema))
- (let ((path (or *compile-file-pathname* *load-pathname*)))
- (when path
- ;; Record the file from which the Protobufs schema came, sans file type
- (setf (gethash (make-pathname :type nil :defaults (truename path)) *all-schemas*) schema))))))
+ (setf (gethash symbol *all-schemas*) schema))
+ (when *protobuf-pathname*
+ ;; Record the file from which the Protobufs schema came
+ (setf (gethash *protobuf-pathname* *all-schemas*) schema)))))
(defmethod print-object ((s protobuf-schema) stream)
- (print-unreadable-object (s stream :type t :identity t)
- (format stream "~@[~S~]~@[ (package ~A)~]"
- (proto-class s) (proto-package s))))
+ (if *print-escape*
+ (print-unreadable-object (s stream :type t :identity t)
+ (format stream "~@[~S~]~@[ (package ~A)~]"
+ (and (slot-boundp s 'class) (proto-class s)) (proto-package s)))
+ (format stream "~S" (and (slot-boundp s 'class) (proto-class s)))))
(defgeneric make-qualified-name (proto name)
(:documentation
generate a fully qualified name string for the name."))
(defmethod make-qualified-name ((schema protobuf-schema) name)
- ;; If we're at the parent, the qualified name is the schema's
- ;; packaged "dot" the name
- (strcat (proto-package schema) "." name))
+ ;; If we're at the schema, the qualified name is the schema's
+ ;; package "dot" the name
+ (if (proto-package schema)
+ (strcat (proto-package schema) "." name)
+ name))
-(defgeneric find-enum (protobuf type)
+(defgeneric find-enum (protobuf type &optional relative-to)
(:documentation
"Given a Protobufs schema or message and the name of an enum type,
returns the Protobufs enum corresponding to the type."))
-(defmethod find-enum ((schema protobuf-schema) (type symbol))
+(defmethod find-enum ((schema protobuf-schema) (type symbol) &optional relative-to)
+ (declare (ignore relative-to))
(labels ((find-it (schema)
(let ((enum (find type (proto-enums schema) :key #'proto-class)))
(when enum
(map () #'find-it (proto-imported-schemas schema)))))
(find-it schema)))
-(defmethod find-enum ((schema protobuf-schema) (name string))
- (labels ((find-it (schema)
- (let ((enum (find-qualified-name name (proto-enums schema))))
- (when enum
- (return-from find-enum enum))
- (map () #'find-it (proto-imported-schemas schema)))))
- (find-it schema)))
-
-(defgeneric find-message (protobuf type)
+(defmethod find-enum ((schema protobuf-schema) (name string) &optional relative-to)
+ (let ((relative-to (or relative-to schema)))
+ (labels ((find-it (schema)
+ (let ((enum (find-qualified-name name (proto-enums schema)
+ :relative-to relative-to)))
+ (when enum
+ (return-from find-enum enum))
+ (map () #'find-it (proto-imported-schemas schema)))))
+ (find-it schema))))
+
+(defgeneric find-message (protobuf type &optional relative-to)
(:documentation
"Given a Protobufs schema or message and a type name or class name,
returns the Protobufs message corresponding to the type."))
-(defmethod find-message ((schema protobuf-schema) (type symbol))
+(defmethod find-message ((schema protobuf-schema) (type symbol) &optional relative-to)
+ (declare (ignore relative-to))
;; Extended messages "shadow" non-extended ones
(labels ((find-it (schema)
(let ((message (or (find type (proto-extenders schema) :key #'proto-class)
(map () #'find-it (proto-imported-schemas schema)))))
(find-it schema)))
-(defmethod find-message ((schema protobuf-schema) (type class))
- (find-message schema (class-name type)))
-
-(defmethod find-message ((schema protobuf-schema) (name string))
- (labels ((find-it (schema)
- (let ((message (or (find-qualified-name name (proto-extenders schema))
- (find-qualified-name name (proto-messages schema)))))
- (when message
- (return-from find-message message))
- (map () #'find-it (proto-imported-schemas schema)))))
- (find-it schema)))
+(defmethod find-message ((schema protobuf-schema) (type class) &optional relative-to)
+ (find-message schema (class-name type) (or relative-to schema)))
+
+(defmethod find-message ((schema protobuf-schema) (name string) &optional relative-to)
+ (let ((relative-to (or relative-to schema)))
+ (labels ((find-it (schema)
+ (let ((message (or (find-qualified-name name (proto-extenders schema)
+ :relative-to relative-to)
+ (find-qualified-name name (proto-messages schema)
+ :relative-to relative-to))))
+ (when message
+ (return-from find-message message))
+ (map () #'find-it (proto-imported-schemas schema)))))
+ (find-it schema))))
(defgeneric find-service (protobuf name)
(:documentation
:initarg :value
:initform nil)
(type :type (or null symbol) ;(optional) Lisp type,
- :reader proto-type ; one of string, integer, sybol (for now)
+ :reader proto-type ; one of string, integer, float, symbol (for now)
:initarg :type
:initform 'string))
(:documentation
(make-load-form-saving-slots o :environment environment))
(defmethod print-object ((o protobuf-option) stream)
- (print-unreadable-object (o stream :type t :identity t)
- (format stream "~A~@[ = ~S~]" (proto-name o) (proto-value o))))
+ (if *print-escape*
+ (print-unreadable-object (o stream :type t :identity t)
+ (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 name :value value :type type))
(defgeneric find-option (protobuf name)
(:documentation
(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 name value type)))))))
+
+(defmethod add-option ((options list) (name string) value &optional (type 'string))
+ (let ((option (find name options :key #'proto-name :test #'option-name=)))
+ (append (remove option options)
+ (list (make-option name value type)))))
+
(defgeneric remove-options (protobuf &rest names)
(:documentation
"Given a Protobufs schema, message, enum, etc and a set of option names,
(make-load-form-saving-slots e :environment environment))
(defmethod print-object ((e protobuf-enum) stream)
- (print-unreadable-object (e stream :type t :identity t)
- (format stream "~S~@[ (alias for ~S)~]"
- (proto-class e) (proto-alias-for e))))
+ (if *print-escape*
+ (print-unreadable-object (e stream :type t :identity t)
+ (format stream "~S~@[ (alias for ~S)~]"
+ (and (slot-boundp e 'class) (proto-class e)) (proto-alias-for e)))
+ (format stream "~S"
+ (and (slot-boundp e 'class) (proto-class e)))))
+
+(defmethod make-qualified-name ((enum protobuf-enum) name)
+ ;; The qualified name is the enum name "dot" the name
+ (let ((qual-name (strcat (proto-name enum) "." name)))
+ (if (proto-parent enum)
+ ;; If there's a parent for this enum (either a message or
+ ;; the schema), prepend the name (or package) of the parent
+ (make-qualified-name (proto-parent enum) qual-name)
+ ;; Guard against a message in the middle of nowhere
+ qual-name)))
;; A Protobufs value within an enumeration
(make-load-form-saving-slots v :environment environment))
(defmethod print-object ((v protobuf-enum-value) stream)
- (print-unreadable-object (v stream :type t :identity t)
- (format stream "~A = ~D"
- (proto-name v) (proto-index v))))
+ (if *print-escape*
+ (print-unreadable-object (v stream :type t :identity t)
+ (format stream "~A = ~D"
+ (proto-name v) (proto-index v)))
+ (format stream "~A" (proto-name v))))
;; A Protobufs message
(defclass protobuf-message (base-protobuf)
- ((parent :type (or protobuf-schema protobuf-message)
- :accessor proto-parent
- :initarg :parent)
- (conc :type (or null string) ;the conc-name used for Lisp accessors
+ ((conc :type (or null string) ;the conc-name used for Lisp accessors
:accessor proto-conc-name
:initarg :conc-name
:initform nil)
(message-type :type (member :message :group :extends)
:accessor proto-message-type
:initarg :message-type
- :initform :message))
+ :initform :message)
+ (aliases :type (list-of protobuf-type-alias) ;type aliases, a Lisp extension
+ :accessor proto-type-aliases
+ :initarg :type-aliases
+ :initform ()))
(:documentation
"The model class that represents a Protobufs message."))
(defmethod make-load-form ((m protobuf-message) &optional environment)
- (with-slots (class name message-type) m
+ (with-slots (class message-type) m
(multiple-value-bind (constructor initializer)
(make-load-form-saving-slots m :environment environment)
(values (if (eq message-type :extends)
constructor
`(let ((m ,constructor))
- (record-protobuf m ',class ',name ',message-type)
+ (record-protobuf m ',class ',message-type)
m))
initializer))))
-(defmethod record-protobuf ((message protobuf-message) &optional class name type)
+(defmethod record-protobuf ((message protobuf-message) &optional class type)
;; No need to record an extension, it's already been recorded
(let ((class (or class (proto-class message)))
- (name (or name (proto-name message)))
(type (or type (proto-message-type message))))
(unless (eq type :extends)
(when class
- (setf (gethash class *all-messages*) message))
- (when name
- (setf (gethash name *all-messages*) message)))))
+ (setf (gethash class *all-messages*) message)))))
(defmethod print-object ((m protobuf-message) stream)
- (print-unreadable-object (m stream :type t :identity t)
- (format stream "~S~@[ (alias for ~S)~]~@[ (group~*)~]~@[ (extended~*)~]"
- (proto-class m) (proto-alias-for m)
- (eq (proto-message-type m) :group)
- (eq (proto-message-type m) :extends))))
+ (if *print-escape*
+ (print-unreadable-object (m stream :type t :identity t)
+ (format stream "~S~@[ (alias for ~S)~]~@[ (group~*)~]~@[ (extended~*)~]"
+ (and (slot-boundp m 'class) (proto-class m))
+ (proto-alias-for m)
+ (eq (proto-message-type m) :group)
+ (eq (proto-message-type m) :extends)))
+ (format stream "~S" (and (slot-boundp m 'class) (proto-class m)))))
(defmethod proto-package ((message protobuf-message))
(and (proto-parent message)
(proto-lisp-package (proto-parent message))))
(defmethod make-qualified-name ((message protobuf-message) name)
- ;; If there's a parent for this message (there should be -- the schema),
- ;; make a partially qualified name of message name "dot" name, then
- ;; ask the parent to add its own qualifiers
- (if (proto-parent message)
- (make-qualified-name (proto-parent message) (strcat (proto-name message) "." name))
- (strcat (proto-name message) "." name)))
-
-(defmethod find-message ((message protobuf-message) (type symbol))
+ ;; The qualified name is the message name "dot" the name
+ (let ((qual-name (strcat (proto-name message) "." name)))
+ (if (proto-parent message)
+ ;; If there's a parent for this message (either a message or
+ ;; the schema), prepend the name (or package) of the parent
+ (make-qualified-name (proto-parent message) qual-name)
+ ;; Guard against a message in the middle of nowhere
+ qual-name)))
+
+(defmethod find-message ((message protobuf-message) (type symbol) &optional relative-to)
;; Extended messages "shadow" non-extended ones
(or (find type (proto-extenders message) :key #'proto-class)
(find type (proto-messages message) :key #'proto-class)
- (find-message (proto-parent message) type)))
+ (find-message (proto-parent message) type (or relative-to message))))
-(defmethod find-message ((message protobuf-message) (type class))
- (find-message message (class-name type)))
+(defmethod find-message ((message protobuf-message) (type class) &optional relative-to)
+ (find-message message (class-name type) (or relative-to message)))
-(defmethod find-message ((message protobuf-message) (name string))
- (or (find-qualified-name name (proto-extenders message))
- (find-qualified-name name (proto-messages message))
- (find-message (proto-parent message) name)))
+(defmethod find-message ((message protobuf-message) (name string) &optional relative-to)
+ (let ((relative-to (or relative-to message)))
+ (or (find-qualified-name name (proto-extenders message)
+ :relative-to relative-to)
+ (find-qualified-name name (proto-messages message)
+ :relative-to relative-to)
+ (find-message (proto-parent message) name relative-to))))
-(defmethod find-enum ((message protobuf-message) type)
+(defmethod find-enum ((message protobuf-message) type &optional relative-to)
(or (find type (proto-enums message) :key #'proto-class)
- (find-enum (proto-parent message) type)))
+ (find-enum (proto-parent message) type (or relative-to message))))
-(defmethod find-enum ((message protobuf-message) (name string))
- (or (find-qualified-name name (proto-enums message))
- (find-enum (proto-parent message) name)))
+(defmethod find-enum ((message protobuf-message) (name string) &optional relative-to)
+ (let ((relative-to (or relative-to message)))
+ (or (find-qualified-name name (proto-enums message)
+ :relative-to relative-to)
+ (find-enum (proto-parent message) name relative-to))))
-(defgeneric find-field (message name)
+(defgeneric find-field (message name &optional relative-to)
(:documentation
"Given a Protobufs message and a slot name, field name or index,
returns the Protobufs field having that name."))
-(defmethod find-field ((message protobuf-message) (name symbol))
+(defmethod find-field ((message protobuf-message) (name symbol) &optional relative-to)
+ (declare (ignore relative-to))
(find name (proto-fields message) :key #'proto-value))
-(defmethod find-field ((message protobuf-message) (name string))
- (find-qualified-name name (proto-fields message) :lisp-key #'proto-value))
+(defmethod find-field ((message protobuf-message) (name string) &optional relative-to)
+ (find-qualified-name name (proto-fields message)
+ :relative-to (or relative-to message)))
-(defmethod find-field ((message protobuf-message) (index integer))
+(defmethod find-field ((message protobuf-message) (index integer) &optional relative-to)
+ (declare (ignore relative-to))
(find index (proto-fields message) :key #'proto-index))
(make-load-form-saving-slots f :environment environment))
(defmethod print-object ((f protobuf-field) stream)
- (print-unreadable-object (f stream :type t :identity t)
- (format stream "~S :: ~S = ~D~@[ (group~*)~]~@[ (extended~*)~]"
- (proto-value f) (proto-class f) (proto-index f)
- (eq (proto-message-type f) :group)
- (eq (proto-message-type f) :extends))))
+ (if *print-escape*
+ (print-unreadable-object (f stream :type t :identity t)
+ (format stream "~S :: ~S = ~D~@[ (group~*)~]~@[ (extended~*)~]"
+ (proto-value f)
+ (and (slot-boundp f 'class) (proto-class f))
+ (proto-index f)
+ (eq (proto-message-type f) :group)
+ (eq (proto-message-type f) :extends)))
+ (format stream "~S" (proto-value f))))
;; The 'value' slot really holds the name of the slot,
;; so let's give it a better name
(eq default $empty-vector)
;; Special handling for imported CLOS classes
(and (not (eq (proto-required field) :optional))
- (or (null default) (equal default #())))))))
+ (or (null default) (equalp default #())))))))
(defgeneric vector-field-p (field)
(:documentation
(defmethod print-object ((e protobuf-extension) stream)
(print-unreadable-object (e stream :type t :identity t)
(format stream "~D - ~D"
- (proto-extension-from e) (proto-extension-from e))))
+ (proto-extension-from e) (proto-extension-to e))))
;; A Protobufs service
(make-load-form-saving-slots s :environment environment))
(defmethod print-object ((s protobuf-service) stream)
- (print-unreadable-object (s stream :type t :identity t)
- (format stream "~A"
- (proto-name s))))
+ (if *print-escape*
+ (print-unreadable-object (s stream :type t :identity t)
+ (format stream "~S" (proto-name s)))
+ (format stream "~S" (proto-name s))))
(defgeneric find-method (service name)
(:documentation
:accessor proto-output-name
:initarg :output-name
:initform nil)
+ (stype :type (or symbol null) ;the Lisp type name of the "streams" type
+ :accessor proto-streams-type
+ :initarg :streams-type
+ :initform nil)
+ (sname :type (or null string) ;the Protobufs name of the "streams" type
+ :accessor proto-streams-name
+ :initarg :streams-name
+ :initform nil)
(index :type (unsigned-byte 32) ;an identifying index for this method
- :accessor proto-index ; (used by Stubby)
+ :accessor proto-index ; (used by the RPC implementation)
:initarg :index))
(:documentation
"The model class that represents one method with a Protobufs service."))
(make-load-form-saving-slots m :environment environment))
(defmethod print-object ((m protobuf-method) stream)
- (print-unreadable-object (m stream :type t :identity t)
- (format stream "~S (~S) => (~S)"
- (proto-class m) (proto-input-type m) (proto-output-type m))))
+ (if *print-escape*
+ (print-unreadable-object (m stream :type t :identity t)
+ (format stream "~S (~S) => (~S)"
+ (proto-class m)
+ (and (slot-boundp m 'itype) (proto-input-type m))
+ (and (slot-boundp m 'otype) (proto-output-type m))))
+ (format stream "~S" (proto-class m))))
+
+
+;;; Lisp-only extensions
+
+;; A Protobufs message
+(defclass protobuf-type-alias (base-protobuf)
+ ((lisp-type :reader proto-lisp-type ;a Lisp type specifier
+ :initarg :lisp-type)
+ (proto-type :reader proto-proto-type ;a .proto type specifier
+ :initarg :proto-type)
+ (proto-type-str :reader proto-proto-type-str
+ :initarg :proto-type-str)
+ (serializer :reader proto-serializer ;Lisp -> Protobufs conversion function
+ :initarg :serializer)
+ (deserializer :reader proto-deserializer ;Protobufs -> Lisp conversion function
+ :initarg :deserializer))
+ (:documentation
+ "The model class that represents a Protobufs type alias."))
+
+(defmethod make-load-form ((m protobuf-type-alias) &optional environment)
+ (make-load-form-saving-slots m :environment environment))
+
+(defmethod print-object ((m protobuf-type-alias) stream)
+ (if *print-escape*
+ (print-unreadable-object (m stream :type t :identity t)
+ (format stream "~S (maps ~S to ~S)"
+ (proto-class m)
+ (proto-lisp-type m) (proto-proto-type m)))
+ (format stream "~S" (proto-class m))))
+
+(defgeneric find-type-alias (protobuf type)
+ (:documentation
+ "Given a Protobufs schema or message and the name of a type alias,
+ returns the Protobufs type alias corresponding to the name."))
+
+(defmethod find-type-alias ((schema protobuf-schema) (type symbol))
+ (labels ((find-it (schema)
+ (let ((alias (find type (proto-type-aliases schema) :key #'proto-class)))
+ (when alias
+ (return-from find-type-alias alias))
+ (map () #'find-it (proto-imported-schemas schema)))))
+ (find-it schema)))
+
+(defmethod find-type-alias ((message protobuf-message) type)
+ (or (find type (proto-type-aliases message) :key #'proto-class)
+ (find-type-alias (proto-parent message) type)))
projects / cl-protobufs.git / blobdiff