summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
Diffstat (limited to 'guix')
-rw-r--r--guix/build-system/gnu.scm4
-rw-r--r--guix/build/haskell-build-system.scm8
-rw-r--r--guix/download.scm9
-rw-r--r--guix/packages.scm3
-rw-r--r--guix/profiles.scm8
-rw-r--r--guix/records.scm273
-rw-r--r--guix/scripts/build.scm13
-rw-r--r--guix/scripts/environment.scm28
-rw-r--r--guix/tests.scm10
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."
generated by cgit v1.2.3 (git 2.46.2) at 2024-11-14 09:15:47 +0000