Merge branch 'core-updates' into core-updates-next

5 files changed, 68 insertions, 37 deletions

diff --git a/guix/build/download.scm b/guix/build/download.scm
index 315a3554ec..54163849a2 100644
--- a/guix/build/download.scm
+++ b/guix/build/download.scm
@@ -115,7 +115,7 @@ and 'guix publish', something like
         (string-drop path 33)
         path)))
 
-(define* (ftp-fetch uri file #:key timeout)
+(define* (ftp-fetch uri file #:key timeout print-build-trace?)
   "Fetch data from URI and write it to FILE.  Return FILE on success.  Bail
 out if the connection could not be established in less than TIMEOUT seconds."
   (let* ((conn (match (and=> (uri-userinfo uri)
@@ -136,12 +136,17 @@ out if the connection could not be established in less than TIMEOUT seconds."
       (lambda (out)
         (dump-port* in out
                     #:buffer-size %http-receive-buffer-size
-                    #:reporter (progress-reporter/file
-                                (uri-abbreviation uri) size))))
-
-    (ftp-close conn))
-    (newline)
-  file)
+                    #:reporter
+                    (if print-build-trace?
+                        (progress-reporter/trace
+                         file (uri->string uri) size)
+                        (progress-reporter/file
+                         (uri-abbreviation uri) size)))))
+
+    (ftp-close conn)
+    (unless print-build-trace?
+      (newline))
+    file))
 
 ;; Autoload GnuTLS so that this module can be used even when GnuTLS is
 ;; not available.  At compile time, this yields "possibly unbound
@@ -723,7 +728,8 @@ Return a list of URIs."
                     #:key
                     (timeout 10) (verify-certificate? #t)
                     (mirrors '()) (content-addressed-mirrors '())
-                    (hashes '()))
+                    (hashes '())
+                    print-build-trace?)
   "Fetch FILE from URL; URL may be either a single string, or a list of
 string denoting alternate URLs for FILE.  Return #f on failure, and FILE
 on success.
@@ -759,13 +765,18 @@ otherwise simply ignore them."
             (lambda (output)
               (dump-port* port output
                           #:buffer-size %http-receive-buffer-size
-                          #:reporter (progress-reporter/file
-                                      (uri-abbreviation uri) size))
+                          #:reporter (if print-build-trace?
+                                         (progress-reporter/trace
+                                          file (uri->string uri) size)
+                                         (progress-reporter/file
+                                          (uri-abbreviation uri) size)))
               (newline)))
           file)))
       ((ftp)
        (false-if-exception* (ftp-fetch uri file
-                                       #:timeout timeout)))
+                                       #:timeout timeout
+                                       #:print-build-trace?
+                                       print-build-trace?)))
       (else
        (format #t "skipping URI with unsupported scheme: ~s~%"
                uri)
diff --git a/guix/build/haskell-build-system.scm b/guix/build/haskell-build-system.scm
index 5a72d22842..7b556f6431 100644
--- a/guix/build/haskell-build-system.scm
+++ b/guix/build/haskell-build-system.scm
@@ -3,6 +3,7 @@
 ;;; Copyright © 2015 Eric Bavier <bavier@member.fsf.org>
 ;;; Copyright © 2015 Paul van der Walt <paul@denknerd.org>
 ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2018 Alex Vong <alexvong1995@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -28,6 +29,7 @@
   #:use-module (ice-9 regex)
   #:use-module (ice-9 match)
   #:use-module (ice-9 vlist)
+  #:use-module (ice-9 ftw)
   #:export (%standard-phases
             haskell-build))
 
@@ -77,6 +79,7 @@ and parameters ~s~%"
          (doc (assoc-ref outputs "doc"))
          (lib (assoc-ref outputs "lib"))
          (bin (assoc-ref outputs "bin"))
+         (name-version (strip-store-file-name out))
          (input-dirs (match inputs
                        (((_ . dir) ...)
                         dir)
@@ -87,7 +90,7 @@ and parameters ~s~%"
                          `(,(string-append "--bindir=" (or bin out) "/bin"))
                          `(,(string-append
                              "--docdir=" (or doc out)
-                             "/share/doc/" (package-name-version out)))
+                             "/share/doc/" name-version))
                          '("--libsubdir=$compiler/$pkg-$version")
                          `(,(string-append "--package-db=" %tmp-db-dir))
                          '("--global")
@@ -126,12 +129,6 @@ and parameters ~s~%"
   "Install a given Haskell package."
   (run-setuphs "copy" '()))
 
-(define (package-name-version store-dir)
-  "Given a store directory STORE-DIR return 'name-version' of the package."
-  (let* ((base (basename store-dir)))
-    (string-drop base
-                 (+ 1 (string-index base #\-)))))
-
 (define (grep rx port)
   "Given a regular-expression RX including a group, read from PORT until the
 first match and return the content of the group."
@@ -146,7 +143,7 @@ first match and return the content of the group."
 (define* (setup-compiler #:key system inputs outputs #:allow-other-keys)
   "Setup the compiler environment."
   (let* ((haskell (assoc-ref inputs "haskell"))
-         (name-version (package-name-version haskell)))
+         (name-version (strip-store-file-name haskell)))
     (cond
      ((string-match "ghc" name-version)
       (make-ghc-package-database system inputs outputs))
@@ -163,6 +160,7 @@ first match and return the content of the group."
 (define (make-ghc-package-database system inputs outputs)
   "Generate the GHC package database."
   (let* ((haskell  (assoc-ref inputs "haskell"))
+         (name-version (strip-store-file-name haskell))
          (input-dirs (match inputs
                        (((_ . dir) ...)
                         dir)
@@ -170,7 +168,7 @@ first match and return the content of the group."
          ;; Silence 'find-files' (see 'evaluate-search-paths')
          (conf-dirs (with-null-error-port
                      (search-path-as-list
-                      `(,(string-append "lib/" (package-name-version haskell)))
+                      `(,(string-append "lib/" name-version))
                       input-dirs #:pattern ".*\\.conf.d$")))
          (conf-files (append-map (cut find-files <> "\\.conf$") conf-dirs)))
     (mkdir-p %tmp-db-dir)
@@ -230,9 +228,10 @@ given Haskell package."
 
   (let* ((out (assoc-ref outputs "out"))
          (haskell  (assoc-ref inputs "haskell"))
+         (name-verion (strip-store-file-name haskell))
          (lib (string-append out "/lib"))
-         (config-dir (string-append lib "/"
-                                    (package-name-version haskell)
+         (config-dir (string-append lib
+                                    "/" name-verion
                                     "/" name ".conf.d"))
          (id-rx (make-regexp "^id: *(.*)$"))
          (config-file (string-append out "/" name ".conf"))
@@ -266,8 +265,19 @@ given Haskell package."
     (run-setuphs "haddock" haddock-flags))
   #t)
 
+(define* (patch-cabal-file #:key cabal-revision #:allow-other-keys)
+  (when cabal-revision
+    ;; Cabal requires there to be a single file with the suffix ".cabal".
+    (match (scandir "." (cut string-suffix? ".cabal" <>))
+      ((original)
+       (format #t "replacing ~s with ~s~%" original cabal-revision)
+       (copy-file cabal-revision original))
+      (_ (error "Could not find a Cabal file to patch."))))
+  #t)
+
 (define %standard-phases
   (modify-phases gnu:%standard-phases
+    (add-after 'unpack 'patch-cabal-file patch-cabal-file)
     (delete 'bootstrap)
     (add-before 'configure 'setup-compiler setup-compiler)
     (add-before 'install 'haddock haddock)
diff --git a/guix/build/java-utils.scm b/guix/build/java-utils.scm
index 128be1edeb..8200638bee 100644
--- a/guix/build/java-utils.scm
+++ b/guix/build/java-utils.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2016 Hartmut Goebel <h.goebel@crazy-compilers.com>
 ;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2018 Alex Vong <alexvong1995@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -23,12 +24,6 @@
             install-jars
             install-javadoc))
 
-;; Copied from haskell-build-system.scm
-(define (package-name-version store-dir)
-  "Given a store directory STORE-DIR return 'name-version' of the package."
-  (let* ((base (basename store-dir)))
-    (string-drop base (+ 1 (string-index base #\-)))))
-
 (define* (ant-build-javadoc #:key (target "javadoc") (make-flags '())
                             #:allow-other-keys)
   (apply invoke `("ant" ,target ,@make-flags)))
@@ -48,8 +43,9 @@ is used in case the build.xml does not include an install target."
 install javadocs when this is not done by the install target."
   (lambda* (#:key outputs #:allow-other-keys)
     (let* ((out (assoc-ref outputs "out"))
+           (name-version (strip-store-file-name out))
            (docs (string-append (or (assoc-ref outputs "doc") out)
-                                "/share/doc/" (package-name-version out) "/")))
+                                "/share/doc/" name-version "/")))
       (mkdir-p docs)
       (copy-recursively apidoc-directory docs)
       #t)))
diff --git a/guix/build/lisp-utils.scm b/guix/build/lisp-utils.scm
index 6470cfec97..97bc6197a3 100644
--- a/guix/build/lisp-utils.scm
+++ b/guix/build/lisp-utils.scm
@@ -84,11 +84,12 @@
 (define (normalize-dependency dependency)
   "Normalize the name of DEPENDENCY.  Handles dependency definitions of the
 dependency-def form described by
-<https://common-lisp.net/project/asdf/asdf.html#The-defsystem-grammar>."
+<https://common-lisp.net/project/asdf/asdf.html#The-defsystem-grammar>.
+Assume that any symbols in DEPENDENCY will be in upper-case."
   (match dependency
-    ((':version name rest ...)
+    ((':VERSION name rest ...)
      `(:version ,(normalize-string name) ,@rest))
-    ((':feature feature-specification dependency-specification)
+    ((':FEATURE feature-specification dependency-specification)
      `(:feature
        ,feature-specification
        ,(normalize-dependency dependency-specification)))
diff --git a/guix/build/store-copy.scm b/guix/build/store-copy.scm
index 2d9590d16f..64ade7885c 100644
--- a/guix/build/store-copy.scm
+++ b/guix/build/store-copy.scm
@@ -19,6 +19,7 @@
 (define-module (guix build store-copy)
   #:use-module (guix build utils)
   #:use-module (guix sets)
+  #:use-module (guix progress)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-26)
@@ -167,7 +168,8 @@ REFERENCE-GRAPHS, a list of reference-graph files."
 
   (reduce + 0 (map file-size items)))
 
-(define* (populate-store reference-graphs target)
+(define* (populate-store reference-graphs target
+                         #:key (log-port (current-error-port)))
   "Populate the store under directory TARGET with the items specified in
 REFERENCE-GRAPHS, a list of reference-graph files."
   (define store
@@ -183,9 +185,20 @@ REFERENCE-GRAPHS, a list of reference-graph files."
 
   (mkdir-p store)
   (chmod store #o1775)
-  (for-each (lambda (thing)
-              (copy-recursively thing
-                                (string-append target thing)))
-            (things-to-copy)))
+
+  (let* ((things   (things-to-copy))
+         (len      (length things))
+         (progress (progress-reporter/bar len
+                                          (format #f "copying ~a store items"
+                                                  len)
+                                          log-port)))
+    (call-with-progress-reporter progress
+      (lambda (report)
+        (for-each (lambda (thing)
+                    (copy-recursively thing
+                                      (string-append target thing)
+                                      #:log (%make-void-port "w"))
+                    (report))
+                  things)))))
 
 ;;; store-copy.scm ends here