guix/gexp.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
   4 ;;; Copyright © 2018 Jan Nieuwenhuizen <janneke@gnu.org>
   5 ;;;
   6 ;;; This file is part of GNU Guix.
   7 ;;;
   8 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   9 ;;; under the terms of the GNU General Public License as published by
  10 ;;; the Free Software Foundation; either version 3 of the License, or (at
  11 ;;; your option) any later version.
  12 ;;;
  13 ;;; GNU Guix is distributed in the hope that it will be useful, but
  14 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;;; GNU General Public License for more details.
  17 ;;;
  18 ;;; You should have received a copy of the GNU General Public License
  19 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  20
  21 (define-module (guix gexp)
  22   #:use-module (guix store)
  23   #:use-module (guix monads)
  24   #:use-module (guix derivations)
  25   #:use-module (guix grafts)
  26   #:use-module (guix utils)
  27   #:use-module (rnrs bytevectors)
  28   #:use-module (srfi srfi-1)
  29   #:use-module (srfi srfi-9)
  30   #:use-module (srfi srfi-9 gnu)
  31   #:use-module (srfi srfi-26)
  32   #:use-module (srfi srfi-34)
  33   #:use-module (srfi srfi-35)
  34   #:use-module (ice-9 match)
  35   #:export (gexp
  36             gexp?
  37             with-imported-modules
  38             with-extensions
  39
  40             gexp-input
  41             gexp-input?
  42
  43             local-file
  44             local-file?
  45             local-file-file
  46             local-file-absolute-file-name
  47             local-file-name
  48             local-file-recursive?
  49
  50             plain-file
  51             plain-file?
  52             plain-file-name
  53             plain-file-content
  54
  55             computed-file
  56             computed-file?
  57             computed-file-name
  58             computed-file-gexp
  59             computed-file-options
  60
  61             program-file
  62             program-file?
  63             program-file-name
  64             program-file-gexp
  65             program-file-guile
  66             program-file-module-path
  67
  68             scheme-file
  69             scheme-file?
  70             scheme-file-name
  71             scheme-file-gexp
  72
  73             file-append
  74             file-append?
  75             file-append-base
  76             file-append-suffix
  77
  78             load-path-expression
  79             gexp-modules
  80
  81             gexp->derivation
  82             gexp->file
  83             gexp->script
  84             text-file*
  85             mixed-text-file
  86             file-union
  87             directory-union
  88             imported-files
  89             imported-modules
  90             compiled-modules
  91
  92             define-gexp-compiler
  93             gexp-compiler?
  94             file-like?
  95             lower-object
  96
  97             lower-inputs
  98
  99             &gexp-error
 100             gexp-error?
 101             &gexp-input-error
 102             gexp-input-error?
 103             gexp-error-invalid-input))
 104
 105 ;;; Commentary:
 106 ;;;
 107 ;;; This module implements "G-expressions", or "gexps".  Gexps are like
 108 ;;; S-expressions (sexps), with two differences:
 109 ;;;
 110 ;;;   1. References (un-quotations) to derivations or packages in a gexp are
 111 ;;;      replaced by the corresponding output file name; in addition, the
 112 ;;;      'ungexp-native' unquote-like form allows code to explicitly refer to
 113 ;;;      the native code of a given package, in case of cross-compilation;
 114 ;;;
 115 ;;;   2. Gexps embed information about the derivations they refer to.
 116 ;;;
 117 ;;; Gexps make it easy to write to files Scheme code that refers to store
 118 ;;; items, or to write Scheme code to build derivations.
 119 ;;;
 120 ;;; Code:
 121
 122 ;; "G expressions".
 123 (define-record-type <gexp>
 124   (make-gexp references modules extensions proc)
 125   gexp?
 126   (references gexp-references)                    ;list of <gexp-input>
 127   (modules    gexp-self-modules)                  ;list of module names
 128   (extensions gexp-self-extensions)               ;list of lowerable things
 129   (proc       gexp-proc))                         ;procedure
 130
 131 (define (write-gexp gexp port)
 132   "Write GEXP on PORT."
 133   (display "#<gexp " port)
 134
 135   ;; Try to write the underlying sexp.  Now, this trick doesn't work when
 136   ;; doing things like (ungexp-splicing (gexp ())) because GEXP's procedure
 137   ;; tries to use 'append' on that, which fails with wrong-type-arg.
 138   (false-if-exception
 139    (write (apply (gexp-proc gexp)
 140                  (gexp-references gexp))
 141           port))
 142   (format port " ~a>"
 143           (number->string (object-address gexp) 16)))
 144
 145 (set-record-type-printer! <gexp> write-gexp)
 146
 147 \f
 148 ;;;
 149 ;;; Methods.
 150 ;;;
 151
 152 ;; Compiler for a type of objects that may be introduced in a gexp.
 153 (define-record-type <gexp-compiler>
 154   (gexp-compiler type lower expand)
 155   gexp-compiler?
 156   (type       gexp-compiler-type)                 ;record type descriptor
 157   (lower      gexp-compiler-lower)
 158   (expand     gexp-compiler-expand))              ;#f | DRV -> sexp
 159
 160 (define-condition-type &gexp-error &error
 161   gexp-error?)
 162
 163 (define-condition-type &gexp-input-error &gexp-error
 164   gexp-input-error?
 165   (input gexp-error-invalid-input))
 166
 167
 168 (define %gexp-compilers
 169   ;; 'eq?' mapping of record type descriptor to <gexp-compiler>.
 170   (make-hash-table 20))
 171
 172 (define (default-expander thing obj output)
 173   "This is the default expander for \"things\" that appear in gexps.  It
 174 returns its output file name of OBJ's OUTPUT."
 175   (match obj
 176     ((? derivation? drv)
 177      (derivation->output-path drv output))
 178     ((? string? file)
 179      file)))
 180
 181 (define (register-compiler! compiler)
 182   "Register COMPILER as a gexp compiler."
 183   (hashq-set! %gexp-compilers
 184               (gexp-compiler-type compiler) compiler))
 185
 186 (define (lookup-compiler object)
 187   "Search for a compiler for OBJECT.  Upon success, return the three argument
 188 procedure to lower it; otherwise return #f."
 189   (and=> (hashq-ref %gexp-compilers (struct-vtable object))
 190          gexp-compiler-lower))
 191
 192 (define (file-like? object)
 193   "Return #t if OBJECT leads to a file in the store once unquoted in a
 194 G-expression; otherwise return #f."
 195   (and (struct? object) (->bool (lookup-compiler object))))
 196
 197 (define (lookup-expander object)
 198   "Search for an expander for OBJECT.  Upon success, return the three argument
 199 procedure to expand it; otherwise return #f."
 200   (and=> (hashq-ref %gexp-compilers (struct-vtable object))
 201          gexp-compiler-expand))
 202
 203 (define* (lower-object obj
 204                        #:optional (system (%current-system))
 205                        #:key target)
 206   "Return as a value in %STORE-MONAD the derivation or store item
 207 corresponding to OBJ for SYSTEM, cross-compiling for TARGET if TARGET is true.
 208 OBJ must be an object that has an associated gexp compiler, such as a
 209 <package>."
 210   (match (lookup-compiler obj)
 211     (#f
 212      (raise (condition (&gexp-input-error (input obj)))))
 213     (lower
 214      ;; Cache in STORE the result of lowering OBJ.
 215      (mlet %store-monad ((graft? (grafting?)))
 216        (mcached (let ((lower (lookup-compiler obj)))
 217                   (lower obj system target))
 218                 obj
 219                 system target graft?)))))
 220
 221 (define-syntax define-gexp-compiler
 222   (syntax-rules (=> compiler expander)
 223     "Define NAME as a compiler for objects matching PREDICATE encountered in
 224 gexps.
 225
 226 In the simplest form of the macro, BODY must return a derivation for PARAM, an
 227 object that matches PREDICATE, for SYSTEM and TARGET (the latter of which is
 228 #f except when cross-compiling.)
 229
 230 The more elaborate form allows you to specify an expander:
 231
 232   (define-gexp-compiler something something?
 233     compiler => (lambda (param system target) ...)
 234     expander => (lambda (param drv output) ...))
 235
 236 The expander specifies how an object is converted to its sexp representation."
 237     ((_ (name (param record-type) system target) body ...)
 238      (define-gexp-compiler name record-type
 239        compiler => (lambda (param system target) body ...)
 240        expander => default-expander))
 241     ((_ name record-type
 242         compiler => compile
 243         expander => expand)
 244      (begin
 245        (define name
 246          (gexp-compiler record-type compile expand))
 247        (register-compiler! name)))))
 248
 249 (define-gexp-compiler (derivation-compiler (drv <derivation>) system target)
 250   ;; Derivations are the lowest-level representation, so this is the identity
 251   ;; compiler.
 252   (with-monad %store-monad
 253     (return drv)))
 254
 255 \f
 256 ;;;
 257 ;;; File declarations.
 258 ;;;
 259
 260 ;; A local file name.  FILE is the file name the user entered, which can be a
 261 ;; relative file name, and ABSOLUTE is a promise that computes its canonical
 262 ;; absolute file name.  We keep it in a promise to compute it lazily and avoid
 263 ;; repeated 'stat' calls.
 264 (define-record-type <local-file>
 265   (%%local-file file absolute name recursive? select?)
 266   local-file?
 267   (file       local-file-file)                    ;string
 268   (absolute   %local-file-absolute-file-name)     ;promise string
 269   (name       local-file-name)                    ;string
 270   (recursive? local-file-recursive?)              ;Boolean
 271   (select?    local-file-select?))                ;string stat -> Boolean
 272
 273 (define (true file stat) #t)
 274
 275 (define* (%local-file file promise #:optional (name (basename file))
 276                       #:key recursive? (select? true))
 277   ;; This intermediate procedure is part of our ABI, but the underlying
 278   ;; %%LOCAL-FILE is not.
 279   (%%local-file file promise name recursive? select?))
 280
 281 (define (absolute-file-name file directory)
 282   "Return the canonical absolute file name for FILE, which lives in the
 283 vicinity of DIRECTORY."
 284   (canonicalize-path
 285    (cond ((string-prefix? "/" file) file)
 286          ((not directory) file)
 287          ((string-prefix? "/" directory)
 288           (string-append directory "/" file))
 289          (else file))))
 290
 291 (define-syntax local-file
 292   (lambda (s)
 293     "Return an object representing local file FILE to add to the store; this
 294 object can be used in a gexp.  If FILE is a relative file name, it is looked
 295 up relative to the source file where this form appears.  FILE will be added to
 296 the store under NAME--by default the base name of FILE.
 297
 298 When RECURSIVE? is true, the contents of FILE are added recursively; if FILE
 299 designates a flat file and RECURSIVE? is true, its contents are added, and its
 300 permission bits are kept.
 301
 302 When RECURSIVE? is true, call (SELECT?  FILE STAT) for each directory entry,
 303 where FILE is the entry's absolute file name and STAT is the result of
 304 'lstat'; exclude entries for which SELECT? does not return true.
 305
 306 This is the declarative counterpart of the 'interned-file' monadic procedure.
 307 It is implemented as a macro to capture the current source directory where it
 308 appears."
 309     (syntax-case s ()
 310       ((_ file rest ...)
 311        #'(%local-file file
 312                       (delay (absolute-file-name file (current-source-directory)))
 313                       rest ...))
 314       ((_)
 315        #'(syntax-error "missing file name"))
 316       (id
 317        (identifier? #'id)
 318        ;; XXX: We could return #'(lambda (file . rest) ...).  However,
 319        ;; (syntax-source #'id) is #f so (current-source-directory) would not
 320        ;; work.  Thus, simply forbid this form.
 321        #'(syntax-error
 322           "'local-file' is a macro and cannot be used like this")))))
 323
 324 (define (local-file-absolute-file-name file)
 325   "Return the absolute file name for FILE, a <local-file> instance.  A
 326 'system-error' exception is raised if FILE could not be found."
 327   (force (%local-file-absolute-file-name file)))
 328
 329 (define-gexp-compiler (local-file-compiler (file <local-file>) system target)
 330   ;; "Compile" FILE by adding it to the store.
 331   (match file
 332     (($ <local-file> file (= force absolute) name recursive? select?)
 333      ;; Canonicalize FILE so that if it's a symlink, it is resolved.  Failing
 334      ;; to do that, when RECURSIVE? is #t, we could end up creating a dangling
 335      ;; symlink in the store, and when RECURSIVE? is #f 'add-to-store' would
 336      ;; just throw an error, both of which are inconvenient.
 337      (interned-file absolute name
 338                     #:recursive? recursive? #:select? select?))))
 339
 340 (define-record-type <plain-file>
 341   (%plain-file name content references)
 342   plain-file?
 343   (name        plain-file-name)                   ;string
 344   (content     plain-file-content)                ;string or bytevector
 345   (references  plain-file-references))            ;list (currently unused)
 346
 347 (define (plain-file name content)
 348   "Return an object representing a text file called NAME with the given
 349 CONTENT (a string) to be added to the store.
 350
 351 This is the declarative counterpart of 'text-file'."
 352   ;; XXX: For now just ignore 'references' because it's not clear how to use
 353   ;; them in a declarative context.
 354   (%plain-file name content '()))
 355
 356 (define-gexp-compiler (plain-file-compiler (file <plain-file>) system target)
 357   ;; "Compile" FILE by adding it to the store.
 358   (match file
 359     (($ <plain-file> name (and (? string?) content) references)
 360      (text-file name content references))
 361     (($ <plain-file> name (and (? bytevector?) content) references)
 362      (binary-file name content references))))
 363
 364 (define-record-type <computed-file>
 365   (%computed-file name gexp guile options)
 366   computed-file?
 367   (name       computed-file-name)                 ;string
 368   (gexp       computed-file-gexp)                 ;gexp
 369   (guile      computed-file-guile)                ;<package>
 370   (options    computed-file-options))             ;list of arguments
 371
 372 (define* (computed-file name gexp
 373                         #:key guile (options '(#:local-build? #t)))
 374   "Return an object representing the store item NAME, a file or directory
 375 computed by GEXP.  OPTIONS is a list of additional arguments to pass
 376 to 'gexp->derivation'.
 377
 378 This is the declarative counterpart of 'gexp->derivation'."
 379   (%computed-file name gexp guile options))
 380
 381 (define-gexp-compiler (computed-file-compiler (file <computed-file>)
 382                                               system target)
 383   ;; Compile FILE by returning a derivation whose build expression is its
 384   ;; gexp.
 385   (match file
 386     (($ <computed-file> name gexp guile options)
 387      (if guile
 388          (mlet %store-monad ((guile (lower-object guile system
 389                                                   #:target target)))
 390            (apply gexp->derivation name gexp #:guile-for-build guile
 391                   #:system system #:target target options))
 392          (apply gexp->derivation name gexp
 393                 #:system system #:target target options)))))
 394
 395 (define-record-type <program-file>
 396   (%program-file name gexp guile path)
 397   program-file?
 398   (name       program-file-name)                  ;string
 399   (gexp       program-file-gexp)                  ;gexp
 400   (guile      program-file-guile)                 ;package
 401   (path       program-file-module-path))          ;list of strings
 402
 403 (define* (program-file name gexp #:key (guile #f) (module-path %load-path))
 404   "Return an object representing the executable store item NAME that runs
 405 GEXP.  GUILE is the Guile package used to execute that script.  Imported
 406 modules of GEXP are looked up in MODULE-PATH.
 407
 408 This is the declarative counterpart of 'gexp->script'."
 409   (%program-file name gexp guile module-path))
 410
 411 (define-gexp-compiler (program-file-compiler (file <program-file>)
 412                                              system target)
 413   ;; Compile FILE by returning a derivation that builds the script.
 414   (match file
 415     (($ <program-file> name gexp guile module-path)
 416      (gexp->script name gexp
 417                    #:module-path module-path
 418                    #:guile (or guile (default-guile))))))
 419
 420 (define-record-type <scheme-file>
 421   (%scheme-file name gexp splice?)
 422   scheme-file?
 423   (name       scheme-file-name)                  ;string
 424   (gexp       scheme-file-gexp)                  ;gexp
 425   (splice?    scheme-file-splice?))              ;Boolean
 426
 427 (define* (scheme-file name gexp #:key splice?)
 428   "Return an object representing the Scheme file NAME that contains GEXP.
 429
 430 This is the declarative counterpart of 'gexp->file'."
 431   (%scheme-file name gexp splice?))
 432
 433 (define-gexp-compiler (scheme-file-compiler (file <scheme-file>)
 434                                             system target)
 435   ;; Compile FILE by returning a derivation that builds the file.
 436   (match file
 437     (($ <scheme-file> name gexp splice?)
 438      (gexp->file name gexp #:splice? splice?))))
 439
 440 ;; Appending SUFFIX to BASE's output file name.
 441 (define-record-type <file-append>
 442   (%file-append base suffix)
 443   file-append?
 444   (base   file-append-base)                    ;<package> | <derivation> | ...
 445   (suffix file-append-suffix))                 ;list of strings
 446
 447 (define (write-file-append file port)
 448   (match file
 449     (($ <file-append> base suffix)
 450      (format port "#<file-append ~s ~s>" base
 451              (string-join suffix)))))
 452
 453 (set-record-type-printer! <file-append> write-file-append)
 454
 455 (define (file-append base . suffix)
 456   "Return a <file-append> object that expands to the concatenation of BASE and
 457 SUFFIX."
 458   (%file-append base suffix))
 459
 460 (define-gexp-compiler file-append-compiler <file-append>
 461   compiler => (lambda (obj system target)
 462                 (match obj
 463                   (($ <file-append> base _)
 464                    (lower-object base system #:target target))))
 465   expander => (lambda (obj lowered output)
 466                 (match obj
 467                   (($ <file-append> base suffix)
 468                    (let* ((expand (lookup-expander base))
 469                           (base   (expand base lowered output)))
 470                      (string-append base (string-concatenate suffix)))))))
 471
 472 \f
 473 ;;;
 474 ;;; Inputs & outputs.
 475 ;;;
 476
 477 ;; The input of a gexp.
 478 (define-record-type <gexp-input>
 479   (%gexp-input thing output native?)
 480   gexp-input?
 481   (thing     gexp-input-thing)       ;<package> | <origin> | <derivation> | ...
 482   (output    gexp-input-output)      ;string
 483   (native?   gexp-input-native?))    ;Boolean
 484
 485 (define (write-gexp-input input port)
 486   (match input
 487     (($ <gexp-input> thing output #f)
 488      (format port "#<gexp-input ~s:~a>" thing output))
 489     (($ <gexp-input> thing output #t)
 490      (format port "#<gexp-input native ~s:~a>" thing output))))
 491
 492 (set-record-type-printer! <gexp-input> write-gexp-input)
 493
 494 (define* (gexp-input thing                        ;convenience procedure
 495                      #:optional (output "out")
 496                      #:key native?)
 497   "Return a new <gexp-input> for the OUTPUT of THING; NATIVE? determines
 498 whether this should be considered a \"native\" input or not."
 499   (%gexp-input thing output native?))
 500
 501 ;; Reference to one of the derivation's outputs, for gexps used in
 502 ;; derivations.
 503 (define-record-type <gexp-output>
 504   (gexp-output name)
 505   gexp-output?
 506   (name gexp-output-name))
 507
 508 (define (write-gexp-output output port)
 509   (match output
 510     (($ <gexp-output> name)
 511      (format port "#<gexp-output ~a>" name))))
 512
 513 (set-record-type-printer! <gexp-output> write-gexp-output)
 514
 515 (define* (gexp-attribute gexp self-attribute #:optional (equal? equal?))
 516   "Recurse on GEXP and the expressions it refers to, summing the items
 517 returned by SELF-ATTRIBUTE, a procedure that takes a gexp.  Use EQUAL? as the
 518 second argument to 'delete-duplicates'."
 519   (if (gexp? gexp)
 520       (delete-duplicates
 521        (append (self-attribute gexp)
 522                (append-map (match-lambda
 523                              (($ <gexp-input> (? gexp? exp))
 524                               (gexp-attribute exp self-attribute))
 525                              (($ <gexp-input> (lst ...))
 526                               (append-map (lambda (item)
 527                                             (if (gexp? item)
 528                                                 (gexp-attribute item
 529                                                                 self-attribute)
 530                                                 '()))
 531                                           lst))
 532                              (_
 533                               '()))
 534                            (gexp-references gexp)))
 535        equal?)
 536       '()))                                       ;plain Scheme data type
 537
 538 (define (gexp-modules gexp)
 539   "Return the list of Guile module names GEXP relies on.  If (gexp? GEXP) is
 540 false, meaning that GEXP is a plain Scheme object, return the empty list."
 541   (define (module=? m1 m2)
 542     ;; Return #t when M1 equals M2.  Special-case '=>' specs because their
 543     ;; right-hand side may not be comparable with 'equal?': it's typically a
 544     ;; file-like object that embeds a gexp, which in turn embeds closure;
 545     ;; those closures may be 'eq?' when running compiled code but are unlikely
 546     ;; to be 'eq?' when running on 'eval'.  Ignore the right-hand side to
 547     ;; avoid this discrepancy.
 548     (match m1
 549       (((name1 ...) '=> _)
 550        (match m2
 551          (((name2 ...) '=> _) (equal? name1 name2))
 552          (_ #f)))
 553       (_
 554        (equal? m1 m2))))
 555
 556   (gexp-attribute gexp gexp-self-modules module=?))
 557
 558 (define (gexp-extensions gexp)
 559   "Return the list of Guile extensions (packages) GEXP relies on.  If (gexp?
 560 GEXP) is false, meaning that GEXP is a plain Scheme object, return the empty
 561 list."
 562   (gexp-attribute gexp gexp-self-extensions))
 563
 564 (define* (lower-inputs inputs
 565                        #:key system target)
 566   "Turn any package from INPUTS into a derivation for SYSTEM; return the
 567 corresponding input list as a monadic value.  When TARGET is true, use it as
 568 the cross-compilation target triplet."
 569   (with-monad %store-monad
 570     (mapm %store-monad
 571           (match-lambda
 572             (((? struct? thing) sub-drv ...)
 573              (mlet %store-monad ((drv (lower-object
 574                                        thing system #:target target)))
 575                (return `(,drv ,@sub-drv))))
 576             (input
 577              (return input)))
 578           inputs)))
 579
 580 (define* (lower-reference-graphs graphs #:key system target)
 581   "Given GRAPHS, a list of (FILE-NAME INPUT ...) lists for use as a
 582 #:reference-graphs argument, lower it such that each INPUT is replaced by the
 583 corresponding derivation."
 584   (match graphs
 585     (((file-names . inputs) ...)
 586      (mlet %store-monad ((inputs (lower-inputs inputs
 587                                                #:system system
 588                                                #:target target)))
 589        (return (map cons file-names inputs))))))
 590
 591 (define* (lower-references lst #:key system target)
 592   "Based on LST, a list of output names and packages, return a list of output
 593 names and file names suitable for the #:allowed-references argument to
 594 'derivation'."
 595   (with-monad %store-monad
 596     (define lower
 597       (match-lambda
 598        ((? string? output)
 599         (return output))
 600        (($ <gexp-input> thing output native?)
 601         (mlet %store-monad ((drv (lower-object thing system
 602                                                #:target (if native?
 603                                                             #f target))))
 604           (return (derivation->output-path drv output))))
 605        (thing
 606         (mlet %store-monad ((drv (lower-object thing system
 607                                                #:target target)))
 608           (return (derivation->output-path drv))))))
 609
 610     (mapm %store-monad lower lst)))
 611
 612 (define default-guile-derivation
 613   ;; Here we break the abstraction by talking to the higher-level layer.
 614   ;; Thus, do the resolution lazily to hide the circular dependency.
 615   (let ((proc (delay
 616                 (let ((iface (resolve-interface '(guix packages))))
 617                   (module-ref iface 'default-guile-derivation)))))
 618     (lambda (system)
 619       ((force proc) system))))
 620
 621 (define* (gexp->derivation name exp
 622                            #:key
 623                            system (target 'current)
 624                            hash hash-algo recursive?
 625                            (env-vars '())
 626                            (modules '())
 627                            (module-path %load-path)
 628                            (guile-for-build (%guile-for-build))
 629                            (effective-version "2.2")
 630                            (graft? (%graft?))
 631                            references-graphs
 632                            allowed-references disallowed-references
 633                            leaked-env-vars
 634                            local-build? (substitutable? #t)
 635                            (properties '())
 636
 637                            deprecation-warnings
 638                            (script-name (string-append name "-builder")))
 639   "Return a derivation NAME that runs EXP (a gexp) with GUILE-FOR-BUILD (a
 640 derivation) on SYSTEM; EXP is stored in a file called SCRIPT-NAME.  When
 641 TARGET is true, it is used as the cross-compilation target triplet for
 642 packages referred to by EXP.
 643
 644 MODULES is deprecated in favor of 'with-imported-modules'.  Its meaning is to
 645 make MODULES available in the evaluation context of EXP; MODULES is a list of
 646 names of Guile modules searched in MODULE-PATH to be copied in the store,
 647 compiled, and made available in the load path during the execution of
 648 EXP---e.g., '((guix build utils) (guix build gnu-build-system)).
 649
 650 EFFECTIVE-VERSION determines the string to use when adding extensions of
 651 EXP (see 'with-extensions') to the search path---e.g., \"2.2\".
 652
 653 GRAFT? determines whether packages referred to by EXP should be grafted when
 654 applicable.
 655
 656 When REFERENCES-GRAPHS is true, it must be a list of tuples of one of the
 657 following forms:
 658
 659   (FILE-NAME PACKAGE)
 660   (FILE-NAME PACKAGE OUTPUT)
 661   (FILE-NAME DERIVATION)
 662   (FILE-NAME DERIVATION OUTPUT)
 663   (FILE-NAME STORE-ITEM)
 664
 665 The right-hand-side of each element of REFERENCES-GRAPHS is automatically made
 666 an input of the build process of EXP.  In the build environment, each
 667 FILE-NAME contains the reference graph of the corresponding item, in a simple
 668 text format.
 669
 670 ALLOWED-REFERENCES must be either #f or a list of output names and packages.
 671 In the latter case, the list denotes store items that the result is allowed to
 672 refer to.  Any reference to another store item will lead to a build error.
 673 Similarly for DISALLOWED-REFERENCES, which can list items that must not be
 674 referenced by the outputs.
 675
 676 DEPRECATION-WARNINGS determines whether to show deprecation warnings while
 677 compiling modules.  It can be #f, #t, or 'detailed.
 678
 679 The other arguments are as for 'derivation'."
 680   (define %modules
 681     (delete-duplicates
 682      (append modules (gexp-modules exp))))
 683   (define outputs (gexp-outputs exp))
 684
 685   (define (graphs-file-names graphs)
 686     ;; Return a list of (FILE-NAME . STORE-PATH) pairs made from GRAPHS.
 687     (map (match-lambda
 688            ;; TODO: Remove 'derivation?' special cases.
 689            ((file-name (? derivation? drv))
 690             (cons file-name (derivation->output-path drv)))
 691            ((file-name (? derivation? drv) sub-drv)
 692             (cons file-name (derivation->output-path drv sub-drv)))
 693            ((file-name thing)
 694             (cons file-name thing)))
 695          graphs))
 696
 697   (define (extension-flags extension)
 698     `("-L" ,(string-append (derivation->output-path extension)
 699                            "/share/guile/site/" effective-version)
 700       "-C" ,(string-append (derivation->output-path extension)
 701                            "/lib/guile/" effective-version "/site-ccache")))
 702
 703   (mlet* %store-monad ( ;; The following binding forces '%current-system' and
 704                        ;; '%current-target-system' to be looked up at >>=
 705                        ;; time.
 706                        (graft?    (set-grafting graft?))
 707
 708                        (system -> (or system (%current-system)))
 709                        (target -> (if (eq? target 'current)
 710                                       (%current-target-system)
 711                                       target))
 712                        (normals  (lower-inputs (gexp-inputs exp)
 713                                                #:system system
 714                                                #:target target))
 715                        (natives  (lower-inputs (gexp-native-inputs exp)
 716                                                #:system system
 717                                                #:target #f))
 718                        (inputs -> (append normals natives))
 719                        (sexp     (gexp->sexp exp
 720                                              #:system system
 721                                              #:target target))
 722                        (builder  (text-file script-name
 723                                             (object->string sexp)))
 724                        (extensions -> (gexp-extensions exp))
 725                        (exts     (mapm %store-monad
 726                                        (lambda (obj)
 727                                          (lower-object obj system))
 728                                        extensions))
 729                        (modules  (if (pair? %modules)
 730                                      (imported-modules %modules
 731                                                        #:system system
 732                                                        #:module-path module-path
 733                                                        #:guile guile-for-build)
 734                                      (return #f)))
 735                        (compiled (if (pair? %modules)
 736                                      (compiled-modules %modules
 737                                                        #:system system
 738                                                        #:module-path module-path
 739                                                        #:extensions extensions
 740                                                        #:guile guile-for-build
 741                                                        #:deprecation-warnings
 742                                                        deprecation-warnings)
 743                                      (return #f)))
 744                        (graphs   (if references-graphs
 745                                      (lower-reference-graphs references-graphs
 746                                                              #:system system
 747                                                              #:target target)
 748                                      (return #f)))
 749                        (allowed  (if allowed-references
 750                                      (lower-references allowed-references
 751                                                        #:system system
 752                                                        #:target target)
 753                                      (return #f)))
 754                        (disallowed (if disallowed-references
 755                                        (lower-references disallowed-references
 756                                                          #:system system
 757                                                          #:target target)
 758                                        (return #f)))
 759                        (guile    (if guile-for-build
 760                                      (return guile-for-build)
 761                                      (default-guile-derivation system))))
 762     (mbegin %store-monad
 763       (set-grafting graft?)                       ;restore the initial setting
 764       (raw-derivation name
 765                       (string-append (derivation->output-path guile)
 766                                      "/bin/guile")
 767                       `("--no-auto-compile"
 768                         ,@(if (pair? %modules)
 769                               `("-L" ,(if (derivation? modules)
 770                                           (derivation->output-path modules)
 771                                           modules)
 772                                 "-C" ,(derivation->output-path compiled))
 773                               '())
 774                         ,@(append-map extension-flags exts)
 775                         ,builder)
 776                       #:outputs outputs
 777                       #:env-vars env-vars
 778                       #:system system
 779                       #:inputs `((,guile)
 780                                  (,builder)
 781                                  ,@(if modules
 782                                        `((,modules) (,compiled) ,@inputs)
 783                                        inputs)
 784                                  ,@(map list exts)
 785                                  ,@(match graphs
 786                                      (((_ . inputs) ...) inputs)
 787                                      (_ '())))
 788                       #:hash hash #:hash-algo hash-algo #:recursive? recursive?
 789                       #:references-graphs (and=> graphs graphs-file-names)
 790                       #:allowed-references allowed
 791                       #:disallowed-references disallowed
 792                       #:leaked-env-vars leaked-env-vars
 793                       #:local-build? local-build?
 794                       #:substitutable? substitutable?
 795                       #:properties properties))))
 796
 797 (define* (gexp-inputs exp #:key native?)
 798   "Return the input list for EXP.  When NATIVE? is true, return only native
 799 references; otherwise, return only non-native references."
 800   (define (add-reference-inputs ref result)
 801     (match ref
 802       (($ <gexp-input> (? gexp? exp) _ #t)
 803        (if native?
 804            (append (gexp-inputs exp)
 805                    (gexp-inputs exp #:native? #t)
 806                    result)
 807            result))
 808       (($ <gexp-input> (? gexp? exp) _ #f)
 809        (append (gexp-inputs exp #:native? native?)
 810                result))
 811       (($ <gexp-input> (? string? str))
 812        (if (direct-store-path? str)
 813            (cons `(,str) result)
 814            result))
 815       (($ <gexp-input> (? struct? thing) output n?)
 816        (if (and (eqv? n? native?) (lookup-compiler thing))
 817            ;; THING is a derivation, or a package, or an origin, etc.
 818            (cons `(,thing ,output) result)
 819            result))
 820       (($ <gexp-input> (lst ...) output n?)
 821        (fold-right add-reference-inputs result
 822                    ;; XXX: For now, automatically convert LST to a list of
 823                    ;; gexp-inputs.  Inherit N?.
 824                    (map (match-lambda
 825                           ((? gexp-input? x)
 826                            (%gexp-input (gexp-input-thing x)
 827                                         (gexp-input-output x)
 828                                         n?))
 829                           (x
 830                            (%gexp-input x "out" n?)))
 831                         lst)))
 832       (_
 833        ;; Ignore references to other kinds of objects.
 834        result)))
 835
 836   (fold-right add-reference-inputs
 837               '()
 838               (gexp-references exp)))
 839
 840 (define gexp-native-inputs
 841   (cut gexp-inputs <> #:native? #t))
 842
 843 (define (gexp-outputs exp)
 844   "Return the outputs referred to by EXP as a list of strings."
 845   (define (add-reference-output ref result)
 846     (match ref
 847       (($ <gexp-output> name)
 848        (cons name result))
 849       (($ <gexp-input> (? gexp? exp))
 850        (append (gexp-outputs exp) result))
 851       (($ <gexp-input> (lst ...) output native?)
 852        ;; XXX: Automatically convert LST.
 853        (add-reference-output (map (match-lambda
 854                                    ((? gexp-input? x) x)
 855                                    (x (%gexp-input x "out" native?)))
 856                                   lst)
 857                              result))
 858       ((lst ...)
 859        (fold-right add-reference-output result lst))
 860       (_
 861        result)))
 862
 863   (delete-duplicates
 864    (add-reference-output (gexp-references exp) '())))
 865
 866 (define* (gexp->sexp exp #:key
 867                      (system (%current-system))
 868                      (target (%current-target-system)))
 869   "Return (monadically) the sexp corresponding to EXP for the given OUTPUT,
 870 and in the current monad setting (system type, etc.)"
 871   (define* (reference->sexp ref #:optional native?)
 872     (with-monad %store-monad
 873       (match ref
 874         (($ <gexp-output> output)
 875          ;; Output file names are not known in advance but the daemon defines
 876          ;; an environment variable for each of them at build time, so use
 877          ;; that trick.
 878          (return `((@ (guile) getenv) ,output)))
 879         (($ <gexp-input> (? gexp? exp) output n?)
 880          (gexp->sexp exp
 881                      #:system system
 882                      #:target (if (or n? native?) #f target)))
 883         (($ <gexp-input> (refs ...) output n?)
 884          (mapm %store-monad
 885                (lambda (ref)
 886                  ;; XXX: Automatically convert REF to an gexp-input.
 887                  (reference->sexp
 888                   (if (gexp-input? ref)
 889                       ref
 890                       (%gexp-input ref "out" n?))
 891                   (or n? native?)))
 892                refs))
 893         (($ <gexp-input> (? struct? thing) output n?)
 894          (let ((target (if (or n? native?) #f target))
 895                (expand (lookup-expander thing)))
 896            (mlet %store-monad ((obj (lower-object thing system
 897                                                   #:target target)))
 898              ;; OBJ must be either a derivation or a store file name.
 899              (return (expand thing obj output)))))
 900         (($ <gexp-input> x)
 901          (return x))
 902         (x
 903          (return x)))))
 904
 905   (mlet %store-monad
 906       ((args (mapm %store-monad
 907                    reference->sexp (gexp-references exp))))
 908     (return (apply (gexp-proc exp) args))))
 909
 910 (define (syntax-location-string s)
 911   "Return a string representing the source code location of S."
 912   (let ((props (syntax-source s)))
 913     (if props
 914         (let ((file   (assoc-ref props 'filename))
 915               (line   (and=> (assoc-ref props 'line) 1+))
 916               (column (assoc-ref props 'column)))
 917           (if file
 918               (simple-format #f "~a:~a:~a"
 919                              file line column)
 920               (simple-format #f "~a:~a" line column)))
 921         "<unknown location>")))
 922
 923 (define-syntax-rule (define-syntax-parameter-once name proc)
 924   ;; Like 'define-syntax-parameter' but ensure the top-level binding for NAME
 925   ;; does not get redefined.  This works around a race condition in a
 926   ;; multi-threaded context with Guile <= 2.2.4: <https://bugs.gnu.org/27476>.
 927   (eval-when (load eval expand compile)
 928     (define name
 929       (if (module-locally-bound? (current-module) 'name)
 930           (module-ref (current-module) 'name)
 931           (make-syntax-transformer 'name 'syntax-parameter
 932                                    (list proc))))))
 933
 934 (define-syntax-parameter-once current-imported-modules
 935   ;; Current list of imported modules.
 936   (identifier-syntax '()))
 937
 938 (define-syntax-rule (with-imported-modules modules body ...)
 939   "Mark the gexps defined in BODY... as requiring MODULES in their execution
 940 environment."
 941   (syntax-parameterize ((current-imported-modules
 942                          (identifier-syntax modules)))
 943     body ...))
 944
 945 (define-syntax-parameter-once current-imported-extensions
 946   ;; Current list of extensions.
 947   (identifier-syntax '()))
 948
 949 (define-syntax-rule (with-extensions extensions body ...)
 950   "Mark the gexps defined in BODY... as requiring EXTENSIONS in their
 951 execution environment."
 952   (syntax-parameterize ((current-imported-extensions
 953                          (identifier-syntax extensions)))
 954     body ...))
 955
 956 (define-syntax gexp
 957   (lambda (s)
 958     (define (collect-escapes exp)
 959       ;; Return all the 'ungexp' present in EXP.
 960       (let loop ((exp    exp)
 961                  (result '()))
 962         (syntax-case exp (ungexp
 963                           ungexp-splicing
 964                           ungexp-native
 965                           ungexp-native-splicing)
 966           ((ungexp _)
 967            (cons exp result))
 968           ((ungexp _ _)
 969            (cons exp result))
 970           ((ungexp-splicing _ ...)
 971            (cons exp result))
 972           ((ungexp-native _ ...)
 973            (cons exp result))
 974           ((ungexp-native-splicing _ ...)
 975            (cons exp result))
 976           ((exp0 . exp)
 977            (let ((result (loop #'exp0 result)))
 978              (loop  #'exp result)))
 979           (_
 980            result))))
 981
 982     (define (escape->ref exp)
 983       ;; Turn 'ungexp' form EXP into a "reference".
 984       (syntax-case exp (ungexp ungexp-splicing
 985                         ungexp-native ungexp-native-splicing
 986                         output)
 987         ((ungexp output)
 988          #'(gexp-output "out"))
 989         ((ungexp output name)
 990          #'(gexp-output name))
 991         ((ungexp thing)
 992          #'(%gexp-input thing "out" #f))
 993         ((ungexp drv-or-pkg out)
 994          #'(%gexp-input drv-or-pkg out #f))
 995         ((ungexp-splicing lst)
 996          #'(%gexp-input lst "out" #f))
 997         ((ungexp-native thing)
 998          #'(%gexp-input thing "out" #t))
 999         ((ungexp-native drv-or-pkg out)
1000          #'(%gexp-input drv-or-pkg out #t))
1001         ((ungexp-native-splicing lst)
1002          #'(%gexp-input lst "out" #t))))
1003
1004     (define (substitute-ungexp exp substs)
1005       ;; Given EXP, an 'ungexp' or 'ungexp-native' form, substitute it with
1006       ;; the corresponding form in SUBSTS.
1007       (match (assoc exp substs)
1008         ((_ id)
1009          id)
1010         (_                                        ;internal error
1011          (with-syntax ((exp exp))
1012            #'(syntax-error "error: no 'ungexp' substitution" exp)))))
1013
1014     (define (substitute-ungexp-splicing exp substs)
1015       (syntax-case exp ()
1016         ((exp rest ...)
1017          (match (assoc #'exp substs)
1018            ((_ id)
1019             (with-syntax ((id id))
1020               #`(append id
1021                         #,(substitute-references #'(rest ...) substs))))
1022            (_
1023             #'(syntax-error "error: no 'ungexp-splicing' substitution"
1024                             exp))))))
1025
1026     (define (substitute-references exp substs)
1027       ;; Return a variant of EXP where all the cars of SUBSTS have been
1028       ;; replaced by the corresponding cdr.
1029       (syntax-case exp (ungexp ungexp-native
1030                         ungexp-splicing ungexp-native-splicing)
1031         ((ungexp _ ...)
1032          (substitute-ungexp exp substs))
1033         ((ungexp-native _ ...)
1034          (substitute-ungexp exp substs))
1035         (((ungexp-splicing _ ...) rest ...)
1036          (substitute-ungexp-splicing exp substs))
1037         (((ungexp-native-splicing _ ...) rest ...)
1038          (substitute-ungexp-splicing exp substs))
1039         ((exp0 . exp)
1040          #`(cons #,(substitute-references #'exp0 substs)
1041                  #,(substitute-references #'exp substs)))
1042         (x #''x)))
1043
1044     (syntax-case s (ungexp output)
1045       ((_ exp)
1046        (let* ((escapes (delete-duplicates (collect-escapes #'exp)))
1047               (formals (generate-temporaries escapes))
1048               (sexp    (substitute-references #'exp (zip escapes formals)))
1049               (refs    (map escape->ref escapes)))
1050          #`(make-gexp (list #,@refs)
1051                       current-imported-modules
1052                       current-imported-extensions
1053                       (lambda #,formals
1054                         #,sexp)))))))
1055
1056 \f
1057 ;;;
1058 ;;; Module handling.
1059 ;;;
1060
1061 (define %not-slash
1062   (char-set-complement (char-set #\/)))
1063
1064 (define (file-mapping->tree mapping)
1065   "Convert MAPPING, an alist like:
1066
1067   ((\"guix/build/utils.scm\" . \"…/utils.scm\"))
1068
1069 to a tree suitable for 'interned-file-tree'."
1070   (let ((mapping (map (match-lambda
1071                         ((destination . source)
1072                          (cons (string-tokenize destination
1073                                                 %not-slash)
1074                                source)))
1075                       mapping)))
1076     (fold (lambda (pair result)
1077             (match pair
1078               ((destination . source)
1079                (let loop ((destination destination)
1080                           (result result))
1081                  (match destination
1082                    ((file)
1083                     (let* ((mode (stat:mode (stat source)))
1084                            (type (if (zero? (logand mode #o100))
1085                                      'regular
1086                                      'executable)))
1087                       (alist-cons file
1088                                   `(,type (file ,source))
1089                                   result)))
1090                    ((file rest ...)
1091                     (let ((directory (assoc-ref result file)))
1092                       (alist-cons file
1093                                   `(directory
1094                                     ,@(loop rest
1095                                             (match directory
1096                                               (('directory . entries) entries)
1097                                               (#f '()))))
1098                                   (if directory
1099                                       (alist-delete file result)
1100                                       result)))))))))
1101           '()
1102           mapping)))
1103
1104 (define %utils-module
1105   ;; This file provides 'mkdir-p', needed to implement 'imported-files' and
1106   ;; other primitives below.  Note: We give the file name relative to this
1107   ;; file you are currently reading; 'search-path' could return a file name
1108   ;; relative to the current working directory.
1109   (local-file "build/utils.scm"
1110               "build-utils.scm"))
1111
1112 (define* (imported-files/derivation files
1113                                     #:key (name "file-import")
1114                                     (symlink? #f)
1115                                     (system (%current-system))
1116                                     (guile (%guile-for-build)))
1117   "Return a derivation that imports FILES into STORE.  FILES must be a list
1118 of (FINAL-PATH . FILE) pairs.  Each FILE is mapped to FINAL-PATH in the
1119 resulting store path.  FILE can be either a file name, or a file-like object,
1120 as returned by 'local-file' for example.  If SYMLINK? is true, create symlinks
1121 to the source files instead of copying them."
1122   (define file-pair
1123     (match-lambda
1124      ((final-path . (? string? file-name))
1125       (mlet %store-monad ((file (interned-file file-name
1126                                                (basename final-path))))
1127         (return (list final-path file))))
1128      ((final-path . file-like)
1129       (mlet %store-monad ((file (lower-object file-like system)))
1130         (return (list final-path file))))))
1131
1132   (mlet %store-monad ((files (mapm %store-monad file-pair files)))
1133     (define build
1134       (gexp
1135        (begin
1136          (primitive-load (ungexp %utils-module))  ;for 'mkdir-p'
1137          (use-modules (ice-9 match))
1138
1139          (mkdir (ungexp output)) (chdir (ungexp output))
1140          (for-each (match-lambda
1141                     ((final-path store-path)
1142                      (mkdir-p (dirname final-path))
1143                      ((ungexp (if symlink? 'symlink 'copy-file))
1144                       store-path final-path)))
1145                    '(ungexp files)))))
1146
1147     ;; TODO: Pass FILES as an environment variable so that BUILD remains
1148     ;; exactly the same regardless of FILES: less disk space, and fewer
1149     ;; 'add-to-store' RPCs.
1150     (gexp->derivation name build
1151                       #:system system
1152                       #:guile-for-build guile
1153                       #:local-build? #t
1154
1155                       ;; Avoid deprecation warnings about the use of the _IO*
1156                       ;; constants in (guix build utils).
1157                       #:env-vars
1158                       '(("GUILE_WARN_DEPRECATED" . "no")))))
1159
1160 (define* (imported-files files
1161                          #:key (name "file-import")
1162                          ;; The following parameters make sense when creating
1163                          ;; an actual derivation.
1164                          (system (%current-system))
1165                          (guile (%guile-for-build)))
1166   "Import FILES into the store and return the resulting derivation or store
1167 file name (a derivation is created if and only if some elements of FILES are
1168 file-like objects and not local file names.)  FILES must be a list
1169 of (FINAL-PATH . FILE) pairs.  Each FILE is mapped to FINAL-PATH in the
1170 resulting store path.  FILE can be either a file name, or a file-like object,
1171 as returned by 'local-file' for example."
1172   (if (any (match-lambda
1173              ((_ . (? struct? source)) #t)
1174              (_ #f))
1175            files)
1176       (imported-files/derivation files #:name name
1177                                  #:symlink? derivation?
1178                                  #:system system #:guile guile)
1179       (interned-file-tree `(,name directory
1180                                   ,@(file-mapping->tree files)))))
1181
1182 (define* (imported-modules modules
1183                            #:key (name "module-import")
1184                            (system (%current-system))
1185                            (guile (%guile-for-build))
1186                            (module-path %load-path))
1187   "Return a derivation that contains the source files of MODULES, a list of
1188 module names such as `(ice-9 q)'.  All of MODULES must be either names of
1189 modules to be found in the MODULE-PATH search path, or a module name followed
1190 by an arrow followed by a file-like object.  For example:
1191
1192   (imported-modules `((guix build utils)
1193                       (guix gcrypt)
1194                       ((guix config) => ,(scheme-file …))))
1195
1196 In this example, the first two modules are taken from MODULE-PATH, and the
1197 last one is created from the given <scheme-file> object."
1198   (let ((files (map (match-lambda
1199                       (((module ...) '=> file)
1200                        (cons (module->source-file-name module)
1201                              file))
1202                       ((module ...)
1203                        (let ((f (module->source-file-name module)))
1204                          (cons f (search-path* module-path f)))))
1205                     modules)))
1206     (imported-files files #:name name
1207                     #:system system
1208                     #:guile guile)))
1209
1210 (define* (compiled-modules modules
1211                            #:key (name "module-import-compiled")
1212                            (system (%current-system))
1213                            (guile (%guile-for-build))
1214                            (module-path %load-path)
1215                            (extensions '())
1216                            (deprecation-warnings #f))
1217   "Return a derivation that builds a tree containing the `.go' files
1218 corresponding to MODULES.  All the MODULES are built in a context where
1219 they can refer to each other."
1220   (define total (length modules))
1221
1222   (mlet %store-monad ((modules (imported-modules modules
1223                                                  #:system system
1224                                                  #:guile guile
1225                                                  #:module-path
1226                                                  module-path)))
1227     (define build
1228       (gexp
1229        (begin
1230          (primitive-load (ungexp %utils-module))  ;for 'mkdir-p'
1231
1232          (use-modules (ice-9 ftw)
1233                       (ice-9 format)
1234                       (srfi srfi-1)
1235                       (srfi srfi-26)
1236                       (system base compile))
1237
1238          (define (regular? file)
1239            (not (member file '("." ".."))))
1240
1241          (define (process-entry entry output processed)
1242            (if (file-is-directory? entry)
1243                (let ((output (string-append output "/" (basename entry))))
1244                  (mkdir-p output)
1245                  (process-directory entry output processed))
1246                (let* ((base   (basename entry ".scm"))
1247                       (output (string-append output "/" base ".go")))
1248                  (format #t "[~2@a/~2@a] Compiling '~a'...~%"
1249                          (+ 1 processed) (ungexp total) entry)
1250                  (compile-file entry
1251                                #:output-file output
1252                                #:opts %auto-compilation-options)
1253                  (+ 1 processed))))
1254
1255          (define (process-directory directory output processed)
1256            (let ((entries (map (cut string-append directory "/" <>)
1257                                (scandir directory regular?))))
1258              (fold (cut process-entry <> output <>)
1259                    processed
1260                    entries)))
1261
1262          (setvbuf (current-output-port)
1263                   (cond-expand (guile-2.2 'line) (else _IOLBF)))
1264
1265          (define mkdir-p
1266            ;; Capture 'mkdir-p'.
1267            (@ (guix build utils) mkdir-p))
1268
1269          ;; Add EXTENSIONS to the search path.
1270          (set! %load-path
1271            (append (map (lambda (extension)
1272                           (string-append extension
1273                                          "/share/guile/site/"
1274                                          (effective-version)))
1275                         '((ungexp-native-splicing extensions)))
1276                    %load-path))
1277          (set! %load-compiled-path
1278            (append (map (lambda (extension)
1279                           (string-append extension "/lib/guile/"
1280                                          (effective-version)
1281                                          "/site-ccache"))
1282                         '((ungexp-native-splicing extensions)))
1283                    %load-compiled-path))
1284
1285          (set! %load-path (cons (ungexp modules) %load-path))
1286
1287          ;; Above we loaded our own (guix build utils) but now we may need to
1288          ;; load a compile a different one.  Thus, force a reload.
1289          (let ((utils (string-append (ungexp modules)
1290                                      "/guix/build/utils.scm")))
1291            (when (file-exists? utils)
1292              (load utils)))
1293
1294          (mkdir (ungexp output))
1295          (chdir (ungexp modules))
1296          (process-directory "." (ungexp output) 0))))
1297
1298     ;; TODO: Pass MODULES as an environment variable.
1299     (gexp->derivation name build
1300                       #:system system
1301                       #:guile-for-build guile
1302                       #:local-build? #t
1303                       #:env-vars
1304                       (case deprecation-warnings
1305                         ((#f)
1306                          '(("GUILE_WARN_DEPRECATED" . "no")))
1307                         ((detailed)
1308                          '(("GUILE_WARN_DEPRECATED" . "detailed")))
1309                         (else
1310                          '())))))
1311
1312 \f
1313 ;;;
1314 ;;; Convenience procedures.
1315 ;;;
1316
1317 (define (default-guile)
1318   ;; Lazily resolve 'guile-2.2' (not 'guile-final' because this is for
1319   ;; programs returned by 'program-file' and we don't want to keep references
1320   ;; to several Guile packages).  This module must not refer to (gnu …)
1321   ;; modules directly, to avoid circular dependencies, hence this hack.
1322   (module-ref (resolve-interface '(gnu packages guile))
1323               'guile-2.2))
1324
1325 (define* (load-path-expression modules #:optional (path %load-path)
1326                                #:key (extensions '()))
1327   "Return as a monadic value a gexp that sets '%load-path' and
1328 '%load-compiled-path' to point to MODULES, a list of module names.  MODULES
1329 are searched for in PATH.  Return #f when MODULES and EXTENSIONS are empty."
1330   (if (and (null? modules) (null? extensions))
1331       (with-monad %store-monad
1332         (return #f))
1333       (mlet %store-monad ((modules  (imported-modules modules
1334                                                       #:module-path path))
1335                           (compiled (compiled-modules modules
1336                                                       #:extensions extensions
1337                                                       #:module-path path)))
1338         (return (gexp (eval-when (expand load eval)
1339                         (set! %load-path
1340                           (cons (ungexp modules)
1341                                 (append (map (lambda (extension)
1342                                                (string-append extension
1343                                                               "/share/guile/site/"
1344                                                               (effective-version)))
1345                                              '((ungexp-native-splicing extensions)))
1346                                         %load-path)))
1347                         (set! %load-compiled-path
1348                           (cons (ungexp compiled)
1349                                 (append (map (lambda (extension)
1350                                                (string-append extension
1351                                                               "/lib/guile/"
1352                                                               (effective-version)
1353                                                               "/site-ccache"))
1354                                              '((ungexp-native-splicing extensions)))
1355                                         %load-compiled-path)))))))))
1356
1357 (define* (gexp->script name exp
1358                        #:key (guile (default-guile))
1359                        (module-path %load-path))
1360   "Return an executable script NAME that runs EXP using GUILE, with EXP's
1361 imported modules in its search path.  Look up EXP's modules in MODULE-PATH."
1362   (mlet %store-monad ((set-load-path
1363                        (load-path-expression (gexp-modules exp)
1364                                              module-path
1365                                              #:extensions
1366                                              (gexp-extensions exp))))
1367     (gexp->derivation name
1368                       (gexp
1369                        (call-with-output-file (ungexp output)
1370                          (lambda (port)
1371                            ;; Note: that makes a long shebang.  When the store
1372                            ;; is /gnu/store, that fits within the 128-byte
1373                            ;; limit imposed by Linux, but that may go beyond
1374                            ;; when running tests.
1375                            (format port
1376                                    "#!~a/bin/guile --no-auto-compile~%!#~%"
1377                                    (ungexp guile))
1378
1379                            (ungexp-splicing
1380                             (if set-load-path
1381                                 (gexp ((write '(ungexp set-load-path) port)))
1382                                 (gexp ())))
1383
1384                            (write '(ungexp exp) port)
1385                            (chmod port #o555))))
1386                       #:module-path module-path)))
1387
1388 (define* (gexp->file name exp #:key
1389                      (set-load-path? #t)
1390                      (module-path %load-path)
1391                      (splice? #f))
1392   "Return a derivation that builds a file NAME containing EXP.  When SPLICE?
1393 is true, EXP is considered to be a list of expressions that will be spliced in
1394 the resulting file.
1395
1396 When SET-LOAD-PATH? is true, emit code in the resulting file to set
1397 '%load-path' and '%load-compiled-path' to honor EXP's imported modules.
1398 Lookup EXP's modules in MODULE-PATH."
1399   (define modules (gexp-modules exp))
1400   (define extensions (gexp-extensions exp))
1401
1402   (if (or (not set-load-path?)
1403           (and (null? modules) (null? extensions)))
1404       (gexp->derivation name
1405                         (gexp
1406                          (call-with-output-file (ungexp output)
1407                            (lambda (port)
1408                              (for-each (lambda (exp)
1409                                          (write exp port))
1410                                        '(ungexp (if splice?
1411                                                     exp
1412                                                     (gexp ((ungexp exp)))))))))
1413                         #:local-build? #t
1414                         #:substitutable? #f)
1415       (mlet %store-monad ((set-load-path
1416                            (load-path-expression modules module-path
1417                                                  #:extensions extensions)))
1418         (gexp->derivation name
1419                           (gexp
1420                            (call-with-output-file (ungexp output)
1421                              (lambda (port)
1422                                (write '(ungexp set-load-path) port)
1423                                (for-each (lambda (exp)
1424                                            (write exp port))
1425                                          '(ungexp (if splice?
1426                                                       exp
1427                                                       (gexp ((ungexp exp)))))))))
1428                           #:module-path module-path
1429                           #:local-build? #t
1430                           #:substitutable? #f))))
1431
1432 (define* (text-file* name #:rest text)
1433   "Return as a monadic value a derivation that builds a text file containing
1434 all of TEXT.  TEXT may list, in addition to strings, objects of any type that
1435 can be used in a gexp: packages, derivations, local file objects, etc.  The
1436 resulting store file holds references to all these."
1437   (define builder
1438     (gexp (call-with-output-file (ungexp output "out")
1439             (lambda (port)
1440               (display (string-append (ungexp-splicing text)) port)))))
1441
1442   (gexp->derivation name builder
1443                     #:local-build? #t
1444                     #:substitutable? #f))
1445
1446 (define* (mixed-text-file name #:rest text)
1447   "Return an object representing store file NAME containing TEXT.  TEXT is a
1448 sequence of strings and file-like objects, as in:
1449
1450   (mixed-text-file \"profile\"
1451                    \"export PATH=\" coreutils \"/bin:\" grep \"/bin\")
1452
1453 This is the declarative counterpart of 'text-file*'."
1454   (define build
1455     (gexp (call-with-output-file (ungexp output "out")
1456             (lambda (port)
1457               (display (string-append (ungexp-splicing text)) port)))))
1458
1459   (computed-file name build))
1460
1461 (define (file-union name files)
1462   "Return a <computed-file> that builds a directory containing all of FILES.
1463 Each item in FILES must be a two-element list where the first element is the
1464 file name to use in the new directory, and the second element is a gexp
1465 denoting the target file.  Here's an example:
1466
1467   (file-union \"etc\"
1468               `((\"hosts\" ,(plain-file \"hosts\"
1469                                         \"127.0.0.1 localhost\"))
1470                 (\"bashrc\" ,(plain-file \"bashrc\"
1471                                          \"alias ls='ls --color'\"))
1472                 (\"libvirt/qemu.conf\" ,(plain-file \"qemu.conf\" \"\"))))
1473
1474 This yields an 'etc' directory containing these two files."
1475   (computed-file name
1476                  (with-imported-modules '((guix build utils))
1477                    (gexp
1478                     (begin
1479                       (use-modules (guix build utils))
1480
1481                       (mkdir (ungexp output))
1482                       (chdir (ungexp output))
1483                       (ungexp-splicing
1484                        (map (match-lambda
1485                               ((target source)
1486                                (gexp
1487                                 (begin
1488                                   ;; Stat the source to abort early if it does
1489                                   ;; not exist.
1490                                   (stat (ungexp source))
1491
1492                                   (mkdir-p (dirname (ungexp target)))
1493                                   (symlink (ungexp source)
1494                                            (ungexp target))))))
1495                             files)))))))
1496
1497 (define* (directory-union name things
1498                           #:key (copy? #f) (quiet? #f)
1499                           (resolve-collision 'warn-about-collision))
1500   "Return a directory that is the union of THINGS, where THINGS is a list of
1501 file-like objects denoting directories.  For example:
1502
1503   (directory-union \"guile+emacs\" (list guile emacs))
1504
1505 yields a directory that is the union of the 'guile' and 'emacs' packages.
1506
1507 Call RESOLVE-COLLISION when several files collide, passing it the list of
1508 colliding files.  RESOLVE-COLLISION must return the chosen file or #f, in
1509 which case the colliding entry is skipped altogether.
1510
1511 When HARD-LINKS? is true, create hard links instead of symlinks.  When QUIET?
1512 is true, the derivation will not print anything."
1513   (define symlink
1514     (if copy?
1515         (gexp (lambda (old new)
1516                 (if (file-is-directory? old)
1517                     (symlink old new)
1518                     (copy-file old new))))
1519         (gexp symlink)))
1520
1521   (define log-port
1522     (if quiet?
1523         (gexp (%make-void-port "w"))
1524         (gexp (current-error-port))))
1525
1526   (match things
1527     ((one)
1528      ;; Only one thing; return it.
1529      one)
1530     (_
1531      (computed-file name
1532                     (with-imported-modules '((guix build union))
1533                       (gexp (begin
1534                               (use-modules (guix build union)
1535                                            (srfi srfi-1)) ;for 'first' and 'last'
1536
1537                               (union-build (ungexp output)
1538                                            '(ungexp things)
1539
1540                                            #:log-port (ungexp log-port)
1541                                            #:symlink (ungexp symlink)
1542                                            #:resolve-collision
1543                                            (ungexp resolve-collision)))))))))
1544
1545 \f
1546 ;;;
1547 ;;; Syntactic sugar.
1548 ;;;
1549
1550 (eval-when (expand load eval)
1551   (define* (read-ungexp chr port #:optional native?)
1552     "Read an 'ungexp' or 'ungexp-splicing' form from PORT.  When NATIVE? is
1553 true, use 'ungexp-native' and 'ungexp-native-splicing' instead."
1554     (define unquote-symbol
1555       (match (peek-char port)
1556         (#\@
1557          (read-char port)
1558          (if native?
1559              'ungexp-native-splicing
1560              'ungexp-splicing))
1561         (_
1562          (if native?
1563              'ungexp-native
1564              'ungexp))))
1565
1566     (match (read port)
1567       ((? symbol? symbol)
1568        (let ((str (symbol->string symbol)))
1569          (match (string-index-right str #\:)
1570            (#f
1571             `(,unquote-symbol ,symbol))
1572            (colon
1573             (let ((name   (string->symbol (substring str 0 colon)))
1574                   (output (substring str (+ colon 1))))
1575               `(,unquote-symbol ,name ,output))))))
1576       (x
1577        `(,unquote-symbol ,x))))
1578
1579   (define (read-gexp chr port)
1580     "Read a 'gexp' form from PORT."
1581     `(gexp ,(read port)))
1582
1583   ;; Extend the reader
1584   (read-hash-extend #\~ read-gexp)
1585   (read-hash-extend #\$ read-ungexp)
1586   (read-hash-extend #\+ (cut read-ungexp <> <> #t)))
1587
1588 ;;; gexp.scm ends here