mirror of https://notabug.org/mthl/cuirass.git
λ all the things!
parent
7ae6ce0690
commit
13db5aa618
|
@ -86,7 +86,7 @@ if required."
|
||||||
(define (evaluate store db spec)
|
(define (evaluate store db spec)
|
||||||
"Evaluate and build package derivations. Return a list a jobs."
|
"Evaluate and build package derivations. Return a list a jobs."
|
||||||
(save-module-excursion
|
(save-module-excursion
|
||||||
(lambda ()
|
(λ ()
|
||||||
(set-current-module %user-module)
|
(set-current-module %user-module)
|
||||||
;; Handle both relative and absolute file names for SPEC-FILE.
|
;; Handle both relative and absolute file names for SPEC-FILE.
|
||||||
(with-directory-excursion
|
(with-directory-excursion
|
||||||
|
@ -108,7 +108,7 @@ if required."
|
||||||
(guix-variable 'store 'current-build-output-port))
|
(guix-variable 'store 'current-build-output-port))
|
||||||
(derivation-path->output-path
|
(derivation-path->output-path
|
||||||
(guix-variable 'derivations 'derivation-path->output-path)))
|
(guix-variable 'derivations 'derivation-path->output-path)))
|
||||||
(map (lambda (job)
|
(map (λ (job)
|
||||||
(let ((log-port (tmpfile))
|
(let ((log-port (tmpfile))
|
||||||
(name (job-name job))
|
(name (job-name job))
|
||||||
(drv (job-derivation job)))
|
(drv (job-derivation job)))
|
||||||
|
@ -155,13 +155,13 @@ if required."
|
||||||
(let ((store ((guix-variable 'store 'open-connection))))
|
(let ((store ((guix-variable 'store 'open-connection))))
|
||||||
(dynamic-wind
|
(dynamic-wind
|
||||||
(const #t)
|
(const #t)
|
||||||
(lambda ()
|
(λ ()
|
||||||
(let ((jobs (evaluate store db spec))
|
(let ((jobs (evaluate store db spec))
|
||||||
(set-build-options
|
(set-build-options
|
||||||
(guix-variable 'store 'set-build-options)))
|
(guix-variable 'store 'set-build-options)))
|
||||||
(set-build-options store #:use-substitutes? #f)
|
(set-build-options store #:use-substitutes? #f)
|
||||||
(build-packages store db jobs)))
|
(build-packages store db jobs)))
|
||||||
(lambda ()
|
(λ ()
|
||||||
((guix-variable 'store 'close-connection) store)
|
((guix-variable 'store 'close-connection) store)
|
||||||
(set! %load-path old-path))))))
|
(set! %load-path old-path))))))
|
||||||
specs)
|
specs)
|
||||||
|
|
|
@ -68,7 +68,7 @@ values."
|
||||||
(define (call-with-time-display thunk)
|
(define (call-with-time-display thunk)
|
||||||
"Call THUNK and write to the current output port its duration."
|
"Call THUNK and write to the current output port its duration."
|
||||||
(call-with-time thunk
|
(call-with-time thunk
|
||||||
(lambda (time . results)
|
(λ (time . results)
|
||||||
(format #t "~,3f seconds~%"
|
(format #t "~,3f seconds~%"
|
||||||
(+ (time-second time)
|
(+ (time-second time)
|
||||||
(/ (time-nanosecond time) 1e9)))
|
(/ (time-nanosecond time) 1e9)))
|
||||||
|
|
|
@ -119,10 +119,8 @@ database object."
|
||||||
(let ((db (db-init)))
|
(let ((db (db-init)))
|
||||||
(dynamic-wind
|
(dynamic-wind
|
||||||
(const #t)
|
(const #t)
|
||||||
(lambda ()
|
(λ () body ...)
|
||||||
body ...)
|
(λ () (db-close db)))))
|
||||||
(lambda ()
|
|
||||||
(db-close db)))))
|
|
||||||
|
|
||||||
(define* (read-quoted-string #:optional port)
|
(define* (read-quoted-string #:optional port)
|
||||||
"Read all of the characters out of PORT and return them as a SQL quoted
|
"Read all of the characters out of PORT and return them as a SQL quoted
|
||||||
|
|
|
@ -23,11 +23,15 @@
|
||||||
#:export (;; Procedures
|
#:export (;; Procedures
|
||||||
mkdir-p
|
mkdir-p
|
||||||
;; Macros.
|
;; Macros.
|
||||||
|
λ*
|
||||||
with-directory-excursion))
|
with-directory-excursion))
|
||||||
|
|
||||||
|
(define-syntax-rule (λ* formals body ...)
|
||||||
|
(lambda* formals body ...))
|
||||||
|
|
||||||
(define mkdir-p
|
(define mkdir-p
|
||||||
(let ((not-slash (char-set-complement (char-set #\/))))
|
(let ((not-slash (char-set-complement (char-set #\/))))
|
||||||
(lambda* (dir #:optional mode)
|
(λ* (dir #:optional mode)
|
||||||
"Create directory DIR and all its ancestors."
|
"Create directory DIR and all its ancestors."
|
||||||
(let ((absolute? (string-prefix? "/" dir)))
|
(let ((absolute? (string-prefix? "/" dir)))
|
||||||
(let loop ((components (string-tokenize dir not-slash))
|
(let loop ((components (string-tokenize dir not-slash))
|
||||||
|
@ -36,12 +40,12 @@
|
||||||
((head tail ...)
|
((head tail ...)
|
||||||
(let ((dir-name (string-append root "/" head)))
|
(let ((dir-name (string-append root "/" head)))
|
||||||
(catch 'system-error
|
(catch 'system-error
|
||||||
(lambda ()
|
(λ ()
|
||||||
(if mode
|
(if mode
|
||||||
(mkdir dir-name mode)
|
(mkdir dir-name mode)
|
||||||
(mkdir dir-name))
|
(mkdir dir-name))
|
||||||
(loop tail dir-name))
|
(loop tail dir-name))
|
||||||
(lambda args
|
(λ args
|
||||||
;; On GNU/Hurd we can get EROFS instead of EEXIST here.
|
;; On GNU/Hurd we can get EROFS instead of EEXIST here.
|
||||||
;; Thus, if we get something other than EEXIST, check
|
;; Thus, if we get something other than EEXIST, check
|
||||||
;; whether DIR-NAME exists. See
|
;; whether DIR-NAME exists. See
|
||||||
|
@ -57,9 +61,6 @@
|
||||||
"Run BODY with DIR as the process's current directory."
|
"Run BODY with DIR as the process's current directory."
|
||||||
(let ((init (getcwd)))
|
(let ((init (getcwd)))
|
||||||
(dynamic-wind
|
(dynamic-wind
|
||||||
(lambda ()
|
(λ () (chdir dir))
|
||||||
(chdir dir))
|
(λ () body ...)
|
||||||
(lambda ()
|
(λ () (chdir init)))))
|
||||||
body ...)
|
|
||||||
(lambda ()
|
|
||||||
(chdir init)))))
|
|
||||||
|
|
Loading…
Reference in New Issue