summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
authorMarius Bakke <mbakke@fastmail.com>2020-03-21 22:16:02 +0100
committerMarius Bakke <mbakke@fastmail.com>2020-03-21 22:16:02 +0100
commitd19b14c8349ce8cacb62619ab68953265daeeca7 (patch)
tree9aacc6f9378ca69951c87232b3a7526fef2f2054 /guix
parent680b56116a4840a281a45cb130fd45d6d3d46c56 (diff)
parentee4c927f33a1d3b01cf36be3c74227f6b7fd69ff (diff)
Merge branch 'master' into core-updates
Diffstat (limited to 'guix')
-rw-r--r--guix/inferior.scm24
-rw-r--r--guix/lint.scm1
-rw-r--r--guix/packages.scm37
-rw-r--r--guix/repl.scm86
-rw-r--r--guix/scripts/package.scm2
5 files changed, 113 insertions, 37 deletions
diff --git a/guix/inferior.scm b/guix/inferior.scm
index 6b685ece30..c9a5ee5129 100644
--- a/guix/inferior.scm
+++ b/guix/inferior.scm
@@ -66,6 +66,7 @@
inferior-exception?
inferior-exception-arguments
inferior-exception-inferior
+ inferior-exception-stack
read-repl-response
inferior-packages
@@ -159,6 +160,15 @@ inferior."
(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 1) result)))
+ (_
+ #t))
+
(inferior-eval '(use-modules (guix)) result)
(inferior-eval '(use-modules (gnu)) result)
(inferior-eval '(use-modules (ice-9 match)) result)
@@ -202,7 +212,8 @@ equivalent. Return #f if the inferior could not be launched."
(define-condition-type &inferior-exception &error
inferior-exception?
(arguments inferior-exception-arguments) ;key + arguments
- (inferior inferior-exception-inferior)) ;<inferior> | #f
+ (inferior inferior-exception-inferior) ;<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.
@@ -217,10 +228,19 @@ Raise '&inferior-exception' when an exception is read from PORT."
(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/guix/lint.scm b/guix/lint.scm
index 24fbf05202..40bddd0a41 100644
--- a/guix/lint.scm
+++ b/guix/lint.scm
@@ -317,6 +317,7 @@ of a package, and INPUT-NAMES, a list of package specifications such as
"python-pytest-cov" "python2-pytest-cov"
"python-setuptools-scm" "python2-setuptools-scm"
"python-sphinx" "python2-sphinx"
+ "scdoc"
"swig"
"qmake"
"qttools"
diff --git a/guix/packages.scm b/guix/packages.scm
index d925e754a3..5c6d1a92d5 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -355,25 +355,24 @@ object."
(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)))
diff --git a/guix/repl.scm b/guix/repl.scm
index 0f75f9cd0b..0ace5976cf 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 <ludo@gnu.org>
+;;; Copyright © 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -17,6 +17,8 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(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,15 +41,53 @@
(one-of symbol? string? keyword? pair? null? array?
number? boolean? char?)))
-(define (send-repl-response exp output)
+(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
-output port."
+output port. VERSION is the client's protocol version we are targeting."
(define (value->sexp value)
(if (self-quoting? value)
`(value ,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
@@ -58,10 +98,8 @@ output port."
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))
@@ -72,13 +110,33 @@ 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."
- (write `(repl-version 0 0) output)
- (newline output)
- (force-output output)
+ (define tag
+ (make-prompt-tag "repl-prompt"))
- (let loop ()
- (match (read input)
+ (define (loop exp version)
+ (match exp
((? eof-object?) #t)
(exp
- (send-repl-response exp output)
- (loop)))))
+ (send-repl-response exp output
+ #:version version)
+ (loop (read input) version))))
+
+ (write `(repl-version 0 1 1) output)
+ (newline output)
+ (force-output output)
+
+ ;; 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.
+
+ (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)))
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 792c458850..bdddc11b7b 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -42,8 +42,6 @@
#: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)