;;; ;;;
;;; 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.")
(defvar *protobuf-package* nil
"The Lisp package in which the Protobufs schema is being defined.")
+(defvar *protobuf-rpc-package* nil
+ "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.
'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* ()
+(defvar *protobuf-pathname* nil
"The name of the file from where the .proto file is being parsed.")
(defvar *protobuf-search-path* ()
: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)
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=)
;;--- This needs more sophisticated search, e.g., relative to current namespace
- (find name protos :key full-key :test #'string=)
- ;; Maybe we can find the symbol in Lisp land?
- (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))))))
+ (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."))
(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
: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))
+ :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."))
(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))))
+ (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)
(find name (proto-fields message) :key #'proto-value))
(defmethod find-field ((message protobuf-message) (name string) &optional relative-to)
- (find-qualified-name name (proto-fields message) :lisp-key #'proto-value
+ (find-qualified-name name (proto-fields message)
:relative-to (or relative-to message)))
(defmethod find-field ((message protobuf-message) (index integer) &optional relative-to)
(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
(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