X-Git-Url: https://asedeno.scripts.mit.edu/gitweb/?a=blobdiff_plain;f=model-classes.lisp;h=09b0f710ca2bc139a1aaad1375b362215f43504a;hb=f9f010e9e43a0c9f90d1ce32e905f4c36b195449;hp=bc7ba08cb23675f7f3fb1c400d48412faf4be469;hpb=19d0ca1cdb0280739e5f8f9a04cdae0b48275ece;p=cl-protobufs.git diff --git a/model-classes.lisp b/model-classes.lisp index bc7ba08..09b0f71 100644 --- a/model-classes.lisp +++ b/model-classes.lisp @@ -2,7 +2,7 @@ ;;; ;;; ;;; 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 ;;; ;;; ;;; @@ -11,28 +11,26 @@ (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 @@ -46,27 +44,44 @@ (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, e.g., a schema, a message, etc.") + "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* () + "Bound to the search-path to use to resolve any relative pathnames.") + +(defvar *protobuf-output-path* () + "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 @@ -76,10 +91,13 @@ :reader proto-name :initarg :name :initform nil) - (full-name :type (or null string) ;the fully qualified name, e.g., "proto2.MessageSet" + (qual-name :type string ;the fully qualified name, e.g., "proto2.MessageSet" :accessor proto-qualified-name :initarg :qualified-name - :initform nil) + :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 @@ -87,28 +105,22 @@ (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) (lisp-key #'proto-class)) - "Find something by its string name. - First do a simple name match. - Failing that, exhaustively search qualified names." + &key (proto-key #'proto-name) (full-key #'proto-qualified-name) + 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=) - ;; 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 @@ -121,7 +133,7 @@ :accessor proto-package :initarg :package :initform nil) - (lisp-pkg :type (or null string) ;the Lisp package, from 'option lisp_package = ...' + (lisp-pkg :type (or null string) ;the Lisp package, from 'option lisp_package = ...' :accessor proto-lisp-package :initarg :lisp-package :initform nil) @@ -147,46 +159,61 @@ (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 find-enum (protobuf type) +(defgeneric make-qualified-name (proto name) + (:documentation + "Give a schema or message and a name, + generate a fully qualified name string for the name.")) + +(defmethod make-qualified-name ((schema protobuf-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 &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 @@ -194,20 +221,23 @@ (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) @@ -217,17 +247,20 @@ (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 @@ -257,7 +290,7 @@ :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 @@ -267,8 +300,15 @@ (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 @@ -288,6 +328,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 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, @@ -334,9 +396,22 @@ (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 @@ -355,17 +430,16 @@ (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) @@ -402,73 +476,103 @@ (message-type :type (member :message :group :extends) :accessor proto-message-type :initarg :message-type - :initform :message)) - (:documentation + :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)))) - -(defmethod find-message ((message protobuf-message) (type symbol)) + (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-package (proto-parent message)))) + +(defmethod proto-lisp-package ((message protobuf-message)) + (and (proto-parent message) + (proto-lisp-package (proto-parent message)))) + +(defmethod make-qualified-name ((message protobuf-message) name) + ;; 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)) @@ -550,11 +654,15 @@ (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 @@ -574,7 +682,7 @@ (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 @@ -603,7 +711,7 @@ (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 @@ -619,9 +727,10 @@ (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 @@ -660,8 +769,16 @@ :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.")) @@ -670,6 +787,56 @@ (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)))