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 "proto")
  71     ;; No ':proto-pathname', the path of the protobuf file
  72     ;; defaults to that of the Lisp file with a ".proto" suffix
  73     (make-pathname :type "proto" :defaults (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 (defmethod input-files ((op proto-to-lisp) (component protobuf-file))
  90   "The input file is just the .proto file."
  91   (list (protobuf-input-file component)))
  92
  93 (defmethod output-files ((op proto-to-lisp) (component protobuf-file))
  94   "The output file gets stored where .fasl files are stored."
  95   (values (list (component-pathname component))
  96           nil))
  97
  98 (defmethod perform ((op proto-to-lisp) (component protobuf-file))
  99   (let* ((input  (protobuf-input-file component))
 100          (output (first (output-files op component)))
 101          (paths  (cons (directory-namestring input) (resolve-search-path component)))
 102          (proto-impl:*protobuf-search-path* paths)
 103          (proto-impl:*protobuf-output-path* output))
 104     (dolist (path paths (error 'compile-failed
 105                           :component component :operation op))
 106       (let ((proto (make-pathname :type "proto" :defaults (merge-pathnames* path (pathname input))))
 107             (lisp  (make-pathname :type "lisp"  :defaults output)))
 108         (when (probe-file proto)
 109           (return-from perform
 110             (proto-impl:parse-protobuf-file proto lisp
 111                                             :conc-name (proto-conc-name component))))))))
 112
 113 (defmethod operation-description ((op proto-to-lisp) (component protobuf-file))
 114   (format nil (compatfmt "~@<proto-compiling ~3i~_~A~@:>")
 115           (make-pathname :name (pathname-name (component-pathname component))
 116                          :type "proto"
 117                          :defaults (first (output-files op component)))))
 118
 119 (defmethod perform ((op compile-op) (component protobuf-file))
 120   (let* ((input  (protobuf-input-file component))
 121          (output (first (output-files op component)))
 122          (lisp   (make-pathname :type "lisp" :defaults output))
 123          (fasl   output)
 124          (paths  (cons (directory-namestring input) (resolve-search-path component)))
 125          (proto-impl:*protobuf-search-path* paths)
 126          (proto-impl:*protobuf-output-path* output)
 127          (*compile-file-warnings-behaviour* (operation-on-warnings op))
 128          (*compile-file-failure-behaviour* (operation-on-failure op)))
 129     (multiple-value-bind (output warnings-p failure-p)
 130         (apply #'compile-file* lisp
 131                :output-file fasl
 132                (compile-op-flags op))
 133       (when warnings-p
 134         (case (operation-on-warnings op)
 135           (:warn  (warn "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>" op component))
 136           (:error (error 'compile-warned
 137                          :component component :operation op))
 138           (:ignore nil)))
 139       (when failure-p
 140         (case (operation-on-failure op)
 141           (:warn  (warn "~@<COMPILE-FILE failed while performing ~A on ~A.~@:>" op component))
 142           (:error (error 'compile-failed
 143                          :component component :operation op))
 144           (:ignore nil)))
 145       (unless output
 146         (error 'compile-error
 147                :component component :operation op)))))
 148
 149 (defmethod operation-description ((op compile-op) (component protobuf-file))
 150   (format nil (compatfmt "~@<compiling ~3i~_~A~@:>")
 151           (make-pathname :name (pathname-name (component-pathname component))
 152                          :type "lisp"
 153                          :defaults (first (output-files op component)))))
 154
 155 \f
 156 ;;; Processing of imports
 157
 158 (in-package "PROTO-IMPL")
 159
 160 (defun parse-protobuf-file (protobuf-file lisp-file &key (conc-name ""))
 161   (let ((schema (parse-schema-from-file protobuf-file :conc-name conc-name)))
 162     (with-open-file (stream lisp-file
 163                      :direction :output
 164                      :if-exists :supersede
 165                      :external-format :utf-8
 166                      :element-type 'character)
 167       (write-schema schema :stream stream :type :lisp)))
 168   lisp-file)
 169
 170 ;; Process 'import' lines
 171 (defun process-imports (schema imports
 172                         &key (search-path *protobuf-search-path*)
 173                              (output-path *protobuf-output-path*))
 174   "Imports all of the files given by 'imports'.
 175    If the file is a .proto file, it first parses it and writes a .lisp file.
 176    The .lisp file is the compiled and loaded."
 177   (dolist (import imports)
 178     (block import-one
 179       (let* ((import      (pathname import))
 180              (import-name (pathname-name import))
 181              (imported    (find-schema (class-name->proto import-name))))
 182         ;; If this schema has already been imported somewhere else,
 183         ;; mark it as imported here and carry on
 184         (when imported
 185           (setf (proto-imported-schemas schema)
 186                 (nconc (proto-imported-schemas schema) (list imported)))
 187           (return-from import-one))
 188         (dolist (path search-path (error "Could not import ~S" import))
 189           (let* ((base-path  (asdf:merge-pathnames* import path))
 190                  (proto-file (make-pathname :name import-name :type "proto"
 191                                             :defaults base-path))
 192                  (lisp-file  (if output-path
 193                                (make-pathname :name import-name :type "lisp"
 194                                               :directory (pathname-directory output-path))
 195                                (make-pathname :type "lisp" :defaults base-path)))
 196                  (fasl-file  (compile-file-pathname lisp-file))
 197                  (asdf:*asdf-verbose* nil)      ;for safe-file-write-date
 198                  (proto-date (asdf::safe-file-write-date proto-file))
 199                  (lisp-date  (asdf::safe-file-write-date lisp-file))
 200                  (fasl-date  (asdf::safe-file-write-date fasl-file)))
 201             (when (probe-file proto-file)
 202               (let ((*protobuf-pathname* proto-file))
 203                 (when (string= (pathname-type base-path) "proto")
 204                   ;; The user asked to import a .proto file
 205                   ;; If there's no .lisp file or an older .lisp file, parse the .proto file now
 206                   (cond ((not proto-date)
 207                          (warn "Could not find the .proto file to be imported: ~A" proto-file))
 208                         ((or (not lisp-date)
 209                              (< lisp-date proto-date))
 210                          (parse-protobuf-file proto-file lisp-file)
 211                          (setq lisp-date (file-write-date lisp-file)))))
 212                 ;; Compile the .lisp file, if necessary
 213                 (cond ((not lisp-date)
 214                        (unless (string= (pathname-type base-path) "proto")
 215                          (warn "Could not find the .lisp file to be compiled: ~A" lisp-file)))
 216                       (t
 217                        (when (or (not fasl-date)
 218                                  (< fasl-date lisp-date))
 219                          (let ((*compile-file-pathname* lisp-file)
 220                                (*load-pathname* nil))
 221                            (setq fasl-file (compile-file lisp-file)))
 222                          (setq fasl-date (file-write-date fasl-file)))
 223                        ;; Now we can load the .fasl file
 224                        (let ((*compile-file-pathname* nil)
 225                              (*load-pathname* fasl-file))
 226                          (load fasl-file)))))
 227               (let* ((imported (find-schema base-path)))
 228                 (when imported
 229                   (setf (proto-imported-schemas schema)
 230                         (nconc (proto-imported-schemas schema) (list imported))))
 231                 (return-from import-one)))))))))