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 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 (defmethod input-files ((op proto-to-lisp) (component protobuf-file))
  90   "The input file is just the .proto file."
  91   (declare (ignorable op))
  92   (list (protobuf-input-file component)))
  93
  94 (defmethod output-files ((op proto-to-lisp) (component protobuf-file))
  95   "The output file is a .lisp file and a .proto-imports file with dependency data,
  96    stored where .fasl files are stored"
  97   (declare (ignorable op))
  98   (let* ((base-pathname (component-pathname component))
  99          (lisp-file (make-pathname
 100                      :name (format nil "~A.proto" (pathname-name base-pathname))
 101                      :type "lisp"
 102                      :defaults base-pathname)))
 103     (values (list lisp-file
 104                   (make-pathname :type "proto-imports"
 105                                  :defaults lisp-file))
 106             nil)))
 107
 108 (defmethod perform ((op proto-to-lisp) (component protobuf-file))
 109   (let* ((input  (protobuf-input-file component))
 110          (output (first (output-files op component)))
 111          (paths  (cons (directory-namestring input) (resolve-search-path component)))
 112          (proto-impl:*protobuf-search-path* paths)
 113          (proto-impl:*protobuf-output-path* output))
 114     (dolist (path paths (error 'compile-failed
 115                           :component component :operation op))
 116       (let ((proto (make-pathname :type "proto" :defaults (merge-pathnames* path (pathname input)))))
 117         (destructuring-bind (lisp imports)
 118             (output-files op component)
 119           (when (probe-file proto)
 120             (return-from perform
 121               (proto-impl:parse-protobuf-file proto lisp imports
 122                                               :conc-name (proto-conc-name component)))))))))
 123
 124 (defmethod operation-description ((op proto-to-lisp) (component protobuf-file))
 125   (format nil (compatfmt "~@<proto-compiling ~3i~_~A~@:>")
 126           (first (input-files op component))))
 127
 128 (defmethod input-files ((op compile-op) (component protobuf-file))
 129   "The input files are the .lisp and .proto-imports files."
 130   (declare (ignorable op))
 131   (output-files (make-instance 'proto-to-lisp) component))
 132
 133 (defmethod perform ((op compile-op) (component protobuf-file))
 134   (destructuring-bind (lisp-file imports-file) (input-files op component)
 135     (destructuring-bind (fasl-file
 136                          &optional
 137                            #+clisp lib-file
 138                            #+(or ecl mkcl) object-file
 139                            #+asdf3 warnings-file)
 140         (output-files op component)
 141       (let* ((proto-file (protobuf-input-file component))
 142              (paths  (cons (directory-namestring proto-file)
 143                            (resolve-search-path component)))
 144              (proto-impl:*protobuf-search-path* paths)
 145              (proto-impl:*protobuf-output-path* fasl-file)
 146              (*compile-file-warnings-behaviour* (operation-on-warnings op))
 147              (*compile-file-failure-behaviour* (operation-on-failure op)))
 148         (proto-impl:process-imports-from-file imports-file)
 149         (multiple-value-bind (output warnings-p failure-p)
 150             (apply #'compile-file* lisp-file
 151                    :output-file fasl-file
 152                    #+asdf3 #+asdf3
 153                    :warnings-file warnings-file
 154                    (append
 155                     #+clisp (list :lib-file lib-file)
 156                     #+(or ecl mkcl) (list :object-file object-file)
 157                     (compile-op-flags op)))
 158           #+asdf3
 159           (check-lisp-compile-results output warnings-p failure-p
 160                                       "~/asdf-action::format-action/" (list (cons op component)))
 161           #-asdf3
 162           (progn
 163             (when warnings-p
 164               (case (operation-on-warnings op)
 165                 (:warn  (warn "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>" op component))
 166                 (:error (error 'compile-warned
 167                                :component component :operation op))
 168                 (:ignore nil)))
 169             (when failure-p
 170               (case (operation-on-failure op)
 171                 (:warn  (warn "~@<COMPILE-FILE failed while performing ~A on ~A.~@:>" op component))
 172                 (:error (error 'compile-failed
 173                                :component component :operation op))
 174                 (:ignore nil)))
 175             (unless output
 176               (error 'compile-error
 177                      :component component :operation op))))))))
 178
 179 (defmethod input-files ((op load-op) (component protobuf-file))
 180   "The input files are the .fasl and .proto-imports files."
 181   (declare (ignorable op))
 182   (list (first (output-files (make-instance 'compile-op) component))       ;fasl
 183         (second (output-files (make-instance 'proto-to-lisp) component)))) ;proto-imports
 184
 185 (defmethod perform ((op load-op) (component protobuf-file))
 186   (let* ((input  (protobuf-input-file component))
 187          (paths  (cons (directory-namestring input) (resolve-search-path component)))
 188          (proto-impl:*protobuf-search-path* paths)
 189          (proto-impl:*protobuf-output-path* (first (input-files op component))))
 190     (destructuring-bind (fasl proto-imports)
 191         (input-files op component)
 192       (proto-impl:process-imports-from-file proto-imports)
 193       (load fasl))))
 194
 195 (defmethod operation-description ((op compile-op) (component protobuf-file))
 196   (format nil (compatfmt "~@<compiling ~3i~_~A~@:>")
 197           (first (input-files op component))))
 198
 199 \f
 200 ;;; Processing of imports
 201
 202 (in-package "PROTO-IMPL")
 203
 204 (defun parse-protobuf-file (protobuf-file lisp-file imports-file &key (conc-name ""))
 205   (let ((schema (parse-schema-from-file protobuf-file :conc-name conc-name)))
 206     (with-open-file (stream lisp-file
 207                      :direction :output
 208                      :if-exists :supersede
 209                      :external-format :utf-8
 210                      :element-type 'character)
 211       (write-schema schema :stream stream :type :lisp))
 212     (with-open-file (stream imports-file
 213                      :direction :output
 214                      :if-exists :supersede
 215                      :external-format :utf-8
 216                      :element-type 'character)
 217       (with-standard-io-syntax
 218         (format stream "~W~%" (proto-imports schema)))))
 219   lisp-file)
 220
 221 ;; Process 'import' lines
 222 (defun process-imports (schema imports)
 223   "Imports all of the files given by 'imports'.
 224    If the file is a .proto file, it first parses it and writes a .lisp file.
 225    The .lisp file is the compiled and loaded."
 226   (dolist (import imports)
 227     (block import-one
 228       (let* ((import      (pathname import))
 229              (import-name (pathname-name import))
 230              (imported    (find-schema (class-name->proto import-name))))
 231         ;; If this schema has already been imported somewhere else,
 232         ;; mark it as imported here and carry on
 233         (when imported
 234           (appendf (proto-imported-schemas schema) (list imported))
 235           (return-from import-one))
 236         (do-process-import import import-name)
 237         (let* ((imported (find-schema (class-name->proto import-name))))
 238           (when imported
 239             (appendf (proto-imported-schemas schema) (list imported)))
 240           (return-from import-one))))))
 241
 242 (defun process-imports-from-file (imports-file)
 243   (when (probe-file imports-file)
 244     (let ((imports (with-open-file (stream imports-file
 245                                     :direction :input
 246                                     :external-format :utf-8
 247                                     :element-type 'character)
 248                      (with-standard-io-syntax (read stream)))))
 249       (dolist (import imports)
 250         (let* ((import      (pathname import))
 251                (import-name (pathname-name import)))
 252           ;; If this schema has already been loaded, we're done.
 253           (unless (find-schema (class-name->proto import-name))
 254             (do-process-import import import-name)))))))
 255
 256 (defun do-process-import (import import-name
 257                           &key (search-path *protobuf-search-path*)
 258                                (output-path *protobuf-output-path*))
 259   (dolist (path search-path (error "Could not import ~S" import))
 260     (let* ((base-path  (asdf::merge-pathnames* import path))
 261            (proto-file (make-pathname :name import-name :type "proto"
 262                                       :defaults base-path))
 263            (lisp-file  (asdf::lispize-pathname
 264                         (if output-path
 265                             (make-pathname :name import-name
 266                                            :directory (pathname-directory output-path))
 267                             base-path)))
 268            (imports-file (make-pathname :type "proto-imports"
 269                                         :defaults lisp-file))
 270            (fasl-file  (compile-file-pathname lisp-file))
 271            (asdf:*asdf-verbose* nil)    ;for safe-file-write-date
 272            (proto-date (asdf::safe-file-write-date proto-file))
 273            (lisp-date  (asdf::safe-file-write-date lisp-file))
 274            (fasl-date  (asdf::safe-file-write-date fasl-file))
 275            (imports-date  (asdf::safe-file-write-date imports-file)))
 276       (when (probe-file proto-file)
 277         (let ((*protobuf-pathname* proto-file))
 278           (when (string= (pathname-type base-path) "proto")
 279             ;; The user asked to import a .proto file
 280             ;; If there's no .lisp file or an older .lisp file, or no
 281             ;; .proto-imports file or an older .proto-imports file parse
 282             ;; the .proto file now
 283             ;; If we did not parse the .proto file, process the generated
 284             ;; .proto-imports file now.
 285             (cond ((not proto-date)
 286                    (warn "Could not find the .proto file to be imported: ~A" proto-file))
 287                   ((or (not (and lisp-date imports-date))
 288                        (< lisp-date proto-date)
 289                        (< imports-date proto-date))
 290                    (parse-protobuf-file proto-file lisp-file imports-file)
 291                    (setq lisp-date (file-write-date lisp-file))
 292                    (setq imports-date (file-write-date imports-file)))
 293                   (t
 294                    (process-imports-from-file imports-file))))
 295           ;; Compile the .lisp file, if necessary
 296           (cond ((not lisp-date)
 297                  (unless (string= (pathname-type base-path) "proto")
 298                    (warn "Could not find the .lisp file to be compiled: ~A" lisp-file)))
 299                 (t
 300                  (when (or (not fasl-date)
 301                            (< fasl-date lisp-date))
 302                    (let ((*compile-file-pathname* lisp-file)
 303                          (*load-pathname* nil))
 304                      (setq fasl-file (compile-file lisp-file)))
 305                    (setq fasl-date (file-write-date fasl-file)))))
 306           ;; Load the .fasl file
 307           (cond ((not fasl-date)
 308                  (unless (string= (pathname-type base-path) "proto")
 309                    (warn "Could not find the .fasl file to be loaded: ~A" fasl-file)))
 310                 (t
 311                  (let ((*compile-file-pathname* nil)
 312                        (*load-pathname* fasl-file))
 313                    (load fasl-file)))))
 314         (return (values))))))