action.lisp 20.3 KB
Newer Older
1 2 3
;;;; -------------------------------------------------------------------------
;;;; Actions

4
(uiop/package:define-package :asdf/action
5
  (:nicknames :asdf-action)
6
  (:recycle :asdf/action :asdf)
7
  (:use :uiop/common-lisp :uiop :asdf/upgrade
8
   :asdf/component :asdf/system #:asdf/cache :asdf/find-system :asdf/find-component :asdf/operation)
9
  (:export
10
   #:action #:define-convenience-action-methods
11
   #:explain #:action-description
12
   #:downward-operation #:upward-operation #:sideway-operation #:selfward-operation #:non-propagating-operation
13
   #:component-depends-on
14 15 16
   #:input-files #:output-files #:output-file #:operation-done-p
   #:action-status #:action-stamp #:action-done-p
   #:component-operation-time #:mark-operation-done #:compute-action-stamp
17
   #:perform #:perform-with-restarts #:retry #:accept
18
   #:traverse-actions #:traverse-sub-actions #:required-components ;; in plan
19
   #:action-path #:find-action #:stamp #:done-p
20 21
   #:operation-definition-warning #:operation-definition-error ;; condition
   #:build-op ;; THE generic operation
22
   ))
23 24
(in-package :asdf/action)

25 26 27 28 29 30 31 32
(eval-when (#-lispworks :compile-toplevel :load-toplevel :execute) ;; LispWorks issues spurious warning
  (deftype action () '(cons operation component)) ;; a step to be performed while building

  (deftype operation-designator ()
    ;; an operation designates itself,
    ;; nil designates a context-dependent current operation, and
    ;; class-name or class designates an instance of the designated class.
    '(or operation null symbol class)))
33

34
(with-upgradability ()
35 36 37
  (defgeneric traverse-actions (actions &key &allow-other-keys))
  (defgeneric traverse-sub-actions (operation component &key &allow-other-keys))
  (defgeneric required-components (component &key &allow-other-keys)))
38

39 40 41 42 43 44
;;;; Reified representation for storage or debugging. Note: dropping original-initargs
(with-upgradability ()
  (defun action-path (action)
    (destructuring-bind (o . c) action (cons (type-of o) (component-find-path c))))
  (defun find-action (path)
    (destructuring-bind (o . c) path (cons (make-operation o) (find-component () c)))))
45

46 47

;;;; Convenience methods
48 49
(with-upgradability ()
  (defmacro define-convenience-action-methods
50
      (function formals &key if-no-operation if-no-component operation-initargs)
51 52
    (let* ((rest (gensym "REST"))
           (found (gensym "FOUND"))
53 54 55
           (keyp (equal (last formals) '(&key)))
           (formals-no-key (if keyp (butlast formals) formals))
           (len (length formals-no-key))
56 57 58 59 60 61
           (operation 'operation)
           (component 'component)
           (opix (position operation formals))
           (coix (position component formals))
           (prefix (subseq formals 0 opix))
           (suffix (subseq formals (1+ coix) len))
62
           (more-args (when keyp `(&rest ,rest &key &allow-other-keys))))
63
      (assert (and (integerp opix) (integerp coix) (= coix (1+ opix))))
64 65
      (flet ((next-method (o c)
               (if keyp
66 67
                   `(apply ',function ,@prefix ,o ,c ,@suffix ,rest)
                   `(,function ,@prefix ,o ,c ,@suffix))))
68
        `(progn
69
           (defmethod ,function (,@prefix (,operation symbol) component ,@suffix ,@more-args)
70 71 72 73 74 75 76
             (if ,operation
                 ,(next-method
                   (if operation-initargs ;backward-compatibility with ASDF1's operate. Yuck.
                       `(apply 'make-operation ,operation :original-initargs ,rest ,rest)
                       `(make-operation ,operation))
                   `(or (find-component () ,component) ,if-no-component))
                 ,if-no-operation))
77
           (defmethod ,function (,@prefix (,operation operation) ,component ,@suffix ,@more-args)
78 79 80
             (if (typep ,component 'component)
                 (error "No defined method for ~S on ~/asdf-action:format-action/"
                        ',function (cons ,operation ,component))
81 82 83
                 (if-let (,found (find-component () ,component))
                    ,(next-method operation found)
                    ,if-no-component))))))))
84

85 86

;;;; self-description
87 88 89
(with-upgradability ()
  (defgeneric action-description (operation component)
    (:documentation "returns a phrase that describes performing this operation
90 91
on this component, e.g. \"loading /a/b/c\".
You can put together sentences using this phrase."))
92 93 94 95 96 97 98
  (defmethod action-description (operation component)
    (format nil (compatfmt "~@<~A on ~A~@:>")
            (type-of operation) component))
  (defgeneric* (explain) (operation component))
  (defmethod explain ((o operation) (c component))
    (asdf-message (compatfmt "~&~@<; ~@;~A~:>~%") (action-description o c)))
  (define-convenience-action-methods explain (operation component))
99

100 101 102 103
  (defun format-action (stream action &optional colon-p at-sign-p)
    (assert (null colon-p)) (assert (null at-sign-p))
    (destructuring-bind (operation . component) action
      (princ (action-description operation component) stream))))
104 105 106


;;;; Dependencies
107
(with-upgradability ()
108
  (defgeneric* (component-depends-on) (operation component) ;; ASDF4: rename to component-dependencies
109 110
    (:documentation
     "Returns a list of dependencies needed by the component to perform
111 112
    the operation.  A dependency has one of the following forms:

113 114 115 116 117
      (<operation> <component>*), where <operation> is an operation designator
        with respect to FIND-OPERATION in the context of the OPERATION argument,
        and each <component> is a component designator with respect to
        FIND-COMPONENT in the context of the COMPONENT argument,
        and means that the component depends on
118 119 120 121
        <operation> having been performed on each <component>;

        [Note: an <operation> is an operation designator -- it can be either an
        operation name or an operation object.  Similarly, a <component> may be
122 123
        a component name or a component object.  Also note that, the degenerate
        case of (<operation>) is a no-op.]
124 125

      or
126 127

      (FEATURE <feature>), which means that the component depends
128 129
        on the <feature> expression satisfying FEATUREP.
        (This is DEPRECATED -- use :IF-FEATURE instead.)
130 131

    Methods specialized on subclasses of existing component types
132
    should usually append the results of CALL-NEXT-METHOD to the list."))
133
  (define-convenience-action-methods component-depends-on (operation component))
134 135 136

  (defmethod component-depends-on :around ((o operation) (c component))
    (do-asdf-cache `(component-depends-on ,o ,c)
137
      (call-next-method))))
138 139


140 141
;;;; upward-operation, downward-operation, sideway-operation, selfward-operation
;; These together handle actions that propagate along the component hierarchy or operation universe.
142 143 144
(with-upgradability ()
  (defclass downward-operation (operation)
    ((downward-operation
145
      :initform nil :reader downward-operation
146
      :type operation-designator :allocation :class))
147 148 149 150 151 152
    (:documentation "A DOWNWARD-OPERATION's dependencies propagate down the component hierarchy.
I.e., if O is a DOWNWARD-OPERATION and its DOWNWARD-OPERATION slot designates operation D, then
the action (O . M) of O on module M will depends on each of (D . C) for each child C of module M.
The default value for slot DOWNWARD-OPERATION is NIL, which designates the operation O itself.
E.g. in order for a MODULE to be loaded with LOAD-OP (resp. compiled with COMPILE-OP), all the
children of the MODULE must have been loaded with LOAD-OP (resp. compiled with COMPILE-OP."))
153 154
  (defun downward-operation-depends-on (o c)
    `((,(or (downward-operation o) o) ,@(component-children c))))
155
  (defmethod component-depends-on ((o downward-operation) (c parent-component))
156
    `(,@(downward-operation-depends-on o c) ,@(call-next-method)))
157

158 159
  (defclass upward-operation (operation)
    ((upward-operation
160
      :initform nil :reader upward-operation
161
      :type operation-designator :allocation :class))
162 163 164 165 166 167
    (:documentation "An UPWARD-OPERATION has dependencies that propagate up the component hierarchy.
I.e., if O is an instance of UPWARD-OPERATION, and its UPWARD-OPERATION slot designates operation U,
then the action (O . C) of O on a component C that has the parent P will depends on (U . P).
The default value for slot UPWARD-OPERATION is NIL, which designates the operation O itself.
E.g. in order for a COMPONENT to be prepared for loading or compiling with PREPARE-OP, its PARENT
must first be prepared for loading or compiling with PREPARE-OP."))
168 169
  ;; For backward-compatibility reasons, a system inherits from module and is a child-component
  ;; so we must guard against this case. ASDF4: remove that.
170 171
  (defun upward-operation-depends-on (o c)
    (if-let (p (component-parent c)) `((,(or (upward-operation o) o) ,p))))
172
  (defmethod component-depends-on ((o upward-operation) (c child-component))
173
    `(,@(upward-operation-depends-on o c) ,@(call-next-method)))
174

175 176
  (defclass sideway-operation (operation)
    ((sideway-operation
177
      :initform nil :reader sideway-operation
178
      :type operation-designator :allocation :class))
179 180 181 182 183 184
    (:documentation "A SIDEWAY-OPERATION has dependencies that propagate \"sideway\" to siblings
that a component depends on. I.e. if O is a SIDEWAY-OPERATION, and its SIDEWAY-OPERATION slot
designates operation S (where NIL designates O itself), then the action (O . C) of O on component C
depends on each of (S . D) where D is a declared dependency of C.
E.g. in order for a COMPONENT to be prepared for loading or compiling with PREPARE-OP,
each of its declared dependencies must first be loaded as by LOAD-OP."))
185
  (defun sideway-operation-depends-on (o c)
186 187
    `((,(or (sideway-operation o) o)
       ,@(loop :for dep :in (component-sideway-dependencies c)
188 189 190
               :collect (resolve-dependency-spec c dep)))))
  (defmethod component-depends-on ((o sideway-operation) (c component))
    `(,@(sideway-operation-depends-on o c) ,@(call-next-method)))
191

192 193
  (defclass selfward-operation (operation)
    ((selfward-operation
194
      ;; NB: no :initform -- if an operation depends on others, it must explicitly specify which
195
      :type (or operation-designator list) :reader selfward-operation :allocation :class))
196
    (:documentation "A SELFWARD-OPERATION depends on another operation on the same component.
197 198
I.e., if O is a SELFWARD-OPERATION, and its SELFWARD-OPERATION designates a list of operations L,
then the action (O . C) of O on component C depends on each (S . C) for S in L.
199
E.g. before a component may be loaded by LOAD-OP, it must have been compiled by COMPILE-OP.
200 201
A operation-designator designates a singleton list of the designated operation;
a list of operation-designators designates the list of designated operations;
202 203 204
NIL is not a valid operation designator in that context.  Note that any dependency
ordering between the operations in a list of SELFWARD-OPERATION should be specified separately
in the respective operation's COMPONENT-DEPENDS-ON methods so that they be scheduled properly."))
205 206
  (defun selfward-operation-depends-on (o c)
    (loop :for op :in (ensure-list (selfward-operation o)) :collect `(,op ,c)))
207
  (defmethod component-depends-on ((o selfward-operation) (c component))
208
    `(,@(selfward-operation-depends-on o c) ,@(call-next-method)))
209 210 211

  (defclass non-propagating-operation (operation)
    ()
212
    (:documentation "A NON-PROPAGATING-OPERATION is an operation that propagates
213 214 215 216 217 218 219 220
no dependencies whatsoever.  It is supplied in order that the programmer be able
to specify that s/he is intentionally specifying an operation which invokes no
dependencies.")))


;;;---------------------------------------------------------------------------
;;; Help programmers catch obsolete OPERATION subclasses
;;;---------------------------------------------------------------------------
221 222 223 224 225 226 227 228 229 230 231 232
(with-upgradability ()
  (define-condition operation-definition-warning (simple-warning)
    ()
    (:documentation "Warning condition related to definition of obsolete OPERATION objects."))

  (define-condition operation-definition-error (simple-error)
    ()
    (:documentation "Error condition related to definition of incorrect OPERATION objects."))

  (defmethod initialize-instance :before ((o operation) &key)
    ;; build-op is a special case.
    (unless (typep o '(or downward-operation upward-operation sideway-operation
233
                          selfward-operation non-propagating-operation))
234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254
      (warn 'operation-definition-warning
            :format-control
            "No dependency propagating scheme specified for operation class ~S.
The class needs to be updated for ASDF 3.1 and specify appropriate propagation mixins."
            :format-arguments (list (type-of o)))))

  (defmethod initialize-instance :before ((o non-propagating-operation) &key)
    (when (typep o '(or downward-operation upward-operation sideway-operation selfward-operation))
      (error 'operation-definition-error
             :format-control
             "Inconsistent class: ~S
  NON-PROPAGATING-OPERATION is incompatible with propagating operation classes as superclasses."
             :format-arguments
             (list (type-of o)))))

  (defmethod component-depends-on ((o operation) (c component))
    `(;; Normal behavior, to allow user-specified in-order-to dependencies
      ,@(cdr (assoc (type-of o) (component-in-order-to c)))
      ;; For backward-compatibility with ASDF2, any operation that doesn't specify propagation
      ;; or non-propagation through an appropriate mixin will be downward and sideway.
      ,@(unless (typep o '(or downward-operation upward-operation sideway-operation
255
                              selfward-operation non-propagating-operation))
256 257 258 259 260 261
          `(,@(downward-operation-depends-on o c)
            ,@(sideway-operation-depends-on o c)))))

  (defmethod downward-operation ((o operation)) nil)
  (defmethod sideway-operation ((o operation)) nil))

262 263 264 265

;;;---------------------------------------------------------------------------
;;; End of OPERATION class checking
;;;---------------------------------------------------------------------------
266 267 268


;;;; Inputs, Outputs, and invisible dependencies
269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311
(with-upgradability ()
  (defgeneric* (output-files) (operation component))
  (defgeneric* (input-files) (operation component))
  (defgeneric* (operation-done-p) (operation component)
    (:documentation "Returns a boolean, which is NIL if the action is forced to be performed again"))
  (define-convenience-action-methods output-files (operation component))
  (define-convenience-action-methods input-files (operation component))
  (define-convenience-action-methods operation-done-p (operation component))

  (defmethod operation-done-p ((o operation) (c component))
    t)

  (defmethod output-files :around (operation component)
    "Translate output files, unless asked not to. Memoize the result."
    operation component ;; hush genera, not convinced by declare ignorable(!)
    (do-asdf-cache `(output-files ,operation ,component)
      (values
       (multiple-value-bind (pathnames fixedp) (call-next-method)
         ;; 1- Make sure we have absolute pathnames
         (let* ((directory (pathname-directory-pathname
                            (component-pathname (find-component () component))))
                (absolute-pathnames
                  (loop
                    :for pathname :in pathnames
                    :collect (ensure-absolute-pathname pathname directory))))
           ;; 2- Translate those pathnames as required
           (if fixedp
               absolute-pathnames
               (mapcar *output-translation-function* absolute-pathnames))))
       t)))
  (defmethod output-files ((o operation) (c component))
    nil)
  (defun output-file (operation component)
    "The unique output file of performing OPERATION on COMPONENT"
    (let ((files (output-files operation component)))
      (assert (length=n-p files 1))
      (first files)))

  (defmethod input-files :around (operation component)
    "memoize input files."
    (do-asdf-cache `(input-files ,operation ,component)
      (call-next-method)))

312
  (defmethod input-files ((o operation) (c component))
313 314
    nil)

315 316 317 318 319 320
  (defmethod input-files ((o selfward-operation) (c component))
    `(,@(or (loop :for dep-o :in (ensure-list (selfward-operation o))
                  :append (or (output-files dep-o c) (input-files dep-o c)))
            (if-let ((pathname (component-pathname c)))
              (and (file-pathname-p pathname) (list pathname))))
      ,@(call-next-method))))
321 322 323


;;;; Done performing
324 325 326
(with-upgradability ()
  (defgeneric component-operation-time (operation component)) ;; ASDF4: hide it behind plan-action-stamp
  (define-convenience-action-methods component-operation-time (operation component))
327

328 329 330
  (defgeneric mark-operation-done (operation component)) ;; ASDF4: hide it behind (setf plan-action-stamp)
  (defgeneric compute-action-stamp (plan operation component &key just-done)
    (:documentation "Has this action been successfully done already,
331 332 333 334 335 336 337 338 339 340 341 342 343
and at what known timestamp has it been done at or will it be done at?
Takes two keywords JUST-DONE and PLAN:
JUST-DONE is a boolean that is true if the action was just successfully performed,
at which point we want compute the actual stamp and warn if files are missing;
otherwise we are making plans, anticipating the effects of the action.
PLAN is a plan object modelling future effects of actions,
or NIL to denote what actually happened.
Returns two values:
* a STAMP saying when it was done or will be done,
  or T if the action has involves files that need to be recomputed.
* a boolean DONE-P that indicates whether the action has actually been done,
  and both its output-files and its in-image side-effects are up to date."))

344 345 346 347
  (defclass action-status ()
    ((stamp
      :initarg :stamp :reader action-stamp
      :documentation "STAMP associated with the ACTION if it has been completed already
348
in some previous image, or T if it needs to be done.")
349 350 351 352
     (done-p
      :initarg :done-p :reader action-done-p
      :documentation "a boolean, true iff the action was already done (before any planned action)."))
    (:documentation "Status of an action"))
353

354 355 356 357
  (defmethod print-object ((status action-status) stream)
    (print-unreadable-object (status stream :type t)
      (with-slots (stamp done-p) status
        (format stream "~@{~S~^ ~}" :stamp stamp :done-p done-p))))
358

359 360
  (defmethod component-operation-time ((o operation) (c component))
    (gethash (type-of o) (component-operation-times c)))
361

362 363 364
  (defmethod mark-operation-done ((o operation) (c component))
    (setf (gethash (type-of o) (component-operation-times c))
          (compute-action-stamp nil o c :just-done t))))
365 366 367


;;;; Perform
368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404
(with-upgradability ()
  (defgeneric* (perform-with-restarts) (operation component))
  (defgeneric* (perform) (operation component))
  (define-convenience-action-methods perform (operation component))

  (defmethod perform :before ((o operation) (c component))
    (ensure-all-directories-exist (output-files o c)))
  (defmethod perform :after ((o operation) (c component))
    (mark-operation-done o c))
  (defmethod perform ((o operation) (c parent-component))
    nil)
  (defmethod perform ((o operation) (c source-file))
    (sysdef-error
     (compatfmt "~@<Required method PERFORM not implemented for operation ~A, component ~A~@:>")
     (class-of o) (class-of c)))

  (defmethod perform-with-restarts (operation component)
    ;; TOO verbose, especially as the default. Add your own :before method
    ;; to perform-with-restart or perform if you want that:
    #|(explain operation component)|#
    (perform operation component))
  (defmethod perform-with-restarts :around (operation component)
    (loop
      (restart-case
          (return (call-next-method))
        (retry ()
          :report
          (lambda (s)
            (format s (compatfmt "~@<Retry ~A.~@:>")
                    (action-description operation component))))
        (accept ()
          :report
          (lambda (s)
            (format s (compatfmt "~@<Continue, treating ~A as having been successful.~@:>")
                    (action-description operation component)))
          (mark-operation-done operation component)
          (return))))))
405

406
;;; Generic build operation
407
(with-upgradability ()
408 409 410 411 412
  ;; BUILD-OP was intended to be the default "master" operation to invoke on a system in ASDF3
  ;; (LOAD-OP typically serves that function now).
  ;; This feature has not yet been fully implemented yet, and is not used by anyone yet.
  ;; This is a path forward, and its default below is to backward compatibly depend on LOAD-OP.
  ;; [2014/01/26:rpg]
413
  (defclass build-op (non-propagating-operation) ())
414 415
  (defmethod component-depends-on ((o build-op) (c component))
    `((,(or (component-build-operation c) 'load-op) ,c))))
416