From f06a26f5b594b1d1865a41facca0ea65a3837901 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 15 Mar 2020 14:27:09 +0100 Subject: repl: Allow clients to send their protocol version. * guix/repl.scm (send-repl-response): Add #:version. (machine-repl): Make 'loop' an internal define with a 'version' parameter. Pass VERSION to 'send-repl-response'. Send (0 1) as the protocol version. If the first element read from INPUT matches (() repl-version _ ...), interpret it as the client's protocol version. --- guix/repl.scm | 34 ++++++++++++++++++++++++---------- 1 file changed, 24 insertions(+), 10 deletions(-) (limited to 'guix') diff --git a/guix/repl.scm b/guix/repl.scm index 0f75f9cd0b..a141003812 100644 --- a/guix/repl.scm +++ b/guix/repl.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2018, 2019 Ludovic Courtès +;;; Copyright © 2018, 2019, 2020 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -39,9 +39,10 @@ (define (self-quoting? x) (one-of symbol? string? keyword? pair? null? array? number? boolean? char?))) -(define (send-repl-response exp output) +(define* (send-repl-response exp output + #:key (version '(0 0))) "Write the response corresponding to the evaluation of EXP to PORT, an -output port." +output port. VERSION is the client's protocol version we are targeting." (define (value->sexp value) (if (self-quoting? value) `(value ,value) @@ -72,13 +73,26 @@ (define* (machine-repl #:optional 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." - (write `(repl-version 0 0) output) + (define (loop exp version) + (match exp + ((? eof-object?) #t) + (exp + (send-repl-response exp output + #:version version) + (loop (read input) version)))) + + (write `(repl-version 0 1) output) (newline output) (force-output output) - (let loop () - (match (read input) - ((? eof-object?) #t) - (exp - (send-repl-response exp output) - (loop))))) + ;; In protocol version (0 0), clients would not send their supported + ;; protocol version. Thus, the code below checks for two case: (1) a (0 0) + ;; client that directly sends an expression to evaluate, and (2) a more + ;; 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))))) -- cgit v1.2.3 From ec0a8661728f915c21058076327b398ac5c38bbe Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 15 Mar 2020 14:34:01 +0100 Subject: inferior: Adjust to protocol (0 1). * guix/inferior.scm (port->inferior): For protocol (0 x ...), where x >= 1, send the (() repl-version ...) form. --- guix/inferior.scm | 9 +++++++++ 1 file changed, 9 insertions(+) (limited to 'guix') diff --git a/guix/inferior.scm b/guix/inferior.scm index 6b685ece30..ec8ff8ddbe 100644 --- a/guix/inferior.scm +++ b/guix/inferior.scm @@ -159,6 +159,15 @@ (define* (port->inferior pipe #:optional (close close-port)) (letrec ((result (inferior 'pipe pipe close (cons 0 rest) (delay (%inferior-packages result)) (delay (%inferior-package-table result))))) + + ;; For protocol (0 1) and later, send the protocol version we support. + (match rest + ((n _ ...) + (when (>= n 1) + (send-inferior-request '(() repl-version 0 1) result))) + (_ + #t)) + (inferior-eval '(use-modules (guix)) result) (inferior-eval '(use-modules (gnu)) result) (inferior-eval '(use-modules (ice-9 match)) result) -- cgit v1.2.3 From 2b0a370d00e72aba7385eba0fa5db2e3ca7085fb Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 15 Mar 2020 17:22:30 +0100 Subject: repl: Return stack traces along with exceptions. * 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(-) (limited to 'guix') 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 @@ (define (self-quoting? x) (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 @@ (define (value->sexp value) `(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 @@ (define (value->sexp value) 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 @@ (define* (machine-repl #:optional 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 @@ (define (loop exp version) #: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 @@ (define (loop exp version) ;; 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))) -- cgit v1.2.3 From 1dca6aaafa9f842565deab1fe7e6929f25544551 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 15 Mar 2020 17:26:45 +0100 Subject: inferior: '&inferior-exception' includes a stack trace. * guix/inferior.scm (port->inferior): Bump protocol to (0 1 1). (&inferior-exception)[stack]: New field. (read-repl-response): Recognize 'exception' form for protocol (0 1 1). * tests/inferior.scm ("&inferior-exception"): Check the value returned by 'inferior-exception-stack'. --- guix/inferior.scm | 17 ++++++++++++++--- tests/inferior.scm | 3 +++ 2 files changed, 17 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/inferior.scm b/guix/inferior.scm index ec8ff8ddbe..c9a5ee5129 100644 --- a/guix/inferior.scm +++ b/guix/inferior.scm @@ -66,6 +66,7 @@ (define-module (guix inferior) inferior-exception? inferior-exception-arguments inferior-exception-inferior + inferior-exception-stack read-repl-response inferior-packages @@ -164,7 +165,7 @@ (define* (port->inferior pipe #:optional (close close-port)) (match rest ((n _ ...) (when (>= n 1) - (send-inferior-request '(() repl-version 0 1) result))) + (send-inferior-request '(() repl-version 0 1 1) result))) (_ #t)) @@ -211,7 +212,8 @@ (define (write-inferior-object object port) (define-condition-type &inferior-exception &error inferior-exception? (arguments inferior-exception-arguments) ;key + arguments - (inferior inferior-exception-inferior)) ; | #f + (inferior inferior-exception-inferior) ; | #f + (stack inferior-exception-stack)) ;list of (FILE COLUMN LINE) (define* (read-repl-response port #:optional inferior) "Read a (guix repl) response from PORT and return it as a Scheme object. @@ -226,10 +228,19 @@ (define sexp->object (match (read port) (('values objects ...) (apply values (map sexp->object objects))) + (('exception ('arguments key objects ...) + ('stack frames ...)) + ;; Protocol (0 1 1) and later. + (raise (condition (&inferior-exception + (arguments (cons key (map sexp->object objects))) + (inferior inferior) + (stack frames))))) (('exception key objects ...) + ;; Protocol (0 0). (raise (condition (&inferior-exception (arguments (cons key (map sexp->object objects))) - (inferior inferior))))))) + (inferior inferior) + (stack '()))))))) (define (read-inferior-response inferior) (read-repl-response (inferior-socket inferior) diff --git a/tests/inferior.scm b/tests/inferior.scm index b4417d8629..2f5215920b 100644 --- a/tests/inferior.scm +++ b/tests/inferior.scm @@ -68,6 +68,9 @@ (define (manifest-entry->list entry) (guard (c ((inferior-exception? c) (close-inferior inferior) (and (eq? inferior (inferior-exception-inferior c)) + (match (inferior-exception-stack c) + (((_ (files lines columns)) ..1) + (member "guix/repl.scm" files))) (inferior-exception-arguments c)))) (inferior-eval '(throw 'a 'b 'c 'd) inferior) 'badness))) -- cgit v1.2.3 From 892ca1d92f6236b5e176b8fb189a83b86a6a3afe Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 19 Mar 2020 12:10:58 +0100 Subject: guix package: Remove unneeded import. This is a followup to 55e1dfa4dd189e010c541e3997b65434c702b4a5. * guix/scripts/package.scm: Remove unneeded #:use-module. --- guix/scripts/package.scm | 2 -- 1 file changed, 2 deletions(-) (limited to 'guix') diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index d2f4f1ccd3..e620309e30 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -42,8 +42,6 @@ (define-module (guix scripts package) #:autoload (guix store roots) (gc-roots user-owned?) #:use-module ((guix build utils) #:select (directory-exists? mkdir-p)) - #:use-module ((guix build syscalls) - #:select (with-file-lock/no-wait)) #:use-module (ice-9 format) #:use-module (ice-9 match) #:use-module (ice-9 regex) -- cgit v1.2.3 From 3e000955cd232c437cbe6994c124e30a35bc2605 Mon Sep 17 00:00:00 2001 From: Brendan Tildesley Date: Fri, 20 Mar 2020 01:24:39 +1100 Subject: guix: lint: Ad scdoc as a suggested native input. * guix/lint.scm (check-inputs-should-be-native): Add scdoc. Signed-off-by: Danny Milosavljevic --- guix/lint.scm | 1 + 1 file changed, 1 insertion(+) (limited to 'guix') diff --git a/guix/lint.scm b/guix/lint.scm index 24fbf05202..40bddd0a41 100644 --- a/guix/lint.scm +++ b/guix/lint.scm @@ -317,6 +317,7 @@ (define (check-inputs-should-be-native package) "python-pytest-cov" "python2-pytest-cov" "python-setuptools-scm" "python2-setuptools-scm" "python-sphinx" "python2-sphinx" + "scdoc" "swig" "qmake" "qttools" -- cgit v1.2.3 From f2b24f01f42c1bad3ddffd140194de1aec38a5f8 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 20 Mar 2020 23:34:03 +0100 Subject: packages: 'package-field-location' preserves the original file name. Fixes . Reported by Alex ter Weele . * guix/packages.scm (package-field-location): Remove 'with-fluids' for '%file-port-name-canonicalization'. Change the 'file' field of the resulting location to FILE. --- guix/packages.scm | 37 ++++++++++++++++++------------------- 1 file changed, 18 insertions(+), 19 deletions(-) (limited to 'guix') diff --git a/guix/packages.scm b/guix/packages.scm index 5ecb97f946..4ab8650340 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -355,25 +355,24 @@ (define (goto port line column) (catch 'system-error (lambda () ;; In general we want to keep relative file names for modules. - (with-fluids ((%file-port-name-canonicalization 'relative)) - (call-with-input-file (search-path %load-path file) - (lambda (port) - (goto port line column) - (match (read port) - (('package inits ...) - (let ((field (assoc field inits))) - (match field - ((_ value) - ;; Put the `or' here, and not in the first argument of - ;; `and=>', to work around a compiler bug in 2.0.5. - (or (and=> (source-properties value) - source-properties->location) - (and=> (source-properties field) - source-properties->location))) - (_ - #f)))) - (_ - #f)))))) + (call-with-input-file (search-path %load-path file) + (lambda (port) + (goto port line column) + (match (read port) + (('package inits ...) + (let ((field (assoc field inits))) + (match field + ((_ value) + (let ((props (source-properties value))) + (and props + ;; Preserve the original file name, which may be a + ;; relative file name. + (let ((loc (source-properties->location props))) + (set-field loc (location-file) file))))) + (_ + #f)))) + (_ + #f))))) (lambda _ #f))) (_ #f))) -- cgit v1.2.3