asdf-support.lisp

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;;;                                                                  ;;;
   3 ;;; Free Software published under an MIT-like license. See LICENSE   ;;;
   4 ;;;                                                                  ;;;
   5 ;;; Copyright (c) 2012 Google, Inc.  All rights reserved.            ;;;
   6 ;;;                                                                  ;;;
   7 ;;; Original author: Scott McKay                                     ;;;
   8 ;;; Based on work by: Robert Brown, Francois-Rene Rideau             ;;;
   9 ;;;                                                                  ;;;
  10 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  11
  12 (in-package "ASDF")
  13
  14
  15 ;;; ASDF support for CL-Protobufs
  16
  17 (defclass protobuf-file (cl-source-file)
  18   ((type :initform "proto")             ;default file type
  19    ;; If non-nil, use this relative pathname
  20    (proto-pathname :accessor proto-relative-pathname
  21                    :initform nil
  22                    :initarg :proto-pathname
  23                    :documentation "Relative pathname giving the location of the .proto file")
  24    ;; A search path to try when looking for system-provided .proto files
  25    (search-path :accessor proto-search-path
  26                 :initform ()
  27                 :initarg :search-path
  28                 :documentation
  29                 "List of directories where the protocol buffer compiler should search
  30                  for imported protobuf files.  Relative pathnames are treated as relative
  31                  to the directory containing the DEFSYSTEM form in which they appear.")
  32    (conc-name :accessor proto-conc-name
  33               :initform ""
  34               :initarg :conc-name))
  35   (:documentation
  36    "This ASDF component defines PROTO-TO-LISP, COMPILE-OP and LOAD-OP
  37     operations that compile the .proto file into a .lisp file. The .lisp
  38     file is then compiled, and possibly loaded, as well."))
  39
  40 (defclass proto-to-lisp (compile-op) ()
  41   (:documentation
  42    "The ASDF operation that compiles a .proto file containing Protocol Buffers
  43     definitions into a .lisp source file."))
  44
  45 (defmethod component-depends-on ((op compile-op) (component protobuf-file))
  46   "Compiling a protocol buffer file depends on generating Lisp source code for it."
  47   (if (typep op 'proto-to-lisp)
  48     (call-next-method)
  49     `((proto-to-lisp ,(component-name component))
  50       ,@(call-next-method))))
  51
  52 (defmethod component-depends-on ((op load-op) (component protobuf-file))
  53   "Loading a protocol buffer file depends on generating Lisp source code for it."
  54   `((proto-to-lisp ,(component-name component))
  55     ,@(call-next-method)))
  56
  57 (defmethod component-self-dependencies :around ((op load-op) (component protobuf-file))
  58   (remove-if #'(lambda (x)
  59                  (eq (car x) 'proto-to-lisp))
  60              (call-next-method)))
  61
  62 (defun protobuf-input-file (component)
  63   "Returns the pathname of the protocol buffer definition file that must be
  64    translated into Lisp source code for this PROTO-FILE component."
  65   (check-type component protobuf-file)
  66   (if (proto-relative-pathname component)
  67     ;; Path was specified with ':proto-pathname'
  68     (subpathname (component-pathname (component-parent component))
  69                  (proto-relative-pathname component)
  70                  :type (source-file-explicit-type component))
  71     ;; No ':proto-pathname', the path of the protobuf file
  72     ;; defaults to the component-pathname, with its automatic type "proto"
  73     (component-pathname component)))
  74
  75 (defun resolve-search-path (component)
  76   (check-type component protobuf-file)
  77   (let* ((search-path (proto-search-path component))
  78          (parent-path (component-pathname (component-parent component))))
  79     (mapcar #'(lambda (path)
  80                 (resolve-relative-pathname path parent-path))
  81             search-path)))
  82
  83 (defun resolve-relative-pathname (path parent-path)
  84   "When 'path' doesn't have an absolute directory component,
  85    treat it as relative to 'parent-path'."
  86   (pathname-directory-pathname
  87    (merge-pathnames* path parent-path)))
  88
  89 (defun protobuf-mangle-name (input-file)
  90   (let ((directory (pathname-directory input-file)))
  91     (format nil "~{~A-~}~A-~A"
  92             (if (eq (first directory) :absolute)
  93               (rest directory)
  94               directory)
  95             (pathname-name input-file)
  96             (pathname-type input-file))))
  97
  98 (defun protobuf-lispize-pathname (input-file)
  99   (make-pathname
 100    :name (protobuf-mangle-name input-file)
 101    :type "lisp"
 102    :defaults input-file))
 103
 104 (defmethod input-files ((op proto-to-lisp) (component protobuf-file))
 105   "The input file is just the .proto file."
 106   (declare (ignorable op))
 107   (list (protobuf-input-file component)))
 108
 109 (defmethod output-files ((op proto-to-lisp) (component protobuf-file))
 110   "The output file is a .lisp file and a .proto-imports file with dependency data,
 111    stored where .fasl files are stored"
 112   (declare (ignorable op))
 113   (let* ((base-pathname (component-pathname component))
 114          (lisp-file (protobuf-lispize-pathname base-pathname)))
 115     (values (list lisp-file
 116                   (make-pathname :type "proto-imports"
 117                                  :defaults lisp-file))
 118             nil)))
 119
 120 (defmethod perform ((op proto-to-lisp) (component protobuf-file))
 121   (let* ((input  (protobuf-input-file component))
 122          (output (first (output-files op component)))
 123          (paths  (cons (directory-namestring input) (resolve-search-path component)))
 124          (proto-impl:*protobuf-search-path* paths)
 125          (proto-impl:*protobuf-output-path* output))
 126     (dolist (path paths (error 'compile-failed
 127                           :component component :operation op))
 128       (let ((proto (merge-pathnames* path input)))
 129         (destructuring-bind (lisp imports)
 130             (output-files op component)
 131           (when (probe-file proto)
 132             (return-from perform
 133               (proto-impl:parse-protobuf-file proto lisp imports
 134                                               :conc-name (proto-conc-name component)))))))))
 135
 136 (defmethod operation-description ((op proto-to-lisp) (component protobuf-file))
 137   (format nil (compatfmt "~@<proto-compiling ~3i~_~A~@:>")
 138           (first (input-files op component))))
 139
 140 (defmethod input-files ((op compile-op) (component protobuf-file))
 141   "The input files are the .lisp and .proto-imports files."
 142   (declare (ignorable op))
 143   (output-files (make-instance 'proto-to-lisp) component))
 144
 145 (defmethod perform ((op compile-op) (component protobuf-file))
 146   (destructuring-bind (lisp-file imports-file) (input-files op component)
 147     (destructuring-bind (fasl-file
 148                          &optional
 149                            #+clisp lib-file
 150                            #+(or ecl mkcl) object-file
 151                            #+asdf3 warnings-file)
 152         (output-files op component)
 153       (let* ((proto-file (protobuf-input-file component))
 154              (paths  (cons (directory-namestring proto-file)
 155                            (resolve-search-path component)))
 156              (proto-impl:*protobuf-search-path* paths)
 157              (proto-impl:*protobuf-output-path* fasl-file)
 158              (*compile-file-warnings-behaviour* (operation-on-warnings op))
 159              (*compile-file-failure-behaviour* (operation-on-failure op)))
 160         (proto-impl:process-imports-from-file imports-file)
 161         (multiple-value-bind (output warnings-p failure-p)
 162             (apply #'compile-file* lisp-file
 163                    :output-file fasl-file
 164                    #+asdf3 #+asdf3
 165                    :warnings-file warnings-file
 166                    (append
 167                     #+clisp (list :lib-file lib-file)
 168                     #+(or ecl mkcl) (list :object-file object-file)
 169                     (compile-op-flags op)))
 170           #+asdf3
 171           (check-lisp-compile-results output warnings-p failure-p
 172                                       "~/asdf-action::format-action/" (list (cons op component)))
 173           #-asdf3
 174           (progn
 175             (when warnings-p
 176               (case (operation-on-warnings op)
 177                 (:warn  (warn "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>" op component))
 178                 (:error (error 'compile-warned
 179                                :component component :operation op))
 180                 (:ignore nil)))
 181             (when failure-p
 182               (case (operation-on-failure op)
 183                 (:warn  (warn "~@<COMPILE-FILE failed while performing ~A on ~A.~@:>" op component))
 184                 (:error (error 'compile-failed
 185                                :component component :operation op))
 186                 (:ignore nil)))
 187             (unless output
 188               (error 'compile-error
 189                      :component component :operation op))))))))
 190
 191 (defmethod input-files ((op load-op) (component protobuf-file))
 192   "The input files are the .fasl and .proto-imports files."
 193   (declare (ignorable op))
 194   (list (first (output-files (make-instance 'compile-op) component))       ;fasl
 195         (second (output-files (make-instance 'proto-to-lisp) component)))) ;proto-imports
 196
 197 (defmethod perform ((op load-op) (component protobuf-file))
 198   (let* ((input  (protobuf-input-file component))
 199          (paths  (cons (directory-namestring input) (resolve-search-path component)))
 200          (proto-impl:*protobuf-search-path* paths)
 201          (proto-impl:*protobuf-output-path* (first (input-files op component))))
 202     (destructuring-bind (fasl proto-imports)
 203         (input-files op component)
 204       (proto-impl:process-imports-from-file proto-imports)
 205       (let ((proto-impl:*protobuf-pathname* (protobuf-input-file component)))
 206         (load fasl)))))
 207
 208 (defmethod operation-description ((op compile-op) (component protobuf-file))
 209   (format nil (compatfmt "~@<compiling ~3i~_~A~@:>")
 210           (first (input-files op component))))
 211
 212 \f
 213 ;;; Processing of imports
 214
 215 (in-package "PROTO-IMPL")
 216
 217 (defun parse-protobuf-file (protobuf-file lisp-file imports-file &key (conc-name ""))
 218   (let ((schema (parse-schema-from-file protobuf-file :conc-name conc-name)))
 219     (with-open-file (stream lisp-file
 220                      :direction :output
 221                      :if-exists :supersede
 222                      :external-format :utf-8
 223                      :element-type 'character)
 224       (write-schema schema :stream stream :type :lisp))
 225     (with-open-file (stream imports-file
 226                      :direction :output
 227                      :if-exists :supersede
 228                      :external-format :utf-8
 229                      :element-type 'character)
 230       (with-standard-io-syntax
 231         (format stream "~W~%" (proto-imports schema)))))
 232   lisp-file)
 233
 234 ;; Process 'import' lines
 235 (defun process-imports (schema imports)
 236   "Processes the imports for a schema.
 237    If the import is a symbol, see if that resolves to an existing schema.
 238    If the import is a file (string, pathname), parse it as a .proto in the usual manner."
 239   (dolist (import imports)
 240     (let ((imported-schema (find-schema
 241                             (etypecase import
 242                               ((or string pathname)
 243                                (do-process-import (pathname import)))
 244                               (symbol import)))))
 245       (if imported-schema
 246         (appendf (proto-imported-schemas schema) (list imported-schema))
 247         (error "Could not import ~S" import)))))
 248
 249 (defun process-imports-from-file (imports-file)
 250   (when (probe-file imports-file)
 251     (let ((imports (with-open-file (stream imports-file
 252                                     :direction :input
 253                                     :external-format :utf-8
 254                                     :element-type 'character)
 255                      (with-standard-io-syntax (read stream)))))
 256       (dolist (import imports)
 257         (do-process-import (pathname import))))))
 258
 259 (defun do-process-import (import
 260                           &key (search-path *protobuf-search-path*)
 261                                (output-path *protobuf-output-path*))
 262   (dolist (path (or search-path
 263                     ;; Fallback in case someone is playing with 'parse-schema' by hand
 264                     (and (asdf::absolute-pathname-p import) (list (directory-namestring import))))
 265            (error "Could not import ~S" import))
 266     (let* ((proto-file (asdf::merge-pathnames* import path))
 267            (lisp-file (if output-path
 268                         (asdf::lispize-pathname
 269                          (make-pathname :name (asdf::protobuf-mangle-name proto-file)
 270                                         :directory (pathname-directory output-path)))
 271                         (asdf::protobuf-lispize-pathname proto-file)))
 272            (imports-file (make-pathname :type "proto-imports"
 273                                         :defaults lisp-file))
 274            (fasl-file  (compile-file-pathname lisp-file))
 275            #-asdf3 (asdf:*asdf-verbose* nil)    ;for safe-file-write-date
 276            (proto-date (asdf::safe-file-write-date proto-file))
 277            (lisp-date  (asdf::safe-file-write-date lisp-file))
 278            (fasl-date  (asdf::safe-file-write-date fasl-file))
 279            (imports-date  (asdf::safe-file-write-date imports-file)))
 280       (when (probe-file proto-file)
 281         (when (find-schema proto-file)
 282           (return proto-file))
 283         (let ((*protobuf-pathname* proto-file))
 284           ;; The user asked to import a .proto file
 285           ;; If there's no .lisp file or an older .lisp file, or no
 286           ;; .proto-imports file or an older .proto-imports file parse
 287           ;; the .proto file now.
 288           ;; If we did not parse the .proto file, process the generated
 289           ;; .proto-imports file now.
 290           (cond ((not proto-date)
 291                  (warn "Could not find the .proto file to be imported: ~A" proto-file))
 292                 ((or (not (and lisp-date imports-date))
 293                      (< lisp-date proto-date)
 294                      (< imports-date proto-date))
 295                  (parse-protobuf-file proto-file lisp-file imports-file)
 296                  (setq lisp-date (file-write-date lisp-file))
 297                  (setq imports-date (file-write-date imports-file)))
 298                 (t
 299                  (process-imports-from-file imports-file)))
 300           ;; Compile the .lisp file, if necessary
 301           (cond ((not lisp-date)
 302                  (warn "Could not find the .lisp file to be compiled: ~A" lisp-file))
 303                 (t
 304                  (when (or (not fasl-date)
 305                            (< fasl-date lisp-date))
 306                    (let ((*compile-file-pathname* lisp-file)
 307                          (*load-pathname* nil))
 308                      (setq fasl-file (compile-file lisp-file)))
 309                    (setq fasl-date (file-write-date fasl-file)))))
 310           ;; Load the .fasl file
 311           (cond ((not fasl-date)
 312                  (warn "Could not find the .fasl file to be loaded: ~A" fasl-file))
 313                 (t
 314                  (let ((*compile-file-pathname* nil)
 315                        (*load-pathname* fasl-file))
 316                    (load fasl-file)))))
 317         (return proto-file)))))