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

4
(asdf/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
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
17
   #:perform #:perform-with-restarts #:retry #:accept
18
   #:traverse-actions #:traverse-sub-actions #:required-components ;; in plan
19
20
21
22
   #:action-path #:find-action #:stamp #:done-p
   ;; condition
   #:operation-definition-error
   ))
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
122
123
124
125
        <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
        a component name or a component object.  Finally, the degenerate case of
        (<operation>) is treated as a no-op.]

      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
137

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

139
  (defmethod component-depends-on ((o operation) (c component))
140
    (cdr (assoc (type-of o) (component-in-order-to c))))) ; User-specified in-order dependencies
141
142


143
144
;;;; upward-operation, downward-operation, sideway-operation, selfward-operation
;; These together handle actions that propagate along the component hierarchy or operation universe.
145
146
147
(with-upgradability ()
  (defclass downward-operation (operation)
    ((downward-operation
148
      :initform nil :reader downward-operation
149
      :type operation-designator :allocation :class))
150
151
152
153
154
155
    (: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."))
156
157
  (defmethod component-depends-on ((o downward-operation) (c parent-component))
    `((,(or (downward-operation o) o) ,@(component-children c)) ,@(call-next-method)))
158

159
160
  (defclass upward-operation (operation)
    ((upward-operation
161
      :initform nil :reader upward-operation
162
      :type operation-designator :allocation :class))
163
164
165
166
167
168
    (: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."))
169
170
171
172
173
  ;; For backward-compatibility reasons, a system inherits from module and is a child-component
  ;; so we must guard against this case. ASDF4: remove that.
  (defmethod component-depends-on ((o upward-operation) (c child-component))
    `(,@(if-let (p (component-parent c))
          `((,(or (upward-operation o) o) ,p))) ,@(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
186
187
  (defmethod component-depends-on ((o sideway-operation) (c component))
    `((,(or (sideway-operation o) o)
       ,@(loop :for dep :in (component-sideway-dependencies c)
188
               :collect (resolve-dependency-spec c dep)))
189
      ,@(call-next-method)))
190

191
192
  (defclass selfward-operation (operation)
    ((selfward-operation
193
      ;; NB: no :initform -- if an operation depends on others, it must explicitly specify which
194
      :type (or operation-designator list) :reader selfward-operation :allocation :class))
195
    (:documentation "A SELFWARD-OPERATION depends on another operation on the same component.
196
197
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.
198
E.g. before a component may be loaded by LOAD-OP, it must have been compiled by COMPILE-OP.
199
200
A operation-designator designates a singleton list of the designated operation;
a list of operation-designators designates the list of designated operations;
201
202
203
NIL is not a valid operation designator in that context.  Note that orderings between 
the operations in a list of SELWARD-OPERATION should be indicated separately in order
that they be scheduled properly."))
204
205
206
  (defmethod component-depends-on ((o selfward-operation) (c component))
    `(,@(loop :for op :in (ensure-list (selfward-operation o))
              :collect `(,op ,c))
207
208
209
210
211
212
213
214
215
216
217
218
219
      ,@(call-next-method)))

  (defclass non-propagating-operation (operation)
    ()
    (:documentation "A NON-PROPAGATING-OPERATION is an operation that propagates 
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
;;;---------------------------------------------------------------------------
220
221
222
223
(define-condition operation-definition-error (simple-error)
  ()
  (:documentation "Error conditions related to incorrect definitions of 
OPERATION objects."))
224
225
226
(defmethod initialize-instance :before ((obj operation) &key)
  (unless 
      (loop :for x :in '(downward-operation upward-operation sideway-operation
227
228
229
                                            selfward-operation non-propagating-operation
                                            ;; the following is a special case
                                            build-op)
230
231
232
            :when (typep obj x)
            :return t
            :finally (return nil))
233
    (error 'operation-definition-error
234
           :format-control
235
           "No dependency propagating scheme specified for operation ~a. This is likely because the OPERATION subclass of this object has not been updated for ASDF 3."
236
           :format-arguments (list obj))))
237
238
239
240
241
242
243
244

(defmethod initialize-instance :before ((obj non-propagating-operation) &key)
  (when
      (loop :for x :in '(downward-operation upward-operation sideway-operation
                                            selfward-operation)
            :when (typep obj x)
            :return t
            :finally (return nil))
245
    (error 'operation-definition-error
246
           :format-control
247
           "Inconsistent class: ~a. No class should have both NON-PROPAGATING-OPERATION and a propagating operation class as superclasses."
248
249
250
           :format-arguments
           (list
            (class-name (class-of obj))))))
251
252
253
254

;;;---------------------------------------------------------------------------
;;; End of OPERATION class checking
;;;---------------------------------------------------------------------------
255
256
257


;;;; Inputs, Outputs, and invisible dependencies
258
259
260
261
262
263
264
265
266
267
268
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
(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))
    (declare (ignorable o c))
    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))
    (declare (ignorable o c))
    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)))

303
  (defmethod input-files ((o operation) (c component))
304
305
306
    (declare (ignorable o c))
    nil)

307
308
309
310
311
312
  (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))))
313
314
315


;;;; Done performing
316
317
318
(with-upgradability ()
  (defgeneric component-operation-time (operation component)) ;; ASDF4: hide it behind plan-action-stamp
  (define-convenience-action-methods component-operation-time (operation component))
319

320
321
322
  (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,
323
324
325
326
327
328
329
330
331
332
333
334
335
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."))

336
337
338
339
  (defclass action-status ()
    ((stamp
      :initarg :stamp :reader action-stamp
      :documentation "STAMP associated with the ACTION if it has been completed already
340
in some previous image, or T if it needs to be done.")
341
342
343
344
     (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"))
345

346
347
348
349
  (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))))
350

351
352
  (defmethod component-operation-time ((o operation) (c component))
    (gethash (type-of o) (component-operation-times c)))
353

354
355
356
  (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))))
357
358
359


;;;; Perform
360
361
362
363
364
365
366
367
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
(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))
    (declare (ignorable o c))
    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))))))
398

399
;;; Generic build operation
400
401
402
(with-upgradability ()
  (defmethod component-depends-on ((o build-op) (c component))
    `((,(or (component-build-operation c) 'load-op) ,c))))
403