You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
565 lines
22 KiB
565 lines
22 KiB
;;; GNU Guix --- Functional package management for GNU
|
|
;;; Copyright © 2014 Ludovic Courtès <ludo@gnu.org>
|
|
;;;
|
|
;;; This file is part of GNU Guix.
|
|
;;;
|
|
;;; GNU Guix is free software; you can redistribute it and/or modify it
|
|
;;; under the terms of the GNU General Public License as published by
|
|
;;; the Free Software Foundation; either version 3 of the License, or (at
|
|
;;; your option) any later version.
|
|
;;;
|
|
;;; GNU Guix is distributed in the hope that it will be useful, but
|
|
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
;;; GNU General Public License for more details.
|
|
;;;
|
|
;;; You should have received a copy of the GNU General Public License
|
|
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
|
|
|
|
(define-module (guix gexp)
|
|
#:use-module ((guix store)
|
|
#:select (direct-store-path?))
|
|
#:use-module (guix monads)
|
|
#:use-module ((guix derivations)
|
|
#:select (derivation? derivation->output-path
|
|
%guile-for-build derivation))
|
|
#:use-module (guix packages)
|
|
#:use-module (srfi srfi-1)
|
|
#:use-module (srfi srfi-9)
|
|
#:use-module (srfi srfi-9 gnu)
|
|
#:use-module (srfi srfi-26)
|
|
#:use-module (ice-9 match)
|
|
#:export (gexp
|
|
gexp?
|
|
gexp->derivation
|
|
gexp->file
|
|
gexp->script))
|
|
|
|
;;; Commentary:
|
|
;;;
|
|
;;; This module implements "G-expressions", or "gexps". Gexps are like
|
|
;;; S-expressions (sexps), with two differences:
|
|
;;;
|
|
;;; 1. References (un-quotations) to derivations or packages in a gexp are
|
|
;;; replaced by the corresponding output file name; in addition, the
|
|
;;; 'ungexp-native' unquote-like form allows code to explicitly refer to
|
|
;;; the native code of a given package, in case of cross-compilation;
|
|
;;;
|
|
;;; 2. Gexps embed information about the derivations they refer to.
|
|
;;;
|
|
;;; Gexps make it easy to write to files Scheme code that refers to store
|
|
;;; items, or to write Scheme code to build derivations.
|
|
;;;
|
|
;;; Code:
|
|
|
|
;; "G expressions".
|
|
(define-record-type <gexp>
|
|
(make-gexp references natives proc)
|
|
gexp?
|
|
(references gexp-references) ; ((DRV-OR-PKG OUTPUT) ...)
|
|
(natives gexp-native-references) ; ((DRV-OR-PKG OUTPUT) ...)
|
|
(proc gexp-proc)) ; procedure
|
|
|
|
(define (write-gexp gexp port)
|
|
"Write GEXP on PORT."
|
|
(display "#<gexp " port)
|
|
|
|
;; Try to write the underlying sexp. Now, this trick doesn't work when
|
|
;; doing things like (ungexp-splicing (gexp ())) because GEXP's procedure
|
|
;; tries to use 'append' on that, which fails with wrong-type-arg.
|
|
(false-if-exception
|
|
(write (apply (gexp-proc gexp)
|
|
(append (gexp-references gexp)
|
|
(gexp-native-references gexp)))
|
|
port))
|
|
(format port " ~a>"
|
|
(number->string (object-address gexp) 16)))
|
|
|
|
(set-record-type-printer! <gexp> write-gexp)
|
|
|
|
;; Reference to one of the derivation's outputs, for gexps used in
|
|
;; derivations.
|
|
(define-record-type <output-ref>
|
|
(output-ref name)
|
|
output-ref?
|
|
(name output-ref-name))
|
|
|
|
(define raw-derivation
|
|
(store-lift derivation))
|
|
|
|
(define* (lower-inputs inputs
|
|
#:key system target)
|
|
"Turn any package from INPUTS into a derivation for SYSTEM; return the
|
|
corresponding input list as a monadic value. When TARGET is true, use it as
|
|
the cross-compilation target triplet."
|
|
(with-monad %store-monad
|
|
(sequence %store-monad
|
|
(map (match-lambda
|
|
(((? package? package) sub-drv ...)
|
|
(mlet %store-monad
|
|
((drv (if target
|
|
(package->cross-derivation package target
|
|
system)
|
|
(package->derivation package system))))
|
|
(return `(,drv ,@sub-drv))))
|
|
(((? origin? origin) sub-drv ...)
|
|
(mlet %store-monad ((drv (origin->derivation origin)))
|
|
(return `(,drv ,@sub-drv))))
|
|
(input
|
|
(return input)))
|
|
inputs))))
|
|
|
|
(define* (lower-reference-graphs graphs #:key system target)
|
|
"Given GRAPHS, a list of (FILE-NAME INPUT ...) lists for use as a
|
|
#:reference-graphs argument, lower it such that each INPUT is replaced by the
|
|
corresponding derivation."
|
|
(match graphs
|
|
(((file-names . inputs) ...)
|
|
(mlet %store-monad ((inputs (lower-inputs inputs
|
|
#:system system
|
|
#:target target)))
|
|
(return (map cons file-names inputs))))))
|
|
|
|
(define* (gexp->derivation name exp
|
|
#:key
|
|
system (target 'current)
|
|
hash hash-algo recursive?
|
|
(env-vars '())
|
|
(modules '())
|
|
(guile-for-build (%guile-for-build))
|
|
references-graphs
|
|
local-build?)
|
|
"Return a derivation NAME that runs EXP (a gexp) with GUILE-FOR-BUILD (a
|
|
derivation) on SYSTEM. When TARGET is true, it is used as the
|
|
cross-compilation target triplet for packages referred to by EXP.
|
|
|
|
Make MODULES available in the evaluation context of EXP; MODULES is a list of
|
|
names of Guile modules from the current search path to be copied in the store,
|
|
compiled, and made available in the load path during the execution of
|
|
EXP---e.g., '((guix build utils) (guix build gnu-build-system)).
|
|
|
|
When REFERENCES-GRAPHS is true, it must be a list of tuples of one of the
|
|
following forms:
|
|
|
|
(FILE-NAME PACKAGE)
|
|
(FILE-NAME PACKAGE OUTPUT)
|
|
(FILE-NAME DERIVATION)
|
|
(FILE-NAME DERIVATION OUTPUT)
|
|
(FILE-NAME STORE-ITEM)
|
|
|
|
The right-hand-side of each element of REFERENCES-GRAPHS is automatically made
|
|
an input of the build process of EXP. In the build environment, each
|
|
FILE-NAME contains the reference graph of the corresponding item, in a simple
|
|
text format.
|
|
|
|
In that case, the reference graph of each store path is exported in
|
|
the build environment in the corresponding file, in a simple text format.
|
|
|
|
The other arguments are as for 'derivation'."
|
|
(define %modules modules)
|
|
(define outputs (gexp-outputs exp))
|
|
|
|
(define (graphs-file-names graphs)
|
|
;; Return a list of (FILE-NAME . STORE-PATH) pairs made from GRAPHS.
|
|
(map (match-lambda
|
|
((file-name (? derivation? drv))
|
|
(cons file-name (derivation->output-path drv)))
|
|
((file-name (? derivation? drv) sub-drv)
|
|
(cons file-name (derivation->output-path drv sub-drv)))
|
|
((file-name thing)
|
|
(cons file-name thing)))
|
|
graphs))
|
|
|
|
(mlet* %store-monad (;; The following binding is here to force
|
|
;; '%current-system' and '%current-target-system' to be
|
|
;; looked up at >>= time.
|
|
(unused (return #f))
|
|
|
|
(system -> (or system (%current-system)))
|
|
(target -> (if (eq? target 'current)
|
|
(%current-target-system)
|
|
target))
|
|
(normals (lower-inputs (gexp-inputs exp)
|
|
#:system system
|
|
#:target target))
|
|
(natives (lower-inputs (gexp-native-inputs exp)
|
|
#:system system
|
|
#:target #f))
|
|
(inputs -> (append normals natives))
|
|
(sexp (gexp->sexp exp
|
|
#:system system
|
|
#:target target))
|
|
(builder (text-file (string-append name "-builder")
|
|
(object->string sexp)))
|
|
(modules (if (pair? %modules)
|
|
(imported-modules %modules
|
|
#:system system
|
|
#:guile guile-for-build)
|
|
(return #f)))
|
|
(compiled (if (pair? %modules)
|
|
(compiled-modules %modules
|
|
#:system system
|
|
#:guile guile-for-build)
|
|
(return #f)))
|
|
(graphs (if references-graphs
|
|
(lower-reference-graphs references-graphs
|
|
#:system system
|
|
#:target target)
|
|
(return #f)))
|
|
(guile (if guile-for-build
|
|
(return guile-for-build)
|
|
(package->derivation (default-guile)
|
|
system))))
|
|
(raw-derivation name
|
|
(string-append (derivation->output-path guile)
|
|
"/bin/guile")
|
|
`("--no-auto-compile"
|
|
,@(if (pair? %modules)
|
|
`("-L" ,(derivation->output-path modules)
|
|
"-C" ,(derivation->output-path compiled))
|
|
'())
|
|
,builder)
|
|
#:outputs outputs
|
|
#:env-vars env-vars
|
|
#:system system
|
|
#:inputs `((,guile)
|
|
(,builder)
|
|
,@(if modules
|
|
`((,modules) (,compiled) ,@inputs)
|
|
inputs)
|
|
,@(match graphs
|
|
(((_ . inputs) ...) inputs)
|
|
(_ '())))
|
|
#:hash hash #:hash-algo hash-algo #:recursive? recursive?
|
|
#:references-graphs (and=> graphs graphs-file-names)
|
|
#:local-build? local-build?)))
|
|
|
|
(define* (gexp-inputs exp #:optional (references gexp-references))
|
|
"Return the input list for EXP, using REFERENCES to get its list of
|
|
references."
|
|
(define (add-reference-inputs ref result)
|
|
(match ref
|
|
(((? derivation?) (? string?))
|
|
(cons ref result))
|
|
(((? package?) (? string?))
|
|
(cons ref result))
|
|
(((? origin?) (? string?))
|
|
(cons ref result))
|
|
((? gexp? exp)
|
|
(append (gexp-inputs exp references) result))
|
|
(((? string? file))
|
|
(if (direct-store-path? file)
|
|
(cons ref result)
|
|
result))
|
|
((refs ...)
|
|
(fold-right add-reference-inputs result refs))
|
|
(_
|
|
;; Ignore references to other kinds of objects.
|
|
result)))
|
|
|
|
(fold-right add-reference-inputs
|
|
'()
|
|
(references exp)))
|
|
|
|
(define gexp-native-inputs
|
|
(cut gexp-inputs <> gexp-native-references))
|
|
|
|
(define (gexp-outputs exp)
|
|
"Return the outputs referred to by EXP as a list of strings."
|
|
(define (add-reference-output ref result)
|
|
(match ref
|
|
(($ <output-ref> name)
|
|
(cons name result))
|
|
((? gexp? exp)
|
|
(append (gexp-outputs exp) result))
|
|
(_
|
|
result)))
|
|
|
|
(fold-right add-reference-output
|
|
'()
|
|
(gexp-references exp)))
|
|
|
|
(define* (gexp->sexp exp #:key
|
|
(system (%current-system))
|
|
(target (%current-target-system)))
|
|
"Return (monadically) the sexp corresponding to EXP for the given OUTPUT,
|
|
and in the current monad setting (system type, etc.)"
|
|
(define* (reference->sexp ref #:optional native?)
|
|
(with-monad %store-monad
|
|
(match ref
|
|
(((? derivation? drv) (? string? output))
|
|
(return (derivation->output-path drv output)))
|
|
(((? package? p) (? string? output))
|
|
(package-file p
|
|
#:output output
|
|
#:system system
|
|
#:target (if native? #f target)))
|
|
(((? origin? o) (? string? output))
|
|
(mlet %store-monad ((drv (origin->derivation o)))
|
|
(return (derivation->output-path drv output))))
|
|
(($ <output-ref> output)
|
|
;; Output file names are not known in advance but the daemon defines
|
|
;; an environment variable for each of them at build time, so use
|
|
;; that trick.
|
|
(return `((@ (guile) getenv) ,output)))
|
|
((? gexp? exp)
|
|
(gexp->sexp exp
|
|
#:system system
|
|
#:target (if native? #f target)))
|
|
(((? string? str))
|
|
(return (if (direct-store-path? str) str ref)))
|
|
((refs ...)
|
|
(sequence %store-monad
|
|
(map (cut reference->sexp <> native?) refs)))
|
|
(x
|
|
(return x)))))
|
|
|
|
(mlet %store-monad
|
|
((args (sequence %store-monad
|
|
(append (map reference->sexp (gexp-references exp))
|
|
(map (cut reference->sexp <> #t)
|
|
(gexp-native-references exp))))))
|
|
(return (apply (gexp-proc exp) args))))
|
|
|
|
(define (canonicalize-reference ref)
|
|
"Return a canonical variant of REF, which adds any missing output part in
|
|
package/derivation references."
|
|
(match ref
|
|
((? package? p)
|
|
`(,p "out"))
|
|
((? origin? o)
|
|
`(,o "out"))
|
|
((? derivation? d)
|
|
`(,d "out"))
|
|
(((? package?) (? string?))
|
|
ref)
|
|
(((? origin?) (? string?))
|
|
ref)
|
|
(((? derivation?) (? string?))
|
|
ref)
|
|
((? string? s)
|
|
(if (direct-store-path? s) `(,s) s))
|
|
((refs ...)
|
|
(map canonicalize-reference refs))
|
|
(x x)))
|
|
|
|
(define (syntax-location-string s)
|
|
"Return a string representing the source code location of S."
|
|
(let ((props (syntax-source s)))
|
|
(if props
|
|
(let ((file (assoc-ref props 'filename))
|
|
(line (and=> (assoc-ref props 'line) 1+))
|
|
(column (assoc-ref props 'column)))
|
|
(if file
|
|
(simple-format #f "~a:~a:~a"
|
|
file line column)
|
|
(simple-format #f "~a:~a" line column)))
|
|
"<unknown location>")))
|
|
|
|
(define-syntax gexp
|
|
(lambda (s)
|
|
(define (collect-escapes exp)
|
|
;; Return all the 'ungexp' present in EXP.
|
|
(let loop ((exp exp)
|
|
(result '()))
|
|
(syntax-case exp (ungexp ungexp-splicing)
|
|
((ungexp _)
|
|
(cons exp result))
|
|
((ungexp _ _)
|
|
(cons exp result))
|
|
((ungexp-splicing _ ...)
|
|
(cons exp result))
|
|
((exp0 exp ...)
|
|
(let ((result (loop #'exp0 result)))
|
|
(fold loop result #'(exp ...))))
|
|
(_
|
|
result))))
|
|
|
|
(define (collect-native-escapes exp)
|
|
;; Return all the 'ungexp-native' forms present in EXP.
|
|
(let loop ((exp exp)
|
|
(result '()))
|
|
(syntax-case exp (ungexp-native ungexp-native-splicing)
|
|
((ungexp-native _)
|
|
(cons exp result))
|
|
((ungexp-native _ _)
|
|
(cons exp result))
|
|
((ungexp-native-splicing _ ...)
|
|
(cons exp result))
|
|
((exp0 exp ...)
|
|
(let ((result (loop #'exp0 result)))
|
|
(fold loop result #'(exp ...))))
|
|
(_
|
|
result))))
|
|
|
|
(define (escape->ref exp)
|
|
;; Turn 'ungexp' form EXP into a "reference".
|
|
(syntax-case exp (ungexp ungexp-splicing
|
|
ungexp-native ungexp-native-splicing
|
|
output)
|
|
((ungexp output)
|
|
#'(output-ref "out"))
|
|
((ungexp output name)
|
|
#'(output-ref name))
|
|
((ungexp thing)
|
|
#'thing)
|
|
((ungexp drv-or-pkg out)
|
|
#'(list drv-or-pkg out))
|
|
((ungexp-splicing lst)
|
|
#'lst)
|
|
((ungexp-native thing)
|
|
#'thing)
|
|
((ungexp-native drv-or-pkg out)
|
|
#'(list drv-or-pkg out))
|
|
((ungexp-native-splicing lst)
|
|
#'lst)))
|
|
|
|
(define (substitute-ungexp exp substs)
|
|
;; Given EXP, an 'ungexp' or 'ungexp-native' form, substitute it with
|
|
;; the corresponding form in SUBSTS.
|
|
(match (assoc exp substs)
|
|
((_ id)
|
|
id)
|
|
(_
|
|
#'(syntax-error "error: no 'ungexp' substitution"
|
|
#'ref))))
|
|
|
|
(define (substitute-ungexp-splicing exp substs)
|
|
(syntax-case exp ()
|
|
((exp rest ...)
|
|
(match (assoc #'exp substs)
|
|
((_ id)
|
|
(with-syntax ((id id))
|
|
#`(append id
|
|
#,(substitute-references #'(rest ...) substs))))
|
|
(_
|
|
#'(syntax-error "error: no 'ungexp-splicing' substitution"
|
|
#'ref))))))
|
|
|
|
(define (substitute-references exp substs)
|
|
;; Return a variant of EXP where all the cars of SUBSTS have been
|
|
;; replaced by the corresponding cdr.
|
|
(syntax-case exp (ungexp ungexp-native
|
|
ungexp-splicing ungexp-native-splicing)
|
|
((ungexp _ ...)
|
|
(substitute-ungexp exp substs))
|
|
((ungexp-native _ ...)
|
|
(substitute-ungexp exp substs))
|
|
(((ungexp-splicing _ ...) rest ...)
|
|
(substitute-ungexp-splicing exp substs))
|
|
(((ungexp-native-splicing _ ...) rest ...)
|
|
(substitute-ungexp-splicing exp substs))
|
|
((exp0 exp ...)
|
|
#`(cons #,(substitute-references #'exp0 substs)
|
|
#,(substitute-references #'(exp ...) substs)))
|
|
(x #''x)))
|
|
|
|
(syntax-case s (ungexp output)
|
|
((_ exp)
|
|
(let* ((normals (delete-duplicates (collect-escapes #'exp)))
|
|
(natives (delete-duplicates (collect-native-escapes #'exp)))
|
|
(escapes (append normals natives))
|
|
(formals (generate-temporaries escapes))
|
|
(sexp (substitute-references #'exp (zip escapes formals)))
|
|
(refs (map escape->ref normals))
|
|
(nrefs (map escape->ref natives)))
|
|
#`(make-gexp (map canonicalize-reference (list #,@refs))
|
|
(map canonicalize-reference (list #,@nrefs))
|
|
(lambda #,formals
|
|
#,sexp)))))))
|
|
|
|
|
|
;;;
|
|
;;; Convenience procedures.
|
|
;;;
|
|
|
|
(define (default-guile)
|
|
;; Lazily resolve 'guile-final'. This module must not refer to (gnu …)
|
|
;; modules directly, to avoid circular dependencies, hence this hack.
|
|
(module-ref (resolve-interface '(gnu packages commencement))
|
|
'guile-final))
|
|
|
|
(define* (gexp->script name exp
|
|
#:key (modules '()) (guile (default-guile)))
|
|
"Return an executable script NAME that runs EXP using GUILE with MODULES in
|
|
its search path."
|
|
(mlet %store-monad ((modules (imported-modules modules))
|
|
(compiled (compiled-modules modules)))
|
|
(gexp->derivation name
|
|
(gexp
|
|
(call-with-output-file (ungexp output)
|
|
(lambda (port)
|
|
;; Note: that makes a long shebang. When the store
|
|
;; is /gnu/store, that fits within the 128-byte
|
|
;; limit imposed by Linux, but that may go beyond
|
|
;; when running tests.
|
|
(format port
|
|
"#!~a/bin/guile --no-auto-compile~%!#~%"
|
|
(ungexp guile))
|
|
|
|
;; Write the 'eval-when' form so that it can be
|
|
;; compiled.
|
|
(write
|
|
'(eval-when (expand load eval)
|
|
(set! %load-path
|
|
(cons (ungexp modules) %load-path))
|
|
(set! %load-compiled-path
|
|
(cons (ungexp compiled)
|
|
%load-compiled-path)))
|
|
port)
|
|
(write '(ungexp exp) port)
|
|
(chmod port #o555)))))))
|
|
|
|
(define (gexp->file name exp)
|
|
"Return a derivation that builds a file NAME containing EXP."
|
|
(gexp->derivation name
|
|
(gexp
|
|
(call-with-output-file (ungexp output)
|
|
(lambda (port)
|
|
(write '(ungexp exp) port))))
|
|
#:local-build? #t))
|
|
|
|
|
|
;;;
|
|
;;; Syntactic sugar.
|
|
;;;
|
|
|
|
(eval-when (expand load eval)
|
|
(define* (read-ungexp chr port #:optional native?)
|
|
"Read an 'ungexp' or 'ungexp-splicing' form from PORT. When NATIVE? is
|
|
true, use 'ungexp-native' and 'ungexp-native-splicing' instead."
|
|
(define unquote-symbol
|
|
(match (peek-char port)
|
|
(#\@
|
|
(read-char port)
|
|
(if native?
|
|
'ungexp-native-splicing
|
|
'ungexp-splicing))
|
|
(_
|
|
(if native?
|
|
'ungexp-native
|
|
'ungexp))))
|
|
|
|
(match (read port)
|
|
((? symbol? symbol)
|
|
(let ((str (symbol->string symbol)))
|
|
(match (string-index-right str #\:)
|
|
(#f
|
|
`(,unquote-symbol ,symbol))
|
|
(colon
|
|
(let ((name (string->symbol (substring str 0 colon)))
|
|
(output (substring str (+ colon 1))))
|
|
`(,unquote-symbol ,name ,output))))))
|
|
(x
|
|
`(,unquote-symbol ,x))))
|
|
|
|
(define (read-gexp chr port)
|
|
"Read a 'gexp' form from PORT."
|
|
`(gexp ,(read port)))
|
|
|
|
;; Extend the reader
|
|
(read-hash-extend #\~ read-gexp)
|
|
(read-hash-extend #\$ read-ungexp)
|
|
(read-hash-extend #\+ (cut read-ungexp <> <> #t)))
|
|
|
|
;;; gexp.scm ends here
|