guix/gexp.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2014-2022 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
   4 ;;; Copyright © 2018 Jan Nieuwenhuizen <janneke@gnu.org>
   5 ;;; Copyright © 2019, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
   6 ;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com>
   7 ;;; Copyright © 2021, 2022 Maxime Devos <maximedevos@telenet.be>
   8 ;;;
   9 ;;; This file is part of GNU Guix.
  10 ;;;
  11 ;;; GNU Guix is free software; you can redistribute it and/or modify it
  12 ;;; under the terms of the GNU General Public License as published by
  13 ;;; the Free Software Foundation; either version 3 of the License, or (at
  14 ;;; your option) any later version.
  15 ;;;
  16 ;;; GNU Guix is distributed in the hope that it will be useful, but
  17 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;;; GNU General Public License for more details.
  20 ;;;
  21 ;;; You should have received a copy of the GNU General Public License
  22 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 (define-module (guix gexp)
  25   #:use-module (guix store)
  26   #:use-module (guix monads)
  27   #:use-module (guix derivations)
  28   #:use-module (guix grafts)
  29   #:use-module (guix utils)
  30   #:use-module (guix diagnostics)
  31   #:use-module (guix i18n)
  32   #:use-module (rnrs bytevectors)
  33   #:use-module (srfi srfi-1)
  34   #:use-module (srfi srfi-9)
  35   #:use-module (srfi srfi-9 gnu)
  36   #:use-module (srfi srfi-26)
  37   #:use-module (srfi srfi-34)
  38   #:use-module (srfi srfi-35)
  39   #:use-module (ice-9 format)
  40   #:use-module (ice-9 match)
  41   #:export (gexp
  42             gexp?
  43             sexp->gexp
  44             with-imported-modules
  45             with-extensions
  46             let-system
  47             gexp->approximate-sexp
  48
  49             gexp-input
  50             gexp-input?
  51             gexp-input-thing
  52             gexp-input-output
  53             gexp-input-native?
  54
  55             assume-valid-file-name
  56             local-file
  57             local-file?
  58             local-file-file
  59             local-file-absolute-file-name
  60             local-file-name
  61             local-file-recursive?
  62             local-file-select?
  63
  64             plain-file
  65             plain-file?
  66             plain-file-name
  67             plain-file-content
  68
  69             computed-file
  70             computed-file?
  71             computed-file-name
  72             computed-file-gexp
  73             computed-file-options
  74
  75             program-file
  76             program-file?
  77             program-file-name
  78             program-file-gexp
  79             program-file-guile
  80             program-file-module-path
  81
  82             scheme-file
  83             scheme-file?
  84             scheme-file-name
  85             scheme-file-gexp
  86
  87             file-append
  88             file-append?
  89             file-append-base
  90             file-append-suffix
  91
  92             raw-derivation-file
  93             raw-derivation-file?
  94
  95             with-parameters
  96             parameterized?
  97
  98             load-path-expression
  99             gexp-modules
 100
 101             lower-gexp
 102             lowered-gexp?
 103             lowered-gexp-sexp
 104             lowered-gexp-inputs
 105             lowered-gexp-sources
 106             lowered-gexp-guile
 107             lowered-gexp-load-path
 108             lowered-gexp-load-compiled-path
 109
 110             with-build-variables
 111             input-tuples->gexp
 112             outputs->gexp
 113
 114             gexp->derivation
 115             gexp->file
 116             gexp->script
 117             text-file*
 118             mixed-text-file
 119             file-union
 120             directory-union
 121             references-file
 122
 123             imported-files
 124             imported-modules
 125             compiled-modules
 126
 127             define-gexp-compiler
 128             gexp-compiler?
 129             file-like?
 130             lower-object
 131
 132             &gexp-error
 133             gexp-error?
 134             &gexp-input-error
 135             gexp-input-error?
 136             gexp-error-invalid-input))
 137
 138 ;;; Commentary:
 139 ;;;
 140 ;;; This module implements "G-expressions", or "gexps".  Gexps are like
 141 ;;; S-expressions (sexps), with two differences:
 142 ;;;
 143 ;;;   1. References (un-quotations) to derivations or packages in a gexp are
 144 ;;;      replaced by the corresponding output file name; in addition, the
 145 ;;;      'ungexp-native' unquote-like form allows code to explicitly refer to
 146 ;;;      the native code of a given package, in case of cross-compilation;
 147 ;;;
 148 ;;;   2. Gexps embed information about the derivations they refer to.
 149 ;;;
 150 ;;; Gexps make it easy to write to files Scheme code that refers to store
 151 ;;; items, or to write Scheme code to build derivations.
 152 ;;;
 153 ;;; Code:
 154
 155 ;; "G expressions".
 156 (define-record-type <gexp>
 157   (make-gexp references modules extensions proc location)
 158   gexp?
 159   (references gexp-references)                    ;list of <gexp-input>
 160   (modules    gexp-self-modules)                  ;list of module names
 161   (extensions gexp-self-extensions)               ;list of lowerable things
 162   (proc       gexp-proc)                          ;procedure
 163   (location   %gexp-location))                    ;location alist
 164
 165 (define (gexp-location gexp)
 166   "Return the source code location of GEXP."
 167   (and=> (%gexp-location gexp) source-properties->location))
 168
 169 (define* (gexp->approximate-sexp gexp)
 170   "Return the S-expression corresponding to GEXP, but do not lower anything.
 171 As a result, the S-expression will be approximate if GEXP has references."
 172   (define (gexp-like? thing)
 173     (or (gexp? thing) (gexp-input? thing)))
 174   (apply (gexp-proc gexp)
 175          (map (lambda (reference)
 176                 (match reference
 177                   (($ <gexp-input> thing output native)
 178                    (cond ((gexp-like? thing)
 179                           (gexp->approximate-sexp thing))
 180                          ((not (record? thing)) ; a S-exp
 181                           thing)
 182                          (#true
 183                           ;; Simply returning 'thing' won't work in some
 184                           ;; situations; see 'write-gexp' below.
 185                           '(*approximate*))))
 186                   (($ <gexp-output>) '(*approximate*))))
 187               (gexp-references gexp))))
 188
 189 (define (write-gexp gexp port)
 190   "Write GEXP on PORT."
 191   (display "#<gexp " port)
 192
 193   ;; Try to write the underlying sexp.  Now, this trick doesn't work when
 194   ;; doing things like (ungexp-splicing (gexp ())) because GEXP's procedure
 195   ;; tries to use 'append' on that, which fails with wrong-type-arg.
 196   (false-if-exception
 197    (write (apply (gexp-proc gexp)
 198                  (gexp-references gexp))
 199           port))
 200
 201   (let ((loc (gexp-location gexp)))
 202     (when loc
 203       (format port " ~a" (location->string loc))))
 204
 205   (format port " ~a>"
 206           (number->string (object-address gexp) 16)))
 207
 208 (set-record-type-printer! <gexp> write-gexp)
 209
 210 (define (gexp-with-hidden-inputs gexp inputs)
 211   "Add INPUTS, a list of <gexp-input>, to the references of GEXP.  These are
 212 \"hidden inputs\" because they do not actually appear in the expansion of GEXP
 213 returned by 'gexp->sexp'."
 214   (make-gexp (append inputs (gexp-references gexp))
 215              (gexp-self-modules gexp)
 216              (gexp-self-extensions gexp)
 217              (let ((extra (length inputs)))
 218                (lambda args
 219                  (apply (gexp-proc gexp) (drop args extra))))
 220              (gexp-location gexp)))
 221
 222 \f
 223 ;;;
 224 ;;; Methods.
 225 ;;;
 226
 227 ;; Compiler for a type of objects that may be introduced in a gexp.
 228 (define-record-type <gexp-compiler>
 229   (gexp-compiler type lower expand)
 230   gexp-compiler?
 231   (type       gexp-compiler-type)                 ;record type descriptor
 232   (lower      gexp-compiler-lower)
 233   (expand     gexp-compiler-expand))              ;#f | DRV -> sexp
 234
 235 (define-condition-type &gexp-error &error
 236   gexp-error?)
 237
 238 (define-condition-type &gexp-input-error &gexp-error
 239   gexp-input-error?
 240   (input gexp-error-invalid-input))
 241
 242
 243 (define %gexp-compilers
 244   ;; 'eq?' mapping of record type descriptor to <gexp-compiler>.
 245   (make-hash-table 20))
 246
 247 (define (default-expander thing obj output)
 248   "This is the default expander for \"things\" that appear in gexps.  It
 249 returns its output file name of OBJ's OUTPUT."
 250   (match obj
 251     ((? derivation? drv)
 252      (derivation->output-path drv output))
 253     ((? string? file)
 254      file)
 255     ((? self-quoting? obj)
 256      obj)))
 257
 258 (define (register-compiler! compiler)
 259   "Register COMPILER as a gexp compiler."
 260   (hashq-set! %gexp-compilers
 261               (gexp-compiler-type compiler) compiler))
 262
 263 (define (lookup-compiler object)
 264   "Search for a compiler for OBJECT.  Upon success, return the three argument
 265 procedure to lower it; otherwise return #f."
 266   (and=> (hashq-ref %gexp-compilers (struct-vtable object))
 267          gexp-compiler-lower))
 268
 269 (define (file-like? object)
 270   "Return #t if OBJECT leads to a file in the store once unquoted in a
 271 G-expression; otherwise return #f."
 272   (and (struct? object) (->bool (lookup-compiler object))))
 273
 274 (define (lookup-expander object)
 275   "Search for an expander for OBJECT.  Upon success, return the three argument
 276 procedure to expand it; otherwise return #f."
 277   (and=> (hashq-ref %gexp-compilers (struct-vtable object))
 278          gexp-compiler-expand))
 279
 280 (define* (lower-object obj
 281                        #:optional (system (%current-system))
 282                        #:key (target 'current))
 283   "Return as a value in %STORE-MONAD the derivation or store item
 284 corresponding to OBJ for SYSTEM, cross-compiling for TARGET if TARGET is true.
 285 OBJ must be an object that has an associated gexp compiler, such as a
 286 <package>."
 287   (mlet %store-monad ((target (if (eq? target 'current)
 288                                   (current-target-system)
 289                                   (return target)))
 290                       (graft? (grafting?)))
 291     (let loop ((obj obj))
 292       (match (lookup-compiler obj)
 293         (#f
 294          (raise (condition (&gexp-input-error (input obj)))))
 295         (lower
 296          ;; Cache in STORE the result of lowering OBJ.  If OBJ is a
 297          ;; derivation, bypass the cache.
 298          (if (derivation? obj)
 299              (return obj)
 300              (mcached (mlet %store-monad ((lowered (lower obj system target)))
 301                         (if (and (struct? lowered)
 302                                  (not (derivation? lowered)))
 303                             (loop lowered)
 304                             (return lowered)))
 305                       obj
 306                       system target graft?)))))))
 307
 308 (define* (lower+expand-object obj
 309                               #:optional (system (%current-system))
 310                               #:key target (output "out"))
 311   "Return as a value in %STORE-MONAD the output of object OBJ expands to for
 312 SYSTEM and TARGET.  Object such as <package>, <file-append>, or <plain-file>
 313 expand to file names, but it's possible to expand to a plain data type."
 314   (let loop ((obj obj)
 315              (expand (and (struct? obj) (lookup-expander obj))))
 316     (match (lookup-compiler obj)
 317       (#f
 318        (raise (condition (&gexp-input-error (input obj)))))
 319       (lower
 320        (mlet* %store-monad ((graft?  (grafting?))
 321                             (lowered (if (derivation? obj)
 322                                          (return obj)
 323                                          (mcached (lower obj system target)
 324                                                   obj
 325                                                   system target graft?))))
 326          ;; LOWER might return something that needs to be further
 327          ;; lowered.
 328          (if (struct? lowered)
 329              ;; If we lack an expander, delegate to that of LOWERED.
 330              (if (not expand)
 331                  (loop lowered (lookup-expander lowered))
 332                  (return (expand obj lowered output)))
 333              (if (not expand)                     ;self-quoting
 334                  (return lowered)
 335                  (return (expand obj lowered output)))))))))
 336
 337 (define-syntax define-gexp-compiler
 338   (syntax-rules (=> compiler expander)
 339     "Define NAME as a compiler for objects matching PREDICATE encountered in
 340 gexps.
 341
 342 In the simplest form of the macro, BODY must return (1) a derivation for
 343 a record of the specified type, for SYSTEM and TARGET (the latter of which is
 344 #f except when cross-compiling), (2) another record that can itself be
 345 compiled down to a derivation, or (3) an object of a primitive data type.
 346
 347 The more elaborate form allows you to specify an expander:
 348
 349   (define-gexp-compiler something-compiler <something>
 350     compiler => (lambda (param system target) ...)
 351     expander => (lambda (param drv output) ...))
 352
 353 The expander specifies how an object is converted to its sexp representation."
 354     ((_ (name (param record-type) system target) body ...)
 355      (define-gexp-compiler name record-type
 356        compiler => (lambda (param system target) body ...)
 357        expander => default-expander))
 358     ((_ name record-type
 359         compiler => compile
 360         expander => expand)
 361      (begin
 362        (define name
 363          (gexp-compiler record-type compile expand))
 364        (register-compiler! name)))))
 365
 366 (define-gexp-compiler (derivation-compiler (drv <derivation>) system target)
 367   ;; Derivations are the lowest-level representation, so this is the identity
 368   ;; compiler.
 369   (with-monad %store-monad
 370     (return drv)))
 371
 372 ;; Expand to a raw ".drv" file for the lowerable object it wraps.  In other
 373 ;; words, this gives the raw ".drv" file instead of its build result.
 374 (define-record-type <raw-derivation-file>
 375   (raw-derivation-file obj)
 376   raw-derivation-file?
 377   (obj  raw-derivation-file-object))              ;lowerable object
 378
 379 (define-gexp-compiler raw-derivation-file-compiler <raw-derivation-file>
 380   compiler => (lambda (obj system target)
 381                 (mlet %store-monad ((obj (lower-object
 382                                           (raw-derivation-file-object obj)
 383                                           system #:target target)))
 384                   ;; Returning the .drv file name instead of the <derivation>
 385                   ;; record ensures that 'lower-gexp' will classify it as a
 386                   ;; "source" and not as an "input".
 387                   (return (if (derivation? obj)
 388                               (derivation-file-name obj)
 389                               obj))))
 390   expander => (lambda (obj lowered output)
 391                 (if (derivation? lowered)
 392                     (derivation-file-name lowered)
 393                     lowered)))
 394
 395 \f
 396 ;;;
 397 ;;; System dependencies.
 398 ;;;
 399
 400 ;; Binding form for the current system and cross-compilation target.
 401 (define-record-type <system-binding>
 402   (system-binding proc)
 403   system-binding?
 404   (proc system-binding-proc))
 405
 406 (define-syntax let-system
 407   (syntax-rules ()
 408     "Introduce a system binding in a gexp.  The simplest form is:
 409
 410   (let-system system
 411     (cond ((string=? system \"x86_64-linux\") ...)
 412           (else ...)))
 413
 414 which binds SYSTEM to the currently targeted system.  The second form is
 415 similar, but it also shows the cross-compilation target:
 416
 417   (let-system (system target)
 418     ...)
 419
 420 Here TARGET is bound to the cross-compilation triplet or #f."
 421     ((_ (system target) exp0 exp ...)
 422      (system-binding (lambda (system target)
 423                        exp0 exp ...)))
 424     ((_ system exp0 exp ...)
 425      (system-binding (lambda (system target)
 426                        exp0 exp ...)))))
 427
 428 (define-gexp-compiler system-binding-compiler <system-binding>
 429   compiler => (lambda (binding system target)
 430                 (match binding
 431                   (($ <system-binding> proc)
 432                    (with-monad %store-monad
 433                      ;; PROC is expected to return a lowerable object.
 434                      ;; 'lower-object' takes care of residualizing it to a
 435                      ;; derivation or similar.
 436                      (return (proc system target))))))
 437
 438   ;; Delegate to the expander of the object returned by PROC.
 439   expander => #f)
 440
 441 \f
 442 ;;;
 443 ;;; File declarations.
 444 ;;;
 445
 446 ;; A local file name.  FILE is the file name the user entered, which can be a
 447 ;; relative file name, and ABSOLUTE is a promise that computes its canonical
 448 ;; absolute file name.  We keep it in a promise to compute it lazily and avoid
 449 ;; repeated 'stat' calls.
 450 (define-record-type <local-file>
 451   (%%local-file file absolute name recursive? select?)
 452   local-file?
 453   (file       local-file-file)                    ;string
 454   (absolute   %local-file-absolute-file-name)     ;promise string
 455   (name       local-file-name)                    ;string
 456   (recursive? local-file-recursive?)              ;Boolean
 457   (select?    local-file-select?))                ;string stat -> Boolean
 458
 459 (define (true file stat) #t)
 460
 461 (define* (%local-file file promise #:optional (name (basename file))
 462                       #:key
 463                       (literal? #t) location
 464                       recursive? (select? true))
 465   ;; This intermediate procedure is part of our ABI, but the underlying
 466   ;; %%LOCAL-FILE is not.
 467   (when (and (not literal?) (not (string-prefix? "/" file)))
 468     (warning (and=> location source-properties->location)
 469              (G_ "resolving '~a' relative to current directory~%")
 470              file))
 471   (%%local-file file promise name recursive? select?))
 472
 473 (define (absolute-file-name file directory)
 474   "Return the canonical absolute file name for FILE, which lives in the
 475 vicinity of DIRECTORY."
 476   (canonicalize-path
 477    (cond ((string-prefix? "/" file) file)
 478          ((not directory) file)
 479          ((string-prefix? "/" directory)
 480           (string-append directory "/" file))
 481          (else file))))
 482
 483 (define-syntax-rule (assume-valid-file-name file)
 484   "This is a syntactic keyword to tell 'local-file' that it can assume that
 485 the given file name is valid, even if it's not a string literal, and thus not
 486 warn about it."
 487   file)
 488
 489 (define-syntax local-file
 490   (lambda (s)
 491     "Return an object representing local file FILE to add to the store; this
 492 object can be used in a gexp.  If FILE is a relative file name, it is looked
 493 up relative to the source file where this form appears.  FILE will be added to
 494 the store under NAME--by default the base name of FILE.
 495
 496 When RECURSIVE? is true, the contents of FILE are added recursively; if FILE
 497 designates a flat file and RECURSIVE? is true, its contents are added, and its
 498 permission bits are kept.
 499
 500 When RECURSIVE? is true, call (SELECT?  FILE STAT) for each directory entry,
 501 where FILE is the entry's absolute file name and STAT is the result of
 502 'lstat'; exclude entries for which SELECT? does not return true.
 503
 504 This is the declarative counterpart of the 'interned-file' monadic procedure.
 505 It is implemented as a macro to capture the current source directory where it
 506 appears."
 507     (syntax-case s (assume-valid-file-name)
 508       ((_ file rest ...)
 509        (string? (syntax->datum #'file))
 510        ;; FILE is a literal, so resolve it relative to the source directory.
 511        #'(%local-file file
 512                       (delay (absolute-file-name file (current-source-directory)))
 513                       rest ...))
 514       ((_ (assume-valid-file-name file) rest ...)
 515        ;; FILE is not a literal, so resolve it relative to the current
 516        ;; directory.  Since the user declared FILE is valid, do not pass
 517        ;; #:literal? #f so that we do not warn about it later on.
 518        #'(%local-file file
 519                       (delay (absolute-file-name file (getcwd)))
 520                       rest ...))
 521       ((_ file rest ...)
 522        ;; Resolve FILE relative to the current directory.
 523        (with-syntax ((location (datum->syntax s (syntax-source s))))
 524         #`(%local-file file
 525                        (delay (absolute-file-name file (getcwd)))
 526                        rest ...
 527                        #:location 'location
 528                        #:literal? #f)))           ;warn if FILE is relative
 529       ((_)
 530        #'(syntax-error "missing file name"))
 531       (id
 532        (identifier? #'id)
 533        ;; XXX: We could return #'(lambda (file . rest) ...).  However,
 534        ;; (syntax-source #'id) is #f so (current-source-directory) would not
 535        ;; work.  Thus, simply forbid this form.
 536        #'(syntax-error
 537           "'local-file' is a macro and cannot be used like this")))))
 538
 539 (define (local-file-absolute-file-name file)
 540   "Return the absolute file name for FILE, a <local-file> instance.  A
 541 'system-error' exception is raised if FILE could not be found."
 542   (force (%local-file-absolute-file-name file)))
 543
 544 (define-gexp-compiler (local-file-compiler (file <local-file>) system target)
 545   ;; "Compile" FILE by adding it to the store.
 546   (match file
 547     (($ <local-file> file (= force absolute) name recursive? select?)
 548      ;; Canonicalize FILE so that if it's a symlink, it is resolved.  Failing
 549      ;; to do that, when RECURSIVE? is #t, we could end up creating a dangling
 550      ;; symlink in the store, and when RECURSIVE? is #f 'add-to-store' would
 551      ;; just throw an error, both of which are inconvenient.
 552      (interned-file absolute name
 553                     #:recursive? recursive? #:select? select?))))
 554
 555 (define-record-type <plain-file>
 556   (%plain-file name content references)
 557   plain-file?
 558   (name        plain-file-name)                   ;string
 559   (content     plain-file-content)                ;string or bytevector
 560   (references  plain-file-references))            ;list (currently unused)
 561
 562 (define (plain-file name content)
 563   "Return an object representing a text file called NAME with the given
 564 CONTENT (a string) to be added to the store.
 565
 566 This is the declarative counterpart of 'text-file'."
 567   ;; XXX: For now just ignore 'references' because it's not clear how to use
 568   ;; them in a declarative context.
 569   (%plain-file name content '()))
 570
 571 (define-gexp-compiler (plain-file-compiler (file <plain-file>) system target)
 572   ;; "Compile" FILE by adding it to the store.
 573   (match file
 574     (($ <plain-file> name (and (? string?) content) references)
 575      (text-file name content references))
 576     (($ <plain-file> name (and (? bytevector?) content) references)
 577      (binary-file name content references))))
 578
 579 (define-record-type <computed-file>
 580   (%computed-file name gexp guile options)
 581   computed-file?
 582   (name       computed-file-name)                 ;string
 583   (gexp       computed-file-gexp)                 ;gexp
 584   (guile      computed-file-guile)                ;<package>
 585   (options    computed-file-options))             ;list of arguments
 586
 587 (define* (computed-file name gexp
 588                         #:key guile (local-build? #t) (options '()))
 589   "Return an object representing the store item NAME, a file or directory
 590 computed by GEXP.  When LOCAL-BUILD? is #t (the default), it ensures the
 591 corresponding derivation is built locally.  OPTIONS may be used to pass
 592 additional arguments to 'gexp->derivation'.
 593
 594 This is the declarative counterpart of 'gexp->derivation'."
 595   (let ((options* `(#:local-build? ,local-build? ,@options)))
 596     (%computed-file name gexp guile options*)))
 597
 598 (define-gexp-compiler (computed-file-compiler (file <computed-file>)
 599                                               system target)
 600   ;; Compile FILE by returning a derivation whose build expression is its
 601   ;; gexp.
 602   (match file
 603     (($ <computed-file> name gexp guile options)
 604      (mlet %store-monad ((guile (lower-object (or guile (default-guile))
 605                                               system #:target #f)))
 606        (apply gexp->derivation name gexp #:guile-for-build guile
 607               #:system system #:target target options)))))
 608
 609 (define-record-type <program-file>
 610   (%program-file name gexp guile path)
 611   program-file?
 612   (name       program-file-name)                  ;string
 613   (gexp       program-file-gexp)                  ;gexp
 614   (guile      program-file-guile)                 ;package
 615   (path       program-file-module-path))          ;list of strings
 616
 617 (define* (program-file name gexp #:key (guile #f) (module-path %load-path))
 618   "Return an object representing the executable store item NAME that runs
 619 GEXP.  GUILE is the Guile package used to execute that script.  Imported
 620 modules of GEXP are looked up in MODULE-PATH.
 621
 622 This is the declarative counterpart of 'gexp->script'."
 623   (%program-file name gexp guile module-path))
 624
 625 (define-gexp-compiler (program-file-compiler (file <program-file>)
 626                                              system target)
 627   ;; Compile FILE by returning a derivation that builds the script.
 628   (match file
 629     (($ <program-file> name gexp guile module-path)
 630      (gexp->script name gexp
 631                    #:module-path module-path
 632                    #:guile (or guile (default-guile))
 633                    #:system system
 634                    #:target target))))
 635
 636 (define-record-type <scheme-file>
 637   (%scheme-file name gexp splice? load-path?)
 638   scheme-file?
 639   (name       scheme-file-name)                  ;string
 640   (gexp       scheme-file-gexp)                  ;gexp
 641   (splice?    scheme-file-splice?)               ;Boolean
 642   (load-path? scheme-file-set-load-path?))       ;Boolean
 643
 644 (define* (scheme-file name gexp #:key splice? (set-load-path? #t))
 645   "Return an object representing the Scheme file NAME that contains GEXP.
 646
 647 This is the declarative counterpart of 'gexp->file'."
 648   (%scheme-file name gexp splice? set-load-path?))
 649
 650 (define-gexp-compiler (scheme-file-compiler (file <scheme-file>)
 651                                             system target)
 652   ;; Compile FILE by returning a derivation that builds the file.
 653   (match file
 654     (($ <scheme-file> name gexp splice? set-load-path?)
 655      (gexp->file name gexp
 656                  #:set-load-path? set-load-path?
 657                  #:splice? splice?
 658                  #:system system
 659                  #:target target))))
 660
 661 ;; Appending SUFFIX to BASE's output file name.
 662 (define-record-type <file-append>
 663   (%file-append base suffix)
 664   file-append?
 665   (base   file-append-base)                    ;<package> | <derivation> | ...
 666   (suffix file-append-suffix))                 ;list of strings
 667
 668 (define (write-file-append file port)
 669   (match file
 670     (($ <file-append> base suffix)
 671      (format port "#<file-append ~s ~s>" base
 672              (string-join suffix)))))
 673
 674 (set-record-type-printer! <file-append> write-file-append)
 675
 676 (define (file-append base . suffix)
 677   "Return a <file-append> object that expands to the concatenation of BASE and
 678 SUFFIX."
 679   (%file-append base suffix))
 680
 681 (define-gexp-compiler file-append-compiler <file-append>
 682   compiler => (lambda (obj system target)
 683                 (match obj
 684                   (($ <file-append> base _)
 685                    (lower-object base system #:target target))))
 686   expander => (lambda (obj lowered output)
 687                 (match obj
 688                   (($ <file-append> base suffix)
 689                    (let* ((expand (or (lookup-expander base)
 690                                       (lookup-expander lowered)))
 691                           (base   (expand base lowered output)))
 692                      (string-append base (string-concatenate suffix)))))))
 693
 694 ;; Representation of SRFI-39 parameter settings in the dynamic scope of an
 695 ;; object lowering.
 696 (define-record-type <parameterized>
 697   (parameterized bindings thunk)
 698   parameterized?
 699   (bindings parameterized-bindings)             ;list of parameter/value pairs
 700   (thunk    parameterized-thunk))               ;thunk
 701
 702 (define-syntax-rule (with-parameters ((param value) ...) body ...)
 703   "Bind each PARAM to the corresponding VALUE for the extent during which BODY
 704 is lowered.  Consider this example:
 705
 706   (with-parameters ((%current-system \"x86_64-linux\"))
 707     coreutils)
 708
 709 It returns a <parameterized> object that ensures %CURRENT-SYSTEM is set to
 710 x86_64-linux when COREUTILS is lowered."
 711   (parameterized (list (list param (lambda () value)) ...)
 712                  (lambda ()
 713                    body ...)))
 714
 715 (define-gexp-compiler compile-parameterized <parameterized>
 716   compiler =>
 717   (lambda (parameterized system target)
 718     (match (parameterized-bindings parameterized)
 719       (((parameters values) ...)
 720        (let ((fluids (map parameter-fluid parameters))
 721              (thunk  (parameterized-thunk parameterized)))
 722          ;; Install the PARAMETERS for the dynamic extent of THUNK.
 723          (with-fluids* fluids
 724            (map (lambda (thunk) (thunk)) values)
 725            (lambda ()
 726              ;; Special-case '%current-system' and '%current-target-system' to
 727              ;; make sure we get the desired effect.
 728              (let ((system (if (memq %current-system parameters)
 729                                (%current-system)
 730                                system))
 731                    (target (if (memq %current-target-system parameters)
 732                                (%current-target-system)
 733                                target)))
 734                (lower-object (thunk) system #:target target))))))))
 735
 736   expander => (lambda (parameterized lowered output)
 737                 (match (parameterized-bindings parameterized)
 738                   (((parameters values) ...)
 739                    (let ((fluids (map parameter-fluid parameters))
 740                          (thunk  (parameterized-thunk parameterized)))
 741                      ;; Install the PARAMETERS for the dynamic extent of THUNK.
 742                      (with-fluids* fluids
 743                        (map (lambda (thunk) (thunk)) values)
 744                        (lambda ()
 745                          ;; Delegate to the expander of the wrapped object.
 746                          (let* ((base   (thunk))
 747                                 (expand (lookup-expander base)))
 748                            (expand base lowered output)))))))))
 749
 750 \f
 751 ;;;
 752 ;;; Inputs & outputs.
 753 ;;;
 754
 755 ;; The input of a gexp.
 756 (define-record-type <gexp-input>
 757   (%gexp-input thing output native?)
 758   gexp-input?
 759   (thing     gexp-input-thing)       ;<package> | <origin> | <derivation> | ...
 760   (output    gexp-input-output)      ;string
 761   (native?   gexp-input-native?))    ;Boolean
 762
 763 (define (write-gexp-input input port)
 764   (match input
 765     (($ <gexp-input> thing output #f)
 766      (format port "#<gexp-input ~s:~a>" thing output))
 767     (($ <gexp-input> thing output #t)
 768      (format port "#<gexp-input native ~s:~a>" thing output))))
 769
 770 (set-record-type-printer! <gexp-input> write-gexp-input)
 771
 772 (define* (gexp-input thing                        ;convenience procedure
 773                      #:optional (output "out")
 774                      #:key native?)
 775   "Return a new <gexp-input> for the OUTPUT of THING; NATIVE? determines
 776 whether this should be considered a \"native\" input or not."
 777   (%gexp-input thing output native?))
 778
 779 ;; Reference to one of the derivation's outputs, for gexps used in
 780 ;; derivations.
 781 (define-record-type <gexp-output>
 782   (gexp-output name)
 783   gexp-output?
 784   (name gexp-output-name))
 785
 786 (define (write-gexp-output output port)
 787   (match output
 788     (($ <gexp-output> name)
 789      (format port "#<gexp-output ~a>" name))))
 790
 791 (set-record-type-printer! <gexp-output> write-gexp-output)
 792
 793 (define* (gexp-attribute gexp self-attribute #:optional (equal? equal?)
 794                          #:key (validate (const #t)))
 795   "Recurse on GEXP and the expressions it refers to, summing the items
 796 returned by SELF-ATTRIBUTE, a procedure that takes a gexp.  Use EQUAL? as the
 797 second argument to 'delete-duplicates'.  Pass VALIDATE every gexp and
 798 attribute that is traversed."
 799   (if (gexp? gexp)
 800       (delete-duplicates
 801        (append (let ((attribute (self-attribute gexp)))
 802                  (validate gexp attribute)
 803                  attribute)
 804                (reverse
 805                 (fold (lambda (input result)
 806                         (match input
 807                           (($ <gexp-input> (? gexp? exp))
 808                            (append (gexp-attribute exp self-attribute
 809                                                    #:validate validate)
 810                                    result))
 811                           (($ <gexp-input> (lst ...))
 812                            (fold/tree (lambda (obj result)
 813                                         (match obj
 814                                           ((? gexp? exp)
 815                                            (append (gexp-attribute exp self-attribute
 816                                                                    #:validate validate)
 817                                                    result))
 818                                           (_
 819                                            result)))
 820                                       result
 821                                       lst))
 822                           (_
 823                            result)))
 824                       '()
 825                       (gexp-references gexp))))
 826        equal?)
 827       '()))                                       ;plain Scheme data type
 828
 829 (define (gexp-modules gexp)
 830   "Return the list of Guile module names GEXP relies on.  If (gexp? GEXP) is
 831 false, meaning that GEXP is a plain Scheme object, return the empty list."
 832   (define (module=? m1 m2)
 833     ;; Return #t when M1 equals M2.  Special-case '=>' specs because their
 834     ;; right-hand side may not be comparable with 'equal?': it's typically a
 835     ;; file-like object that embeds a gexp, which in turn embeds closure;
 836     ;; those closures may be 'eq?' when running compiled code but are unlikely
 837     ;; to be 'eq?' when running on 'eval'.  Ignore the right-hand side to
 838     ;; avoid this discrepancy.
 839     (match m1
 840       (((name1 ...) '=> _)
 841        (match m2
 842          (((name2 ...) '=> _) (equal? name1 name2))
 843          (_ #f)))
 844       (_
 845        (equal? m1 m2))))
 846
 847   (define (validate-modules gexp modules)
 848     ;; Warn if MODULES, imported by GEXP, contains modules that in general
 849     ;; should not be imported from the host because they vary from user to
 850     ;; user and may thus be a source of non-reproducibility.  This includes
 851     ;; (guix config) as well as modules that come with Guile.
 852     (match (filter (match-lambda
 853                      ((or ('guix 'config) ('ice-9 . _)) #t)
 854                      (_ #f))
 855                    modules)
 856       (() #t)
 857       (suspects
 858        (warning (gexp-location gexp)
 859                 (N_ "importing module~{ ~a~} from the host~%"
 860                     "importing modules~{ ~a~} from the host~%"
 861                     (length suspects))
 862                 suspects))))
 863
 864   (gexp-attribute gexp gexp-self-modules module=?
 865                   #:validate validate-modules))
 866
 867 (define (gexp-extensions gexp)
 868   "Return the list of Guile extensions (packages) GEXP relies on.  If (gexp?
 869 GEXP) is false, meaning that GEXP is a plain Scheme object, return the empty
 870 list."
 871   (gexp-attribute gexp gexp-self-extensions))
 872
 873 (define (self-quoting? x)
 874   (letrec-syntax ((one-of (syntax-rules ()
 875                             ((_) #f)
 876                             ((_ pred rest ...)
 877                              (or (pred x)
 878                                  (one-of rest ...))))))
 879     (one-of symbol? string? keyword? pair? null? array?
 880             number? boolean? char?)))
 881
 882 (define (lower-inputs inputs system target)
 883   "Turn any object from INPUTS into a derivation input for SYSTEM or a store
 884 item (a \"source\"); return the corresponding input list as a monadic value.
 885 When TARGET is true, use it as the cross-compilation target triplet."
 886   (define (store-item? obj)
 887     (and (string? obj) (store-path? obj)))
 888
 889   (define filterm
 890     (lift1 (cut filter ->bool <>) %store-monad))
 891
 892   (with-monad %store-monad
 893     (>>= (mapm/accumulate-builds
 894           (match-lambda
 895             (($ <gexp-input> (? store-item? item))
 896              (return item))
 897             (($ <gexp-input> thing output native?)
 898              (mlet %store-monad ((obj (lower-object thing system
 899                                                     #:target
 900                                                     (and (not native?)
 901                                                          target))))
 902                (return (match obj
 903                          ((? derivation? drv)
 904                           (derivation-input drv (list output)))
 905                          ((? store-item? item)
 906                           item)
 907                          ((? self-quoting?)
 908                           ;; Some inputs such as <system-binding> can lower to
 909                           ;; a self-quoting object that FILTERM will filter
 910                           ;; out.
 911                           #f))))))
 912           inputs)
 913          filterm)))
 914
 915 (define* (lower-reference-graphs graphs #:key system target)
 916   "Given GRAPHS, a list of (FILE-NAME INPUT ...) lists for use as a
 917 #:reference-graphs argument, lower it such that each INPUT is replaced by the
 918 corresponding <derivation-input> or store item."
 919   (define tuple->gexp-input
 920     (match-lambda
 921       ((thing)
 922        (%gexp-input thing "out" (not target)))
 923       ((thing output)
 924        (%gexp-input thing output (not target)))))
 925
 926   (match graphs
 927     (((file-names . inputs) ...)
 928      (mlet %store-monad ((inputs (lower-inputs (map tuple->gexp-input inputs)
 929                                                system target)))
 930        (return (map cons file-names inputs))))))
 931
 932 (define* (lower-references lst #:key system target)
 933   "Based on LST, a list of output names and packages, return a list of output
 934 names and file names suitable for the #:allowed-references argument to
 935 'derivation'."
 936   (with-monad %store-monad
 937     (define lower
 938       (match-lambda
 939        ((? string? output)
 940         (return output))
 941        (($ <gexp-input> thing output native?)
 942         (mlet %store-monad ((drv (lower-object thing system
 943                                                #:target (if native?
 944                                                             #f target))))
 945           (return (derivation->output-path drv output))))
 946        (thing
 947         (mlet %store-monad ((drv (lower-object thing system
 948                                                #:target target)))
 949           (return (derivation->output-path drv))))))
 950
 951     (mapm/accumulate-builds lower lst)))
 952
 953 (define default-guile-derivation
 954   ;; Here we break the abstraction by talking to the higher-level layer.
 955   ;; Thus, do the resolution lazily to hide the circular dependency.
 956   (let ((proc (delay
 957                 (let ((iface (resolve-interface '(guix packages))))
 958                   (module-ref iface 'default-guile-derivation)))))
 959     (lambda (system)
 960       ((force proc) system))))
 961
 962 ;; Representation of a gexp instantiated for a given target and system.
 963 ;; It's an intermediate representation between <gexp> and <derivation>.
 964 (define-record-type <lowered-gexp>
 965   (lowered-gexp sexp inputs sources guile load-path load-compiled-path)
 966   lowered-gexp?
 967   (sexp                lowered-gexp-sexp)         ;sexp
 968   (inputs              lowered-gexp-inputs)       ;list of <derivation-input>
 969   (sources             lowered-gexp-sources)      ;list of store items
 970   (guile               lowered-gexp-guile)        ;<derivation-input> | #f
 971   (load-path           lowered-gexp-load-path)    ;list of store items
 972   (load-compiled-path  lowered-gexp-load-compiled-path)) ;list of store items
 973
 974 (define* (imported+compiled-modules modules system
 975                                     #:key (extensions '())
 976                                     deprecation-warnings guile
 977                                     (module-path %load-path))
 978   "Return a pair where the first element is the imported MODULES and the
 979 second element is the derivation to compile them."
 980   (mcached equal?
 981            (mlet %store-monad ((modules  (if (pair? modules)
 982                                              (imported-modules modules
 983                                                                #:guile guile
 984                                                                #:system system
 985                                                                #:module-path module-path)
 986                                              (return #f)))
 987                                (compiled (if (pair? modules)
 988                                              (compiled-modules modules
 989                                                                #:system system
 990                                                                #:module-path module-path
 991                                                                #:extensions extensions
 992                                                                #:guile guile
 993                                                                #:deprecation-warnings
 994                                                                deprecation-warnings)
 995                                              (return #f))))
 996              (return (cons modules compiled)))
 997            modules
 998            system extensions guile deprecation-warnings module-path))
 999
1000 (define (sexp->string sexp)
1001   "Like 'object->string', but deterministic and slightly faster."
1002   ;; Explicitly use UTF-8 for determinism, and also because UTF-8 output is
1003   ;; faster.
1004   (with-fluids ((%default-port-encoding "UTF-8"))
1005     (call-with-output-string
1006      (lambda (port)
1007        (write sexp port)))))
1008
1009 (define* (lower-gexp exp
1010                      #:key
1011                      (module-path %load-path)
1012                      (system (%current-system))
1013                      (target 'current)
1014                      (graft? (%graft?))
1015                      (guile-for-build (%guile-for-build))
1016                      (effective-version "3.0")
1017
1018                      deprecation-warnings)
1019   "*Note: This API is subject to change; use at your own risk!*
1020
1021 Lower EXP, a gexp, instantiating it for SYSTEM and TARGET.  Return a
1022 <lowered-gexp> ready to be used.
1023
1024 Lowered gexps are an intermediate representation that's useful for
1025 applications that deal with gexps outside in a way that is disconnected from
1026 derivations--e.g., code evaluated for its side effects."
1027   (define %modules
1028     (delete-duplicates (gexp-modules exp)))
1029
1030   (define (search-path modules extensions suffix)
1031     (append (match modules
1032               ((? derivation? drv)
1033                (list (derivation->output-path drv)))
1034               (#f
1035                '())
1036               ((? store-path? item)
1037                (list item)))
1038             (map (lambda (extension)
1039                    (string-append (match extension
1040                                     ((? derivation? drv)
1041                                      (derivation->output-path drv))
1042                                     ((? store-path? item)
1043                                      item))
1044                                   suffix))
1045                  extensions)))
1046
1047   (mlet* %store-monad ( ;; The following binding forces '%current-system' and
1048                        ;; '%current-target-system' to be looked up at >>=
1049                        ;; time.
1050                        (graft?    (set-grafting graft?))
1051
1052                        (system -> (or system (%current-system)))
1053                        (target -> (if (eq? target 'current)
1054                                       (%current-target-system)
1055                                       target))
1056                        (guile     (if guile-for-build
1057                                       (return guile-for-build)
1058                                       (default-guile-derivation system)))
1059                        (inputs   (lower-inputs (gexp-inputs exp)
1060                                                system target))
1061                        (sexp     (gexp->sexp exp system target))
1062                        (extensions -> (gexp-extensions exp))
1063                        (exts     (mapm %store-monad
1064                                        (lambda (obj)
1065                                          (lower-object obj system
1066                                                        #:target #f))
1067                                        extensions))
1068                        (modules+compiled (imported+compiled-modules
1069                                           %modules system
1070                                           #:extensions extensions
1071                                           #:deprecation-warnings
1072                                           deprecation-warnings
1073                                           #:guile guile
1074                                           #:module-path module-path))
1075                        (modules ->  (car modules+compiled))
1076                        (compiled -> (cdr modules+compiled)))
1077     (define load-path
1078       (search-path modules exts
1079                    (string-append "/share/guile/site/" effective-version)))
1080
1081     (define load-compiled-path
1082       (search-path compiled exts
1083                    (string-append "/lib/guile/" effective-version
1084                                   "/site-ccache")))
1085
1086     (mbegin %store-monad
1087       (set-grafting graft?)                       ;restore the initial setting
1088       (return (lowered-gexp sexp
1089                             `(,@(if (derivation? modules)
1090                                     (list (derivation-input modules))
1091                                     '())
1092                               ,@(if compiled
1093                                     (list (derivation-input compiled))
1094                                     '())
1095                               ,@(map derivation-input exts)
1096                               ,@(filter derivation-input? inputs))
1097                             (filter string? (cons modules inputs))
1098                             (derivation-input guile '("out"))
1099                             load-path
1100                             load-compiled-path)))))
1101
1102 (define* (gexp->derivation name exp
1103                            #:key
1104                            system (target 'current)
1105                            hash hash-algo recursive?
1106                            (env-vars '())
1107                            (modules '())
1108                            (module-path %load-path)
1109                            (guile-for-build (%guile-for-build))
1110                            (effective-version "3.0")
1111                            (graft? (%graft?))
1112                            references-graphs
1113                            allowed-references disallowed-references
1114                            leaked-env-vars
1115                            local-build? (substitutable? #t)
1116                            (properties '())
1117                            deprecation-warnings
1118                            (script-name (string-append name "-builder")))
1119   "Return a derivation NAME that runs EXP (a gexp) with GUILE-FOR-BUILD (a
1120 derivation) on SYSTEM; EXP is stored in a file called SCRIPT-NAME.  When
1121 TARGET is true, it is used as the cross-compilation target triplet for
1122 packages referred to by EXP.
1123
1124 MODULES is deprecated in favor of 'with-imported-modules'.  Its meaning is to
1125 make MODULES available in the evaluation context of EXP; MODULES is a list of
1126 names of Guile modules searched in MODULE-PATH to be copied in the store,
1127 compiled, and made available in the load path during the execution of
1128 EXP---e.g., '((guix build utils) (guix build gnu-build-system)).
1129
1130 EFFECTIVE-VERSION determines the string to use when adding extensions of
1131 EXP (see 'with-extensions') to the search path---e.g., \"2.2\".
1132
1133 GRAFT? determines whether packages referred to by EXP should be grafted when
1134 applicable.
1135
1136 When REFERENCES-GRAPHS is true, it must be a list of tuples of one of the
1137 following forms:
1138
1139   (FILE-NAME PACKAGE)
1140   (FILE-NAME PACKAGE OUTPUT)
1141   (FILE-NAME DERIVATION)
1142   (FILE-NAME DERIVATION OUTPUT)
1143   (FILE-NAME STORE-ITEM)
1144
1145 The right-hand-side of each element of REFERENCES-GRAPHS is automatically made
1146 an input of the build process of EXP.  In the build environment, each
1147 FILE-NAME contains the reference graph of the corresponding item, in a simple
1148 text format.
1149
1150 ALLOWED-REFERENCES must be either #f or a list of output names and packages.
1151 In the latter case, the list denotes store items that the result is allowed to
1152 refer to.  Any reference to another store item will lead to a build error.
1153 Similarly for DISALLOWED-REFERENCES, which can list items that must not be
1154 referenced by the outputs.
1155
1156 DEPRECATION-WARNINGS determines whether to show deprecation warnings while
1157 compiling modules.  It can be #f, #t, or 'detailed.
1158
1159 The other arguments are as for 'derivation'."
1160   (define outputs (gexp-outputs exp))
1161   (define requested-graft? graft?)
1162
1163   (define (graphs-file-names graphs)
1164     ;; Return a list of (FILE-NAME . STORE-PATH) pairs made from GRAPHS.
1165     (map (match-lambda
1166            ((file-name . (? derivation-input? input))
1167             (cons file-name (first (derivation-input-output-paths input))))
1168            ((file-name . (? string? item))
1169             (cons file-name item)))
1170          graphs))
1171
1172   (define (add-modules exp modules)
1173     (if (null? modules)
1174         exp
1175         (make-gexp (gexp-references exp)
1176                    (append modules (gexp-self-modules exp))
1177                    (gexp-self-extensions exp)
1178                    (gexp-proc exp)
1179                    (gexp-location exp))))
1180
1181   (mlet* %store-monad ( ;; The following binding forces '%current-system' and
1182                        ;; '%current-target-system' to be looked up at >>=
1183                        ;; time.
1184                        (graft?    (set-grafting graft?))
1185
1186                        (system -> (or system (%current-system)))
1187                        (target -> (if (eq? target 'current)
1188                                       (%current-target-system)
1189                                       target))
1190                        (exp ->    (add-modules exp modules))
1191                        (lowered   (lower-gexp exp
1192                                               #:module-path module-path
1193                                               #:system system
1194                                               #:target target
1195                                               #:graft? requested-graft?
1196                                               #:guile-for-build
1197                                               guile-for-build
1198                                               #:effective-version
1199                                               effective-version
1200                                               #:deprecation-warnings
1201                                               deprecation-warnings))
1202
1203                        (graphs   (if references-graphs
1204                                      (lower-reference-graphs references-graphs
1205                                                              #:system system
1206                                                              #:target target)
1207                                      (return #f)))
1208                        (allowed  (if allowed-references
1209                                      (lower-references allowed-references
1210                                                        #:system system
1211                                                        #:target target)
1212                                      (return #f)))
1213                        (disallowed (if disallowed-references
1214                                        (lower-references disallowed-references
1215                                                          #:system system
1216                                                          #:target target)
1217                                        (return #f)))
1218                        (guile -> (lowered-gexp-guile lowered))
1219                        (builder  (text-file script-name
1220                                             (sexp->string
1221                                              (lowered-gexp-sexp lowered)))))
1222     (mbegin %store-monad
1223       (set-grafting graft?)                       ;restore the initial setting
1224       (raw-derivation name
1225                       (string-append (derivation-input-output-path guile)
1226                                      "/bin/guile")
1227                       `("--no-auto-compile"
1228                         ,@(append-map (lambda (directory)
1229                                         `("-L" ,directory))
1230                                       (lowered-gexp-load-path lowered))
1231                         ,@(append-map (lambda (directory)
1232                                         `("-C" ,directory))
1233                                       (lowered-gexp-load-compiled-path lowered))
1234                         ,builder)
1235                       #:outputs outputs
1236                       #:env-vars env-vars
1237                       #:system system
1238                       #:inputs `(,guile
1239                                  ,@(lowered-gexp-inputs lowered)
1240                                  ,@(match graphs
1241                                      (((_ . inputs) ...)
1242                                       (filter derivation-input? inputs))
1243                                      (#f '())))
1244                       #:sources `(,builder
1245                                   ,@(if (and (string? modules)
1246                                              (store-path? modules))
1247                                         (list modules)
1248                                         '())
1249                                   ,@(lowered-gexp-sources lowered)
1250                                   ,@(match graphs
1251                                       (((_ . inputs) ...)
1252                                        (filter string? inputs))
1253                                       (#f '())))
1254
1255                       #:hash hash #:hash-algo hash-algo #:recursive? recursive?
1256                       #:references-graphs (and=> graphs graphs-file-names)
1257                       #:allowed-references allowed
1258                       #:disallowed-references disallowed
1259                       #:leaked-env-vars leaked-env-vars
1260                       #:local-build? local-build?
1261                       #:substitutable? substitutable?
1262                       #:properties properties))))
1263
1264 (define (fold/tree proc seed lst)
1265   "Like 'fold', but recurse into sub-lists of LST and accept improper lists."
1266   (let loop ((obj lst)
1267              (result seed))
1268     (match obj
1269       ((head . tail)
1270        (loop tail (loop head result)))
1271       (_
1272        (proc obj result)))))
1273
1274 (define (gexp-inputs exp)
1275   "Return the list of <gexp-input> for EXP."
1276   (define set-gexp-input-native?
1277     (match-lambda
1278       (($ <gexp-input> thing output)
1279        (%gexp-input thing output #t))))
1280
1281   (define (interesting? obj)
1282     (or (file-like? obj)
1283         (and (string? obj) (direct-store-path? obj))))
1284
1285   (define (add-reference-inputs ref result)
1286     (match ref
1287       (($ <gexp-input> (? gexp? exp) _ #t)
1288        (append (map set-gexp-input-native? (gexp-inputs exp))
1289                result))
1290       (($ <gexp-input> (? gexp? exp) _ #f)
1291        (append (gexp-inputs exp) result))
1292       (($ <gexp-input> (? string? str))
1293        (if (direct-store-path? str)
1294            (cons ref result)
1295            result))
1296       (($ <gexp-input> (? struct? thing) output n?)
1297        (if (lookup-compiler thing)
1298            ;; THING is a derivation, or a package, or an origin, etc.
1299            (cons ref result)
1300            result))
1301       (($ <gexp-input> (? pair? lst) output n?)
1302        ;; XXX: Scan LST for inputs.  Inherit N?.
1303        (fold/tree (lambda (obj result)
1304                     (match obj
1305                       ((? gexp-input? x)
1306                        (cons (%gexp-input (gexp-input-thing x)
1307                                           (gexp-input-output x)
1308                                           n?)
1309                              result))
1310                       ((? interesting? x)
1311                        (cons (%gexp-input x "out" n?) result))
1312                       ((? gexp? x)
1313                        (append (gexp-inputs x) result))
1314                       (_
1315                        result)))
1316                   result
1317                   lst))
1318       (_
1319        ;; Ignore references to other kinds of objects.
1320        result)))
1321
1322   (fold-right add-reference-inputs
1323               '()
1324               (gexp-references exp)))
1325
1326 (define (gexp-outputs exp)
1327   "Return the outputs referred to by EXP as a list of strings."
1328   (define (add-reference-output ref result)
1329     (match ref
1330       (($ <gexp-output> name)
1331        (cons name result))
1332       (($ <gexp-input> (? gexp? exp))
1333        (append (gexp-outputs exp) result))
1334       (($ <gexp-input> (? pair? lst))
1335        ;; XXX: Scan LST for outputs.
1336        (fold/tree (lambda (obj result)
1337                     (match obj
1338                       (($ <gexp-output> name) (cons name result))
1339                       ((? gexp? x) (append (gexp-outputs x) result))
1340                       (_ result)))
1341                   result
1342                   lst))
1343       (_
1344        result)))
1345
1346   (delete-duplicates
1347    (fold add-reference-output '() (gexp-references exp))))
1348
1349 (define (gexp->sexp exp system target)
1350   "Return (monadically) the sexp corresponding to EXP for the given OUTPUT,
1351 and in the current monad setting (system type, etc.)"
1352   (define* (reference->sexp ref #:optional native?)
1353     (with-monad %store-monad
1354       (match ref
1355         (($ <gexp-output> output)
1356          ;; Output file names are not known in advance but the daemon defines
1357          ;; an environment variable for each of them at build time, so use
1358          ;; that trick.
1359          (return `((@ (guile) getenv) ,output)))
1360         (($ <gexp-input> (? gexp? exp) output n?)
1361          (gexp->sexp exp
1362                      system (if (or n? native?) #f target)))
1363         (($ <gexp-input> (refs ...) output n?)
1364          (mapm %store-monad
1365                (lambda (ref)
1366                  ;; XXX: Automatically convert REF to an gexp-input.
1367                  (if (or (symbol? ref) (number? ref)
1368                          (boolean? ref) (null? ref) (array? ref))
1369                      (return ref)
1370                      (reference->sexp
1371                       (if (gexp-input? ref)
1372                           ref
1373                           (%gexp-input ref "out" n?))
1374                       (or n? native?))))
1375                refs))
1376         (($ <gexp-input> (? struct? thing) output n?)
1377          (let ((target (if (or n? native?) #f target)))
1378            (lower+expand-object thing system
1379                                 #:target target
1380                                 #:output output)))
1381         (($ <gexp-input> (? self-quoting? x))
1382          (return x))
1383         (($ <gexp-input> x)
1384          (raise (condition (&gexp-input-error (input x)))))
1385         (x
1386          (return x)))))
1387
1388   (mlet %store-monad
1389       ((args (mapm %store-monad
1390                    reference->sexp (gexp-references exp))))
1391     (return (apply (gexp-proc exp) args))))
1392
1393 (define-syntax-parameter current-imported-modules
1394   ;; Current list of imported modules.
1395   (identifier-syntax '()))
1396
1397 (define-syntax-rule (with-imported-modules modules body ...)
1398   "Mark the gexps defined in BODY... as requiring MODULES in their execution
1399 environment."
1400   (syntax-parameterize ((current-imported-modules
1401                          (identifier-syntax modules)))
1402     body ...))
1403
1404 (define-syntax-parameter current-imported-extensions
1405   ;; Current list of extensions.
1406   (identifier-syntax '()))
1407
1408 (define-syntax-rule (with-extensions extensions body ...)
1409   "Mark the gexps defined in BODY... as requiring EXTENSIONS in their
1410 execution environment."
1411   (syntax-parameterize ((current-imported-extensions
1412                          (identifier-syntax extensions)))
1413     body ...))
1414
1415 (define-syntax gexp
1416   (lambda (s)
1417     (define (collect-escapes exp)
1418       ;; Return all the 'ungexp' present in EXP.
1419       (let loop ((exp    exp)
1420                  (result '()))
1421         (syntax-case exp (ungexp
1422                           ungexp-splicing
1423                           ungexp-native
1424                           ungexp-native-splicing)
1425           ((ungexp _)
1426            (cons exp result))
1427           ((ungexp _ _)
1428            (cons exp result))
1429           ((ungexp-splicing _ ...)
1430            (cons exp result))
1431           ((ungexp-native _ ...)
1432            (cons exp result))
1433           ((ungexp-native-splicing _ ...)
1434            (cons exp result))
1435           ((exp0 . exp)
1436            (let ((result (loop #'exp0 result)))
1437              (loop  #'exp result)))
1438           (_
1439            result))))
1440
1441     (define (escape->ref exp)
1442       ;; Turn 'ungexp' form EXP into a "reference".
1443       (syntax-case exp (ungexp ungexp-splicing
1444                         ungexp-native ungexp-native-splicing
1445                         output)
1446         ((ungexp output)
1447          #'(gexp-output "out"))
1448         ((ungexp output name)
1449          #'(gexp-output name))
1450         ((ungexp thing)
1451          #'(%gexp-input thing "out" #f))
1452         ((ungexp drv-or-pkg out)
1453          #'(%gexp-input drv-or-pkg out #f))
1454         ((ungexp-splicing lst)
1455          #'(%gexp-input lst "out" #f))
1456         ((ungexp-native thing)
1457          #'(%gexp-input thing "out" #t))
1458         ((ungexp-native drv-or-pkg out)
1459          #'(%gexp-input drv-or-pkg out #t))
1460         ((ungexp-native-splicing lst)
1461          #'(%gexp-input lst "out" #t))))
1462
1463     (define (substitute-ungexp exp substs)
1464       ;; Given EXP, an 'ungexp' or 'ungexp-native' form, substitute it with
1465       ;; the corresponding form in SUBSTS.
1466       (match (assoc exp substs)
1467         ((_ id)
1468          id)
1469         (_                                        ;internal error
1470          (with-syntax ((exp exp))
1471            #'(syntax-error "error: no 'ungexp' substitution" exp)))))
1472
1473     (define (substitute-ungexp-splicing exp substs)
1474       (syntax-case exp ()
1475         ((exp rest ...)
1476          (match (assoc #'exp substs)
1477            ((_ id)
1478             (with-syntax ((id id))
1479               #`(append id
1480                         #,(substitute-references #'(rest ...) substs))))
1481            (_
1482             #'(syntax-error "error: no 'ungexp-splicing' substitution"
1483                             exp))))))
1484
1485     (define (substitute-references exp substs)
1486       ;; Return a variant of EXP where all the cars of SUBSTS have been
1487       ;; replaced by the corresponding cdr.
1488       (syntax-case exp (ungexp ungexp-native
1489                         ungexp-splicing ungexp-native-splicing)
1490         ((ungexp _ ...)
1491          (substitute-ungexp exp substs))
1492         ((ungexp-native _ ...)
1493          (substitute-ungexp exp substs))
1494         (((ungexp-splicing _ ...) rest ...)
1495          (substitute-ungexp-splicing exp substs))
1496         (((ungexp-native-splicing _ ...) rest ...)
1497          (substitute-ungexp-splicing exp substs))
1498         ((exp0 . exp)
1499          #`(cons #,(substitute-references #'exp0 substs)
1500                  #,(substitute-references #'exp substs)))
1501         (x #''x)))
1502
1503     (syntax-case s (ungexp output)
1504       ((_ exp)
1505        (let* ((escapes (delete-duplicates (collect-escapes #'exp)))
1506               (formals (generate-temporaries escapes))
1507               (sexp    (substitute-references #'exp (zip escapes formals)))
1508               (refs    (map escape->ref escapes)))
1509          #`(make-gexp (list #,@refs)
1510                       current-imported-modules
1511                       current-imported-extensions
1512                       (lambda #,formals
1513                         #,sexp)
1514                       (current-source-location)))))))
1515
1516 \f
1517 ;;;
1518 ;;; Module handling.
1519 ;;;
1520
1521 (define %utils-module
1522   ;; This file provides 'mkdir-p', needed to implement 'imported-files' and
1523   ;; other primitives below.  Note: We give the file name relative to this
1524   ;; file you are currently reading; 'search-path' could return a file name
1525   ;; relative to the current working directory.
1526   (local-file "build/utils.scm"
1527               "build-utils.scm"))
1528
1529 (define* (imported-files/derivation files
1530                                     #:key (name "file-import")
1531                                     (symlink? #f)
1532                                     (system (%current-system))
1533                                     (guile (%guile-for-build)))
1534   "Return a derivation that imports FILES into STORE.  FILES must be a list
1535 of (FINAL-PATH . FILE) pairs.  Each FILE is mapped to FINAL-PATH in the
1536 resulting store path.  FILE can be either a file name, or a file-like object,
1537 as returned by 'local-file' for example.  If SYMLINK? is true, create symlinks
1538 to the source files instead of copying them."
1539   (define file-pair
1540     (match-lambda
1541      ((final-path . (? string? file-name))
1542       (mlet %store-monad ((file (interned-file file-name
1543                                                (basename final-path))))
1544         (return (list final-path file))))
1545      ((final-path . file-like)
1546       (mlet %store-monad ((file (lower-object file-like system)))
1547         (return (list final-path file))))))
1548
1549   (mlet %store-monad ((files (mapm %store-monad file-pair files)))
1550     (define build
1551       (gexp
1552        (begin
1553          (primitive-load (ungexp %utils-module))  ;for 'mkdir-p'
1554          (use-modules (ice-9 match))
1555
1556          (mkdir (ungexp output)) (chdir (ungexp output))
1557          (for-each (match-lambda
1558                     ((final-path store-path)
1559                      (mkdir-p (dirname final-path))
1560                      ((ungexp (if symlink? 'symlink 'copy-file))
1561                       store-path final-path)))
1562                    '(ungexp files)))))
1563
1564     ;; TODO: Pass FILES as an environment variable so that BUILD remains
1565     ;; exactly the same regardless of FILES: less disk space, and fewer
1566     ;; 'add-to-store' RPCs.
1567     (gexp->derivation name build
1568                       #:system system
1569                       #:guile-for-build guile
1570                       #:local-build? #t
1571                       #:substitutable? #f
1572
1573                       ;; Avoid deprecation warnings about the use of the _IO*
1574                       ;; constants in (guix build utils).
1575                       #:env-vars
1576                       '(("GUILE_WARN_DEPRECATED" . "no")))))
1577
1578 (define* (imported-files files
1579                          #:key (name "file-import")
1580                          ;; The following parameters make sense when creating
1581                          ;; an actual derivation.
1582                          (system (%current-system))
1583                          (guile (%guile-for-build)))
1584   "Import FILES into the store and return the resulting derivation or store
1585 file name (a derivation is created if and only if some elements of FILES are
1586 file-like objects and not local file names.)  FILES must be a list
1587 of (FINAL-PATH . FILE) pairs.  Each FILE is mapped to FINAL-PATH in the
1588 resulting store path.  FILE can be either a file name, or a file-like object,
1589 as returned by 'local-file' for example."
1590   (if (any (match-lambda
1591              ((_ . (? struct? source)) #t)
1592              (_ #f))
1593            files)
1594       (imported-files/derivation files #:name name
1595                                  #:symlink? derivation?
1596                                  #:system system #:guile guile)
1597       (interned-file-tree `(,name directory
1598                                   ,@(file-mapping->tree files)))))
1599
1600 (define* (imported-modules modules
1601                            #:key (name "module-import")
1602                            (system (%current-system))
1603                            (guile (%guile-for-build))
1604                            (module-path %load-path))
1605   "Return a derivation that contains the source files of MODULES, a list of
1606 module names such as `(ice-9 q)'.  All of MODULES must be either names of
1607 modules to be found in the MODULE-PATH search path, or a module name followed
1608 by an arrow followed by a file-like object.  For example:
1609
1610   (imported-modules `((guix build utils)
1611                       (guix gcrypt)
1612                       ((guix config) => ,(scheme-file …))))
1613
1614 In this example, the first two modules are taken from MODULE-PATH, and the
1615 last one is created from the given <scheme-file> object."
1616   (let ((files (map (match-lambda
1617                       (((module ...) '=> file)
1618                        (cons (module->source-file-name module)
1619                              file))
1620                       ((module ...)
1621                        (let ((f (module->source-file-name module)))
1622                          (cons f (search-path* module-path f)))))
1623                     modules)))
1624     (imported-files files #:name name
1625                     #:system system
1626                     #:guile guile)))
1627
1628 (define* (compiled-modules modules
1629                            #:key (name "module-import-compiled")
1630                            (system (%current-system))
1631                            target
1632                            (guile (%guile-for-build))
1633                            (module-path %load-path)
1634                            (extensions '())
1635                            (deprecation-warnings #f)
1636                            (optimization-level 1))
1637   "Return a derivation that builds a tree containing the `.go' files
1638 corresponding to MODULES.  All the MODULES are built in a context where
1639 they can refer to each other.  When TARGET is true, cross-compile MODULES for
1640 TARGET, a GNU triplet."
1641   (define total (length modules))
1642
1643   (mlet %store-monad ((modules (imported-modules modules
1644                                                  #:system system
1645                                                  #:guile guile
1646                                                  #:module-path
1647                                                  module-path))
1648                       (extensions (mapm %store-monad
1649                                         (lambda (extension)
1650                                           (lower-object extension system
1651                                                         #:target #f))
1652                                         extensions)))
1653     (define build
1654       (gexp-with-hidden-inputs
1655        (gexp
1656         (begin
1657           (primitive-load (ungexp %utils-module)) ;for 'mkdir-p'
1658
1659           (use-modules (ice-9 ftw)
1660                        (ice-9 format)
1661                        (srfi srfi-1)
1662                        (srfi srfi-26)
1663                        (system base target)
1664                        (system base compile))
1665
1666           (define modules
1667             (getenv "modules"))
1668
1669           (define total
1670             (string->number (getenv "module count")))
1671
1672           (define extensions
1673             (string-split (getenv "extensions") #\space))
1674
1675           (define target
1676             (getenv "target"))
1677
1678           (define optimization-level
1679             (string->number (getenv "optimization level")))
1680
1681           (define optimizations-for-level
1682             (or (and=> (false-if-exception
1683                         (resolve-interface '(system base optimize)))
1684                        (lambda (iface)
1685                          (module-ref iface 'optimizations-for-level))) ;Guile 3.0
1686                 (const '())))
1687
1688           (define (regular? file)
1689             (not (member file '("." ".."))))
1690
1691           (define (process-entry entry output processed)
1692             (if (file-is-directory? entry)
1693                 (let ((output (string-append output "/" (basename entry))))
1694                   (mkdir-p output)
1695                   (process-directory entry output processed))
1696                 (let* ((base   (basename entry ".scm"))
1697                        (output (string-append output "/" base ".go")))
1698                   (format #t "[~2@a/~2@a] Compiling '~a'...~%"
1699                           (+ 1 processed total)
1700                           (* total 2)
1701                           entry)
1702
1703                   (with-target (or target %host-type)
1704                                (lambda ()
1705                                  (compile-file entry
1706                                                #:output-file output
1707                                                #:opts
1708                                                `(,@%auto-compilation-options
1709                                                  ,@(optimizations-for-level
1710                                                     optimization-level)))))
1711
1712                   (+ 1 processed))))
1713
1714           (define (process-directory directory output processed)
1715             (let ((entries (map (cut string-append directory "/" <>)
1716                                 (scandir directory regular?))))
1717               (fold (cut process-entry <> output <>)
1718                     processed
1719                     entries)))
1720
1721           (define* (load-from-directory directory
1722                                         #:optional (loaded 0))
1723             "Load all the source files found in DIRECTORY."
1724             ;; XXX: This works around <https://bugs.gnu.org/15602>.
1725             (let ((entries (map (cut string-append directory "/" <>)
1726                                 (scandir directory regular?))))
1727               (fold (lambda (file loaded)
1728                       (if (file-is-directory? file)
1729                           (load-from-directory file loaded)
1730                           (begin
1731                             (format #t "[~2@a/~2@a] Loading '~a'...~%"
1732                                     (+ 1 loaded) (* 2 total)
1733                                     file)
1734                             (save-module-excursion
1735                              (lambda ()
1736                                (primitive-load file)))
1737                             (+ 1 loaded))))
1738                     loaded
1739                     entries)))
1740
1741           (setvbuf (current-output-port)
1742                    (cond-expand (guile-2.2 'line) (else _IOLBF)))
1743
1744           (define mkdir-p
1745             ;; Capture 'mkdir-p'.
1746             (@ (guix build utils) mkdir-p))
1747
1748           ;; Remove environment variables for internal consumption.
1749           (unsetenv "modules")
1750           (unsetenv "module count")
1751           (unsetenv "extensions")
1752           (unsetenv "target")
1753           (unsetenv "optimization level")
1754
1755           ;; Add EXTENSIONS to the search path.
1756           (set! %load-path
1757             (append (map (lambda (extension)
1758                            (string-append extension
1759                                           "/share/guile/site/"
1760                                           (effective-version)))
1761                          extensions)
1762                     %load-path))
1763           (set! %load-compiled-path
1764             (append (map (lambda (extension)
1765                            (string-append extension "/lib/guile/"
1766                                           (effective-version)
1767                                           "/site-ccache"))
1768                          extensions)
1769                     %load-compiled-path))
1770
1771           (set! %load-path (cons modules %load-path))
1772
1773           ;; Above we loaded our own (guix build utils) but now we may need to
1774           ;; load a compile a different one.  Thus, force a reload.
1775           (let ((utils (string-append modules
1776                                       "/guix/build/utils.scm")))
1777             (when (file-exists? utils)
1778               (load utils)))
1779
1780           (mkdir (ungexp output))
1781           (chdir modules)
1782
1783           (load-from-directory ".")
1784           (process-directory "." (ungexp output) 0)))
1785        (append (map gexp-input extensions)
1786                (list (gexp-input modules)))))
1787
1788     (gexp->derivation name build
1789                       #:script-name "compile-modules"
1790                       #:system system
1791                       #:target target
1792                       #:guile-for-build guile
1793                       #:local-build? #t
1794                       #:env-vars
1795                       `(("modules"
1796                          . ,(if (derivation? modules)
1797                                 (derivation->output-path modules)
1798                                 modules))
1799                         ("module count" . ,(number->string total))
1800                         ("extensions"
1801                          . ,(string-join
1802                              (map (match-lambda
1803                                     ((? derivation? drv)
1804                                      (derivation->output-path drv))
1805                                     ((? string? str) str))
1806                                   extensions)))
1807                         ("optimization level"
1808                          . ,(number->string optimization-level))
1809                         ,@(if target
1810                               `(("target" . ,target))
1811                               '())
1812                         ,@(case deprecation-warnings
1813                             ((#f)
1814                              '(("GUILE_WARN_DEPRECATED" . "no")))
1815                             ((detailed)
1816                              '(("GUILE_WARN_DEPRECATED" . "detailed")))
1817                             (else
1818                              '()))))))
1819
1820 \f
1821 ;;;
1822 ;;; Convenience procedures.
1823 ;;;
1824
1825 (define (default-guile)
1826   ;; Lazily resolve 'guile-3.0' (not 'guile-final' because this is for
1827   ;; programs returned by 'program-file' and we don't want to keep references
1828   ;; to several Guile packages).  This module must not refer to (gnu …)
1829   ;; modules directly, to avoid circular dependencies, hence this hack.
1830   (module-ref (resolve-interface '(gnu packages guile))
1831               'guile-3.0))
1832
1833 (define* (load-path-expression modules #:optional (path %load-path)
1834                                #:key (extensions '()) system target
1835                                (guile (default-guile)))
1836   "Return as a monadic value a gexp that sets '%load-path' and
1837 '%load-compiled-path' to point to MODULES, a list of module names.  MODULES
1838 are searched for in PATH.  Return #f when MODULES and EXTENSIONS are empty.
1839 Assume MODULES are compiled with GUILE."
1840   (if (and (null? modules) (null? extensions))
1841       (with-monad %store-monad
1842         (return #f))
1843       (mlet* %store-monad ((guile    (lower-object guile system #:target #f))
1844                            (compiled (compiled-modules modules
1845                                                        #:guile guile
1846                                                        #:extensions extensions
1847                                                        #:module-path path
1848                                                        #:system system
1849                                                        #:target target))
1850                            (modules  (imported-modules modules
1851                                                        #:guile guile
1852                                                        #:module-path path
1853                                                        #:system system)))
1854         (return
1855          (gexp (eval-when (expand load eval)
1856                  ;; Augment the load paths and delete duplicates.  Do that
1857                  ;; without loading (srfi srfi-1) or anything.
1858                  (let ((extensions '((ungexp-splicing extensions)))
1859                        (prepend (lambda (items lst)
1860                                   ;; This is O(N²) but N is typically small.
1861                                   (let loop ((items items)
1862                                              (lst lst))
1863                                     (if (null? items)
1864                                         lst
1865                                         (loop (cdr items)
1866                                               (cons (car items)
1867                                                     (delete (car items) lst))))))))
1868                    (set! %load-path
1869                      (prepend (cons (ungexp modules)
1870                                     (map (lambda (extension)
1871                                            (string-append extension
1872                                                           "/share/guile/site/"
1873                                                           (effective-version)))
1874                                          extensions))
1875                               %load-path))
1876                    (set! %load-compiled-path
1877                      (prepend (cons (ungexp compiled)
1878                                     (map (lambda (extension)
1879                                            (string-append extension
1880                                                           "/lib/guile/"
1881                                                           (effective-version)
1882                                                           "/site-ccache"))
1883                                          extensions))
1884                               %load-compiled-path)))))))))
1885
1886 (define* (input-tuples->gexp inputs #:key native?)
1887   "Given INPUTS, a list of label/gexp-input tuples, return a gexp that expands
1888 to an input alist."
1889   (define references
1890     (map (match-lambda
1891            ((label input) input))
1892          inputs))
1893
1894   (define labels
1895     (match inputs
1896       (((labels . _) ...)
1897        labels)))
1898
1899   (define (proc . args)
1900     (cons 'quote (list (map cons labels args))))
1901
1902   ;; This gexp is more efficient than an equivalent hand-written gexp: fewer
1903   ;; allocations, no need to scan long list-valued <gexp-input> records in
1904   ;; search of file-like objects, etc.
1905   (make-gexp references '() '() proc
1906              (source-properties inputs)))
1907
1908 (define (outputs->gexp outputs)
1909   "Given OUTPUTS, a list of output names, return a gexp that expands to an
1910 output alist."
1911   (define references
1912     (map gexp-output outputs))
1913
1914   (define (proc . args)
1915     `(list ,@(map (lambda (name)
1916                     `(cons ,name ((@ (guile) getenv) ,name)))
1917                   outputs)))
1918
1919   ;; This gexp is more efficient than an equivalent hand-written gexp.
1920   (make-gexp references '() '() proc
1921              (source-properties outputs)))
1922
1923 (define (with-build-variables inputs outputs body)
1924   "Return a gexp that surrounds BODY with a definition of the legacy
1925 '%build-inputs', '%outputs', and '%output' variables based on INPUTS, a list
1926 of name/gexp-input tuples, and OUTPUTS, a list of strings."
1927
1928   ;; These two variables are defined for backward compatibility.  They are
1929   ;; used by package expressions.  These must be top-level defines so that
1930   ;; 'use-modules' form in BODY that are required for macro expansion work as
1931   ;; expected.
1932   (gexp (begin
1933           (define %build-inputs
1934             (ungexp (input-tuples->gexp inputs)))
1935           (define %outputs
1936             (ungexp (outputs->gexp outputs)))
1937           (define %output
1938             (assoc-ref %outputs "out"))
1939
1940           (ungexp body))))
1941
1942 (define (sexp->gexp sexp)
1943   "Turn SEXP into a gexp without any references.
1944
1945 Using this is a way for the caller to tell that SEXP doesn't need to be
1946 scanned for file-like objects, thereby reducing processing costs.  This is
1947 particularly useful if SEXP is a long list or a deep tree."
1948   (make-gexp '() '() '()
1949              (lambda () sexp)
1950              (source-properties sexp)))
1951
1952 (define* (gexp->script name exp
1953                        #:key (guile (default-guile))
1954                        (module-path %load-path)
1955                        (system (%current-system))
1956                        (target 'current))
1957   "Return an executable script NAME that runs EXP using GUILE, with EXP's
1958 imported modules in its search path.  Look up EXP's modules in MODULE-PATH."
1959   (mlet* %store-monad ((target (if (eq? target 'current)
1960                                    (current-target-system)
1961                                    (return target)))
1962                        (set-load-path
1963                         (load-path-expression (gexp-modules exp)
1964                                               module-path
1965                                               #:guile guile
1966                                               #:extensions
1967                                               (gexp-extensions exp)
1968                                               #:system system
1969                                               #:target target))
1970                        (guile-for-build
1971                         (lower-object guile system #:target #f)))
1972     (gexp->derivation name
1973                       (gexp
1974                        (call-with-output-file (ungexp output)
1975                          (lambda (port)
1976                            ;; Note: that makes a long shebang.  When the store
1977                            ;; is /gnu/store, that fits within the 128-byte
1978                            ;; limit imposed by Linux, but that may go beyond
1979                            ;; when running tests.
1980                            (format port
1981                                    "#!~a/bin/guile --no-auto-compile~%!#~%"
1982                                    (ungexp guile))
1983
1984                            (ungexp-splicing
1985                             (if set-load-path
1986                                 (gexp ((write '(ungexp set-load-path) port)))
1987                                 (gexp ())))
1988
1989                            (write '(ungexp exp) port)
1990                            (chmod port #o555))))
1991                       #:system system
1992                       #:target target
1993                       #:module-path module-path
1994                       #:guile-for-build guile-for-build
1995
1996                       ;; These derivations are not worth offloading or
1997                       ;; substituting.
1998                       #:local-build? #t
1999                       #:substitutable? #f)))
2000
2001 (define* (gexp->file name exp #:key
2002                      (set-load-path? #t)
2003                      (module-path %load-path)
2004                      (splice? #f)
2005                      (system (%current-system))
2006                      (target 'current))
2007   "Return a derivation that builds a file NAME containing EXP.  When SPLICE?
2008 is true, EXP is considered to be a list of expressions that will be spliced in
2009 the resulting file.
2010
2011 When SET-LOAD-PATH? is true, emit code in the resulting file to set
2012 '%load-path' and '%load-compiled-path' to honor EXP's imported modules.
2013 Lookup EXP's modules in MODULE-PATH."
2014   (define modules (gexp-modules exp))
2015   (define extensions (gexp-extensions exp))
2016
2017   (mlet* %store-monad
2018       ((target (if (eq? target 'current)
2019                    (current-target-system)
2020                    (return target)))
2021        (no-load-path? -> (or (not set-load-path?)
2022                              (and (null? modules)
2023                                   (null? extensions))))
2024        (set-load-path
2025         (load-path-expression modules module-path
2026                               #:extensions extensions
2027                               #:system system
2028                               #:target target)))
2029     (if no-load-path?
2030         (gexp->derivation name
2031                           (gexp
2032                            (call-with-output-file (ungexp output)
2033                              (lambda (port)
2034                                (for-each
2035                                 (lambda (exp)
2036                                   (write exp port))
2037                                 '(ungexp (if splice?
2038                                              exp
2039                                              (gexp ((ungexp exp)))))))))
2040                           #:local-build? #t
2041                           #:substitutable? #f
2042                           #:system system
2043                           #:target target)
2044         (gexp->derivation name
2045                           (gexp
2046                            (call-with-output-file (ungexp output)
2047                              (lambda (port)
2048                                (write '(ungexp set-load-path) port)
2049                                (for-each
2050                                 (lambda (exp)
2051                                   (write exp port))
2052                                 '(ungexp (if splice?
2053                                              exp
2054                                              (gexp ((ungexp exp)))))))))
2055                           #:module-path module-path
2056                           #:local-build? #t
2057                           #:substitutable? #f
2058                           #:system system
2059                           #:target target))))
2060
2061 (define* (text-file* name #:rest text)
2062   "Return as a monadic value a derivation that builds a text file containing
2063 all of TEXT.  TEXT may list, in addition to strings, objects of any type that
2064 can be used in a gexp: packages, derivations, local file objects, etc.  The
2065 resulting store file holds references to all these."
2066   (define builder
2067     (gexp (call-with-output-file (ungexp output "out")
2068             (lambda (port)
2069               (display (string-append (ungexp-splicing text)) port)))))
2070
2071   (gexp->derivation name builder
2072                     #:local-build? #t
2073                     #:substitutable? #f))
2074
2075 (define* (mixed-text-file name #:key guile #:rest text)
2076   "Return an object representing store file NAME containing TEXT.  TEXT is a
2077 sequence of strings and file-like objects, as in:
2078
2079   (mixed-text-file \"profile\"
2080                    \"export PATH=\" coreutils \"/bin:\" grep \"/bin\")
2081
2082 This is the declarative counterpart of 'text-file*'."
2083   (define build
2084     (let ((text (if guile (drop text 2) text)))
2085       (gexp (call-with-output-file (ungexp output "out")
2086               (lambda (port)
2087                 (set-port-encoding! port "UTF-8")
2088                 (display (string-append (ungexp-splicing text)) port))))))
2089
2090   (computed-file name build #:guile guile))
2091
2092 (define* (file-union name files #:key guile)
2093   "Return a <computed-file> that builds a directory containing all of FILES.
2094 Each item in FILES must be a two-element list where the first element is the
2095 file name to use in the new directory, and the second element is a gexp
2096 denoting the target file.  Here's an example:
2097
2098   (file-union \"etc\"
2099               `((\"hosts\" ,(plain-file \"hosts\"
2100                                         \"127.0.0.1 localhost\"))
2101                 (\"bashrc\" ,(plain-file \"bashrc\"
2102                                          \"alias ls='ls --color'\"))
2103                 (\"libvirt/qemu.conf\" ,(plain-file \"qemu.conf\" \"\"))))
2104
2105 This yields an 'etc' directory containing these two files."
2106   (computed-file name
2107                  (with-imported-modules '((guix build utils))
2108                    (gexp
2109                     (begin
2110                       (use-modules (guix build utils))
2111
2112                       (mkdir (ungexp output))
2113                       (chdir (ungexp output))
2114                       (ungexp-splicing
2115                        (map (match-lambda
2116                               ((target source)
2117                                (gexp
2118                                 (begin
2119                                   ;; Stat the source to abort early if it does
2120                                   ;; not exist.
2121                                   (stat (ungexp source))
2122
2123                                   (mkdir-p (dirname (ungexp target)))
2124                                   (symlink (ungexp source)
2125                                            (ungexp target))))))
2126                             files)))))
2127                  #:guile guile))
2128
2129 (define* (directory-union name things
2130                           #:key (copy? #f) (quiet? #f)
2131                           (resolve-collision 'warn-about-collision))
2132   "Return a directory that is the union of THINGS, where THINGS is a list of
2133 file-like objects denoting directories.  For example:
2134
2135   (directory-union \"guile+emacs\" (list guile emacs))
2136
2137 yields a directory that is the union of the 'guile' and 'emacs' packages.
2138
2139 Call RESOLVE-COLLISION when several files collide, passing it the list of
2140 colliding files.  RESOLVE-COLLISION must return the chosen file or #f, in
2141 which case the colliding entry is skipped altogether.
2142
2143 When COPY? is true, copy files instead of creating symlinks.  When QUIET?  is
2144 true, the derivation will not print anything."
2145   (define symlink
2146     (if copy?
2147         (gexp (lambda (old new)
2148                 (if (file-is-directory? old)
2149                     (symlink old new)
2150                     (copy-file old new))))
2151         (gexp symlink)))
2152
2153   (define log-port
2154     (if quiet?
2155         (gexp (%make-void-port "w"))
2156         (gexp (current-error-port))))
2157
2158   (match things
2159     ((one)
2160      ;; Only one thing; return it.
2161      one)
2162     (_
2163      (computed-file name
2164                     (with-imported-modules '((guix build union))
2165                       (gexp (begin
2166                               (use-modules (guix build union)
2167                                            (srfi srfi-1)) ;for 'first' and 'last'
2168
2169                               (union-build (ungexp output)
2170                                            '(ungexp things)
2171
2172                                            #:log-port (ungexp log-port)
2173                                            #:symlink (ungexp symlink)
2174                                            #:resolve-collision
2175                                            (ungexp resolve-collision)))))))))
2176
2177 (define* (references-file item #:optional (name "references")
2178                           #:key guile)
2179   "Return a file that contains the list of direct and indirect references (the
2180 closure) of ITEM."
2181   (if (struct? item)                              ;lowerable object
2182       (computed-file name
2183                      (gexp (begin
2184                              (use-modules (srfi srfi-1)
2185                                           (ice-9 rdelim)
2186                                           (ice-9 match))
2187
2188                              (define (drop-lines port n)
2189                                ;; Drop N lines read from PORT.
2190                                (let loop ((n n))
2191                                  (unless (zero? n)
2192                                    (read-line port)
2193                                    (loop (- n 1)))))
2194
2195                              (define (read-graph port)
2196                                ;; Return the list of references read from
2197                                ;; PORT.  This is a stripped-down version of
2198                                ;; 'read-reference-graph'.
2199                                (let loop ((items '()))
2200                                  (match (read-line port)
2201                                    ((? eof-object?)
2202                                     (delete-duplicates items))
2203                                    ((? string? item)
2204                                     (let ((deriver (read-line port))
2205                                           (count
2206                                            (string->number (read-line port))))
2207                                       (drop-lines port count)
2208                                       (loop (cons item items)))))))
2209
2210                              (call-with-output-file (ungexp output)
2211                                (lambda (port)
2212                                  (write (call-with-input-file "graph"
2213                                           read-graph)
2214                                         port)))))
2215                      #:guile guile
2216                      #:options `(#:local-build? #t
2217                                  #:references-graphs (("graph" ,item))))
2218       (plain-file name "()")))
2219
2220 \f
2221 ;;;
2222 ;;; Syntactic sugar.
2223 ;;;
2224
2225 (eval-when (expand load eval)
2226   (define-once read-syntax-redefined?
2227     ;; Have we already redefined 'read-syntax'?  This needs to be done on
2228     ;; 3.0.8 only to work around <https://issues.guix.gnu.org/54003>.
2229     (or (not (module-variable the-scm-module 'read-syntax))
2230         (not (guile-version>? "3.0.7"))))
2231
2232   (define read-procedure
2233     ;; The current read procedure being called: either 'read' or
2234     ;; 'read-syntax'.
2235     (make-parameter read))
2236
2237   (define read-syntax*
2238     ;; Replacement for 'read-syntax'.
2239     (let ((read-syntax (and=> (module-variable the-scm-module 'read-syntax)
2240                               variable-ref)))
2241       (lambda (port . rest)
2242         (parameterize ((read-procedure read-syntax))
2243           (apply read-syntax port rest)))))
2244
2245   (unless read-syntax-redefined?
2246     (set! (@ (guile) read-syntax) read-syntax*)
2247     (set! read-syntax-redefined? #t))
2248
2249   (define* (read-ungexp chr port #:optional native?)
2250     "Read an 'ungexp' or 'ungexp-splicing' form from PORT.  When NATIVE? is
2251 true, use 'ungexp-native' and 'ungexp-native-splicing' instead."
2252     (define unquote-symbol
2253       (match (peek-char port)
2254         (#\@
2255          (read-char port)
2256          (if native?
2257              'ungexp-native-splicing
2258              'ungexp-splicing))
2259         (_
2260          (if native?
2261              'ungexp-native
2262              'ungexp))))
2263
2264     (define symbolic?
2265       ;; Depending on whether (read-procedure) is 'read' or 'read-syntax', we
2266       ;; might get either sexps or syntax objects.  Adjust accordingly.
2267       (if (eq? (read-procedure) read)
2268           symbol?
2269           (compose symbol? syntax->datum)))
2270
2271     (define symbolic->string
2272       (if (eq? (read-procedure) read)
2273           symbol->string
2274           (compose symbol->string syntax->datum)))
2275
2276     (define wrapped-symbol
2277       (if (eq? (read-procedure) read)
2278           (lambda (_ symbol) symbol)
2279           datum->syntax))
2280
2281     (match ((read-procedure) port)
2282       ((? symbolic? symbol)
2283        (let ((str (symbolic->string symbol)))
2284          (match (string-index-right str #\:)
2285            (#f
2286             `(,unquote-symbol ,symbol))
2287            (colon
2288             (let ((name   (string->symbol (substring str 0 colon)))
2289                   (output (substring str (+ colon 1))))
2290               `(,unquote-symbol ,(wrapped-symbol symbol name) ,output))))))
2291       (x
2292        `(,unquote-symbol ,x))))
2293
2294   (define (read-gexp chr port)
2295     "Read a 'gexp' form from PORT."
2296     `(gexp ,((read-procedure) port)))
2297
2298   ;; Extend the reader
2299   (read-hash-extend #\~ read-gexp)
2300   (read-hash-extend #\$ read-ungexp)
2301   (read-hash-extend #\+ (cut read-ungexp <> <> #t)))
2302
2303 ;;; gexp.scm ends here