(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.")
(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 (make-pathname :type nil :defaults path) *all-schemas*)))
(defvar *all-messages* (make-hash-table :test #'equal)
;; A few things (the pretty printer) want to keep track of the current schema
-(defvar *protobuf* nil) ;this can be schema, a message, ...
-(defvar *protobuf-package* nil)
-(defvar *protobuf-conc-name* nil)
+(defvar *protobuf* nil
+ "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.")
+
+(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.
+ 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
+ "The 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.")
+
+(defvar *protobuf-output-path* ()
+ "A path to use to direct output during imports, etc.")
;;; The model classes
: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
(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
: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)
(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."))
(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*)))
+ (let ((path (or *protobuf-pathname* *compile-file-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 (make-pathname :type nil :defaults path) *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
+ "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)
+(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
(defmethod find-service ((schema protobuf-schema) (name string))
(find-qualified-name name (proto-services schema)))
+;; Convenience function that accepts a schema name
+(defmethod find-service (schema-name name)
+ (let ((schema (find-schema schema-name)))
+ (assert schema ()
+ "There is no schema named ~A" schema-name)
+ (find-service schema name)))
+
;; We accept and store any option, but only act on a few: default, packed,
;; optimize_for, lisp_package, lisp_name, lisp_alias
: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))))
(defgeneric find-option (protobuf name)
(:documentation
(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))
- (: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)
(setf (gethash name *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))
(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)))