From 64ec0e291209ea6c0fb98204e7b546479c6ab737 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Mon, 30 Nov 2015 23:07:35 +0200 Subject: [PATCH] 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'. --- guix/scripts/build.scm | 203 ++++++++++++++++++++++------------------- 1 file changed, 109 insertions(+), 94 deletions(-) diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index b415403473..192ed5cd45 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -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,106 +424,90 @@ 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)) - (match src - (#f - (list (package->derivation store p sys))) - (#t - (let ((s (package-source p))) - (list (package-source-derivation store s)))) - (proc - (map (cut package-source-derivation store <>) - (proc p))))) - (('argument . (? 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))))) + (append-map (match-lambda + ((? package? p) + (match src + (#f + (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))))) + ((? derivation? drv) + (list drv)) + ((? procedure? proc) + (list (run-with-store store + (mbegin %store-monad + (set-guile-for-build (default-guile)) + (proc)) + #:system system))) + ((? gexp? gexp) + (list (run-with-store store + (mbegin %store-monad + (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) - "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 - (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 (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) - (cons (package-name->name+version (basename uri)) - uri)) - (_ #f)) - opts)) + (map (lambda (uri) + (cons (package-name->name+version (basename uri)) + uri)) + sources)) - (let loop ((opts opts) - (sources new-sources) - (result '())) - (match opts - (() - (unless (null? sources) - (warning (_ "sources do not match any package:~{ ~a~}~%") - (match sources - (((name . uri) ...) - uri)))) - (reverse result)) - ((('argument . (? package? p)) tail ...) - (let ((source (assoc-ref sources (package-name p)))) - (loop tail - (alist-delete (package-name p) sources) - (alist-cons 'argument - (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)))))) + (lambda (store packages) + (let loop ((packages packages) + (sources new-sources) + (result '())) + (match packages + (() + (unless (null? sources) + (warning (_ "sources do not match any package:~{ ~a~}~%") + (match sources + (((name . uri) ...) + uri)))) + (reverse result)) + (((? package? p) tail ...) + (let ((source (assoc-ref sources (package-name p)))) + (loop tail + (alist-delete (package-name p) sources) + (cons (if source + (package-with-source store p source) + p) + 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