gexp?
with-imported-modules
with-extensions
+ let-system
gexp-input
gexp-input?
local-file-absolute-file-name
local-file-name
local-file-recursive?
+ local-file-select?
plain-file
plain-file?
((? derivation? drv)
(derivation->output-path drv output))
((? string? file)
- file)))
+ file)
+ ((? self-quoting? obj)
+ obj)))
(define (register-compiler! compiler)
"Register COMPILER as a gexp compiler."
corresponding to OBJ for SYSTEM, cross-compiling for TARGET if TARGET is true.
OBJ must be an object that has an associated gexp compiler, such as a
<package>."
- (match (lookup-compiler obj)
- (#f
- (raise (condition (&gexp-input-error (input obj)))))
- (lower
- ;; Cache in STORE the result of lowering OBJ.
- (mlet %store-monad ((target (if (eq? target 'current)
- (current-target-system)
- (return target)))
- (graft? (grafting?)))
- (mcached (let ((lower (lookup-compiler obj)))
- (lower obj system target))
- obj
- system target graft?)))))
+ (mlet %store-monad ((target (if (eq? target 'current)
+ (current-target-system)
+ (return target)))
+ (graft? (grafting?)))
+ (let loop ((obj obj))
+ (match (lookup-compiler obj)
+ (#f
+ (raise (condition (&gexp-input-error (input obj)))))
+ (lower
+ ;; Cache in STORE the result of lowering OBJ.
+ (mcached (mlet %store-monad ((lowered (lower obj system target)))
+ (if (and (struct? lowered)
+ (not (derivation? lowered)))
+ (loop lowered)
+ (return lowered)))
+ obj
+ system target graft?))))))
+
+(define* (lower+expand-object obj
+ #:optional (system (%current-system))
+ #:key target (output "out"))
+ "Return as a value in %STORE-MONAD the output of object OBJ expands to for
+SYSTEM and TARGET. Object such as <package>, <file-append>, or <plain-file>
+expand to file names, but it's possible to expand to a plain data type."
+ (let loop ((obj obj)
+ (expand (and (struct? obj) (lookup-expander obj))))
+ (match (lookup-compiler obj)
+ (#f
+ (raise (condition (&gexp-input-error (input obj)))))
+ (lower
+ (mlet* %store-monad ((graft? (grafting?))
+ (lowered (mcached (lower obj system target)
+ obj
+ system target graft?)))
+ ;; LOWER might return something that needs to be further
+ ;; lowered.
+ (if (struct? lowered)
+ ;; If we lack an expander, delegate to that of LOWERED.
+ (if (not expand)
+ (loop lowered (lookup-expander lowered))
+ (return (expand obj lowered output)))
+ (if (not expand) ;self-quoting
+ (return lowered)
+ (return (expand obj lowered output)))))))))
(define-syntax define-gexp-compiler
(syntax-rules (=> compiler expander)
"Define NAME as a compiler for objects matching PREDICATE encountered in
gexps.
-In the simplest form of the macro, BODY must return a derivation for PARAM, an
-object that matches PREDICATE, for SYSTEM and TARGET (the latter of which is
-#f except when cross-compiling.)
+In the simplest form of the macro, BODY must return (1) a derivation for
+a record of the specified type, for SYSTEM and TARGET (the latter of which is
+#f except when cross-compiling), (2) another record that can itself be
+compiled down to a derivation, or (3) an object of a primitive data type.
The more elaborate form allows you to specify an expander:
- (define-gexp-compiler something something?
+ (define-gexp-compiler something-compiler <something>
compiler => (lambda (param system target) ...)
expander => (lambda (param drv output) ...))
lowered)))
\f
+;;;
+;;; System dependencies.
+;;;
+
+;; Binding form for the current system and cross-compilation target.
+(define-record-type <system-binding>
+ (system-binding proc)
+ system-binding?
+ (proc system-binding-proc))
+
+(define-syntax let-system
+ (syntax-rules ()
+ "Introduce a system binding in a gexp. The simplest form is:
+
+ (let-system system
+ (cond ((string=? system \"x86_64-linux\") ...)
+ (else ...)))
+
+which binds SYSTEM to the currently targeted system. The second form is
+similar, but it also shows the cross-compilation target:
+
+ (let-system (system target)
+ ...)
+
+Here TARGET is bound to the cross-compilation triplet or #f."
+ ((_ (system target) exp0 exp ...)
+ (system-binding (lambda (system target)
+ exp0 exp ...)))
+ ((_ system exp0 exp ...)
+ (system-binding (lambda (system target)
+ exp0 exp ...)))))
+
+(define-gexp-compiler system-binding-compiler <system-binding>
+ compiler => (lambda (binding system target)
+ (match binding
+ (($ <system-binding> proc)
+ (with-monad %store-monad
+ ;; PROC is expected to return a lowerable object.
+ ;; 'lower-object' takes care of residualizing it to a
+ ;; derivation or similar.
+ (return (proc system target))))))
+
+ ;; Delegate to the expander of the object returned by PROC.
+ expander => #f)
+
+\f
;;;
;;; File declarations.
;;;
list."
(gexp-attribute gexp gexp-self-extensions))
+(define (self-quoting? x)
+ (letrec-syntax ((one-of (syntax-rules ()
+ ((_) #f)
+ ((_ pred rest ...)
+ (or (pred x)
+ (one-of rest ...))))))
+ (one-of symbol? string? keyword? pair? null? array?
+ number? boolean? char?)))
+
(define* (lower-inputs inputs
#:key system target)
"Turn any object from INPUTS into a derivation input for SYSTEM or a store
(define (store-item? obj)
(and (string? obj) (store-path? obj)))
+ (define filterm
+ (lift1 (cut filter ->bool <>) %store-monad))
+
(with-monad %store-monad
- (mapm/accumulate-builds
- (match-lambda
- (((? struct? thing) sub-drv ...)
- (mlet %store-monad ((obj (lower-object
- thing system #:target target)))
- (return (match obj
- ((? derivation? drv)
- (let ((outputs (if (null? sub-drv)
- '("out")
- sub-drv)))
- (derivation-input drv outputs)))
- ((? store-item? item)
- item)))))
- (((? store-item? item))
- (return item)))
- inputs)))
+ (>>= (mapm/accumulate-builds
+ (match-lambda
+ (((? struct? thing) sub-drv ...)
+ (mlet %store-monad ((obj (lower-object
+ thing system #:target target)))
+ (return (match obj
+ ((? derivation? drv)
+ (let ((outputs (if (null? sub-drv)
+ '("out")
+ sub-drv)))
+ (derivation-input drv outputs)))
+ ((? store-item? item)
+ item)
+ ((? self-quoting?)
+ ;; Some inputs such as <system-binding> can lower to
+ ;; a self-quoting object that FILTERM will filter
+ ;; out.
+ #f)))))
+ (((? store-item? item))
+ (return item)))
+ inputs)
+ filterm)))
(define* (lower-reference-graphs graphs #:key system target)
"Given GRAPHS, a list of (FILE-NAME INPUT ...) lists for use as a
(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 (self-quoting? x)
- (letrec-syntax ((one-of (syntax-rules ()
- ((_) #f)
- ((_ pred rest ...)
- (or (pred x)
- (one-of rest ...))))))
- (one-of symbol? string? keyword? pair? null? array?
- number? boolean? char?)))
-
(define* (reference->sexp ref #:optional native?)
(with-monad %store-monad
(match ref
(or n? native?)))
refs))
(($ <gexp-input> (? struct? thing) output n?)
- (let ((target (if (or n? native?) #f target))
- (expand (lookup-expander thing)))
- (mlet %store-monad ((obj (lower-object thing system
- #:target target)))
- ;; OBJ must be either a derivation or a store file name.
- (return (expand thing obj output)))))
+ (let ((target (if (or n? native?) #f target)))
+ (lower+expand-object thing system
+ #:target target
+ #:output output)))
(($ <gexp-input> (? self-quoting? x))
(return x))
(($ <gexp-input> x)
#:system system
#:guile-for-build guile
#:local-build? #t
+ #:substitutable? #f
;; Avoid deprecation warnings about the use of the _IO*
;; constants in (guix build utils).
HCoop / jackhill / guix / guix.git / blobdiff