Merge branch 'master' into core-updates

Conflicts:
	gnu/packages/commencement.scm
	gnu/packages/xml.scm

9 files changed, 192 insertions, 164 deletions

diff --git a/guix/build-system/gnu.scm b/guix/build-system/gnu.scm
index da664e5422..05b6e6f680 100644
--- a/guix/build-system/gnu.scm
+++ b/guix/build-system/gnu.scm
@@ -160,12 +160,10 @@ flags for VARIABLE, the associated value is augmented."
   "A version of P linked with `-static-gcc'."
   (package-with-extra-configure-variable p "LDFLAGS" "-static-libgcc"))
 
-(define* (static-package p #:optional (loc (current-source-location))
-                         #:key (strip-all? #t))
+(define* (static-package p #:key (strip-all? #t))
   "Return a statically-linked version of package P.  If STRIP-ALL? is true,
 use `--strip-all' as the arguments to `strip'."
   (package (inherit p)
-    (location (source-properties->location loc))
     (arguments
      (let ((a (default-keyword-arguments (package-arguments p)
                 '(#:configure-flags '()
diff --git a/guix/build/haskell-build-system.scm b/guix/build/haskell-build-system.scm
index d382ee403d..c0cb789581 100644
--- a/guix/build/haskell-build-system.scm
+++ b/guix/build/haskell-build-system.scm
@@ -166,13 +166,13 @@ generate the cache as it would clash in user profiles."
                                     (package-name-version haskell)
                                     "/package.conf.d"))
          (id-rx (make-regexp "^id: *(.*)$"))
-         (lib-rx (make-regexp "lib.*\\.(a|so)"))
-         (config-file (string-append config-dir "/" name ".conf"))
+         (config-file (string-append out "/" name ".conf"))
          (params
           (list (string-append "--gen-pkg-config=" config-file))))
-    (unless (null? (find-files lib lib-rx))
+    (run-setuphs "register" params)
+    ;; The conf file is created only when there is a library to register.
+    (when (file-exists? config-file)
       (mkdir-p config-dir)
-      (run-setuphs "register" params)
       (let ((config-file-name+id
              (call-with-ascii-input-file config-file (cut grep id-rx <>))))
         (rename-file config-file
diff --git a/guix/download.scm b/guix/download.scm
index 6b0349402a..3f7f7badce 100644
--- a/guix/download.scm
+++ b/guix/download.scm
@@ -282,14 +282,15 @@ in the store."
                             )))))
 
 (define* (download-to-store store url #:optional (name (basename url))
-                            #:key (log (current-error-port)))
+                            #:key (log (current-error-port)) recursive?)
   "Download from URL to STORE, either under NAME or URL's basename if
-omitted.  Write progress reports to LOG."
+omitted.  Write progress reports to LOG.  RECURSIVE? has the same effect as
+the same-named parameter of 'add-to-store'."
   (define uri
     (string->uri url))
 
   (if (or (not uri) (memq (uri-scheme uri) '(file #f)))
-      (add-to-store store name #f "sha256"
+      (add-to-store store name recursive? "sha256"
                     (if uri (uri-path uri) url))
       (call-with-temporary-output-file
        (lambda (temp port)
@@ -298,6 +299,6 @@ omitted.  Write progress reports to LOG."
                   (build:url-fetch url temp #:mirrors %mirrors))))
            (close port)
            (and result
-                (add-to-store store name #f "sha256" temp)))))))
+                (add-to-store store name recursive? "sha256" temp)))))))
 
 ;;; download.scm ends here
diff --git a/guix/packages.scm b/guix/packages.scm
index cbe6127f28..5a280857ea 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -240,7 +240,8 @@ representation."
 
   (location package-location
             (default (and=> (current-source-location)
-                            source-properties->location))))
+                            source-properties->location))
+            (innate)))
 
 (set-record-type-printer! <package>
                           (lambda (package port)
diff --git a/guix/profiles.scm b/guix/profiles.scm
index 28150affb6..5c19c95d42 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -500,7 +500,10 @@ entries of MANIFEST, or #f if MANIFEST does not have any GHC packages."
           (string-append #$output "/" db-subdir))
 
         (define (conf-files top)
-          (find-files (string-append top "/" db-subdir) "\\.conf$"))
+          (let ((db (string-append top "/" db-subdir)))
+            (if (file-exists? db)
+                (find-files db "\\.conf$")
+                '())))
 
         (define (copy-conf-file conf)
           (let ((base (basename conf)))
@@ -509,7 +512,8 @@ entries of MANIFEST, or #f if MANIFEST does not have any GHC packages."
         (system* (string-append #+ghc "/bin/ghc-pkg") "init" db-dir)
         (for-each copy-conf-file
                   (append-map conf-files
-                              '#$(manifest-inputs manifest)))
+                              (delete-duplicates
+                               '#$(manifest-inputs manifest))))
         (let ((success
                (zero?
                 (system* (string-append #+ghc "/bin/ghc-pkg") "recache"
diff --git a/guix/records.scm b/guix/records.scm
index db59a99052..0d35a747b0 100644
--- a/guix/records.scm
+++ b/guix/records.scm
@@ -42,106 +42,123 @@
                        (format #f fmt args ...)
                        form))))
 
-(eval-when (expand load eval)
-  ;; This procedure is a syntactic helper used by 'define-record-type*', hence
-  ;; 'eval-when'.
-
-  (define* (make-syntactic-constructor type name ctor fields
-                                       #:key (thunked '()) (defaults '())
-                                       (delayed '()))
-    "Make the syntactic constructor NAME for TYPE, that calls CTOR, and expects
-all of FIELDS to be initialized.  DEFAULTS is the list of FIELD/DEFAULT-VALUE
-tuples, THUNKED is the list of identifiers of thunked fields, and DELAYED is
-the list of identifiers of delayed fields."
-    (with-syntax ((type     type)
-                  (name     name)
-                  (ctor     ctor)
-                  (expected fields)
-                  (defaults defaults))
-      #`(define-syntax name
-          (lambda (s)
-            (define (record-inheritance orig-record field+value)
-              ;; Produce code that returns a record identical to ORIG-RECORD,
-              ;; except that values for the FIELD+VALUE alist prevail.
-              (define (field-inherited-value f)
-                (and=> (find (lambda (x)
-                               (eq? f (car (syntax->datum x))))
-                             field+value)
-                       car))
-
-              ;; Make sure there are no unknown field names.
-              (let* ((fields     (map (compose car syntax->datum) field+value))
-                     (unexpected (lset-difference eq? fields 'expected)))
-                (when (pair? unexpected)
-                  (record-error 'name s "extraneous field initializers ~a"
-                                unexpected)))
-
-              #`(make-struct type 0
-                             #,@(map (lambda (field index)
-                                       (or (field-inherited-value field)
-                                           #`(struct-ref #,orig-record
-                                                         #,index)))
-                                     'expected
-                                     (iota (length 'expected)))))
-
-            (define (thunked-field? f)
-              (memq (syntax->datum f) '#,thunked))
-
-            (define (delayed-field? f)
-              (memq (syntax->datum f) '#,delayed))
-
-            (define (wrap-field-value f value)
-              (cond ((thunked-field? f)
-                     #`(lambda () #,value))
-                    ((delayed-field? f)
-                     #`(delay #,value))
-                    (else value)))
-
-            (define (field-bindings field+value)
-              ;; Return field to value bindings, for use in 'let*' below.
-              (map (lambda (field+value)
-                     (syntax-case field+value ()
-                       ((field value)
-                        #`(field
-                           #,(wrap-field-value #'field #'value)))))
-                   field+value))
-
-            (syntax-case s (inherit #,@fields)
-              ((_ (inherit orig-record) (field value) (... ...))
-               #`(let* #,(field-bindings #'((field value) (... ...)))
-                   #,(record-inheritance #'orig-record
-                                         #'((field value) (... ...)))))
-              ((_ (field value) (... ...))
-               (let ((fields (map syntax->datum #'(field (... ...))))
-                     (dflt   (map (match-lambda
-                                    ((f v)
-                                     (list (syntax->datum f) v)))
-                                  #'defaults)))
-
-                 (define (field-value f)
-                   (or (and=> (find (lambda (x)
-                                      (eq? f (car (syntax->datum x))))
-                                    #'((field value) (... ...)))
-                              car)
-                       (let ((value
-                              (car (assoc-ref dflt (syntax->datum f)))))
-                         (wrap-field-value f value))))
-
-                 (let ((fields (append fields (map car dflt))))
-                   (cond ((lset= eq? fields 'expected)
-                          #`(let* #,(field-bindings
-                                     #'((field value) (... ...)))
-                              (ctor #,@(map field-value 'expected))))
-                         ((pair? (lset-difference eq? fields 'expected))
-                          (record-error 'name s
-                                        "extraneous field initializers ~a"
-                                        (lset-difference eq? fields
-                                                         'expected)))
-                         (else
-                          (record-error 'name s
-                                        "missing field initializers ~a"
-                                        (lset-difference eq? 'expected
-                                                         fields)))))))))))))
+(define-syntax make-syntactic-constructor
+  (syntax-rules ()
+    "Make the syntactic constructor NAME for TYPE, that calls CTOR, and
+expects all of EXPECTED fields to be initialized.  DEFAULTS is the list of
+FIELD/DEFAULT-VALUE tuples, THUNKED is the list of identifiers of thunked
+fields, and DELAYED is the list of identifiers of delayed fields."
+    ((_ type name ctor (expected ...)
+        #:thunked thunked
+        #:delayed delayed
+        #:innate innate
+        #:defaults defaults)
+     (define-syntax name
+       (lambda (s)
+         (define (record-inheritance orig-record field+value)
+           ;; Produce code that returns a record identical to ORIG-RECORD,
+           ;; except that values for the FIELD+VALUE alist prevail.
+           (define (field-inherited-value f)
+             (and=> (find (lambda (x)
+                            (eq? f (car (syntax->datum x))))
+                          field+value)
+                    car))
+
+           ;; Make sure there are no unknown field names.
+           (let* ((fields     (map (compose car syntax->datum) field+value))
+                  (unexpected (lset-difference eq? fields '(expected ...))))
+             (when (pair? unexpected)
+               (record-error 'name s "extraneous field initializers ~a"
+                             unexpected)))
+
+           #`(make-struct type 0
+                          #,@(map (lambda (field index)
+                                    (or (field-inherited-value field)
+                                        (if (innate-field? field)
+                                            (wrap-field-value
+                                             field (field-default-value field))
+                                            #`(struct-ref #,orig-record
+                                                          #,index))))
+                                  '(expected ...)
+                                  (iota (length '(expected ...))))))
+
+         (define (thunked-field? f)
+           (memq (syntax->datum f) 'thunked))
+
+         (define (delayed-field? f)
+           (memq (syntax->datum f) 'delayed))
+
+         (define (innate-field? f)
+           (memq (syntax->datum f) 'innate))
+
+         (define (wrap-field-value f value)
+           (cond ((thunked-field? f)
+                  #`(lambda () #,value))
+                 ((delayed-field? f)
+                  #`(delay #,value))
+                 (else value)))
+
+         (define default-values
+           ;; List of symbol/value tuples.
+           (map (match-lambda
+                  ((f v)
+                   (list (syntax->datum f) v)))
+                #'defaults))
+
+         (define (field-default-value f)
+           (car (assoc-ref default-values (syntax->datum f))))
+
+         (define (field-bindings field+value)
+           ;; Return field to value bindings, for use in 'let*' below.
+           (map (lambda (field+value)
+                  (syntax-case field+value ()
+                    ((field value)
+                     #`(field
+                        #,(wrap-field-value #'field #'value)))))
+                field+value))
+
+         (syntax-case s (inherit expected ...)
+           ((_ (inherit orig-record) (field value) (... ...))
+            #`(let* #,(field-bindings #'((field value) (... ...)))
+                #,(record-inheritance #'orig-record
+                                      #'((field value) (... ...)))))
+           ((_ (field value) (... ...))
+            (let ((fields (map syntax->datum #'(field (... ...)))))
+              (define (field-value f)
+                (or (and=> (find (lambda (x)
+                                   (eq? f (car (syntax->datum x))))
+                                 #'((field value) (... ...)))
+                           car)
+                    (wrap-field-value f (field-default-value f))))
+
+              (let ((fields (append fields (map car default-values))))
+                (cond ((lset= eq? fields '(expected ...))
+                       #`(let* #,(field-bindings
+                                  #'((field value) (... ...)))
+                           (ctor #,@(map field-value '(expected ...)))))
+                      ((pair? (lset-difference eq? fields
+                                               '(expected ...)))
+                       (record-error 'name s
+                                     "extraneous field initializers ~a"
+                                     (lset-difference eq? fields
+                                                      '(expected ...))))
+                      (else
+                       (record-error 'name s
+                                     "missing field initializers ~a"
+                                     (lset-difference eq?
+                                                      '(expected ...)
+                                                      fields)))))))))))))
+
+(define-syntax-rule (define-field-property-predicate predicate property)
+  "Define PREDICATE as a procedure that takes a syntax object and, when passed
+a field specification, returns the field name if it has the given PROPERTY."
+  (define (predicate s)
+    (syntax-case s (property)
+      ((field (property values (... ...)) _ (... ...))
+       #'field)
+      ((field _ properties (... ...))
+       (predicate #'(field properties (... ...))))
+      (_ #f))))
 
 (define-syntax define-record-type*
   (lambda (s)
@@ -154,7 +171,8 @@ may look like this:
     thing?
     (name  thing-name (default \"chbouib\"))
     (port  thing-port
-           (default (current-output-port)) (thunked)))
+           (default (current-output-port)) (thunked))
+    (loc   thing-location (innate) (default (current-source-location))))
 
 This example defines a macro 'thing' that can be used to instantiate records
 of this type:
@@ -180,33 +198,20 @@ It is possible to copy an object 'x' created with 'thing' like this:
   (thing (inherit x) (name \"bar\"))
 
 This expression returns a new object equal to 'x' except for its 'name'
-field."
+field and its 'loc' field---the latter is marked as \"innate\", so it is not
+inherited."
 
     (define (field-default-value s)
       (syntax-case s (default)
         ((field (default val) _ ...)
          (list #'field #'val))
-        ((field _ options ...)
-         (field-default-value #'(field options ...)))
-        (_ #f)))
-
-    (define (delayed-field? s)
-      ;; Return the field name if the field defined by S is delayed.
-      (syntax-case s (delayed)
-        ((field (delayed) _ ...)
-         #'field)
-        ((field _ options ...)
-         (delayed-field? #'(field options ...)))
+        ((field _ properties ...)
+         (field-default-value #'(field properties ...)))
         (_ #f)))
 
-    (define (thunked-field? s)
-      ;; Return the field name if the field defined by S is thunked.
-      (syntax-case s (thunked)
-        ((field (thunked) _ ...)
-         #'field)
-        ((field _ options ...)
-         (thunked-field? #'(field options ...)))
-        (_ #f)))
+    (define-field-property-predicate delayed-field? delayed)
+    (define-field-property-predicate thunked-field? thunked)
+    (define-field-property-predicate innate-field? innate)
 
     (define (wrapped-field? s)
       (or (thunked-field? s) (delayed-field? s)))
@@ -215,7 +220,7 @@ field."
       ;; Return the name (an unhygienic syntax object) of the "real"
       ;; getter for field, which is assumed to be a wrapped field.
       (syntax-case field ()
-        ((field get options ...)
+        ((field get properties ...)
          (let* ((getter      (syntax->datum #'get))
                 (real-getter (symbol-append '% getter '-real)))
            (datum->syntax #'get real-getter)))))
@@ -224,7 +229,7 @@ field."
       ;; Convert a field spec of our style to a SRFI-9 field spec of the
       ;; form (field get).
       (syntax-case field ()
-        ((name get options ...)
+        ((name get properties ...)
          #`(name
             #,(if (wrapped-field? field)
                   (wrapped-field-accessor-name field)
@@ -252,12 +257,13 @@ field."
 
     (syntax-case s ()
       ((_ type syntactic-ctor ctor pred
-          (field get options ...) ...)
-       (let* ((field-spec #'((field get options ...) ...))
+          (field get properties ...) ...)
+       (let* ((field-spec #'((field get properties ...) ...))
               (thunked    (filter-map thunked-field? field-spec))
               (delayed    (filter-map delayed-field? field-spec))
+              (innate     (filter-map innate-field? field-spec))
               (defaults   (filter-map field-default-value
-                                      #'((field options ...) ...))))
+                                      #'((field properties ...) ...))))
          (with-syntax (((field-spec* ...)
                         (map field-spec->srfi-9 field-spec))
                        ((thunked-field-accessor ...)
@@ -277,13 +283,14 @@ field."
                  (ctor field ...)
                  pred
                  field-spec* ...)
-               (begin thunked-field-accessor ...
-                      delayed-field-accessor ...)
-               #,(make-syntactic-constructor #'type #'syntactic-ctor #'ctor
-                                             #'(field ...)
-                                             #:thunked thunked
-                                             #:delayed delayed
-                                             #:defaults defaults))))))))
+               thunked-field-accessor ...
+               delayed-field-accessor ...
+               (make-syntactic-constructor type syntactic-ctor ctor
+                                           (field ...)
+                                           #:thunked #,thunked
+                                           #:delayed #,delayed
+                                           #:innate #,innate
+                                           #:defaults #,defaults))))))))
 
 (define* (alist->record alist make keys
                         #:optional (multiple-value-keys '()))
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index 2307f76b42..7fd05da189 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -77,19 +77,26 @@ the new package's version number from URI."
     ;; Return the "base" of FILE-NAME, removing '.tar.gz' or similar
     ;; extensions.
     ;; TODO: Factorize.
-    (cond ((numeric-extension? file-name)
+    (cond ((not (file-extension file-name))
+           file-name)
+          ((numeric-extension? file-name)
            file-name)
           ((string=? (file-extension file-name) "tar")
            (file-sans-extension file-name))
+          ((file-extension file-name)
+           (tarball-base-name (file-sans-extension file-name)))
           (else
-           (tarball-base-name (file-sans-extension file-name)))))
+           file-name)))
 
   (let ((base (tarball-base-name (basename uri))))
     (let-values (((name version)
                   (package-name->name+version base)))
       (package (inherit p)
                (version (or version (package-version p)))
-               (source (download-to-store store uri))))))
+
+               ;; Use #:recursive? #t to allow for directories.
+               (source (download-to-store store uri
+                                          #:recursive? #t))))))
 
 
 ;;;
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index 42178091e6..007fde1606 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -232,20 +232,22 @@ packages."
     (alist-cons 'package arg result))
 
   (with-error-handling
-    (with-store store
-      (let* ((opts  (parse-command-line args %options (list %default-options)
-                                        #:argument-handler handle-argument))
-             (pure? (assoc-ref opts 'pure))
-             (ad-hoc? (assoc-ref opts 'ad-hoc?))
-             (command (assoc-ref opts 'exec))
-             (packages (pick-all (options/resolve-packages opts) 'package))
-             (inputs (if ad-hoc?
+    (let* ((opts     (parse-command-line args %options (list %default-options)
+                                         #:argument-handler handle-argument))
+           (pure?    (assoc-ref opts 'pure))
+           (ad-hoc?  (assoc-ref opts 'ad-hoc?))
+           (command  (assoc-ref opts 'exec))
+           (packages (pick-all (options/resolve-packages opts) 'package))
+           (inputs   (if ad-hoc?
                          (packages+propagated-inputs packages)
-                         (packages->transitive-inputs packages)))
-             (drvs (run-with-store store
-                     (mbegin %store-monad
-                       (set-guile-for-build (default-guile))
-                       (build-inputs inputs opts)))))
+                         (packages->transitive-inputs packages))))
+      (with-store store
+        (define drvs
+          (run-with-store store
+            (mbegin %store-monad
+              (set-guile-for-build (default-guile))
+              (build-inputs inputs opts))))
+
         (cond ((assoc-ref opts 'dry-run?)
                #t)
               ((assoc-ref opts 'search-paths)
diff --git a/guix/tests.scm b/guix/tests.scm
index 87e6cc2830..a19eda250c 100644
--- a/guix/tests.scm
+++ b/guix/tests.scm
@@ -63,8 +63,16 @@
 
       store)))
 
+(define (random-seed)
+  (or (and=> (getenv "GUIX_TESTS_RANDOM_SEED")
+             number->string)
+      (logxor (getpid) (car (gettimeofday)))))
+
 (define %seed
-  (seed->random-state (logxor (getpid) (car (gettimeofday)))))
+  (let ((seed (random-seed)))
+    (format (current-error-port) "random seed for tests: ~a~%"
+            seed)
+    (seed->random-state seed)))
 
 (define (random-text)
   "Return the hexadecimal representation of a random number."