nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

guix build: Modularize transformation handling. 

* guix/scripts/build.scm (options/resolve-packages): Remove.
(options->things-to-build, transform-package-source): New procedure.
(%transformations): New variable.
(options->transformation): New procedure.
(options->derivations): Rewrite to use 'options->things-to-build' and
'options->transformation'.
This commit is contained in:
Ludovic Courtès 2015-11-30 23:07:35 +02:00
parent 27b91d7851
commit 64ec0e2912
1 changed files with 109 additions and 94 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

203
guix/scripts/build.scm
View File

@ -383,9 +383,40 @@ must be one of 'package', 'all', or 'transitive'~%")
%standard-build-options)) %standard-build-options))
(define (options->things-to-build opts)
"Read the arguments from OPTS and return a list of high-level objects to
build---packages, gexps, derivations, and so on."
(define ensure-list
(match-lambda
((x ...) x)
(x (list x))))
(append-map (match-lambda
(('argument . (? string? spec))
(cond ((derivation-path? spec)
(list (call-with-input-file spec read-derivation)))
((store-path? spec)
;; Nothing to do; maybe for --log-file.
'())
(else
(list (specification->package spec)))))
(('file . file)
(ensure-list (load* file (make-user-module '()))))
(('expression . str)
(ensure-list (read/eval str)))
(('argument . (? derivation? drv))
drv)
(('argument . (? derivation-path? drv))
(list ))
(_ '()))
opts))
(define (options->derivations store opts) (define (options->derivations store opts)
"Given OPTS, the result of 'args-fold', return a list of derivations to "Given OPTS, the result of 'args-fold', return a list of derivations to
build." build."
(define transform
(options->transformation opts))
(define package->derivation (define package->derivation
(match (assoc-ref opts 'target) (match (assoc-ref opts 'target)
(#f package-derivation) (#f package-derivation)
@ -393,106 +424,90 @@ build."
(cut package-cross-derivation <> <> triplet <>)))) (cut package-cross-derivation <> <> triplet <>))))
(define src (assoc-ref opts 'source)) (define src (assoc-ref opts 'source))
(define sys (assoc-ref opts 'system)) (define system (assoc-ref opts 'system))
(define graft? (assoc-ref opts 'graft?)) (define graft? (assoc-ref opts 'graft?))
(parameterize ((%graft? graft?)) (parameterize ((%graft? graft?))
(let ((opts (options/with-source store (append-map (match-lambda
(options/resolve-packages store opts)))) ((? package? p)
(concatenate (match src
(filter-map (match-lambda (#f
(('argument . (? package? p)) (list (package->derivation store p system)))
(match src (#t
(#f (let ((s (package-source p)))
(list (package->derivation store p sys))) (list (package-source-derivation store s))))
(#t (proc
(let ((s (package-source p))) (map (cut package-source-derivation store <>)
(list (package-source-derivation store s)))) (proc p)))))
(proc ((? derivation? drv)
(map (cut package-source-derivation store <>) (list drv))
(proc p))))) ((? procedure? proc)
(('argument . (? derivation? drv)) (list (run-with-store store
(list drv)) (mbegin %store-monad
(('argument . (? derivation-path? drv)) (set-guile-for-build (default-guile))
(list (call-with-input-file drv read-derivation))) (proc))
(('argument . (? store-path?)) #:system system)))
;; Nothing to do; maybe for --log-file. ((? gexp? gexp)
#f) (list (run-with-store store
(_ #f)) (mbegin %store-monad
opts))))) (set-guile-for-build (default-guile))
(gexp->derivation "gexp" gexp
#:system system))))))
(transform store (options->things-to-build opts)))))
(define (options/resolve-packages store opts) (define (transform-package-source sources)
"Return OPTS with package specification strings replaced by actual "Return a transformation procedure that uses replaces package sources with
packages." the matching URIs given in SOURCES."
(define system
(or (assoc-ref opts 'system) (%current-system)))
(define (object->argument obj)
(match obj
((? package? p)
`(argument . ,p))
((? procedure? proc)
(let ((drv (run-with-store store
(mbegin %store-monad
(set-guile-for-build (default-guile))
(proc))
#:system system)))
`(argument . ,drv)))
((? gexp? gexp)
(let ((drv (run-with-store store
(mbegin %store-monad
(set-guile-for-build (default-guile))
(gexp->derivation "gexp" gexp
#:system system)))))
`(argument . ,drv)))))
(map (match-lambda
(('argument . (? string? spec))
(if (store-path? spec)
`(argument . ,spec)
`(argument . ,(specification->package spec))))
(('file . file)
(object->argument (load* file (make-user-module '()))))
(('expression . str)
(object->argument (read/eval str)))
(opt opt))
opts))
(define (options/with-source store opts)
"Process with 'with-source' options in OPTS, replacing the relevant package
arguments with packages that use the specified source."
(define new-sources (define new-sources
(filter-map (match-lambda (map (lambda (uri)
(('with-source . uri) (cons (package-name->name+version (basename uri))
(cons (package-name->name+version (basename uri)) uri))
uri)) sources))
(_ #f))
opts))
(let loop ((opts opts) (lambda (store packages)
(sources new-sources) (let loop ((packages packages)
(result '())) (sources new-sources)
(match opts (result '()))
(() (match packages
(unless (null? sources) (()
(warning (_ "sources do not match any package:~{ ~a~}~%") (unless (null? sources)
(match sources (warning (_ "sources do not match any package:~{ ~a~}~%")
(((name . uri) ...) (match sources
uri)))) (((name . uri) ...)
(reverse result)) uri))))
((('argument . (? package? p)) tail ...) (reverse result))
(let ((source (assoc-ref sources (package-name p)))) (((? package? p) tail ...)
(loop tail (let ((source (assoc-ref sources (package-name p))))
(alist-delete (package-name p) sources) (loop tail
(alist-cons 'argument (alist-delete (package-name p) sources)
(if source (cons (if source
(package-with-source store p source) (package-with-source store p source)
p) p)
result)))) result))))
((('with-source . _) tail ...) ((thing tail ...)
(loop tail sources result)) (loop tail sources result))))))
((head tail ...)
(loop tail sources (cons head result)))))) (define %transformations
;; Transformations that can be applied to things to build. The car is the
;; key used in the option alist, and the cdr is the transformation
;; procedure; it is called with two arguments: the store, and a list of
;; things to build.
`((with-source . ,transform-package-source)))
(define (options->transformation opts)
"Return a procedure that, when passed a list of things to build (packages,
derivations, etc.), applies the transformations specified by OPTS."
(apply compose
(map (match-lambda
((key . transform)
(let ((args (filter-map (match-lambda
((k . arg)
(and (eq? k key) arg)))
opts)))
(if (null? args)
(lambda (store things) things)
(transform args)))))
%transformations)))
(define (show-build-log store file urls) (define (show-build-log store file urls)
"Show the build log for FILE, falling back to remote logs from URLS if "Show the build log for FILE, falling back to remote logs from URLS if