guix system: Add '--on-error'.
* guix/ui.scm (load*): Add #:on-error parameter. [tag, error-string]: New variables. Wrap 'load' call in 'call-with-prompt'. Pass TAG to 'make-stack'. Honor ON-ERROR after 'report-load-error' call. (report-load-error): Change to not exit on error. Make private. * guix/scripts/system.scm (show-help, %options): Add --on-error. (guix-system): Use 'load*' and pass it #:on-error.master
parent
5f1087c481
commit
db030303b8
|
@ -5995,6 +5995,25 @@ For the @code{vm-image} and @code{disk-image} actions, create an image
|
||||||
of the given @var{size}. @var{size} may be a number of bytes, or it may
|
of the given @var{size}. @var{size} may be a number of bytes, or it may
|
||||||
include a unit as a suffix (@pxref{Block size, size specifications,,
|
include a unit as a suffix (@pxref{Block size, size specifications,,
|
||||||
coreutils, GNU Coreutils}).
|
coreutils, GNU Coreutils}).
|
||||||
|
|
||||||
|
@item --on-error=@var{strategy}
|
||||||
|
Apply @var{strategy} when an error occurs when reading @var{file}.
|
||||||
|
@var{strategy} may be one of the following:
|
||||||
|
|
||||||
|
@table @code
|
||||||
|
@item nothing-special
|
||||||
|
Report the error concisely and exit. This is the default strategy.
|
||||||
|
|
||||||
|
@item backtrace
|
||||||
|
Likewise, but also display a backtrace.
|
||||||
|
|
||||||
|
@item debug
|
||||||
|
Report the error and enter Guile's debugger. From there, you can run
|
||||||
|
commands such as @code{,bt} to get a backtrace, @code{,locals} to
|
||||||
|
display local variable values, and more generally inspect the program's
|
||||||
|
state. @xref{Debug Commands,,, guile, GNU Guile Reference Manual}, for
|
||||||
|
a list of available debugging commands.
|
||||||
|
@end table
|
||||||
@end table
|
@end table
|
||||||
|
|
||||||
Note that all the actions above, except @code{build} and @code{init},
|
Note that all the actions above, except @code{build} and @code{init},
|
||||||
|
|
|
@ -382,6 +382,9 @@ Build the operating system declared in FILE according to ACTION.\n"))
|
||||||
- 'init', initialize a root file system to run GNU.\n"))
|
- 'init', initialize a root file system to run GNU.\n"))
|
||||||
|
|
||||||
(show-build-options-help)
|
(show-build-options-help)
|
||||||
|
(display (_ "
|
||||||
|
--on-error=STRATEGY
|
||||||
|
apply STRATEGY when an error occurs while reading FILE"))
|
||||||
(display (_ "
|
(display (_ "
|
||||||
--image-size=SIZE for 'vm-image', produce an image of SIZE"))
|
--image-size=SIZE for 'vm-image', produce an image of SIZE"))
|
||||||
(display (_ "
|
(display (_ "
|
||||||
|
@ -422,6 +425,10 @@ Build the operating system declared in FILE according to ACTION.\n"))
|
||||||
(option '(#\V "version") #f #f
|
(option '(#\V "version") #f #f
|
||||||
(lambda args
|
(lambda args
|
||||||
(show-version-and-exit "guix system")))
|
(show-version-and-exit "guix system")))
|
||||||
|
(option '("on-error") #t #f
|
||||||
|
(lambda (opt name arg result)
|
||||||
|
(alist-cons 'on-error (string->symbol arg)
|
||||||
|
result)))
|
||||||
(option '("image-size") #t #f
|
(option '("image-size") #t #f
|
||||||
(lambda (opt name arg result)
|
(lambda (opt name arg result)
|
||||||
(alist-cons 'image-size (size->number arg)
|
(alist-cons 'image-size (size->number arg)
|
||||||
|
@ -514,7 +521,8 @@ Build the operating system declared in FILE according to ACTION.\n"))
|
||||||
(action (assoc-ref opts 'action))
|
(action (assoc-ref opts 'action))
|
||||||
(system (assoc-ref opts 'system))
|
(system (assoc-ref opts 'system))
|
||||||
(os (if file
|
(os (if file
|
||||||
(read-operating-system file)
|
(load* file %user-module
|
||||||
|
#:on-error (assoc-ref opts 'on-error))
|
||||||
(leave (_ "no configuration file specified~%"))))
|
(leave (_ "no configuration file specified~%"))))
|
||||||
|
|
||||||
(dry? (assoc-ref opts 'dry-run?))
|
(dry? (assoc-ref opts 'dry-run?))
|
||||||
|
|
47
guix/ui.scm
47
guix/ui.scm
|
@ -43,6 +43,8 @@
|
||||||
#:use-module (ice-9 match)
|
#:use-module (ice-9 match)
|
||||||
#:use-module (ice-9 format)
|
#:use-module (ice-9 format)
|
||||||
#:use-module (ice-9 regex)
|
#:use-module (ice-9 regex)
|
||||||
|
#:autoload (system repl repl) (start-repl)
|
||||||
|
#:autoload (system repl debug) (make-debug stack->vector)
|
||||||
#:replace (symlink)
|
#:replace (symlink)
|
||||||
#:export (_
|
#:export (_
|
||||||
N_
|
N_
|
||||||
|
@ -51,7 +53,6 @@
|
||||||
leave
|
leave
|
||||||
make-user-module
|
make-user-module
|
||||||
load*
|
load*
|
||||||
report-load-error
|
|
||||||
warn-about-load-error
|
warn-about-load-error
|
||||||
show-version-and-exit
|
show-version-and-exit
|
||||||
show-bug-report-information
|
show-bug-report-information
|
||||||
|
@ -146,7 +147,8 @@ messages."
|
||||||
modules)
|
modules)
|
||||||
module))
|
module))
|
||||||
|
|
||||||
(define (load* file user-module)
|
(define* (load* file user-module
|
||||||
|
#:key (on-error 'nothing-special))
|
||||||
"Load the user provided Scheme source code FILE."
|
"Load the user provided Scheme source code FILE."
|
||||||
(define (frame-with-source frame)
|
(define (frame-with-source frame)
|
||||||
;; Walk from FRAME upwards until source location information is found.
|
;; Walk from FRAME upwards until source location information is found.
|
||||||
|
@ -158,6 +160,14 @@ messages."
|
||||||
frame
|
frame
|
||||||
(loop (frame-previous frame) frame)))))
|
(loop (frame-previous frame) frame)))))
|
||||||
|
|
||||||
|
(define (error-string frame args)
|
||||||
|
(call-with-output-string
|
||||||
|
(lambda (port)
|
||||||
|
(apply display-error frame port (cdr args)))))
|
||||||
|
|
||||||
|
(define tag
|
||||||
|
(make-prompt-tag "user-code"))
|
||||||
|
|
||||||
(catch #t
|
(catch #t
|
||||||
(lambda ()
|
(lambda ()
|
||||||
;; XXX: Force a recompilation to avoid ABI issues.
|
;; XXX: Force a recompilation to avoid ABI issues.
|
||||||
|
@ -170,11 +180,14 @@ messages."
|
||||||
|
|
||||||
;; Hide the "auto-compiling" messages.
|
;; Hide the "auto-compiling" messages.
|
||||||
(parameterize ((current-warning-port (%make-void-port "w")))
|
(parameterize ((current-warning-port (%make-void-port "w")))
|
||||||
|
(call-with-prompt tag
|
||||||
|
(lambda ()
|
||||||
;; Give 'load' an absolute file name so that it doesn't try to
|
;; Give 'load' an absolute file name so that it doesn't try to
|
||||||
;; search for FILE in %LOAD-PATH. Note: use 'load', not
|
;; search for FILE in %LOAD-PATH. Note: use 'load', not
|
||||||
;; 'primitive-load', so that FILE is compiled, which then allows us
|
;; 'primitive-load', so that FILE is compiled, which then allows us
|
||||||
;; to provide better error reporting with source line numbers.
|
;; to provide better error reporting with source line numbers.
|
||||||
(load (canonicalize-path file))))))
|
(load (canonicalize-path file)))
|
||||||
|
(const #f))))))
|
||||||
(lambda _
|
(lambda _
|
||||||
;; XXX: Errors are reported from the pre-unwind handler below, but
|
;; XXX: Errors are reported from the pre-unwind handler below, but
|
||||||
;; calling 'exit' from there has no effect, so we call it here.
|
;; calling 'exit' from there has no effect, so we call it here.
|
||||||
|
@ -182,31 +195,43 @@ messages."
|
||||||
(rec (handle-error . args)
|
(rec (handle-error . args)
|
||||||
;; Capture the stack up to this procedure call, excluded, and pass
|
;; Capture the stack up to this procedure call, excluded, and pass
|
||||||
;; the faulty stack frame to 'report-load-error'.
|
;; the faulty stack frame to 'report-load-error'.
|
||||||
(let* ((stack (make-stack #t handle-error))
|
(let* ((stack (make-stack #t handle-error tag))
|
||||||
(depth (stack-length stack))
|
(depth (stack-length stack))
|
||||||
(last (and (> depth 0) (stack-ref stack 0)))
|
(last (and (> depth 0) (stack-ref stack 0)))
|
||||||
(frame (frame-with-source
|
(frame (frame-with-source
|
||||||
(if (> depth 1)
|
(if (> depth 1)
|
||||||
(stack-ref stack 1) ;skip the 'throw' frame
|
(stack-ref stack 1) ;skip the 'throw' frame
|
||||||
last))))
|
last))))
|
||||||
(report-load-error file args frame)))))
|
|
||||||
|
(report-load-error file args frame)
|
||||||
|
|
||||||
|
(case on-error
|
||||||
|
((debug)
|
||||||
|
(newline)
|
||||||
|
(display (_ "entering debugger; type ',bt' for a backtrace\n"))
|
||||||
|
(start-repl #:debug (make-debug (stack->vector stack) 0
|
||||||
|
(error-string frame args)
|
||||||
|
#f)))
|
||||||
|
((backtrace)
|
||||||
|
(newline (current-error-port))
|
||||||
|
(display-backtrace stack (current-error-port)))
|
||||||
|
(else
|
||||||
|
#t))))))
|
||||||
|
|
||||||
(define* (report-load-error file args #:optional frame)
|
(define* (report-load-error file args #:optional frame)
|
||||||
"Report the failure to load FILE, a user-provided Scheme file, and exit.
|
"Report the failure to load FILE, a user-provided Scheme file.
|
||||||
ARGS is the list of arguments received by the 'throw' handler."
|
ARGS is the list of arguments received by the 'throw' handler."
|
||||||
(match args
|
(match args
|
||||||
(('system-error . _)
|
(('system-error . _)
|
||||||
(let ((err (system-error-errno args)))
|
(let ((err (system-error-errno args)))
|
||||||
(leave (_ "failed to load '~a': ~a~%") file (strerror err))))
|
(report-error (_ "failed to load '~a': ~a~%") file (strerror err))))
|
||||||
(('syntax-error proc message properties form . rest)
|
(('syntax-error proc message properties form . rest)
|
||||||
(let ((loc (source-properties->location properties)))
|
(let ((loc (source-properties->location properties)))
|
||||||
(format (current-error-port) (_ "~a: error: ~a~%")
|
(format (current-error-port) (_ "~a: error: ~a~%")
|
||||||
(location->string loc) message)
|
(location->string loc) message)))
|
||||||
(exit 1)))
|
|
||||||
((error args ...)
|
((error args ...)
|
||||||
(report-error (_ "failed to load '~a':~%") file)
|
(report-error (_ "failed to load '~a':~%") file)
|
||||||
(apply display-error frame (current-error-port) args)
|
(apply display-error frame (current-error-port) args))))
|
||||||
(exit 1))))
|
|
||||||
|
|
||||||
(define (warn-about-load-error file args) ;FIXME: factorize with ↑
|
(define (warn-about-load-error file args) ;FIXME: factorize with ↑
|
||||||
"Report the failure to load FILE, a user-provided Scheme file, without
|
"Report the failure to load FILE, a user-provided Scheme file, without
|
||||||
|
|
Reference in New Issue