action.lisp 16.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
13
   #:downward-operation #:upward-operation #:sideway-operation #:selfward-operation
   #: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
   #:action-path #:find-action #:stamp #:done-p))
20
21
(in-package :asdf/action)

22
23
(eval-when (#-lispworks :compile-toplevel :load-toplevel :execute)
  (deftype action () '(cons operation component))) ;; a step to be performed while building
24

25
(with-upgradability ()
26
27
28
  (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)))
29

30
31
32
33
34
35
;;;; 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)))))
36

37
38

;;;; Convenience methods
39
40
(with-upgradability ()
  (defmacro define-convenience-action-methods
41
      (function formals &key if-no-operation if-no-component operation-initargs)
42
43
    (let* ((rest (gensym "REST"))
           (found (gensym "FOUND"))
44
45
46
           (keyp (equal (last formals) '(&key)))
           (formals-no-key (if keyp (butlast formals) formals))
           (len (length formals-no-key))
47
48
49
50
51
52
           (operation 'operation)
           (component 'component)
           (opix (position operation formals))
           (coix (position component formals))
           (prefix (subseq formals 0 opix))
           (suffix (subseq formals (1+ coix) len))
53
           (more-args (when keyp `(&rest ,rest &key &allow-other-keys))))
54
      (assert (and (integerp opix) (integerp coix) (= coix (1+ opix))))
55
56
      (flet ((next-method (o c)
               (if keyp
57
58
                   `(apply ',function ,@prefix ,o ,c ,@suffix ,rest)
                   `(,function ,@prefix ,o ,c ,@suffix))))
59
        `(progn
60
           (defmethod ,function (,@prefix (,operation symbol) component ,@suffix ,@more-args)
61
62
63
64
65
66
67
             (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))
68
           (defmethod ,function (,@prefix (,operation operation) ,component ,@suffix ,@more-args)
69
70
71
             (if (typep ,component 'component)
                 (error "No defined method for ~S on ~/asdf-action:format-action/"
                        ',function (cons ,operation ,component))
72
73
74
                 (if-let (,found (find-component () ,component))
                    ,(next-method operation found)
                    ,if-no-component))))))))
75

76
77

;;;; self-description
78
79
80
(with-upgradability ()
  (defgeneric action-description (operation component)
    (:documentation "returns a phrase that describes performing this operation
81
82
on this component, e.g. \"loading /a/b/c\".
You can put together sentences using this phrase."))
83
84
85
86
87
88
89
  (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))
90

91
92
93
94
  (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))))
95
96
97


;;;; Dependencies
98
(with-upgradability ()
99
  (defgeneric* (component-depends-on) (operation component) ;; ASDF4: rename to component-dependencies
100
101
    (:documentation
     "Returns a list of dependencies needed by the component to perform
102
103
    the operation.  A dependency has one of the following forms:

104
105
106
107
108
      (<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
109
110
111
        <operation> having been performed on each <component>; or

      (FEATURE <feature>), which means that the component depends
112
113
        on the <feature> expression satisfying FEATUREP.
        (This is DEPRECATED -- use :IF-FEATURE instead.)
114
115

    Methods specialized on subclasses of existing component types
116
    should usually append the results of CALL-NEXT-METHOD to the list."))
117
  (define-convenience-action-methods component-depends-on (operation component))
118
119
120
121

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

123
  (defmethod component-depends-on ((o operation) (c component))
124
    (cdr (assoc (type-of o) (component-in-order-to c))))) ; User-specified in-order dependencies
125
126
127
128
129
130


;;;; upward-operation, downward-operation
;; These together handle actions that propagate along the component hierarchy.
;; Downward operations like load-op or compile-op propagate down the hierarchy:
;; operation on a parent depends-on operation on its children.
131
;; By default, an operation propagates itself, but it may propagate another one instead.
132
(with-upgradability ()
133
134
  (deftype op-class-designator ()
    '(or symbol class))
135
136
  (defclass downward-operation (operation)
    ((downward-operation
137
138
139
140
141
142
      :initform nil :initarg :downward-operation :reader downward-operation
      :type op-class-designator :allocation :class))
    (:documentation "A DOWNWARD-OPERATION object propagates its DOWNWARD-OPERATION value to its children.  
I.e., if DOWNWARD-OPERATION OP is requested on C, \(DOWNWARD-OPERATION OP\) will be propagated to C's 
children.  E.g., in order to load a MODULE, you must load all of the children of the MODULE.
\(DOWNWARD-OPERATION OP\) defaults to be the same as OP's class."))
143
144
145
146
147
148
149
  (defmethod component-depends-on ((o downward-operation) (c parent-component))
    `((,(or (downward-operation o) o) ,@(component-children c)) ,@(call-next-method)))
  ;; Upward operations like prepare-op propagate up the component hierarchy:
  ;; operation on a child depends-on operation on its parent.
  ;; By default, an operation propagates itself, but it may propagate another one instead.
  (defclass upward-operation (operation)
    ((upward-operation
150
151
152
153
154
155
      :initform nil :initarg :downward-operation :reader upward-operation :allocation :class))
    (:documentation "An UPWARD-OPERATION object propagates its UPWARD-OPERATION value to its parent.  
I.e., if UPWARD-OPERATION OP is requested on C, \(UPWARD-OPERATION OP\) will be propagated to C's 
parent.  E.g., in order to PREPARE-OP (prepare to load) a file C, ASDF must perform PREPARE-OP 
on C's parent MODULE or SYSTEM.
\(UPWARD-OPERATION OP\) defaults to be the same as OP's class."))
156
157
158
159
160
161
162
163
  ;; 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)))
  ;; Sibling operations propagate to siblings in the component hierarchy:
  ;; operation on a child depends-on operation on its parent.
  ;; By default, an operation propagates itself, but it may propagate another one instead.
164
165
  (defclass sideway-operation (operation)
    ((sideway-operation
166
167
168
169
170
      :initform nil :initarg :sideway-operation :reader sideway-operation :allocation :class))
     (:documentation "A SIDEWAY-OPERATION object propagates its SIDEWAY-OPERATION value to its \"leftward\"
siblings: those components that have the same parent as the object component, C, and that are ordered prior to
C in the :DEPENDS-ON graph of C's parent.
\(SIDEWAY-OPERATION OP\) defaults to be the same as OP's class."))
171
172
173
  (defmethod component-depends-on ((o sideway-operation) (c component))
    `((,(or (sideway-operation o) o)
       ,@(loop :for dep :in (component-sideway-dependencies c)
174
               :collect (resolve-dependency-spec c dep)))
175
176
177
178
179
      ,@(call-next-method)))
  ;; Selfward operations propagate to themselves a sub-operation:
  ;; they depend on some other operation being acted on the same component.
  (defclass selfward-operation (operation)
    ((selfward-operation
180
181
182
183
184
      ;; no :initform -- if you are going to propagate an operation to yourself, you must
      ;; specify it explicitly.
      :initarg :selfward-operation :reader selfward-operation :allocation :class))
    (:documentation "A SELFWARD-OPERATION object propagates its SELFWARD-OPERATION value to itself.  
I.e., if SELFWARD-OPERATION OP is requested on C, \(SELFWARD-OPERATION OP\) will first be performed on C."))
185
186
187
  (defmethod component-depends-on ((o selfward-operation) (c component))
    `(,@(loop :for op :in (ensure-list (selfward-operation o))
              :collect `(,op ,c))
188
      ,@(call-next-method))))
189
190
191


;;;; Inputs, Outputs, and invisible dependencies
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
(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)))

237
  (defmethod input-files ((o operation) (c component))
238
239
240
    (declare (ignorable o c))
    nil)

241
242
243
244
245
246
  (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))))
247
248
249


;;;; Done performing
250
251
252
(with-upgradability ()
  (defgeneric component-operation-time (operation component)) ;; ASDF4: hide it behind plan-action-stamp
  (define-convenience-action-methods component-operation-time (operation component))
253

254
255
256
  (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,
257
258
259
260
261
262
263
264
265
266
267
268
269
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."))

270
271
272
273
  (defclass action-status ()
    ((stamp
      :initarg :stamp :reader action-stamp
      :documentation "STAMP associated with the ACTION if it has been completed already
274
in some previous image, or T if it needs to be done.")
275
276
277
278
     (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"))
279

280
281
282
283
  (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))))
284

285
286
  (defmethod component-operation-time ((o operation) (c component))
    (gethash (type-of o) (component-operation-times c)))
287

288
289
290
  (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))))
291
292
293


;;;; Perform
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
(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))))))
332

333
;;; Generic build operation
334
335
336
(with-upgradability ()
  (defmethod component-depends-on ((o build-op) (c component))
    `((,(or (component-build-operation c) 'load-op) ,c))))
337