Commit 4ab3e838 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

Use cl-scripting/failure, to which the code in failure.lisp was moved.

parent 2a8b4f7f
......@@ -31,3 +31,6 @@
[submodule "ext/asdf-encodings"]
path = ext/asdf-encodings
url =
[submodule "ext/cl-scripting"]
path = ext/cl-scripting
url =
Subproject commit d4b064187be2c9cea8d5e687ca9853f66f0ed756
......@@ -5,13 +5,13 @@
(:version "lisp-invocation/all" "1.0.5")
(:version "cl-ppcre" "2.0.4")
(:version "optima.ppcre" "1.0")
(:feature :sbcl "sb-introspect"))
((:file "package")
(:file "failure" :depends-on ("package"))
(:file "main" :depends-on ("failure"))
(:file "main" :depends-on ("package"))
(:file "pathnames" :depends-on ("package"))
(:file "version" :depends-on ("failure"))
(:file "version" :depends-on ("package"))
(:file "test-environment" :depends-on ("pathnames" "main"))
(:file "build" :depends-on ("test-environment"))
(:file "git" :depends-on ("test-environment"))
;;;; Useful information when failing.
(in-package :asdf-tools)
(defvar *fail-fast* nil)
(defvar *fail-verbose* nil)
(defvar *execution-context* nil) ;; context for debugging information
(defvar *failures* nil)
(defvar *failurep* nil)
;;;(defvar *failure-handler* nil)
(define-condition execution-error (error)
(defmethod print-object ((failure execution-error) stream)
(if *print-escape*
(print-unreadable-object (failure stream :type t :identity nil)
(let ((*print-escape* nil))
(print-object failure stream)))
(princ "FAILED" stream)))
(define-condition execution-failure (execution-error)
((context :initform nil :initarg :context :reader failure-context)
(reason :initarg :reason :reader failure-reason)))
(defmethod print-object ((failure execution-failure) stream)
(if *print-escape* (call-next-method)
(format stream "~@[In ~{~A~^, ~}: ~]~:[FAILED~;~:*~A~]"
(reverse (remove nil (failure-context failure)))
(failure-reason failure))))
(define-condition execution-failures (execution-error)
((failures :initform nil :initarg :failures :reader failure-list)))
(defmethod print-object ((failures execution-failures) stream)
(if *print-escape* (call-next-method)
(format stream "Failure~@[~P~:*~{~&~A~&~}~]"
(reverse (failure-list failures)))))
(defun make-error (&optional reason &rest arguments)
(etypecase reason
(error reason)
(string (make-condition 'simple-error
:format-control reason :format-arguments arguments))
(null (make-failures))
(symbol (apply 'make-condition reason arguments))))
(defun fail! (&rest reason-arguments)
(error (apply 'make-error reason-arguments)))
(defun success (&rest values)
"Return magic values that signal success"
((successp values) (apply 'values values))
((failurep values) (apply 'values values))
(t (apply 'values t '#:success values))))
(defun failure (&optional failures)
"Return magic values that signal failure"
(values nil '#:failure failures))
(defun successp (value-list)
(and (length>=n-p value-list 2)
(equal (subseq value-list 0 2)
(multiple-value-list (success)))))
(defun success-values (value-list)
(subseq value-list 2))
(defun failurep (value-list)
(and (length>=n-p value-list 2)
(equal (subseq value-list 0 2)
(subseq (multiple-value-list (failure)) 0 2))))
(defun failure-failures (value-list)
(third value-list))
(defun success-if (test &rest failure-args)
"If TEST, return success, otherwise, return failure with FAILURE-ARGS"
(if test
(apply 'fail! (or failure-args '("failed")))))
(defun failure-if (test &rest failure-args)
"If not TEST, return success, otherwise, return failure with FAILURE-ARGS"
(apply 'success-if (not test) failure-args))
(defun make-failure (&optional reason &rest arguments)
(if (typep reason 'execution-error)
(make-condition 'execution-failure
:context *execution-context*
:reason (apply 'make-error reason arguments))))
(defun make-failures (&optional list)
(make-condition 'execution-failures :failures list))
(defmacro with-failure-context ((&key name (fail-fast t)) &body body)
`(call-with-failure-context (lambda () ,@body) :name ,name :fail-fast ,fail-fast))
(defun register-failures (failure)
(let ((failure (make-failure failure)))
(etypecase failure
(setf *failures* (append (failure-list failure) *failures*)))
(push failure *failures*)))
(defun call-with-failure-context (thunk &key name (fail-fast t))
(let ((toplevel (null *execution-context*))
(*execution-context* (cons name *execution-context*)))
(labels ((compute ()
(block nil
(handler-bind ((error (lambda (c)
(register-failures c)
(toplevel (return (failure *failures*)))
(fail-fast (error (make-failures)))
(t (return (failure)))))))
(funcall thunk))))
(doit ()
(let ((results (multiple-value-list (compute))))
(if (and toplevel *failures*) (failure (reverse *failures*)) (apply 'success results)))))
(if toplevel
(let ((*failures* nil)) (doit))
(defmacro without-stopping (() &body body)
`(call-without-stopping (list ,@(mapcar (lambda (form) `(lambda () ,form)) body))))
(defun call-without-stopping (thunks)
(with-failure-context (:fail-fast nil)
(let ((failurep nil))
(dolist (thunk thunks)
(when (failurep (multiple-value-list (with-failure-context () (funcall thunk))))
(setf failurep t)))
(failure-if failurep (make-failures)))))
(defun run-command (fun &rest args)
(let ((results (multiple-value-list (with-failure-context () (apply fun args)))))
;; Don't print anything on success for regular commands, otherwise print all values returned.
(if (failurep results)
(let ((failures (failure-failures results)))
(format t "~&Failure~P:~{~& ~A~}~&" (length failures) failures))
(format t "~{~&~S~&~}" (if (successp results) (success-values results) results)))
(apply 'values results)))
(defpackage :asdf-tools
(:use :common-lisp :uiop :asdf
:fare-utils :inferior-shell :lisp-invocation :lisp-invocation/non-special :cl-ppcre :optima :optima.ppcre)
(:export ;; TODO: export stuff
;; failure
#:with-failure-context #:success #:failure #:success-if #:failure-if #:fail!
#:without-stopping #:call-without-stopping #:run-command))
:fare-utils :inferior-shell :cl-scripting/failure
:lisp-invocation :lisp-invocation/non-special
:cl-ppcre :optima :optima.ppcre)
(:export)) ;; TODO: export stuff
;; Just so we can use the name in our test scripts...
(defpackage :asdf-test
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment