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
;;;; upward-operation, downward-operation, sideway-operation, selfward-operation
;; These together handle actions that propagate along the component hierarchy or operation universe.
129
(with-upgradability ()
130
  (deftype operation-class-designator ()
131
    '(or symbol class))
132

133 134
  (defclass downward-operation (operation)
    ((downward-operation
135
      :initform nil :initarg :downward-operation :reader downward-operation
136 137 138 139 140 141 142
      :type operation-class-designator :allocation :class))
    (: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."))
143 144
  (defmethod component-depends-on ((o downward-operation) (c parent-component))
    `((,(or (downward-operation o) o) ,@(component-children c)) ,@(call-next-method)))
145

146 147
  (defclass upward-operation (operation)
    ((upward-operation
148 149 150 151 152 153 154 155
      :initform nil :initarg :upward-operation :reader upward-operation
      :type operation-class-designator :allocation :class))
    (: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."))
156 157 158 159 160
  ;; 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)))
161

162 163
  (defclass sideway-operation (operation)
    ((sideway-operation
164 165 166 167 168 169 170 171
      :initform nil :initarg :sideway-operation :reader sideway-operation
      :type operation-class-designator :allocation :class))
    (: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."))
172 173 174
  (defmethod component-depends-on ((o sideway-operation) (c component))
    `((,(or (sideway-operation o) o)
       ,@(loop :for dep :in (component-sideway-dependencies c)
175
               :collect (resolve-dependency-spec c dep)))
176
      ,@(call-next-method)))
177

178 179
  (defclass selfward-operation (operation)
    ((selfward-operation
180 181 182 183 184 185 186
      :initarg :selfward-operation ;; NB: no :initform -- if an operation depends on another one,
      ;; which that is must explicitly specified.
      :type operation-class-designator :reader selfward-operation :allocation :class))
    (:documentation "A SELFWARD-OPERATION depends on another operation on the same component.
I.e., if O is a SELFWARD-OPERATION, and its SELFWARD-OPERATION designates operation S, then
the action (O . C) of O on component C depends on (S . C).
E.g. before a component may be loaded by LOAD-OP, it must have been compiled by COMPILE-OP."))
187 188 189
  (defmethod component-depends-on ((o selfward-operation) (c component))
    `(,@(loop :for op :in (ensure-list (selfward-operation o))
              :collect `(,op ,c))
190
      ,@(call-next-method))))
191 192 193


;;;; Inputs, Outputs, and invisible dependencies
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 237 238
(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)))

239
  (defmethod input-files ((o operation) (c component))
240 241 242
    (declare (ignorable o c))
    nil)

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


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

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

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

282 283 284 285
  (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))))
286

287 288
  (defmethod component-operation-time ((o operation) (c component))
    (gethash (type-of o) (component-operation-times c)))
289

290 291 292
  (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))))
293 294 295


;;;; Perform
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 332 333
(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))))))
334

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