Add a `%current-system' fluid.

* guix/utils.scm (gnu-triplet->nix-system): New procedure.
  (%current-system): New variable.

* tests/utils.scm ("gnu-triplet->nix-system"): New test.

* tests/derivations.scm (%current-system): Remove.  Update users to
  use (%current-system) instead.

3 files changed, 52 insertions, 14 deletions

diff --git a/guix/utils.scm b/guix/utils.scm
index 77ed9ce6ee..5415ab9e63 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -26,6 +26,7 @@
   #:use-module (ice-9 format)
   #:autoload   (ice-9 popen)  (open-pipe*)
   #:autoload   (ice-9 rdelim) (read-line)
+  #:use-module (ice-9 regex)
   #:use-module ((chop hash)
                 #:select (bytevector-hash
                           hash-method/sha256))
@@ -41,7 +42,9 @@
             %nixpkgs-directory
             nixpkgs-derivation
 
-            memoize))
+            memoize
+            gnu-triplet->nix-system
+            %current-system))
 
 
 ;;;
@@ -400,3 +403,29 @@ starting from the right of S."
                              list)))
               (hash-set! cache args results)
               (apply values results)))))))
+
+(define (gnu-triplet->nix-system triplet)
+  "Return the Nix system type corresponding to TRIPLET, a GNU triplet as
+returned by `config.guess'."
+  (let ((triplet (cond ((string-match "^i[345]86-(.*)$" triplet)
+                        =>
+                        (lambda (m)
+                          (string-append "i686-" (match:substring m 1))))
+                       (else triplet))))
+    (cond ((string-match "^([^-]+)-([^-]+-)?linux-gnu.*" triplet)
+           =>
+           (lambda (m)
+             ;; Nix omits `-gnu' for GNU/Linux.
+             (string-append (match:substring m 1) "-linux")))
+          ((string-match "^([^-]+)-([^-]+-)?([[:alpha:]]+)([0-9]+\\.?)*$" triplet)
+           =>
+           (lambda (m)
+             ;; Nix strip the version number from names such as `gnu0.3',
+             ;; `darwin10.2.0', etc., and always strips the vendor part.
+             (string-append (match:substring m 1) "-"
+                            (match:substring m 3))))
+          (else triplet))))
+
+(define %current-system
+  ;; System type as expected by Nix, usually ARCHITECTURE-KERNEL.
+  (make-parameter (gnu-triplet->nix-system %host-type)))
diff --git a/tests/derivations.scm b/tests/derivations.scm
index eb2f360b2a..b4e4ccea8e 100644
--- a/tests/derivations.scm
+++ b/tests/derivations.scm
@@ -30,10 +30,6 @@
   #:use-module (ice-9 rdelim)
   #:use-module (ice-9 ftw))
 
-(define %current-system
-  ;; System type as expected by Nix, usually ARCHITECTURE-KERNEL.
-  "x86_64-linux")
-
 (define %store
   (false-if-exception (open-connection)))
 
@@ -79,7 +75,7 @@
   (let ((builder (add-text-to-store %store "my-builder.sh"
                                     "#!/bin/sh\necho hello, world\n"
                                     '())))
-    (store-path? (derivation %store "foo" %current-system builder
+    (store-path? (derivation %store "foo" (%current-system) builder
                              '() '(("HOME" . "/homeless")) '()))))
 
 (test-assert "build derivation with 1 source"
@@ -88,7 +84,7 @@
                                     "echo hello, world > \"$out\"\n"
                                     '()))
                 ((drv-path drv)
-                 (derivation %store "foo" %current-system
+                 (derivation %store "foo" (%current-system)
                              "/bin/sh" `(,builder)
                              '(("HOME" . "/homeless")
                                ("zzz"  . "Z!")
@@ -106,7 +102,7 @@
   (let* ((builder    (add-text-to-store %store "my-fixed-builder.sh"
                                         "echo -n hello > $out" '()))
          (hash       (sha256 (string->utf8 "hello")))
-         (drv-path   (derivation %store "fixed" %current-system
+         (drv-path   (derivation %store "fixed" (%current-system)
                                  "/bin/sh" `(,builder)
                                  '() `((,builder))
                                  #:hash hash #:hash-algo 'sha256))
@@ -120,7 +116,7 @@
   (let* ((builder    (add-text-to-store %store "my-fixed-builder.sh"
                                         "echo one > $out ; echo two > $second"
                                         '()))
-         (drv-path   (derivation %store "fixed" %current-system
+         (drv-path   (derivation %store "fixed" (%current-system)
                                  "/bin/sh" `(,builder)
                                  '(("HOME" . "/homeless")
                                    ("zzz"  . "Z!")
@@ -146,7 +142,7 @@
                              "echo $PATH ; mkdir --version ; mkdir $out ; touch $out/good"
                              '()))
          (drv-path
-          (derivation %store "foo" %current-system
+          (derivation %store "foo" (%current-system)
                       "/bin/sh" `(,builder)
                       `(("PATH" .
                          ,(string-append
@@ -168,7 +164,7 @@
                         (call-with-output-file (string-append %output "/test")
                           (lambda (p)
                             (display '(hello guix) p)))))
-         (drv-path   (build-expression->derivation %store "goo" %current-system
+         (drv-path   (build-expression->derivation %store "goo" (%current-system)
                                                    builder '()))
          (succeeded? (build-derivations %store (list drv-path))))
     (and succeeded?
@@ -185,7 +181,7 @@
                           (lambda (p)
                             (display '(world) p)))))
          (drv-path   (build-expression->derivation %store "double"
-                                                   %current-system
+                                                   (%current-system)
                                                    builder '()
                                                    #:outputs '("out"
                                                                "second")))
@@ -204,7 +200,7 @@
                             (dup2 (port->fdes p) 1)
                             (execl (string-append cu "/bin/uname")
                                    "uname" "-a")))))
-         (drv-path   (build-expression->derivation %store "uname" %current-system
+         (drv-path   (build-expression->derivation %store "uname" (%current-system)
                                                    builder
                                                    `(("cu" . ,%coreutils))))
          (succeeded? (build-derivations %store (list drv-path))))
@@ -227,7 +223,7 @@
                              (lambda (p)
                                (put-bytevector p bv))))))
          (drv-path    (build-expression->derivation
-                       %store "hello-2.8.tar.gz" %current-system builder '()
+                       %store "hello-2.8.tar.gz" (%current-system) builder '()
                        #:hash (nix-base32-string->bytevector
                                "0wqd8sjmxfskrflaxywc7gqw7sfawrfvdxd9skxawzfgyy0pzdz6")
                        #:hash-algo 'sha256))
diff --git a/tests/utils.scm b/tests/utils.scm
index db4eb5a340..b3c7fefa39 100644
--- a/tests/utils.scm
+++ b/tests/utils.scm
@@ -20,6 +20,7 @@
 (define-module (test-utils)
   #:use-module (guix utils)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-64)
   #:use-module (rnrs bytevectors)
@@ -85,6 +86,18 @@
               (close-pipe p)
               l))))
 
+(test-assert "gnu-triplet->nix-system"
+  (let ((samples '(("i586-gnu0.3" "i686-gnu")
+                   ("x86_64-unknown-linux-gnu" "x86_64-linux")
+                   ("i386-pc-linux-gnu" "i686-linux")
+                   ("x86_64-unknown-freebsd8.2" "x86_64-freebsd")
+                   ("x86_64-apple-darwin10.8.0" "x86_64-darwin")
+                   ("i686-pc-cygwin" "i686-cygwin"))))
+    (let-values (((gnu nix) (unzip2 samples)))
+      (every (lambda (gnu nix)
+               (equal? nix (gnu-triplet->nix-system gnu)))
+             gnu nix))))
+
 (test-end)