Merge branch 'staging' into core-updates

8 files changed, 121 insertions, 55 deletions

diff --git a/guix/build/haskell-build-system.scm b/guix/build/haskell-build-system.scm
index 23d97e6602..91f62138d0 100644
--- a/guix/build/haskell-build-system.scm
+++ b/guix/build/haskell-build-system.scm
@@ -260,7 +260,7 @@ given Haskell package."
   #t)
 
 (define* (haddock #:key outputs haddock? haddock-flags #:allow-other-keys)
-  "Run the test suite of a given Haskell package."
+  "Generate the Haddock documentation of a given Haskell package."
   (when haddock?
     (run-setuphs "haddock" haddock-flags))
   #t)
@@ -275,9 +275,21 @@ given Haskell package."
       (_ (error "Could not find a Cabal file to patch."))))
   #t)
 
+(define* (generate-setuphs #:rest empty)
+  "Generate a default Setup.hs if needed."
+  (when (not (or (file-exists? "Setup.hs")
+                 (file-exists? "Setup.lhs")))
+    (format #t "generating missing Setup.hs~%")
+    (with-output-to-file "Setup.hs"
+      (lambda ()
+        (format #t "import Distribution.Simple~%")
+        (format #t "main = defaultMain~%"))))
+  #t)
+
 (define %standard-phases
   (modify-phases gnu:%standard-phases
     (add-after 'unpack 'patch-cabal-file patch-cabal-file)
+    (add-after 'unpack 'generate-setuphs generate-setuphs)
     (delete 'bootstrap)
     (add-before 'configure 'setup-compiler setup-compiler)
     (add-before 'install 'haddock haddock)
diff --git a/guix/derivations.scm b/guix/derivations.scm
index cad77bdb06..8145d51143 100644
--- a/guix/derivations.scm
+++ b/guix/derivations.scm
@@ -62,6 +62,7 @@
             <derivation-input>
             derivation-input?
             derivation-input-path
+            derivation-input-derivation
             derivation-input-sub-derivations
             derivation-input-output-paths
             valid-derivation-input?
@@ -152,6 +153,10 @@
   (path            derivation-input-path)             ; store path
   (sub-derivations derivation-input-sub-derivations)) ; list of strings
 
+(define (derivation-input-derivation input)
+  "Return the <derivation> object INPUT refers to."
+  (read-derivation-from-file (derivation-input-path input)))
+
 (set-record-type-printer! <derivation>
                           (lambda (drv port)
                             (format port "#<derivation ~a => ~a ~a>"
@@ -243,9 +248,7 @@ result is the set of prerequisites of DRV not already in valid."
       (fold2 loop
              (append inputs result)
              (fold set-insert input-set inputs)
-             (map (lambda (i)
-                    (read-derivation-from-file (derivation-input-path i)))
-                  inputs)))))
+             (map derivation-input-derivation inputs)))))
 
 (define (offloadable-derivation? drv)
   "Return true if DRV can be offloaded, false otherwise."
diff --git a/guix/grafts.scm b/guix/grafts.scm
index a3e12f6efd..3b43e11425 100644
--- a/guix/grafts.scm
+++ b/guix/grafts.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -22,9 +22,9 @@
   #:use-module (guix records)
   #:use-module (guix derivations)
   #:use-module ((guix utils) #:select (%current-system))
+  #:use-module (guix sets)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9 gnu)
-  #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
   #:use-module (ice-9 match)
@@ -151,21 +151,6 @@ are not recursively applied to dependencies of DRV."
                                      #:substitutable? #f
 
                                      #:properties properties)))))
-(define (item->deriver store item)
-  "Return two values: the derivation that led to ITEM (a store item), and the
-name of the output of that derivation ITEM corresponds to (for example
-\"out\").  When ITEM has no deriver, for instance because it is a plain file,
-#f and #f are returned."
-  (match (valid-derivers store item)
-    (()                                           ;ITEM is a plain file
-     (values #f #f))
-    ((drv-file _ ...)
-     (let ((drv (read-derivation-from-file drv-file)))
-       (values drv
-               (any (match-lambda
-                      ((name . path)
-                       (and (string=? item path) name)))
-                    (derivation->output-paths drv)))))))
 
 (define (non-self-references references drv outputs)
   "Return the list of references of the OUTPUTS of DRV, excluding self
@@ -230,6 +215,33 @@ available."
            (set-current-state (vhash-cons key result cache))
            (return result)))))))
 
+(define (reference-origin drv item)
+  "Return the derivation/output pair among the inputs of DRV, recursively,
+that produces ITEM.  Return #f if ITEM is not produced by a derivation (i.e.,
+it's a content-addressed \"source\"), or if it's not produced by a dependency
+of DRV."
+  ;; Perform a breadth-first traversal of the dependency graph of DRV in
+  ;; search of the derivation that produces ITEM.
+  (let loop ((drv (list drv))
+             (visited (setq)))
+    (match drv
+      (()
+       #f)
+      ((drv . rest)
+       (if (set-contains? visited drv)
+           (loop rest visited)
+           (let ((inputs (derivation-inputs drv)))
+             (or (any (lambda (input)
+                        (let ((drv (derivation-input-derivation input)))
+                          (any (match-lambda
+                                 ((output . file)
+                                  (and (string=? file item)
+                                       (cons drv output))))
+                               (derivation->output-paths drv))))
+                      inputs)
+                 (loop (append rest (map derivation-input-derivation inputs))
+                       (set-insert drv visited)))))))))
+
 (define* (cumulative-grafts store drv grafts
                             references
                             #:key
@@ -257,16 +269,17 @@ derivations to the corresponding set of grafts."
        #f)))
 
   (define (dependency-grafts item)
-    (let-values (((drv output) (item->deriver store item)))
-      (if drv
-          ;; If GRAFTS already contains a graft from DRV, do not override it.
-          (if (find (cut graft-origin? drv <>) grafts)
-              (state-return grafts)
-              (cumulative-grafts store drv grafts references
-                                 #:outputs (list output)
-                                 #:guile guile
-                                 #:system system))
-          (state-return grafts))))
+    (match (reference-origin drv item)
+      ((drv . output)
+       ;; If GRAFTS already contains a graft from DRV, do not override it.
+       (if (find (cut graft-origin? drv <>) grafts)
+           (state-return grafts)
+           (cumulative-grafts store drv grafts references
+                              #:outputs (list output)
+                              #:guile guile
+                              #:system system)))
+      (#f
+       (state-return grafts))))
 
   (with-cache (cons (derivation-file-name drv) outputs)
     (match (non-self-references references drv outputs)
diff --git a/guix/import/cabal.scm b/guix/import/cabal.scm
index 1a87be0b00..7dfe771e41 100644
--- a/guix/import/cabal.scm
+++ b/guix/import/cabal.scm
@@ -40,6 +40,7 @@
             cabal-package?
             cabal-package-name
             cabal-package-version
+            cabal-package-revision
             cabal-package-license
             cabal-package-home-page
             cabal-package-source-repository
@@ -638,13 +639,14 @@ If #f use the function 'port-filename' to obtain it."
 ;; information of the Cabal file, but only the ones we currently are
 ;; interested in.
 (define-record-type <cabal-package>
-  (make-cabal-package name version license home-page source-repository
+  (make-cabal-package name version revision license home-page source-repository
                       synopsis description
                       executables lib test-suites
                       flags eval-environment custom-setup)
   cabal-package?
   (name   cabal-package-name)
   (version cabal-package-version)
+  (revision cabal-package-revision)
   (license cabal-package-license)
   (home-page cabal-package-home-page)
   (source-repository cabal-package-source-repository)
@@ -838,6 +840,7 @@ See the manual for limitations.")))))))
   (define (cabal-evaluated-sexp->package evaluated-sexp)
     (let* ((name (lookup-join evaluated-sexp "name"))
            (version (lookup-join evaluated-sexp "version"))
+           (revision (lookup-join evaluated-sexp "x-revision"))
            (license (lookup-join evaluated-sexp "license"))
            (home-page (lookup-join evaluated-sexp "homepage"))
            (home-page-or-hackage
@@ -856,7 +859,7 @@ See the manual for limitations.")))))))
            (custom-setup (match (make-cabal-section evaluated-sexp 'custom-setup)
                            ((x) x)
                            (_ #f))))
-      (make-cabal-package name version license home-page-or-hackage
+      (make-cabal-package name version revision license home-page-or-hackage
                           source-repository synopsis description executables lib
                           test-suites flags eval-environment custom-setup)))
 
diff --git a/guix/import/hackage.scm b/guix/import/hackage.scm
index 366256b40d..6f426af900 100644
--- a/guix/import/hackage.scm
+++ b/guix/import/hackage.scm
@@ -117,19 +117,34 @@ version is returned."
           (#f name)
           (m (match:substring m 1)))))))
 
+(define (read-cabal-and-hash port)
+  "Read a Cabal file from PORT and return it and its hash in nix-base32
+format as two values."
+  (let-values (((port get-hash) (open-sha256-input-port port)))
+    (values (read-cabal (canonical-newline-port port))
+            (bytevector->nix-base32-string (get-hash)))))
+
+(define (hackage-fetch-and-hash name-version)
+  "Fetch the latest Cabal revision for the package NAME-VERSION, and return
+two values: the parsed Cabal file and its hash in nix-base32 format.  If the
+version part is omitted from the package name, then fetch the latest
+version.  On failure, both return values will be #f."
+  (guard (c ((and (http-get-error? c)
+                  (= 404 (http-get-error-code c)))
+             (values #f #f)))           ;"expected" if package is unknown
+    (let*-values (((name version) (package-name->name+version name-version))
+                  ((url)          (hackage-cabal-url name version))
+                  ((port _)       (http-fetch url))
+                  ((cabal hash)   (read-cabal-and-hash port)))
+      (close-port port)
+      (values cabal hash))))
+
 (define (hackage-fetch name-version)
   "Return the Cabal file for the package NAME-VERSION, or #f on failure.  If
 the version part is omitted from the package name, then return the latest
 version."
-  (guard (c ((and (http-get-error? c)
-                  (= 404 (http-get-error-code c)))
-             #f))                       ;"expected" if package is unknown
-    (let-values (((name version) (package-name->name+version name-version)))
-      (let* ((url (hackage-cabal-url name version))
-             (port (http-fetch url))
-             (result (read-cabal (canonical-newline-port port))))
-        (close-port port)
-        result))))
+  (let-values (((cabal hash) (hackage-fetch-and-hash name-version)))
+    cabal))
 
 (define string->license
   ;; List of valid values from
@@ -198,15 +213,20 @@ package being processed and is used to filter references to itself."
                                    (cons own-name ghc-standard-libraries))))
           dependencies))
 
-(define* (hackage-module->sexp cabal #:key (include-test-dependencies? #t))
+(define* (hackage-module->sexp cabal cabal-hash
+                               #:key (include-test-dependencies? #t))
   "Return the `package' S-expression for a Cabal package.  CABAL is the
-representation of a Cabal file as produced by 'read-cabal'."
+representation of a Cabal file as produced by 'read-cabal'.  CABAL-HASH is
+the hash of the Cabal file."
 
   (define name
     (cabal-package-name cabal))
 
   (define version
     (cabal-package-version cabal))
+
+  (define revision
+    (cabal-package-revision cabal))
   
   (define source-url
     (hackage-source-url name version))
@@ -252,9 +272,14 @@ representation of a Cabal file as produced by 'read-cabal'."
                    (list 'quasiquote inputs))))))
   
   (define (maybe-arguments)
-    (if (not include-test-dependencies?)
-        '((arguments `(#:tests? #f)))
-        '()))
+    (match (append (if (not include-test-dependencies?)
+                       '(#:tests? #f)
+                       '())
+                   (if (not (string-null? revision))
+                       `(#:cabal-revision (,revision ,cabal-hash))
+                       '()))
+      (() '())
+      (args `((arguments (,'quasiquote ,args))))))
 
   (let ((tarball (with-store store
                    (download-to-store store source-url))))
@@ -294,10 +319,11 @@ symbol 'true' or 'false'.  The value associated with other keys has to conform
 to the Cabal file format definition.  The default value associated with the
 keys \"os\", \"arch\" and \"impl\" is \"linux\", \"x86_64\" and \"ghc\"
 respectively."
-  (let ((cabal-meta (if port
-                        (read-cabal (canonical-newline-port port))
-                        (hackage-fetch package-name))))
-    (and=> cabal-meta (compose (cut hackage-module->sexp <>
+  (let-values (((cabal-meta cabal-hash)
+                (if port
+                    (read-cabal-and-hash port)
+                    (hackage-fetch-and-hash package-name))))
+    (and=> cabal-meta (compose (cut hackage-module->sexp <> cabal-hash
                                     #:include-test-dependencies?
                                     include-test-dependencies?)
                                (cut eval-cabal <> cabal-environment)))))
diff --git a/guix/licenses.scm b/guix/licenses.scm
index 65d9c3da13..41d4fefad2 100644
--- a/guix/licenses.scm
+++ b/guix/licenses.scm
@@ -94,6 +94,7 @@
             fsf-free
             wtfpl2
             wxwindows3.1+
+            hpnd
             fsdg-compatible))
 
 (define-record-type <license>
@@ -628,6 +629,11 @@ which may be a file:// URI pointing the package's tree."
            "http://www.gzip.org/zlib/zlib_license.html"
            "https://www.gnu.org/licenses/license-list#ZLib"))
 
+(define hpnd
+  (license "HPND"
+           "https://directory.fsf.org/wiki/License:HPND"
+           "https://www.gnu.org/licenses/license-list#HPND"))
+
 (define* (fsf-free uri #:optional (comment ""))
   "Return a license that does not fit any of the ones above or a collection
 of licenses, approved as free by the FSF.  More details can be found at URI."
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index 8fa700c883..61ca4dca9f 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -935,9 +935,12 @@ needed."
                                     #:mode mode))
 
               (cond ((assoc-ref opts 'log-file?)
+                     ;; Pass 'show-build-log' the output file names, not the
+                     ;; derivation file names, because there can be several
+                     ;; derivations leading to the same output.
                      (for-each (cut show-build-log store <> urls)
                                (delete-duplicates
-                                (append (map derivation-file-name drv)
+                                (append (map derivation->output-path drv)
                                         items))))
                     ((assoc-ref opts 'derivations-only?)
                      (format #t "~{~a~%~}" (map derivation-file-name drv))
diff --git a/guix/utils.scm b/guix/utils.scm
index 709cdf9353..f480c3291f 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -718,7 +718,7 @@ environment variable name like \"XDG_CONFIG_HOME\"; SUFFIX is a suffix like
 
 (define (canonical-newline-port port)
   "Return an input port that wraps PORT such that all newlines consist
-  of a single carriage return."
+  of a single linefeed."
   (define (get-position)
     (if (port-has-port-position? port) (port-position port) #f))
   (define (set-position! position)
@@ -730,11 +730,11 @@ environment variable name like \"XDG_CONFIG_HOME\"; SUFFIX is a suffix like
     (let loop ((count 0)
                (byte (get-u8 port)))
       (cond ((eof-object? byte) count)
+            ;; XXX: consume all CRs even if not followed by LF.
+            ((eqv? byte (char->integer #\return)) (loop count (get-u8 port)))
             ((= count (- n 1))
              (bytevector-u8-set! bv (+ start count) byte)
              n)
-            ;; XXX: consume all LFs even if not followed by CR.
-            ((eqv? byte (char->integer #\return)) (loop count (get-u8 port)))
             (else
              (bytevector-u8-set! bv (+ start count) byte)
              (loop (+ count 1) (get-u8 port))))))