From 2cf0ea0dbbd5a43a62dadb81948ee29898585dd7 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Thu, 17 Jul 2014 15:40:06 +0200
Subject: [PATCH] gexp: Gracefully handle printing of gexps with spliced
references.
* guix/gexp.scm (write-gexp): Wrap 'write' call in
'false-if-exception'.
* tests/gexp.scm ("printer", "printer vs. ungexp-splicing"): New tests.
---
guix/gexp.scm | 7 ++++++-
tests/gexp.scm | 18 ++++++++++++++++++
2 files changed, 24 insertions(+), 1 deletion(-)
diff --git a/guix/gexp.scm b/guix/gexp.scm
index 260118affa6..c9f6cbe99ac 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -60,7 +60,12 @@ (define-record-type <gexp>
(define (write-gexp gexp port)
"Write GEXP on PORT."
(display "#<gexp " port)
- (write (apply (gexp-proc gexp) (gexp-references gexp)) port)
+
+ ;; Try to write the underlying sexp. Now, this trick doesn't work when
+ ;; doing things like (ungexp-splicing (gexp ())) because GEXP's procedure
+ ;; tries to use 'append' on that, which fails with wrong-type-arg.
+ (false-if-exception
+ (write (apply (gexp-proc gexp) (gexp-references gexp)) port))
(format port " ~a>"
(number->string (object-address gexp) 16)))
diff --git a/tests/gexp.scm b/tests/gexp.scm
index b0ff1019e67..6d4885e44e0 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -29,6 +29,7 @@ (define-module (test-gexp)
#:use-module (srfi srfi-64)
#:use-module (rnrs io ports)
#:use-module (ice-9 match)
+ #:use-module (ice-9 regex)
#:use-module (ice-9 popen))
;; Test the (guix gexp) module.
@@ -247,6 +248,23 @@ (define shebang
(return (and (zero? (close-pipe pipe))
(= (expt n 2) (string->number str)))))))
+(test-assert "printer"
+ (string-match "^#<gexp \\(string-append .*#<package coreutils.*\
+ \"/bin/uname\"\\) [[:xdigit:]]+>$"
+ (with-output-to-string
+ (lambda ()
+ (write
+ (gexp (string-append (ungexp coreutils)
+ "/bin/uname")))))))
+
+(test-assert "printer vs. ungexp-splicing"
+ (string-match "^#<gexp .* [[:xdigit:]]+>$"
+ (with-output-to-string
+ (lambda ()
+ ;; #~(begin #$@#~())
+ (write
+ (gexp (begin (ungexp-splicing (gexp ())))))))))
+
(test-equal "sugar"
'(gexp (foo (ungexp bar) (ungexp baz "out")
(ungexp (chbouib 42))
--
GitLab