From c2590362ad7c926050db0ea1dacd437027241520 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 11 Jun 2015 11:09:12 +0200 Subject: environment: Connect to the store after the command line has been parsed. * guix/scripts/environment.scm (guix-environment): Call 'parse-command-line' outside of 'with-store'. This allows things like --help to run even if the daemon is not running. --- guix/scripts/environment.scm | 28 +++++++++++++++------------- 1 file changed, 15 insertions(+), 13 deletions(-) (limited to 'guix') 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 @@ (define (handle-argument arg result) (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) -- cgit v1.2.3 From a43b55f1a6fa0eb712b2610b86a1775383d3f2cd Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 11 Jun 2015 11:19:12 +0200 Subject: guix build: Allow directories to be passed to --with-source. * guix/scripts/build.scm (package-with-source)[tarball-base-name]: Gracefully handle file names that lack an extension. Pass #:recursive? #t to 'download-to-store'. * guix/download.scm (download-to-store): Add #:recursive? parameter and pass it to 'add-to-store'. * doc/guix.texi (Invoking guix build): Add an example of --with-source with a directory. --- doc/guix.texi | 7 +++++++ guix/download.scm | 9 +++++---- guix/scripts/build.scm | 13 ++++++++++--- 3 files changed, 22 insertions(+), 7 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index be7a292f08..c70d1000ae 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3438,6 +3438,13 @@ candidates: guix build guile --with-source=../guile-2.0.9.219-e1bb7.tar.xz @end example +@dots{} or to build from a checkout in a pristine environment: + +@example +$ git clone git://git.sv.gnu.org/guix.git +$ guix build guix --with-source=./guix +@end example + @item --no-grafts Do not ``graft'' packages. In practice, this means that package updates available as grafts are not applied. @xref{Security Updates}, for more 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 @@ (define builder ))))) (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 @@ (define uri (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/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 @@ (define (tarball-base-name file-name) ;; 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)))))) ;;; -- cgit v1.2.3 From 39fc041a7de18e4b41c4e9007cfdadbff581334a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 11 Jun 2015 21:37:49 +0200 Subject: records: Replace 'eval-when' with a proper 'define-syntax'. * guix/records.scm (make-syntactic-constructor): Remove enclosing 'eval-when'. Turn into a 'syntax-rules' macro. --- guix/records.scm | 206 +++++++++++++++++++++++++++---------------------------- 1 file changed, 101 insertions(+), 105 deletions(-) (limited to 'guix') diff --git a/guix/records.scm b/guix/records.scm index db59a99052..2378969843 100644 --- a/guix/records.scm +++ b/guix/records.scm @@ -42,106 +42,102 @@ (define-syntax record-error (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 + #: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 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 (... ...)))) + (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 define-record-type* (lambda (s) @@ -279,11 +275,11 @@ (define-record-type type field-spec* ...) (begin thunked-field-accessor ... delayed-field-accessor ...) - #,(make-syntactic-constructor #'type #'syntactic-ctor #'ctor - #'(field ...) - #:thunked thunked - #:delayed delayed - #:defaults defaults)))))))) + (make-syntactic-constructor type syntactic-ctor ctor + (field ...) + #:thunked #,thunked + #:delayed #,delayed + #:defaults #,defaults)))))))) (define* (alist->record alist make keys #:optional (multiple-value-keys '())) -- cgit v1.2.3 From b9c8647337762983ac046aec66328ad0efd2f276 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 11 Jun 2015 21:49:02 +0200 Subject: records: Separate default-value handling. * guix/records.scm (make-syntactic-constructor)[default-values]: New variable. [field-default-value]: New procedure. Use them. --- guix/records.scm | 23 +++++++++++++---------- 1 file changed, 13 insertions(+), 10 deletions(-) (limited to 'guix') diff --git a/guix/records.scm b/guix/records.scm index 2378969843..f66fda8a32 100644 --- a/guix/records.scm +++ b/guix/records.scm @@ -91,6 +91,16 @@ (define (wrap-field-value f value) #`(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) @@ -106,22 +116,15 @@ (define (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))) - + (let ((fields (map syntax->datum #'(field (... ...))))) (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)))) + (wrap-field-value f (field-default-value f)))) - (let ((fields (append fields (map car dflt)))) + (let ((fields (append fields (map car default-values)))) (cond ((lset= eq? fields '(expected ...)) #`(let* #,(field-bindings #'((field value) (... ...))) -- cgit v1.2.3 From faef3b6a96114524c2a25e3b84caa042a2d2e598 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 11 Jun 2015 22:22:05 +0200 Subject: records: Factorize field property predicates. * guix/records.scm (define-field-property-predicate): New macro. (define-record-type*)[thunked-field?, delayed-field?]: Use it. --- guix/records.scm | 30 +++++++++++++----------------- 1 file changed, 13 insertions(+), 17 deletions(-) (limited to 'guix') diff --git a/guix/records.scm b/guix/records.scm index f66fda8a32..dbdd2201a6 100644 --- a/guix/records.scm +++ b/guix/records.scm @@ -142,6 +142,17 @@ (define (field-value f) '(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) "Define the given record type such that an additional \"syntactic @@ -189,23 +200,8 @@ (define (field-default-value s) (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 ...))) - (_ #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 (wrapped-field? s) (or (thunked-field? s) (delayed-field? s))) -- cgit v1.2.3 From 792798f48647ef664cfe6fdd7ff313901e383f6c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 11 Jun 2015 22:26:18 +0200 Subject: records: "options" → "properties". MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/records.scm (define-record-type*): Change "options" to "properties". --- guix/records.scm | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) (limited to 'guix') diff --git a/guix/records.scm b/guix/records.scm index dbdd2201a6..816e9f6f01 100644 --- a/guix/records.scm +++ b/guix/records.scm @@ -196,8 +196,8 @@ (define (field-default-value s) (syntax-case s (default) ((field (default val) _ ...) (list #'field #'val)) - ((field _ options ...) - (field-default-value #'(field options ...))) + ((field _ properties ...) + (field-default-value #'(field properties ...))) (_ #f))) (define-field-property-predicate delayed-field? delayed) @@ -210,7 +210,7 @@ (define (wrapped-field-accessor-name 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))))) @@ -219,7 +219,7 @@ (define (field-spec->srfi-9 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) @@ -247,12 +247,12 @@ (define (delayed-field-accessor-definition 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)) (defaults (filter-map field-default-value - #'((field options ...) ...)))) + #'((field properties ...) ...)))) (with-syntax (((field-spec* ...) (map field-spec->srfi-9 field-spec)) ((thunked-field-accessor ...) -- cgit v1.2.3 From 8a16d064fa265c449d136ff6c3d3267e314cde8d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 11 Jun 2015 22:57:33 +0200 Subject: records: Add support for 'innate' fields. * guix/records.scm (make-syntactic-constructor): Add #:innate parameter. [record-inheritance]: Honor it. [innate-field?]: New procedure. (define-record-type*)[innate-field?]: New procedure. Pass #:innate to 'make-syntactic-constructor'. * tests/records.scm ("define-record-type* & inherit & innate", "define-record-type* & thunked & innate"): New tests. --- guix/records.scm | 20 ++++++++++++++++---- tests/records.scm | 30 ++++++++++++++++++++++++++++++ 2 files changed, 46 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/records.scm b/guix/records.scm index 816e9f6f01..b68aaae1c4 100644 --- a/guix/records.scm +++ b/guix/records.scm @@ -51,6 +51,7 @@ (define-syntax make-syntactic-constructor ((_ type name ctor (expected ...) #:thunked thunked #:delayed delayed + #:innate innate #:defaults defaults) (define-syntax name (lambda (s) @@ -73,8 +74,11 @@ (define (field-inherited-value f) #`(make-struct type 0 #,@(map (lambda (field index) (or (field-inherited-value field) - #`(struct-ref #,orig-record - #,index))) + (if (innate-field? field) + (wrap-field-value + field (field-default-value field)) + #`(struct-ref #,orig-record + #,index)))) '(expected ...) (iota (length '(expected ...)))))) @@ -84,6 +88,9 @@ (define (thunked-field? f) (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)) @@ -164,7 +171,8 @@ (define-record-type* thing make-thing 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: @@ -190,7 +198,8 @@ (define-record-type* thing make-thing (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) @@ -202,6 +211,7 @@ (define (field-default-value s) (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))) @@ -251,6 +261,7 @@ (define (delayed-field-accessor-definition field) (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 properties ...) ...)))) (with-syntax (((field-spec* ...) @@ -278,6 +289,7 @@ (define-record-type type (field ...) #:thunked #,thunked #:delayed #,delayed + #:innate #,innate #:defaults #,defaults)))))))) (define* (alist->record alist make keys diff --git a/tests/records.scm b/tests/records.scm index a00e38db7d..6346c154cd 100644 --- a/tests/records.scm +++ b/tests/records.scm @@ -90,6 +90,20 @@ (define-record-type* foo make-foo (match b (($ 1 2) #t)) (equal? b c))))) +(test-assert "define-record-type* & inherit & innate" + (begin + (define-record-type* foo make-foo + foo? + (bar foo-bar (innate) (default 42))) + (let* ((a (foo (bar 1))) + (b (foo (inherit a))) + (c (foo (inherit a) (bar 3))) + (d (foo))) + (and (match a (($ 1) #t)) + (match b (($ 42) #t)) + (match c (($ 3) #t)) + (match d (($ 42) #t)))))) + (test-assert "define-record-type* & thunked" (begin (define-record-type* foo make-foo @@ -139,6 +153,22 @@ (define-record-type* foo make-foo (parameterize ((mark (cons 'a 'b))) (eq? (foo-baz y) (mark)))))))) +(test-assert "define-record-type* & thunked & innate" + (let ((mark (make-parameter #f))) + (define-record-type* foo make-foo + foo? + (bar foo-bar (thunked) (innate) (default (mark))) + (baz foo-baz (default #f))) + + (let* ((x (foo (bar 42))) + (y (foo (inherit x) (baz 'unused)))) + (and (procedure? (struct-ref x 0)) + (equal? (foo-bar x) 42) + (parameterize ((mark (cons 'a 'b))) + (eq? (foo-bar y) (mark))) + (parameterize ((mark (cons 'a 'b))) + (eq? (foo-bar y) (mark))))))) + (test-assert "define-record-type* & delayed" (begin (define-record-type* foo make-foo -- cgit v1.2.3 From 0004c5904c2e69a89005eac8b6322d18a8e9f611 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 11 Jun 2015 23:06:06 +0200 Subject: packages: Make 'location' field innate. * guix/packages.scm ()[location]: Add 'innate' property. * guix/build-system/gnu.scm (static-package): Remove 'loc' parameter and 'location' field. * gnu/packages/autotools.scm (autoconf-wrapper): Remove 'location' field. * gnu/packages/commencement.scm (gnu-make-boot0, diffutils-boot0, gcc-final): Likewise. * gnu/packages/cross-base.scm (cross): Likewise. * gnu/packages/emacs.scm (emacs-no-x, emacs-no-x-toolkit): Likewise. * gnu/packages/make-bootstrap.scm (tarball-package): Likewise. * gnu/packages/maths.scm (petsc-complex): Likewise. --- gnu/packages/autotools.scm | 1 - gnu/packages/commencement.scm | 3 --- gnu/packages/cross-base.scm | 1 - gnu/packages/emacs.scm | 2 -- gnu/packages/make-bootstrap.scm | 3 +-- gnu/packages/maths.scm | 1 - guix/build-system/gnu.scm | 4 +--- guix/packages.scm | 3 ++- 8 files changed, 4 insertions(+), 14 deletions(-) (limited to 'guix') diff --git a/gnu/packages/autotools.scm b/gnu/packages/autotools.scm index 24ff90cc5c..f2b4d95b95 100644 --- a/gnu/packages/autotools.scm +++ b/gnu/packages/autotools.scm @@ -95,7 +95,6 @@ (define* (autoconf-wrapper #:optional (autoconf autoconf)) only be used internally---users should not end up distributing `configure' files with a system-specific shebang." (package (inherit autoconf) - (location (source-properties->location (current-source-location))) (name (string-append (package-name autoconf) "-wrapper")) (build-system trivial-build-system) (inputs `(("guile" diff --git a/gnu/packages/commencement.scm b/gnu/packages/commencement.scm index 9611ff2620..a5402f0556 100644 --- a/gnu/packages/commencement.scm +++ b/gnu/packages/commencement.scm @@ -65,7 +65,6 @@ (define gnu-make-boot0 (package-with-bootstrap-guile (package (inherit gnu-make) (name "make-boot0") - (location (source-properties->location (current-source-location))) (arguments `(#:guile ,%bootstrap-guile #:implicit-inputs? #f @@ -93,7 +92,6 @@ (define diffutils-boot0 ,@%bootstrap-inputs) #:guile %bootstrap-guile))) (package (inherit p) - (location (source-properties->location (current-source-location))) (arguments `(#:tests? #f ; the test suite needs diffutils ,@(package-arguments p))))))) @@ -531,7 +529,6 @@ (define-public gcc-final ;; The final GCC. (package (inherit gcc-boot0) (name "gcc") - (location (source-properties->location (current-source-location))) (arguments `(#:guile ,%bootstrap-guile #:implicit-inputs? #f diff --git a/gnu/packages/cross-base.scm b/gnu/packages/cross-base.scm index 9a459400e8..f1aca505d8 100644 --- a/gnu/packages/cross-base.scm +++ b/gnu/packages/cross-base.scm @@ -38,7 +38,6 @@ (define-module (gnu packages cross-base) (define (cross p target) (package (inherit p) - (location (source-properties->location (current-source-location))) (name (string-append (package-name p) "-cross-" target)) (arguments (substitute-keyword-arguments (package-arguments p) diff --git a/gnu/packages/emacs.scm b/gnu/packages/emacs.scm index fbddff1cf6..0f71c77bf2 100644 --- a/gnu/packages/emacs.scm +++ b/gnu/packages/emacs.scm @@ -123,7 +123,6 @@ (define-public emacs-no-x ;; This is the version that you should use as an input to packages that just ;; need to byte-compile .el files. (package (inherit emacs) - (location (source-properties->location (current-source-location))) (name "emacs-no-x") (synopsis "The extensible, customizable, self-documenting text editor (console only)") @@ -138,7 +137,6 @@ (define-public emacs-no-x (define-public emacs-no-x-toolkit (package (inherit emacs) - (location (source-properties->location (current-source-location))) (name "emacs-no-x-toolkit") (synopsis "The extensible, customizable, self-documenting text editor (without an X toolkit)" ) diff --git a/gnu/packages/make-bootstrap.scm b/gnu/packages/make-bootstrap.scm index 88fad0e604..7f1b6d50b0 100644 --- a/gnu/packages/make-bootstrap.scm +++ b/gnu/packages/make-bootstrap.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -605,7 +605,6 @@ (define %guile-static-stripped (define (tarball-package pkg) "Return a package containing a tarball of PKG." (package (inherit pkg) - (location (source-properties->location (current-source-location))) (name (string-append (package-name pkg) "-tarball")) (build-system trivial-build-system) (native-inputs `(("tar" ,tar) diff --git a/gnu/packages/maths.scm b/gnu/packages/maths.scm index 4d837c85e2..6fbe6fd27d 100644 --- a/gnu/packages/maths.scm +++ b/gnu/packages/maths.scm @@ -560,7 +560,6 @@ (define-public petsc (define-public petsc-complex (package (inherit petsc) - (location (source-properties->location (current-source-location))) (name "petsc-complex") (arguments (substitute-keyword-arguments (package-arguments petsc) 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 @@ (define (static-libgcc-package p) "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/packages.scm b/guix/packages.scm index c955b35155..c900541e53 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -240,7 +240,8 @@ (define-record-type* (location package-location (default (and=> (current-source-location) - source-properties->location)))) + source-properties->location)) + (innate))) (set-record-type-printer! (lambda (package port) -- cgit v1.2.3 From 79477def6b08437e4eacaf67c012ae8717bd64e3 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 11 Jun 2015 23:17:16 +0200 Subject: tests: Write the random seed to the error port. * guix/tests.scm (random-seed): New procedure. (%seed): Use it, and write the random seed to the error port. --- guix/tests.scm | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) (limited to 'guix') 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 @@ (define (open-connection-for-tests) 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." -- cgit v1.2.3 From ad7c1a2cde80c00f0394a48c0c2be0a478900eb4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 11 Jun 2015 23:28:13 +0200 Subject: records: Remove unnecessary 'begin'. * guix/records.scm (define-record-type*): Remove unnecessary 'begin'. --- guix/records.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/records.scm b/guix/records.scm index b68aaae1c4..0d35a747b0 100644 --- a/guix/records.scm +++ b/guix/records.scm @@ -283,8 +283,8 @@ (define-record-type type (ctor field ...) pred field-spec* ...) - (begin thunked-field-accessor ... - delayed-field-accessor ...) + thunked-field-accessor ... + delayed-field-accessor ... (make-syntactic-constructor type syntactic-ctor ctor (field ...) #:thunked #,thunked -- cgit v1.2.3 From 84de458ba8c6499dd63c6d7e7c67087df339e371 Mon Sep 17 00:00:00 2001 From: Eric Bavier Date: Sat, 6 Jun 2015 06:38:58 -0500 Subject: profiles: Search for ghc conf files only if package db exists. This avoids having 'find-files' report warnings about searching in non-existent directories. * guix/profiles.scm (ghc-package-cache-file)[conf-files]: Only search for *.conf files if the search directory exists. --- guix/profiles.scm | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/profiles.scm b/guix/profiles.scm index 28150affb6..33a0511a3a 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -500,7 +500,10 @@ (define db-dir (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))) -- cgit v1.2.3 From b4b1fe9d2f7321a95fa16d18a5f0088908122361 Mon Sep 17 00:00:00 2001 From: Eric Bavier Date: Sat, 6 Jun 2015 06:43:19 -0500 Subject: profiles: Process ghc conf files only once. A package may be listed in the manifest inputs multiple times. Avoid copying ghc *.conf files twice by deleting duplicates. * guix/profiles.scm (ghc-package-cache-file)[conf-files]: Delete duplicate manifest inputs before copying conf files. --- guix/profiles.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/profiles.scm b/guix/profiles.scm index 33a0511a3a..5c19c95d42 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -512,7 +512,8 @@ (define (copy-conf-file conf) (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" -- cgit v1.2.3 From 6508ce55e95b0472b2212befcb56919eb44fb41c Mon Sep 17 00:00:00 2001 From: Eric Bavier Date: Sat, 6 Jun 2015 07:28:57 -0500 Subject: build-system/haskell: install config for any package that creates it. A Cabal package is allowed to declare an "empty" library, in an otherwise executable-only package, for the purpose of allowing Cabal to use it as a dependency for other packages. See e.g. hspec-discover. * guix/build/haskell-build-system.scm (register): Unconditionally call setup script with "register", and install any config file generated. --- guix/build/haskell-build-system.scm | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) (limited to 'guix') 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 @@ (define* (register #:key name system inputs outputs #:allow-other-keys) (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 -- cgit v1.2.3