#:use-module (ice-9 rdelim)
#:use-module (guix store)
#:use-module (guix utils)
- #:export (derivation?
+ #:export (<derivation>
+ derivation?
derivation-outputs
derivation-inputs
derivation-sources
derivation-system
derivation-builder-arguments
derivation-builder-environment-vars
+ derivation-prerequisites
+ derivation-prerequisites-to-build
+ <derivation-output>
derivation-output?
derivation-output-path
derivation-output-hash-algo
derivation-output-hash
+ <derivation-input>
derivation-input?
derivation-input-path
derivation-input-sub-derivations
derivation
%guile-for-build
- build-expression->derivation))
+ build-expression->derivation
+ imported-files))
;;;
;;; Nix derivations, as implemented in Nix's `derivations.cc'.
#t)
(_ #f)))
+(define (derivation-prerequisites drv)
+ "Return the list of derivation-inputs required to build DRV, recursively."
+ (let loop ((drv drv)
+ (result '()))
+ (let ((inputs (remove (cut member <> result) ; XXX: quadratic
+ (derivation-inputs drv))))
+ (fold loop
+ (append inputs result)
+ (map (lambda (i)
+ (call-with-input-file (derivation-input-path i)
+ read-derivation))
+ inputs)))))
+
+(define (derivation-prerequisites-to-build store drv)
+ "Return the list of derivation-inputs required to build DRV and not already
+available in STORE, recursively."
+ (define input-built?
+ (match-lambda
+ (($ <derivation-input> path sub-drvs)
+ (let ((out (map (cut derivation-path->output-path path <>)
+ sub-drvs)))
+ (any (cut valid-path? store <>) out)))))
+
+ (let loop ((drv drv)
+ (result '()))
+ (let ((inputs (remove (lambda (i)
+ (or (member i result) ; XXX: quadratic
+ (input-built? i)))
+ (derivation-inputs drv))))
+ (fold loop
+ (append inputs result)
+ (map (lambda (i)
+ (call-with-input-file (derivation-input-path i)
+ read-derivation))
+ inputs)))))
+
(define (read-derivation drv-port)
"Read the derivation from DRV-PORT and return the corresponding
<derivation> object."
'()
x))
+ ;; The contents of a derivation are typically ASCII, but choosing
+ ;; UTF-8 allows us to take the fast path for Guile's `scm_getc'.
+ (set-port-encoding! drv-port "UTF-8")
+
(let loop ((exp (read drv-port))
(result '()))
(match exp
"Write the ATerm-like serialization of DRV to PORT. See Section 2.4 of
Eelco Dolstra's PhD dissertation for an overview of a previous version of
that form."
+
+ ;; Make sure we're using the faster implementation.
+ (define format simple-format)
+
(define (list->string lst)
(string-append "[" (string-join lst ",") "]"))
(define (write-list lst)
(display (list->string lst) port))
+ (define (coalesce-duplicate-inputs inputs)
+ ;; Return a list of inputs, such that when INPUTS contains the same DRV
+ ;; twice, they are coalesced, with their sub-derivations merged. This is
+ ;; needed because Nix itself keeps only one of them.
+ (fold (lambda (input result)
+ (match input
+ (($ <derivation-input> path sub-drvs)
+ ;; XXX: quadratic
+ (match (find (match-lambda
+ (($ <derivation-input> p s)
+ (string=? p path)))
+ result)
+ (#f
+ (cons input result))
+ ((and dup ($ <derivation-input> _ sub-drvs2))
+ ;; Merge DUP with INPUT.
+ (let ((sub-drvs (delete-duplicates
+ (append sub-drvs sub-drvs2))))
+ (cons (make-derivation-input path sub-drvs)
+ (delq dup result))))))))
+ '()
+ inputs))
+
+ ;; Note: lists are sorted alphabetically, to conform with the behavior of
+ ;; C++ `std::map' in Nix itself.
+
(match drv
(($ <derivation> outputs inputs sources
system builder args env-vars)
(or (and=> hash-algo symbol->string) "")
(or (and=> hash bytevector->base16-string)
""))))
- outputs))
+ (sort outputs
+ (lambda (o1 o2)
+ (string<? (car o1) (car o2))))))
(display "," port)
(write-list (map (match-lambda
(($ <derivation-input> path sub-drvs)
(format #f "(~s,~a)" path
- (list->string (map object->string sub-drvs)))))
- inputs))
+ (list->string (map object->string
+ (sort sub-drvs string<?))))))
+ (sort (coalesce-duplicate-inputs inputs)
+ (lambda (i1 i2)
+ (string<? (derivation-input-path i1)
+ (derivation-input-path i2))))))
(display "," port)
- (write-list (map object->string sources))
+ (write-list (map object->string (sort sources string<?)))
(format port ",~s,~s," system builder)
(write-list (map object->string args))
(display "," port)
(write-list (map (match-lambda
((name . value)
(format #f "(~s,~s)" name value)))
- env-vars))
+ (sort env-vars
+ (lambda (e1 e2)
+ (string<? (car e1) (car e2))))))
(display ")" port))))
-(define* (derivation-path->output-path path #:optional (output "out"))
- "Read the derivation from PATH (`/nix/store/xxx.drv'), and return the store
+(define derivation-path->output-path
+ ;; This procedure is called frequently, so memoize it.
+ (memoize
+ (lambda* (path #:optional (output "out"))
+ "Read the derivation from PATH (`/nix/store/xxx.drv'), and return the store
path of its output OUTPUT."
- (let* ((drv (call-with-input-file path read-derivation))
- (outputs (derivation-outputs drv)))
- (and=> (assoc-ref outputs output) derivation-output-path)))
+ (let* ((drv (call-with-input-file path read-derivation))
+ (outputs (derivation-outputs drv)))
+ (and=> (assoc-ref outputs output) derivation-output-path)))))
\f
;;;
system builder args env-vars)
;; A regular derivation: replace the path of each input with that
;; input's hash; return the hash of serialization of the resulting
- ;; derivation. Note: inputs are sorted as in the order of their hex
- ;; hash representation because that's what the C++ `std::map' code
- ;; does.
- (let* ((inputs (sort (map (match-lambda
- (($ <derivation-input> path sub-drvs)
- (let ((hash (call-with-input-file path
- (compose bytevector->base16-string
- derivation-hash
- read-derivation))))
- (make-derivation-input hash sub-drvs))))
- inputs)
- (lambda (i1 i2)
- (string<? (derivation-input-path i1)
- (derivation-input-path i2)))))
+ ;; derivation.
+ (let* ((inputs (map (match-lambda
+ (($ <derivation-input> path sub-drvs)
+ (let ((hash (call-with-input-file path
+ (compose bytevector->base16-string
+ derivation-hash
+ read-derivation))))
+ (make-derivation-input hash sub-drvs))))
+ inputs))
(drv (make-derivation outputs inputs sources
system builder args env-vars)))
(sha256
(cons name "")
(cons name val))))
env-vars)))
- (fold-right (lambda (output-name env-vars)
- (if (assoc output-name env-vars)
- env-vars
- (append env-vars `((,output-name . "")))))
- e
- outputs)))
+ (fold (lambda (output-name env-vars)
+ (if (assoc output-name env-vars)
+ env-vars
+ (append env-vars `((,output-name . "")))))
+ e
+ outputs)))
(let* ((outputs (map (lambda (name)
;; Return outputs with an empty path.
(hash-algo sha256) #t #t
input)))
(make-derivation-input path '()))))
- inputs))
+ (delete-duplicates inputs)))
(env-vars (env-vars-with-empty-outputs))
(drv-masked (make-derivation outputs
(filter (compose derivation-path?
system builder args env-vars))
(drv (add-output-paths drv-masked)))
+ ;; (write-derivation drv-masked (current-error-port))
+ ;; (newline (current-error-port))
(values (add-text-to-store store (string-append name ".drv")
(call-with-output-string
(cut write-derivation drv <>))
(define %guile-for-build
;; The derivation of the Guile to be used within the build environment,
;; when using `build-expression->derivation'.
- (make-parameter (false-if-exception (nixpkgs-derivation "guile"))))
+ (make-parameter #f))
+
+(define (parent-directories file-name)
+ "Return the list of parent dirs of FILE-NAME, in the order in which an
+`mkdir -p' implementation would make them."
+ (let ((not-slash (char-set-complement (char-set #\/))))
+ (reverse
+ (fold (lambda (dir result)
+ (match result
+ (()
+ (list dir))
+ ((prev _ ...)
+ (cons (string-append prev "/" dir)
+ result))))
+ '()
+ (remove (cut string=? <> ".")
+ (string-tokenize (dirname file-name) not-slash))))))
+
+(define* (imported-files store files
+ #:key (name "file-import")
+ (system (%current-system))
+ (guile (%guile-for-build)))
+ "Return a derivation that imports FILES into STORE. FILES must be a list
+of (FINAL-PATH . FILE-NAME) pairs; each FILE-NAME is read from the file
+system, imported, and appears under FINAL-PATH in the resulting store path."
+ (let* ((files (map (match-lambda
+ ((final-path . file-name)
+ (list final-path
+ (add-to-store store (basename final-path) #t #f
+ "sha256" file-name))))
+ files))
+ (builder
+ `(begin
+ (mkdir %output) (chdir %output)
+ ,@(append-map (match-lambda
+ ((final-path store-path)
+ (append (match (parent-directories final-path)
+ (() '())
+ ((head ... tail)
+ (append (map (lambda (d)
+ `(false-if-exception
+ (mkdir ,d)))
+ head)
+ `((or (file-exists? ,tail)
+ (mkdir ,tail))))))
+ `((symlink ,store-path ,final-path)))))
+ files))))
+ (build-expression->derivation store name (%current-system)
+ builder files
+ #:guile-for-build guile)))
+
+(define* (imported-modules store modules
+ #:key (name "module-import")
+ (system (%current-system))
+ (guile (%guile-for-build)))
+ "Return a derivation that contains the source files of MODULES, a list of
+module names such as `(ice-9 q)'. All of MODULES must be in the current
+search path."
+ ;; TODO: Determine the closure of MODULES, build the `.go' files,
+ ;; canonicalize the source files through read/write, etc.
+ (let ((files (map (lambda (m)
+ (let ((f (string-append
+ (string-join (map symbol->string m) "/")
+ ".scm")))
+ (cons f (search-path %load-path f))))
+ modules)))
+ (imported-files store files #:name name #:system system
+ #:guile guile)))
+
+(define* (compiled-modules store modules
+ #:key (name "module-import-compiled")
+ (system (%current-system))
+ (guile (%guile-for-build)))
+ "Return a derivation that builds a tree containing the `.go' files
+corresponding to MODULES. All the MODULES are built in a context where
+they can refer to each other."
+ (let* ((module-drv (imported-modules store modules
+ #:system system
+ #:guile guile))
+ (module-dir (derivation-path->output-path module-drv))
+ (files (map (lambda (m)
+ (let ((f (string-join (map symbol->string m)
+ "/")))
+ (cons (string-append f ".go")
+ (string-append module-dir "/" f ".scm"))))
+ modules)))
+ (define builder
+ `(begin
+ (use-modules (system base compile))
+ (let ((out (assoc-ref %outputs "out")))
+ (mkdir out)
+ (chdir out))
+
+ (set! %load-path
+ (cons ,module-dir %load-path))
+
+ ,@(map (match-lambda
+ ((output . input)
+ (let ((make-parent-dirs (map (lambda (dir)
+ `(unless (file-exists? ,dir)
+ (mkdir ,dir)))
+ (parent-directories output))))
+ `(begin
+ ,@make-parent-dirs
+ (compile-file ,input
+ #:output-file ,output
+ #:opts %auto-compilation-options)))))
+ files)))
+
+ (build-expression->derivation store name system builder
+ `(("modules" ,module-drv))
+ #:guile-for-build guile)))
(define* (build-expression->derivation store name system exp inputs
- #:key hash hash-algo)
+ #:key (outputs '("out"))
+ hash hash-algo
+ (env-vars '())
+ (modules '())
+ guile-for-build)
"Return a derivation that executes Scheme expression EXP as a builder for
-derivation NAME. INPUTS must be a list of string/derivation-path pairs. EXP
-is evaluated in an environment where %OUTPUT is bound to the output path, and
-where %BUILD-INPUTS is bound to an alist of string/output-path pairs made
-from INPUTS."
+derivation NAME. INPUTS must be a list of (NAME DRV-PATH SUB-DRV) tuples;
+when SUB-DRV is omitted, \"out\" is assumed. EXP is evaluated in an
+environment where %OUTPUT is bound to the main output path, %OUTPUTS is bound
+to a list of output/path pairs, and where %BUILD-INPUTS is bound to an alist
+of string/output-path pairs made from INPUTS. Optionally, ENV-VARS is a list
+of string pairs specifying the name and value of environment variables
+visible to the builder. The builder terminates by passing the result of EXP
+to `exit'; thus, when EXP returns #f, the build is considered to have
+failed.
+
+EXP is built using GUILE-FOR-BUILD (a derivation). When GUILE-FOR-BUILD is
+omitted or is #f, the value of the `%guile-for-build' fluid is used instead."
+ (define guile-drv
+ (or guile-for-build (%guile-for-build)))
+
(define guile
- (string-append (derivation-path->output-path (%guile-for-build))
+ (string-append (derivation-path->output-path guile-drv)
"/bin/guile"))
+ (define module-form?
+ (match-lambda
+ (((or 'define-module 'use-modules) _ ...) #t)
+ (_ #f)))
+
(let* ((prologue `(begin
+ ,@(match exp
+ ((_ ...)
+ ;; Module forms must appear at the top-level so
+ ;; that any macros they export can be expanded.
+ (filter module-form? exp))
+ (_ `(,exp)))
+
(define %output (getenv "out"))
+ (define %outputs
+ (map (lambda (o)
+ (cons o (getenv o)))
+ ',outputs))
(define %build-inputs
',(map (match-lambda
- ((name . drv)
- (cons name
- (derivation-path->output-path drv))))
- inputs))) )
+ ((name drv . rest)
+ (let ((sub (match rest
+ (() "out")
+ ((x) x))))
+ (cons name
+ (if (derivation-path? drv)
+ (derivation-path->output-path drv
+ sub)
+ drv)))))
+ inputs))
+
+ ,@(if (null? modules)
+ '()
+ ;; Remove our own settings.
+ '((unsetenv "GUILE_LOAD_COMPILED_PATH")))
+
+ ;; Guile sets it, but remove it to avoid conflicts when
+ ;; building Guile-using packages.
+ (unsetenv "LD_LIBRARY_PATH")))
(builder (add-text-to-store store
(string-append name "-guile-builder")
- (string-append (object->string prologue)
- (object->string exp))
- (map cdr inputs))))
- (derivation store name system guile `("--no-auto-compile" ,builder)
- '(("HOME" . "/homeless"))
- `((,(%guile-for-build))
- (,builder)))))
+ (string-append
+ (object->string prologue)
+ (object->string
+ `(exit
+ ,(match exp
+ ((_ ...)
+ (remove module-form? exp))
+ (_ `(,exp))))))
+ (map second inputs)))
+ (mod-drv (and (pair? modules)
+ (imported-modules store modules #:guile guile-drv)))
+ (mod-dir (and mod-drv
+ (derivation-path->output-path mod-drv)))
+ (go-drv (and (pair? modules)
+ (compiled-modules store modules #:guile guile-drv)))
+ (go-dir (and go-drv
+ (derivation-path->output-path go-drv))))
+ (derivation store name system guile
+ `("--no-auto-compile"
+ ,@(if mod-dir `("-L" ,mod-dir) '())
+ ,builder)
+
+ ;; When MODULES is non-empty, shamelessly clobber
+ ;; $GUILE_LOAD_COMPILED_PATH.
+ (if go-dir
+ `(("GUILE_LOAD_COMPILED_PATH" . ,go-dir)
+ ,@(alist-delete "GUILE_LOAD_COMPILED_PATH"
+ env-vars))
+ env-vars)
+
+ `((,(or guile-for-build (%guile-for-build)))
+ (,builder)
+ ,@(map cdr inputs)
+ ,@(if mod-drv `((,mod-drv) (,go-drv)) '()))
+ #:hash hash #:hash-algo hash-algo
+ #:outputs outputs)))
HCoop / jackhill / guix / guix.git / blobdiff