02/02: build-system/r: Use invoke.

[Ricardo Wurmus]

rekado pushed a commit to branch core-updates
in repository guix.

commit babeea3f9f46c1f1f812e590f46283e91684f327
Author: Ricardo Wurmus <address@hidden>
Date:   Thu May 31 09:16:01 2018 +0200

    build-system/r: Use invoke.
    
    * guix/build/r-build-system.scm (invoke-r): Use invoke.
    (pipe-to-r): Raise invoke-error on non-zero return value.
    (check): Unconditionally return #t.
---
 guix/build/r-build-system.scm | 27 +++++++++++++++++----------
 1 file changed, 17 insertions(+), 10 deletions(-)

diff --git a/guix/build/r-build-system.scm b/guix/build/r-build-system.scm
index 5e18939..4d8ac5b 100644
--- a/guix/build/r-build-system.scm
+++ b/guix/build/r-build-system.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2015, 2017 Ricardo Wurmus <address@hidden>
+;;; Copyright © 2015, 2017, 2018 Ricardo Wurmus <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -24,6 +24,7 @@
   #:use-module (ice-9 popen)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-35)
   #:export (%standard-phases
             r-build))
 
@@ -34,12 +35,19 @@
 ;; Code:
 
 (define (invoke-r command params)
-  (zero? (apply system* "R" "CMD" command params)))
+  (apply invoke "R" "CMD" command params))
 
 (define (pipe-to-r command params)
   (let ((port (apply open-pipe* OPEN_WRITE "R" params)))
     (display command port)
-    (zero? (status:exit-val (close-pipe port)))))
+    (let ((code (status:exit-val (close-pipe port))))
+      (unless (zero? code)
+        (raise (condition ((@@ (guix build utils) &invoke-error)
+                           (program "R")
+                           (arguments (string-append params " " command))
+                           (exit-status (status:exit-val code))
+                           (term-signal (status:term-sig code))
+                           (stop-signal (status:stop-sig code)))))))))
 
 (define (generate-site-path inputs)
   (string-join (map (match-lambda
@@ -68,13 +76,12 @@
          (pkg-name  (car (scandir libdir (negate (cut member <> '("." 
".."))))))
          (testdir   (string-append libdir pkg-name "/" test-target))
          (site-path (string-append libdir ":" (generate-site-path inputs))))
-    (if (and tests? (file-exists? testdir))
-        (begin
-          (setenv "R_LIBS_SITE" site-path)
-          (pipe-to-r (string-append "tools::testInstalledPackage(\"" pkg-name 
"\", "
-                                    "lib.loc = \"" libdir "\")")
-                     '("--no-save" "--slave")))
-        #t)))
+    (when (and tests? (file-exists? testdir))
+      (setenv "R_LIBS_SITE" site-path)
+      (pipe-to-r (string-append "tools::testInstalledPackage(\"" pkg-name "\", 
"
+                                "lib.loc = \"" libdir "\")")
+                 '("--no-save" "--slave")))
+    #t))
 
 (define* (install #:key outputs inputs (configure-flags '())
                   #:allow-other-keys)