me/guix
Archived
1
0
Fork 0
Code Activity

guix build: Modularize transformation handling.

Browse source 
* 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

133
guix/scripts/build.scm
View file

@ -383,9 +383,40 @@ must be one of 'package', 'all', or 'transitive'~%")
%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)
"Given OPTS, the result of 'args-fold', return a list of derivations to
build."
(define transform
(options->transformation opts))
(define package->derivation
(match (assoc-ref opts 'target)
(#f package-derivation)
@ -393,86 +424,51 @@ build."
(cut package-cross-derivation <> <> triplet <>))))
(define src (assoc-ref opts 'source))
(define sys (assoc-ref opts 'system))
(define system (assoc-ref opts 'system))
(define graft? (assoc-ref opts 'graft?))
(parameterize ((%graft? graft?))
(let ((opts (options/with-source store
(options/resolve-packages store opts))))
(concatenate
(filter-map (match-lambda
(('argument . (? package? p))
(append-map (match-lambda
((? package? p)
(match src
(#f
(list (package->derivation store p sys)))
(list (package->derivation store p system)))
(#t
(let ((s (package-source p)))
(list (package-source-derivation store s))))
(proc
(map (cut package-source-derivation store <>)
(proc p)))))
(('argument . (? derivation? drv))
((? derivation? drv)
(list drv))
(('argument . (? derivation-path? drv))
(list (call-with-input-file drv read-derivation)))
(('argument . (? store-path?))
;; Nothing to do; maybe for --log-file.
#f)
(_ #f))
opts)))))
(define (options/resolve-packages store opts)
"Return OPTS with package specification strings replaced by actual
packages."
(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
(list (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
(list (run-with-store store
(mbegin %store-monad
(set-guile-for-build (default-guile))
(gexp->derivation "gexp" gexp
#:system system)))))
`(argument . ,drv)))))
#:system system))))))
(transform store (options->things-to-build opts)))))
(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 (transform-package-source sources)
"Return a transformation procedure that uses replaces package sources with
the matching URIs given in SOURCES."
(define new-sources
(filter-map (match-lambda
(('with-source . uri)
(map (lambda (uri)
(cons (package-name->name+version (basename uri))
uri))
(_ #f))
opts))
sources))
(let loop ((opts opts)
(lambda (store packages)
(let loop ((packages packages)
(sources new-sources)
(result '()))
(match opts
(match packages
(()
(unless (null? sources)
(warning (_ "sources do not match any package:~{ ~a~}~%")
@ -480,19 +476,38 @@ arguments with packages that use the specified source."
(((name . uri) ...)
uri))))
(reverse result))
((('argument . (? package? p)) tail ...)
(((? package? p) tail ...)
(let ((source (assoc-ref sources (package-name p))))
(loop tail
(alist-delete (package-name p) sources)
(alist-cons 'argument
(if source
(cons (if source
(package-with-source store p source)
p)
result))))
((('with-source . _) tail ...)
(loop tail sources result))
((head tail ...)
(loop tail sources (cons head result))))))
((thing tail ...)
(loop tail sources 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)
"Show the build log for FILE, falling back to remote logs from URLS if