From mboxrd@z Thu Jan 1 00:00:00 1970 Received: from eggs.gnu.org ([2001:470:142:3::10]:53171) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1jDWrs-0005A4-Md for guix-patches@gnu.org; Sun, 15 Mar 2020 13:16:06 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1jDWrq-0006ak-LJ for guix-patches@gnu.org; Sun, 15 Mar 2020 13:16:04 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:57689) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1jDWrq-0006ZN-Fx for guix-patches@gnu.org; Sun, 15 Mar 2020 13:16:02 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1jDWrq-00029h-Bq for guix-patches@gnu.org; Sun, 15 Mar 2020 13:16:02 -0400 Subject: [bug#40077] [PATCH 3/4] repl: Return stack traces along with exceptions. Resent-Message-ID: From: Ludovic =?UTF-8?Q?Court=C3=A8s?= Date: Sun, 15 Mar 2020 18:15:06 +0100 Message-Id: <20200315171507.22910-3-ludo@gnu.org> In-Reply-To: <20200315171507.22910-1-ludo@gnu.org> References: <20200315171507.22910-1-ludo@gnu.org> MIME-Version: 1.0 Content-Transfer-Encoding: 8bit List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+kyle=kyleam.com@gnu.org Sender: "Guix-patches" To: 40077@debbugs.gnu.org Cc: Ludovic =?UTF-8?Q?Court=C3=A8s?= * guix/repl.scm (repl-prompt): New variable. (stack->frames): New procedure. (send-repl-response)[frame->sexp, handle-exception]: New procedure. Pass HANDLE-EXCEPTION as a pre-unwind handler. (machine-repl): Define 'tag'. Bump protocol version to (0 1 1). Wrap 'loop' call in 'call-with-prompt'. --- guix/repl.scm | 64 +++++++++++++++++++++++++++++++++++++++++++-------- 1 file changed, 54 insertions(+), 10 deletions(-) diff --git a/guix/repl.scm b/guix/repl.scm index a141003812..0ace5976cf 100644 --- a/guix/repl.scm +++ b/guix/repl.scm @@ -17,6 +17,8 @@ ;;; along with GNU Guix. If not, see . (define-module (guix repl) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) #:use-module (ice-9 match) #:export (send-repl-response machine-repl)) @@ -39,6 +41,17 @@ (one-of symbol? string? keyword? pair? null? array? number? boolean? char?))) +(define repl-prompt + ;; Current REPL prompt or #f. + (make-parameter #f)) + +(define (stack->frames stack) + "Return STACK's frames as a list." + (unfold (cute >= <> (stack-length stack)) + (cut stack-ref stack <>) + 1+ + 0)) + (define* (send-repl-response exp output #:key (version '(0 0))) "Write the response corresponding to the evaluation of EXP to PORT, an @@ -49,6 +62,32 @@ output port. VERSION is the client's protocol version we are targeting." `(non-self-quoting ,(object-address value) ,(object->string value)))) + (define (frame->sexp frame) + `(,(frame-procedure-name frame) + ,(match (frame-source frame) + ((_ (? string? file) (? integer? line) . (? integer? column)) + (list file line column)) + (_ + '(#f #f #f))))) + + (define (handle-exception key . args) + (define reply + (match version + ((0 1 (? positive?) _ ...) + ;; Protocol (0 1 1) and later. + (let ((stack (if (repl-prompt) + (make-stack #t handle-exception (repl-prompt)) + (make-stack #t)))) + `(exception (arguments ,key ,@(map value->sexp args)) + (stack ,@(map frame->sexp (stack->frames stack)))))) + (_ + ;; Protocol (0 0). + `(exception ,key ,@(map value->sexp args))))) + + (write reply output) + (newline output) + (force-output output)) + (catch #t (lambda () (let ((results (call-with-values @@ -59,10 +98,8 @@ output port. VERSION is the client's protocol version we are targeting." output) (newline output) (force-output output))) - (lambda (key . args) - (write `(exception ,key ,@(map value->sexp args))) - (newline output) - (force-output output)))) + (const #t) + handle-exception)) (define* (machine-repl #:optional (input (current-input-port)) @@ -73,6 +110,9 @@ The protocol of this REPL is meant to be machine-readable and provides proper support to represent multiple-value returns, exceptions, objects that lack a read syntax, and so on. As such it is more convenient and robust than parsing Guile's REPL prompt." + (define tag + (make-prompt-tag "repl-prompt")) + (define (loop exp version) (match exp ((? eof-object?) #t) @@ -81,7 +121,7 @@ Guile's REPL prompt." #:version version) (loop (read input) version)))) - (write `(repl-version 0 1) output) + (write `(repl-version 0 1 1) output) (newline output) (force-output output) @@ -91,8 +131,12 @@ Guile's REPL prompt." ;; recent client that sends (() repl-version ...). This form is chosen to ;; be unambiguously distinguishable from a regular Scheme expression. - (match (read input) - ((() 'repl-version version ...) - (loop (read input) version)) - (exp - (loop exp '(0 0))))) + (call-with-prompt tag + (lambda () + (parameterize ((repl-prompt tag)) + (match (read input) + ((() 'repl-version version ...) + (loop (read input) version)) + (exp + (loop exp '(0 0)))))) + (const #f))) -- 2.25.1